Fix conflict

basis/bitstreams/bitstreams.factor

@@ -56,13 +56,20 @@ TUPLE: lsb0-bit-writer < bit-writer ;
 GENERIC: peek ( n bitstream -- value )
 GENERIC: poke ( value n bitstream -- )
 
+: get-abp ( bitstream -- abp ) 
+    [ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline
+    
+: set-abp ( abp bitstream -- ) 
+    [ 8 /mod ] dip [ (>>bit-pos) ] [ (>>byte-pos) ] bi ; inline
+
 : seek ( n bitstream -- )
-    {
+    [ get-abp + ] [ set-abp ] bi ; inline
-        [ byte-pos>> 8 * ]
+    
-        [ bit-pos>> + + 8 /mod ]
+: (align) ( n m -- n' )
-        [ (>>bit-pos) ]
+    [ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline
-        [ (>>byte-pos) ]
+    
-    } cleave ; inline
+: align ( n bitstream -- )
+    [ get-abp swap (align) ] [ set-abp ] bi ; inline
 
 : read ( n bitstream -- value )
     [ peek ] [ seek ] 2bi ; inline

basis/compression/inflate/inflate.factor

@@ -151,7 +151,16 @@ CONSTANT: dist-table
         ] when
     ] map ;
     
-: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ;
+:: inflate-raw ( bitstream -- bytes ) 
+    8 bitstream bs:align 
+    16 bitstream bs:read :> len
+    16 bitstream bs:read :> nlen
+    len nlen + 16 >signed -1 assert= ! len + ~len = -1
+    bitstream byte-pos>>
+    bitstream byte-pos>> len +
+    bitstream bytes>> <slice>
+    len 8 * bitstream bs:seek ;
+
 : inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
 
 :: inflate-loop ( bitstream -- bytes )
@@ -194,17 +203,16 @@ CONSTANT: dist-table
 
 PRIVATE>
 
-! for debug -- shows residual values
+: reverse-png-filter' ( lines -- byte-array )
-: reverse-png-filter' ( lines -- filtered )
     [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
-    concat [ 128 + 256 wrap ] map ;
+    concat [ 128 + ] B{ } map-as ;
 
-: reverse-png-filter ( lines -- filtered )
+: reverse-png-filter ( lines -- byte-array )
     dup first [ 0 ] replicate prefix
     [ { 0 0 } prepend  ] map
     2 clump [
         first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
-    ] map concat ;
+    ] map B{ } concat-as ;
 
 : zlib-inflate ( bytes -- bytes )
     bs:<lsb0-bit-reader>

basis/compression/run-length/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/compression/run-length/run-length.factor

@@ -1,7 +1,75 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays grouping sequences ;
+USING: accessors arrays combinators grouping kernel locals math
+math.matrices math.order multiline sequence-parser sequences
+tools.continuations ;
 IN: compression.run-length
 
 : run-length-uncompress ( byte-array -- byte-array' )
-    2 group [ first2 <array> ] map concat ;
+    2 group [ first2 <array> ] map B{ } concat-as ;
+
+: 8hi-lo ( byte -- hi lo )
+    [ HEX: f0 bitand -4 shift ] [ HEX: f bitand ] bi ; inline
+
+:: run-length-uncompress-bitmap4 ( byte-array m n -- byte-array' )
+    byte-array <sequence-parser> :> sp
+    m  1 + n zero-matrix :> matrix
+    n 4 mod n + :> stride
+    0 :> i!
+    0 :> j!
+    f :> done?!
+    [
+        ! i j [ number>string ] bi@ " " glue .
+        sp next dup 0 = [
+            sp next dup HEX: 03 HEX: ff between? [
+                nip [ sp ] dip dup odd?
+                [ 1 + take-n but-last ] [ take-n ] if
+                [ j matrix i swap nth copy ] [ length j + j! ] bi
+            ] [
+                nip {
+                    { 0 [ i 1 + i!  0 j! ] }
+                    { 1 [ t done?! ] }
+                    { 2 [ sp next j + j!  sp next i + i! ] }
+                } case
+            ] if
+        ] [
+            [ sp next 8hi-lo 2array <repetition> concat ] [ head ] bi
+            [ j matrix i swap nth copy ] [ length j + j! ] bi
+        ] if
+        
+        ! j stride >= [ i 1 + i!  0 j! ] when
+        j stride >= [ 0 j! ] when
+        done? not
+    ] loop
+    matrix B{ } concat-as ;
+
+:: run-length-uncompress-bitmap8 ( byte-array m n -- byte-array' )
+    byte-array <sequence-parser> :> sp
+    m  1 + n zero-matrix :> matrix
+    n 4 mod n + :> stride
+    0 :> i!
+    0 :> j!
+    f :> done?!
+    [
+        ! i j [ number>string ] bi@ " " glue .
+        sp next dup 0 = [
+            sp next dup HEX: 03 HEX: ff between? [
+                nip [ sp ] dip dup odd?
+                [ 1 + take-n but-last ] [ take-n ] if
+                [ j matrix i swap nth copy ] [ length j + j! ] bi
+            ] [
+                nip {
+                    { 0 [ i 1 + i!  0 j! ] }
+                    { 1 [ t done?! ] }
+                    { 2 [ sp next j + j!  sp next i + i! ] }
+                } case
+            ] if
+        ] [
+            sp next <array> [ j matrix i swap nth copy ] [ length j + j! ] bi
+        ] if
+        
+        ! j stride >= [ i 1 + i!  0 j! ] when
+        j stride >= [ 0 j! ] when
+        done? not
+    ] loop
+    matrix B{ } concat-as ;

basis/constructors/constructors-tests.factor

@@ -57,3 +57,30 @@ TUPLE: default { a integer initial: 0 } ;
 CONSTRUCTOR: default ( -- obj ) ;
 
 [ 0 ] [ <default> a>> ] unit-test
+
+
+TUPLE: inherit1 a ;
+TUPLE: inherit2 < inherit1 a ;
+
+CONSTRUCTOR: inherit2 ( a -- obj ) ;
+
+[ T{ inherit2 f f 100 } ] [ 100 <inherit2> ] unit-test
+
+
+TUPLE: inherit3 hp max-hp ;
+TUPLE: inherit4 < inherit3 ;
+TUPLE: inherit5 < inherit3 ;
+
+CONSTRUCTOR: inherit3 ( -- obj )
+    dup max-hp>> >>hp ;
+
+BACKWARD-CONSTRUCTOR: inherit4 ( -- obj )
+    10 >>max-hp ;
+
+[ 10 ] [ <inherit4> hp>> ] unit-test
+
+FORWARD-CONSTRUCTOR: inherit5 ( -- obj )
+    5 >>hp
+    10 >>max-hp ;
+
+[ 5 ] [ <inherit5> hp>> ] unit-test

basis/constructors/constructors.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs classes.tuple effects.parser fry
+USING: accessors assocs classes classes.tuple effects.parser
-generalizations generic.standard kernel lexer locals macros
+fry generalizations generic.standard kernel lexer locals macros
-parser sequences slots vocabs words ;
+parser sequences slots vocabs words arrays ;
 IN: constructors
 
 ! An experiment
@@ -25,30 +25,44 @@ IN: constructors
     [ drop define-initializer-generic ]
     [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
 
+: all-slots-assoc ( class -- slots )
+    superclasses [ [ "slots" word-prop ] keep '[ _ ] { } map>assoc ] map concat ;
+
 MACRO:: slots>constructor ( class slots -- quot )
-    class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
+    class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
+    class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
     slots length
-    params length
+    default-params length
     '[
-        _ narray slots swap zip 
+        _ narray slot-assoc swap zip 
-        params swap assoc-union
+        default-params swap assoc-union values _ firstn class boa
-        values _ firstn class boa
     ] ;
 
-:: define-constructor ( constructor-word class effect def -- )
+:: (define-constructor) ( constructor-word class effect def -- word quot )
     constructor-word
     class def define-initializer
-    class effect in>> '[ _ _ slots>constructor ]
+    class effect in>> '[ _ _ slots>constructor ] ;
+
+:: define-constructor ( constructor-word class effect def -- )
+    constructor-word class effect def (define-constructor)
     class lookup-initializer
     '[ @ _ execute( obj -- obj ) ] effect define-declared ;
 
+:: define-auto-constructor ( constructor-word class effect def reverse? -- )
+    constructor-word class effect def (define-constructor)
+    class superclasses [ lookup-initializer ] map sift
+    reverse? [ reverse ] when
+    '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;
+
 : scan-constructor ( -- class word )
     scan-word [ name>> "<" ">" surround create-in ] keep ;
 
-SYNTAX: CONSTRUCTOR:
+: parse-constructor ( -- class word effect def )
-    scan-constructor
+    scan-constructor complete-effect parse-definition ;
-    complete-effect
+
-    parse-definition
+SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ;
-    define-constructor ;
+SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
+SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ;
+SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
 
 "initializers" create-vocab drop

basis/debugger/debugger.factor

@@ -104,8 +104,8 @@ HOOK: signal-error. os ( obj -- )
     "Cannot do next-object outside begin/end-scan" print drop ;
 
 : undefined-symbol-error. ( obj -- )
-    "The image refers to a library or symbol that was not found"
+    "The image refers to a library or symbol that was not found at load time"
-    " at load time" append print drop ;
+    print drop ;
 
 : stack-underflow. ( obj name -- )
     write " stack underflow" print drop ;
@@ -252,12 +252,15 @@ M: no-current-vocab summary
     drop "Not in a vocabulary; IN: form required" ;
 
 M: no-word-error summary
-    name>> "No word named ``" "'' found in current vocabulary search path" surround ;
+    name>>
+    "No word named ``"
+    "'' found in current vocabulary search path" surround ;
 
 M: no-word-error error. summary print ;
 
 M: ambiguous-use-error summary
-    words>> first name>> "More than one vocabulary defines a word named ``" "''" surround ;
+    words>> first name>>
+    "More than one vocabulary defines a word named ``" "''" surround ;
 
 M: ambiguous-use-error error. summary print ;
 

basis/game-input/dinput/dinput.factor

@@ -1,14 +1,13 @@
-USING: windows.dinput windows.dinput.constants parser
+USING: accessors alien alien.c-types alien.strings arrays
-alien.c-types windows.ole32 namespaces assocs kernel arrays
+assocs byte-arrays combinators continuations game-input
-vectors windows.kernel32 windows.com windows.dinput shuffle
+game-input.dinput.keys-array io.encodings.utf16
-windows.user32 windows.messages sequences combinators locals
+io.encodings.utf16n kernel locals math math.bitwise
-math.rectangles accessors math alien alien.strings
+math.rectangles namespaces parser sequences shuffle
-io.encodings.utf16 io.encodings.utf16n continuations
+struct-arrays ui.backend.windows vectors windows.com
-byte-arrays game-input.dinput.keys-array game-input
+windows.dinput windows.dinput.constants windows.errors
-ui.backend.windows windows.errors struct-arrays
+windows.kernel32 windows.messages windows.ole32
-math.bitwise ;
+windows.user32 ;
 IN: game-input.dinput
-
 CONSTANT: MOUSE-BUFFER-SIZE 16
 
 SINGLETON: dinput-game-input-backend

basis/generalizations/generalizations-tests.factor

@@ -60,3 +60,10 @@ IN: generalizations.tests
 
 [ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]
 [ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
+
+[ 1 2 3 4 1 2 3 ] [ 1 2 3 4 3 nover ] unit-test
+
+[ [ 1 2 3 ] [ 1 2 3 ] ]
+[ 1 2 3 [ ] [ ] 3 nbi-curry ] unit-test
+
+[ 15 3 ] [ 1 2 3 4 5 [ + + + + ] [ - - - - ] 5 nbi ] unit-test

basis/generalizations/generalizations.factor

@@ -39,6 +39,9 @@ MACRO: firstn ( n -- )
 MACRO: npick ( n -- )
     1- [ dup ] [ '[ _ dip swap ] ] repeat ;
 
+MACRO: nover ( n -- )
+    dup '[ _ 1 + npick ] n*quot ;
+
 MACRO: ndup ( n -- )
     dup '[ _ npick ] n*quot ;
 
@@ -69,6 +72,9 @@ MACRO: ncurry ( n -- )
 MACRO: nwith ( n -- )
     [ with ] n*quot ;
 
+MACRO: nbi ( n -- )
+    '[ [ _ nkeep ] dip call ] ;
+
 MACRO: ncleave ( quots n -- )
     [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
     compose ;
@@ -91,6 +97,9 @@ MACRO: nweave ( n -- )
     [ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
     '[ _ _ ncleave ] ;
 
+MACRO: nbi-curry ( n -- )
+    [ bi-curry ] n*quot ;
+
 : nappend-as ( n exemplar -- seq )
     [ narray concat ] dip like ; inline
 

basis/images/bitmap/bitmap-tests.factor

@@ -1,7 +1,6 @@
 USING: images.bitmap images.viewer io.encodings.binary
 io.files io.files.unique kernel tools.test images.loader
-literals sequences checksums.md5 checksums
+literals sequences checksums.md5 checksums ;
-images.normalization ;
 IN: images.bitmap.tests
 
 CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp"
@@ -26,8 +25,8 @@ ${
 
 : test-bitmap-save ( path -- ? )
     [ md5 checksum-file ]
-    [ load-image normalize-image ] bi
+    [ load-image ] bi
-    "bitmap-save-test" unique-file
+    "bitmap-save-test" ".bmp" make-unique-file
     [ save-bitmap ]
     [ md5 checksum-file ] bi = ;
 

basis/images/bitmap/bitmap.factor

@@ -2,288 +2,21 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types arrays byte-arrays columns
 combinators compression.run-length endian fry grouping images
-images.loader io io.binary io.encodings.binary io.files
+images.bitmap.loading images.loader io io.binary
+io.encodings.binary io.encodings.string io.files
 io.streams.limited kernel locals macros math math.bitwise
 math.functions namespaces sequences specialized-arrays.uint
-specialized-arrays.ushort strings summary io.encodings.8-bit
+specialized-arrays.ushort strings summary ;
-io.encodings.string ;
-QUALIFIED-WITH: bitstreams b
 IN: images.bitmap
 
-: read2 ( -- n ) 2 read le> ;
-: read4 ( -- n ) 4 read le> ;
 : write2 ( n -- ) 2 >le write ;
 : write4 ( n -- ) 4 >le write ;
 
-SINGLETON: bitmap-image
-"bmp" bitmap-image register-image-class
-
-TUPLE: loading-bitmap 
-magic size reserved1 reserved2 offset header-length width
-height planes bit-count compression size-image
-x-pels y-pels color-used color-important
-red-mask green-mask blue-mask alpha-mask
-cs-type end-points
-gamma-red gamma-green gamma-blue
-intent profile-data profile-size reserved3
-color-palette color-index bitfields ;
-
-! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint
-
-<PRIVATE
-
-: os2-color-lookup ( loading-bitmap -- seq )
-    [ color-index>> >array ]
-    [ color-palette>> 3 <sliced-groups> ] bi
-    '[ _ nth ] map concat ;
-
-: os2v2-color-lookup ( loading-bitmap -- seq )
-    [ color-index>> >array ]
-    [ color-palette>> 3 <sliced-groups> ] bi
-    '[ _ nth ] map concat ;
-
-: v3-color-lookup ( loading-bitmap -- seq )
-    [ color-index>> >array ]
-    [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
-    '[ _ nth ] map concat ;
-
-: color-lookup ( loading-bitmap -- seq )
-    dup header-length>> {
-        { 12 [ os2-color-lookup ] }
-        { 64 [ os2v2-color-lookup ] }
-        { 40 [ v3-color-lookup ] }
-        ! { 108 [ v4-color-lookup ] }
-        ! { 124 [ v5-color-lookup ] }
-    } case ;
-
-ERROR: bmp-not-supported n ;
-
-: uncompress-bitfield ( seq masks -- bytes' )
-    '[
-        _ [
-            [ bitand ] [ bit-count ] [ log2 ] tri - shift
-        ] with map
-    ] { } map-as B{ } concat-as ;
-
-: bitmap>bytes ( loading-bitmap -- byte-array )
-    dup bit-count>>
-    {
-        { 32 [ color-index>> ] }
-        { 24 [ color-index>> ] }
-        { 16 [
-            [
-                ! byte-array>ushort-array
-                2 group [ le> ] map
-                ! 5 6 5
-                ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
-                ! 5 5 5
-                { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
-            ] change-color-index
-            color-index>>
-        ] }
-        { 8 [ color-lookup ] }
-        { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
-        { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
-        [ bmp-not-supported ]
-    } case >byte-array ;
-
-: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
-    dup bit-count>> {
-        { 16 [ dup color-palette>> 4 group [ le> ] map ] }
-        { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
-    } case reverse >>bitfields ;
-
-ERROR: unsupported-bitfield-widths n ;
-
-M: unsupported-bitfield-widths summary
-    drop "Bitmaps only support bitfield compression in 16/32bit images" ;
-
-: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
-    set-bitfield-widths
-    dup bit-count>> {
-        { 16 [
-            dup bitfields>> '[
-                byte-array>ushort-array _ uncompress-bitfield
-            ] change-color-index
-        ] }
-        { 32 [
-            dup bitfields>> '[
-                byte-array>uint-array _ uncompress-bitfield
-            ] change-color-index
-        ] }
-        [ unsupported-bitfield-widths ]
-    } case ;
-
-ERROR: unsupported-bitmap-compression compression ;
-
-: uncompress-bitmap ( loading-bitmap -- loading-bitmap' )
-    dup compression>> {
-        { f [ ] }
-        { 0 [ ] }
-        { 1 [ [ run-length-uncompress ] change-color-index ] }
-        { 2 [ [ 4 b:byte-array-n>seq run-length-uncompress >byte-array ] change-color-index ] }
-        { 3 [ uncompress-bitfield-widths ] }
-        { 4 [ "jpeg" unsupported-bitmap-compression ] }
-        { 5 [ "png" unsupported-bitmap-compression ] }
-    } case ;
-
-: bitmap-padding ( width -- n )
-    3 * 4 mod 4 swap - 4 mod ; inline
-
-: loading-bitmap>bytes ( loading-bitmap -- byte-array )
-    uncompress-bitmap
-    bitmap>bytes ;
-
-: parse-file-header ( loading-bitmap -- loading-bitmap )
-    2 read latin1 decode >>magic
-    read4 >>size
-    read2 >>reserved1
-    read2 >>reserved2
-    read4 >>offset ;
-
-: read-v3-header ( loading-bitmap -- loading-bitmap )
-    read4 >>width
-    read4 32 >signed >>height
-    read2 >>planes
-    read2 >>bit-count
-    read4 >>compression
-    read4 >>size-image
-    read4 >>x-pels
-    read4 >>y-pels
-    read4 >>color-used
-    read4 >>color-important ;
-
-: read-v4-header ( loading-bitmap -- loading-bitmap )
-    read-v3-header
-    read4 >>red-mask
-    read4 >>green-mask
-    read4 >>blue-mask
-    read4 >>alpha-mask
-    read4 >>cs-type
-    read4 read4 read4 3array >>end-points
-    read4 >>gamma-red
-    read4 >>gamma-green
-    read4 >>gamma-blue ;
-
-: read-v5-header ( loading-bitmap -- loading-bitmap )
-    read-v4-header
-    read4 >>intent
-    read4 >>profile-data
-    read4 >>profile-size
-    read4 >>reserved3 ;
-
-: read-os2-header ( loading-bitmap -- loading-bitmap )
-    read2 >>width
-    read2 16 >signed >>height
-    read2 >>planes
-    read2 >>bit-count ;
-
-: read-os2v2-header ( loading-bitmap -- loading-bitmap )
-    read4 >>width
-    read4 32 >signed >>height
-    read2 >>planes
-    read2 >>bit-count ;
-
-ERROR: unknown-bitmap-header n ;
-
-: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
-    read4 [ >>header-length ] keep
-    {
-        { 12 [ read-os2-header ] }
-        { 64 [ read-os2v2-header ] }
-        { 40 [ read-v3-header ] }
-        { 108 [ read-v4-header ] }
-        { 124 [ read-v5-header ] }
-        [ unknown-bitmap-header ]
-    } case ;
-
-: color-palette-length ( loading-bitmap -- n )
-    [ offset>> 14 - ] [ header-length>> ] bi - ;
-
-: color-index-length ( loading-bitmap -- n )
-    {
-        [ width>> ]
-        [ planes>> * ]
-        [ bit-count>> * 31 + 32 /i 4 * ]
-        [ height>> abs * ]
-    } cleave ;
-
-: image-size ( loading-bitmap -- n )
-    [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
-
-: parse-bitmap ( loading-bitmap -- loading-bitmap )
-    dup color-palette-length read >>color-palette
-    dup size-image>> dup 0 > [
-        read >>color-index
-    ] [
-        drop dup color-index-length read >>color-index
-    ] if ;
-
-ERROR: unsupported-bitmap-file magic ;
-
-: load-bitmap ( path -- loading-bitmap )
-    binary stream-throws <limited-file-reader> [
-        loading-bitmap new
-        parse-file-header dup magic>> {
-            { "BM" [ parse-bitmap-header parse-bitmap ] }
-            ! { "BA" [ parse-os2-bitmap-array ] }
-            ! { "CI" [ parse-os2-color-icon ] }
-            ! { "CP" [ parse-os2-color-pointer ] }
-            ! { "IC" [ parse-os2-icon ] }
-            ! { "PT" [ parse-os2-pointer ] }
-            [ unsupported-bitmap-file ]
-        } case 
-    ] with-input-stream ;
-
-ERROR: unknown-component-order bitmap ;
-
-: bitmap>component-order ( loading-bitmap -- object )
-    bit-count>> {
-        { 32 [ BGR ] }
-        { 24 [ BGR ] }
-        { 16 [ BGR ] }
-        { 8 [ BGR ] }
-        { 4 [ BGR ] }
-        { 1 [ BGR ] }
-        [ unknown-component-order ]
-    } case ;
-
-M: bitmap-image load-image* ( path bitmap-image -- bitmap )
-    drop load-bitmap
-    [ image new ] dip
-    {
-        [ loading-bitmap>bytes >>bitmap ]
-        [ [ width>> ] [ height>> abs ] bi 2array >>dim ]
-        [ height>> 0 < not >>upside-down? ]
-        [ compression>> 3 = [ t >>upside-down? ] when ]
-        [ bitmap>component-order >>component-order ]
-    } cleave ;
-
-PRIVATE>
-
-: bitmap>color-index ( bitmap -- byte-array )
-    [
-        bitmap>>
-        4 <sliced-groups>
-        [ 3 head-slice <reversed> ] map
-        B{ } join
-    ] [
-        dim>> first dup bitmap-padding dup 0 > [
-            [ 3 * group ] dip '[ _ <byte-array> append ] map
-            B{ } join
-        ] [
-            2drop
-        ] if
-    ] bi ;
-
-: reverse-lines ( byte-array width -- byte-array )
-    <sliced-groups> <reversed> concat ; inline
-
 : save-bitmap ( image path -- )
     binary [
         B{ CHAR: B CHAR: M } write
         [
-            bitmap>color-index length 14 + 40 + write4
+            bitmap>> length 14 + 40 + write4
             0 write4
             54 write4
             40 write4
@@ -301,8 +34,8 @@ PRIVATE>
                 ! compression
                 [ drop 0 write4 ]
 
-                ! size-image
+                ! image-size
-                [ bitmap>color-index length write4 ]
+                [ bitmap>> length write4 ]
 
                 ! x-pels
                 [ drop 0 write4 ]
@@ -317,12 +50,7 @@ PRIVATE>
                 [ drop 0 write4 ]
 
                 ! color-palette
-                [
+                [ bitmap>> write ]
-                    [ bitmap>color-index ]
-                    [ dim>> first 3 * ]
-                    [ dim>> first bitmap-padding + ] tri
-                    reverse-lines write
-                ]
             } cleave
         ] bi
     ] with-file-writer ;

basis/images/bitmap/loading/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/images/bitmap/loading/loading.factor

@@ -0,0 +1,374 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays combinators
+compression.run-length fry grouping images images.loader io
+io.binary io.encodings.8-bit io.encodings.binary
+io.encodings.string io.streams.limited kernel math math.bitwise
+sequences specialized-arrays.ushort summary ;
+QUALIFIED-WITH: bitstreams b
+IN: images.bitmap.loading
+
+SINGLETON: bitmap-image
+"bmp" bitmap-image register-image-class
+
+! http://www.fileformat.info/format/bmp/egff.htm
+! http://www.digicamsoft.com/bmp/bmp.html
+
+ERROR: unknown-component-order bitmap ;
+ERROR: unknown-bitmap-header n ;
+
+: read2 ( -- n ) 2 read le> ;
+: read4 ( -- n ) 4 read le> ;
+
+TUPLE: loading-bitmap
+    file-header header
+    color-palette color-index bitfields ;
+
+TUPLE: file-header
+    { magic initial: "BM" }
+    { size }
+    { reserved1 initial: 0 }
+    { reserved2 initial: 0 }
+    { offset }
+    { header-length } ;
+
+TUPLE: v3-header
+    { width initial: 0 }
+    { height initial: 0 }
+    { planes initial: 0 }
+    { bit-count initial: 0 }
+    { compression initial: 0 }
+    { image-size initial: 0 }
+    { x-resolution initial: 0 }
+    { y-resolution initial: 0 }
+    { colors-used initial: 0 }
+    { colors-important initial: 0 } ;
+
+TUPLE: v4-header < v3-header
+    { red-mask initial: 0 }
+    { green-mask initial: 0 }
+    { blue-mask initial: 0 }
+    { alpha-mask initial: 0 }
+    { cs-type initial: 0 }
+    { end-points initial: 0 }
+    { gamma-red initial: 0 }
+    { gamma-green initial: 0 }
+    { gamma-blue initial: 0 } ;
+
+TUPLE: v5-header < v4-header
+    { intent initial: 0 }
+    { profile-data initial: 0 }
+    { profile-size initial: 0 }
+    { reserved3 initial: 0 } ;
+
+TUPLE: os2v1-header
+    { width initial: 0 }
+    { height initial: 0 }
+    { planes initial: 0 }
+    { bit-count initial: 0 } ;
+
+TUPLE: os2v2-header < os2v1-header
+    { compression initial: 0 }
+    { image-size initial: 0 }
+    { x-resolution initial: 0 }
+    { y-resolution initial: 0 }
+    { colors-used initial: 0 }
+    { colors-important initial: 0 }
+    { units initial: 0 }
+    { reserved initial: 0 }
+    { recording initial: 0 }
+    { rendering initial: 0 }
+    { size1 initial: 0 }
+    { size2 initial: 0 }
+    { color-encoding initial: 0 }
+    { identifier initial: 0 } ;
+
+UNION: v-header v3-header v4-header v5-header ;
+UNION: os2-header os2v1-header os2v2-header ;
+
+: parse-file-header ( -- file-header )
+    \ file-header new
+        2 read latin1 decode >>magic
+        read4 >>size
+        read2 >>reserved1
+        read2 >>reserved2
+        read4 >>offset
+        read4 >>header-length ;
+
+: read-v3-header-data ( header -- header )
+    read4 >>width
+    read4 32 >signed >>height
+    read2 >>planes
+    read2 >>bit-count
+    read4 >>compression
+    read4 >>image-size
+    read4 >>x-resolution
+    read4 >>y-resolution
+    read4 >>colors-used
+    read4 >>colors-important ;
+
+: read-v3-header ( -- header )
+    \ v3-header new
+        read-v3-header-data ;
+
+: read-v4-header-data ( header -- header )
+    read4 >>red-mask
+    read4 >>green-mask
+    read4 >>blue-mask
+    read4 >>alpha-mask
+    read4 >>cs-type
+    read4 read4 read4 3array >>end-points
+    read4 >>gamma-red
+    read4 >>gamma-green
+    read4 >>gamma-blue ;
+
+: read-v4-header ( -- v4-header )
+    \ v4-header new
+        read-v3-header-data
+        read-v4-header-data ;
+
+: read-v5-header-data ( v5-header -- v5-header )
+    read4 >>intent
+    read4 >>profile-data
+    read4 >>profile-size
+    read4 >>reserved3 ;
+
+: read-v5-header ( -- loading-bitmap )
+    \ v5-header new
+        read-v3-header-data
+        read-v4-header-data
+        read-v5-header-data ;
+
+: read-os2v1-header ( -- os2v1-header )
+    \ os2v1-header new
+        read2 >>width
+        read2 16 >signed >>height
+        read2 >>planes
+        read2 >>bit-count ;
+
+: read-os2v2-header-data ( os2v2-header -- os2v2-header )
+    read4 >>width
+    read4 32 >signed >>height
+    read2 >>planes
+    read2 >>bit-count
+    read4 >>compression
+    read4 >>image-size
+    read4 >>x-resolution
+    read4 >>y-resolution
+    read4 >>colors-used
+    read4 >>colors-important
+    read2 >>units
+    read2 >>reserved
+    read2 >>recording
+    read2 >>rendering
+    read4 >>size1
+    read4 >>size2
+    read4 >>color-encoding
+    read4 >>identifier ;
+
+: read-os2v2-header ( -- os2v2-header )
+    \ os2v2-header new
+        read-os2v2-header-data ;
+
+: parse-header ( n -- header )
+    {
+        { 12 [ read-os2v1-header ] }
+        { 64 [ read-os2v2-header ] }
+        { 40 [ read-v3-header ] }
+        { 108 [ read-v4-header ] }
+        { 124 [ read-v5-header ] }
+        [ unknown-bitmap-header ]
+    } case ;
+
+: color-index-length ( header -- n )
+    {
+        [ width>> ]
+        [ planes>> * ]
+        [ bit-count>> * 31 + 32 /i 4 * ]
+        [ height>> abs * ]
+    } cleave ;
+
+: color-palette-length ( loading-bitmap -- n )
+    file-header>>
+    [ offset>> 14 - ] [ header-length>> ] bi - ;
+
+: parse-color-palette ( loading-bitmap -- loading-bitmap )
+    dup color-palette-length read >>color-palette ;
+
+GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
+
+: parse-color-data ( loading-bitmap -- loading-bitmap )
+    dup header>> parse-color-data* ;
+
+M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
+    color-index-length read >>color-index ;
+
+M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
+    dup image-size>> [ 0 ] unless* dup 0 >
+    [ nip ] [ drop color-index-length ] if read >>color-index ;
+
+: alpha-used? ( loading-bitmap -- ? )
+    color-index>> 4 <sliced-groups> [ fourth 0 = ] all? not ;
+
+GENERIC: bitmap>component-order* ( loading-bitmap header -- object )
+
+: bitmap>component-order ( loading-bitmap -- object )
+    dup header>> bitmap>component-order* ;
+
+: simple-bitmap>component-order ( loading-bitamp -- object )
+    header>> bit-count>> {
+        { 32 [ BGRX ] }
+        { 24 [ BGR ] }
+        { 16 [ BGR ] }
+        { 8 [ BGR ] }
+        { 4 [ BGR ] }
+        { 1 [ BGR ] }
+        [ unknown-component-order ]
+    } case ;
+
+: advanced-bitmap>component-order ( loading-bitmap -- object )
+    [ ] [ header>> bit-count>> ] [ alpha-used? ] tri 2array {
+        { { 32 t } [ drop BGRA ] }
+        { { 32 f } [ drop BGRX ] }
+        [ drop simple-bitmap>component-order ]
+    } case ;
+
+: color-lookup3 ( loading-bitmap -- seq )
+    [ color-index>> >array ]
+    [ color-palette>> 3 <sliced-groups> ] bi
+    '[ _ nth ] map concat ;
+
+: color-lookup4 ( loading-bitmap -- seq )
+    [ color-index>> >array ]
+    [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
+    '[ _ nth ] map concat ;
+
+! os2v1 is 3bytes each, all others are 3 + 1 unused
+: color-lookup ( loading-bitmap -- seq )
+    dup file-header>> header-length>> {
+        { 12 [ color-lookup3 ] }
+        { 64 [ color-lookup4 ] }
+        { 40 [ color-lookup4 ] }
+        { 108 [ color-lookup4 ] }
+        { 124 [ color-lookup4 ] }
+    } case ;
+
+M: os2v1-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: os2v2-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: v3-header bitmap>component-order* drop simple-bitmap>component-order ;
+M: v4-header bitmap>component-order* drop advanced-bitmap>component-order ;
+M: v5-header bitmap>component-order* drop advanced-bitmap>component-order ;
+
+: uncompress-bitfield ( seq masks -- bytes' )
+    '[
+        _ [
+            [ bitand ] [ bit-count ] [ log2 ] tri - shift
+        ] with map
+    ] { } map-as B{ } concat-as ;
+
+ERROR: bmp-not-supported n ;
+
+: bitmap>bytes ( loading-bitmap -- byte-array )
+    dup header>> bit-count>>
+    {
+        { 32 [ color-index>> ] }
+        { 24 [ color-index>> ] }
+        { 16 [
+            [
+                ! byte-array>ushort-array
+                2 group [ le> ] map
+                ! 5 6 5
+                ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
+                ! 5 5 5
+                { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
+            ] change-color-index
+            color-index>>
+        ] }
+        { 8 [ color-lookup ] }
+        { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
+        { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
+        [ bmp-not-supported ]
+    } case >byte-array ;
+
+: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+    dup header>> bit-count>> {
+        { 16 [ dup color-palette>> 4 group [ le> ] map ] }
+        { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
+    } case reverse >>bitfields ;
+
+ERROR: unsupported-bitfield-widths n ;
+
+M: unsupported-bitfield-widths summary
+    drop "Bitmaps only support bitfield compression in 16/32bit images" ;
+
+: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
+    set-bitfield-widths
+    dup header>> bit-count>> {
+        { 16 [
+            dup bitfields>> '[
+                byte-array>ushort-array _ uncompress-bitfield
+            ] change-color-index
+        ] }
+        { 32 [ ] }
+        [ unsupported-bitfield-widths ]
+    } case ;
+
+ERROR: unsupported-bitmap-compression compression ;
+
+GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
+
+: uncompress-bitmap ( loading-bitmap -- loading-bitmap )
+    dup header>> uncompress-bitmap* ;
+
+M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
+    drop ;
+
+: do-run-length-uncompress ( loading-bitmap word -- loading-bitmap )
+    dupd '[
+        _ header>> [ width>> ] [ height>> ] bi
+        _ execute
+    ] change-color-index ; inline
+
+M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
+    compression>> {
+        { f [ ] }
+        { 0 [ ] }
+        { 1 [ \ run-length-uncompress-bitmap8 do-run-length-uncompress ] }
+        { 2 [ \ run-length-uncompress-bitmap4 do-run-length-uncompress ] }
+        { 3 [ uncompress-bitfield-widths ] }
+        { 4 [ "jpeg" unsupported-bitmap-compression ] }
+        { 5 [ "png" unsupported-bitmap-compression ] }
+    } case ;
+
+ERROR: unsupported-bitmap-file magic ;
+
+: load-bitmap ( path -- loading-bitmap )
+    binary stream-throws <limited-file-reader> [
+        \ loading-bitmap new
+        parse-file-header [ >>file-header ] [ ] bi magic>> {
+            { "BM" [
+                dup file-header>> header-length>> parse-header >>header
+                parse-color-palette
+                parse-color-data
+            ] }
+            ! { "BA" [ parse-os2-bitmap-array ] }
+            ! { "CI" [ parse-os2-color-icon ] }
+            ! { "CP" [ parse-os2-color-pointer ] }
+            ! { "IC" [ parse-os2-icon ] }
+            ! { "PT" [ parse-os2-pointer ] }
+            [ unsupported-bitmap-file ]
+        } case
+    ] with-input-stream ;
+
+: loading-bitmap>bytes ( loading-bitmap -- byte-array )
+    uncompress-bitmap bitmap>bytes ;
+
+M: bitmap-image load-image* ( path bitmap-image -- bitmap )
+    drop load-bitmap
+    [ image new ] dip
+    {
+        [ loading-bitmap>bytes >>bitmap ]
+        [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
+        [ header>> height>> 0 < not >>upside-down? ]
+        [ bitmap>component-order >>component-order ]
+    } cleave ;

basis/images/jpeg/jpeg.factor

@@ -6,14 +6,12 @@ images.processing io io.binary io.encodings.binary io.files
 io.streams.byte-array kernel locals math math.bitwise
 math.constants math.functions math.matrices math.order
 math.ranges math.vectors memoize multiline namespaces
-sequences sequences.deep images.loader ;
+sequences sequences.deep ;
-QUALIFIED-WITH: bitstreams bs
 IN: images.jpeg
 
-SINGLETON: jpeg-image
+QUALIFIED-WITH: bitstreams bs
-{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
 
-TUPLE: loading-jpeg < image
+TUPLE: jpeg-image < image
     { headers }
     { bitstream }
     { color-info initial: { f f f f } }
@@ -23,7 +21,7 @@ TUPLE: loading-jpeg < image
 
 <PRIVATE
 
-CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ;
+CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
 
 SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
 APP JPG COM TEM RES ;
@@ -65,7 +63,7 @@ TUPLE: jpeg-color-info
 
 CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
 
-: jpeg> ( -- jpeg-image ) loading-jpeg get ;
+: jpeg> ( -- jpeg-image ) jpeg-image get ;
 
 : apply-diff ( dc color -- dc' )
     [ diff>> + dup ] [ (>>diff) ] bi ;
@@ -77,7 +75,6 @@ CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
 
 : read4/4 ( -- a b ) read1 16 /mod ;
 
-
 ! headers
 
 : decode-frame ( header -- )
@@ -188,6 +185,9 @@ MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
 
 : mb-dim ( component -- dim )  [ h>> ] [ v>> ] bi 2array ;
 
+! : blocks ( component -- seq )
+!    mb-dim ! coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ;
+
 : all-macroblocks ( quot: ( mb -- ) -- )
     [
         jpeg>
@@ -211,12 +211,12 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
 
 : idct ( b -- b' ) idct-blas ;
 
-:: draw-block ( block x,y color jpeg-image -- )
+:: draw-block ( block x,y color-id jpeg-image -- )
     block dup length>> sqrt >fixnum group flip
     dup matrix-dim coord-matrix flip
     [
         [ first2 spin nth nth ]
-        [ x,y v+ color id>> 1- jpeg-image draw-color ] bi
+        [ x,y v+ color-id jpeg-image draw-color ] bi
     ] with each^2 ;
 
 : sign-extend ( bits v -- v' )
@@ -229,7 +229,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
 : read1-jpeg-ac ( decoder -- run/ac )
     [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
 
-:: decode-block ( pos color -- )
+:: decode-block ( color -- pixels )
     color dc-huff-table>> read1-jpeg-dc color apply-diff
     64 0 <array> :> coefs
     0 coefs set-nth
@@ -241,19 +241,38 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
         k 63 < and
     ] loop
     coefs color quant-table>> v*
-    reverse-zigzag idct
+    reverse-zigzag idct ;
-    ! %fixme: color hack
-    ! this eat 50% cpu time
-    color h>> 2 =
-    [ 8 group 2 matrix-zoom concat ] unless
-    pos { 8 8 } v* color jpeg> draw-block ;
     
-: decode-macroblock ( mb -- )
+:: draw-macroblock-yuv420 ( mb blocks -- )
+    mb { 16 16 } v* :> pos
+    0 blocks nth pos { 0 0 } v+ 0 jpeg> draw-block
+    1 blocks nth pos { 8 0 } v+ 0 jpeg> draw-block
+    2 blocks nth pos { 0 8 } v+ 0 jpeg> draw-block
+    3 blocks nth pos { 8 8 } v+ 0 jpeg> draw-block
+    4 blocks nth 8 group 2 matrix-zoom concat pos 1 jpeg> draw-block
+    5 blocks nth 8 group 2 matrix-zoom concat pos 2 jpeg> draw-block ;
+    
+:: draw-macroblock-yuv444 ( mb blocks -- )
+    mb { 8 8 } v* :> pos
+    3 iota [ [ blocks nth pos ] [ jpeg> draw-block ] bi ] each ;
+
+:: draw-macroblock-y ( mb blocks -- )
+    mb { 8 8 } v* :> pos
+    0 blocks nth pos 0 jpeg> draw-block
+    64 0 <array> pos 1 jpeg> draw-block
+    64 0 <array> pos 2 jpeg> draw-block ;
+ 
+    ! %fixme: color hack
+ !   color h>> 2 =
+ !   [ 8 group 2 matrix-zoom concat ] unless
+ !   pos { 8 8 } v* color jpeg> draw-block ;
+
+: decode-macroblock ( -- blocks )
     jpeg> components>>
     [
-        [ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ]
+        [ mb-dim first2 * iota ]
-        [ [ decode-block ] curry each ] bi
+        [ [ decode-block ] curry replicate ] bi
-    ] with each ;
+    ] map concat ;
 
 : cleanup-bitstream ( bytes -- bytes' )
     binary [
@@ -274,33 +293,67 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
     dup dim>> first2 * 3 * 0 <array> >>bitmap
     drop ;
 
-: baseline-decompress ( -- )
+ERROR: unsupported-colorspace ;
-    jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
+SINGLETONS: YUV420 YUV444 Y MAGIC! ;
-    >byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
+
-    jpeg> [ bitstream>> ] [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
+:: detect-colorspace ( jpeg-image -- csp )
-    jpeg> components>> [ fetch-tables ] each
+    jpeg-image color-info>> sift :> colors
-    jpeg> setup-bitmap
+    MAGIC!
-    [ decode-macroblock ] all-macroblocks ;
+    colors length 1 = [ drop Y ] when
+    colors length 3 =
+    [
+        colors [ mb-dim { 1 1 } = ] all?
+        [ drop YUV444 ] when
+
+        colors unclip
+        [ [ mb-dim { 1 1 } = ] all? ]
+        [ mb-dim { 2 2 } =  ] bi* and
+        [ drop YUV420 ] when
+    ] when ;
+    
+! this eats ~50% cpu time
+: draw-macroblocks ( mbs -- )
+    jpeg> detect-colorspace
+    {
+        { YUV420 [ [ first2 draw-macroblock-yuv420 ] each ] }
+        { YUV444 [ [ first2 draw-macroblock-yuv444 ] each ] }
+        { Y      [ [ first2 draw-macroblock-y ] each ] }
+        [ unsupported-colorspace ]
+    } case ;
 
 ! this eats ~25% cpu time
 : color-transform ( yuv -- rgb )
     { 128 0 0 } v+ yuv>bgr-matrix swap m.v
     [ 0 max 255 min >fixnum ] map ;
 
+: baseline-decompress ( -- )
+    jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
+    >byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
+    jpeg> 
+    [ bitstream>> ] 
+    [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
+    jpeg> components>> [ fetch-tables ] each
+    [ decode-macroblock 2array ] accumulator 
+    [ all-macroblocks ] dip
+    jpeg> setup-bitmap draw-macroblocks 
+    jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
+    jpeg> [ >byte-array ] change-bitmap drop ;
+
+ERROR: not-a-jpeg-image ;
+
 PRIVATE>
 
 : load-jpeg ( path -- image )
     binary [
-        parse-marker { SOI } assert=
+        parse-marker { SOI } = [ not-a-jpeg-image ] unless
         parse-headers
-        contents <loading-jpeg>
+        contents <jpeg-image>
     ] with-file-reader
-    dup loading-jpeg [
+    dup jpeg-image [
         baseline-parse
         baseline-decompress
-        jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
-        jpeg> [ >byte-array ] change-bitmap drop
     ] with-variable ;
 
 M: jpeg-image load-image* ( path jpeg-image -- bitmap )
     drop load-jpeg ;
+

basis/images/png/png.factor

@@ -10,9 +10,10 @@ IN: images.png
 SINGLETON: png-image
 "png" png-image register-image-class
 
-TUPLE: loading-png < image chunks
+TUPLE: loading-png
-width height bit-depth color-type compression-method
+    chunks
-filter-method interlace-method uncompressed ;
+    width height bit-depth color-type compression-method
+    filter-method interlace-method uncompressed ;
 
 CONSTRUCTOR: loading-png ( -- image )
     V{ } clone >>chunks ;
@@ -33,22 +34,21 @@ ERROR: bad-png-header header ;
 
 ERROR: bad-checksum ;
 
-: read-png-chunks ( image -- image )
+: read-png-chunks ( loading-png -- loading-png )
     <png-chunk>
     4 read be> [ >>length ] [ 4 + ] bi
     read dup crc32 checksum-bytes
     4 read = [ bad-checksum ] unless
     4 cut-slice
-    [ ascii decode >>type ]
+    [ ascii decode >>type ] [ B{ } like >>data ] bi*
-    [ B{ } like >>data ] bi*
     [ over chunks>> push ] 
     [ type>> ] bi "IEND" =
     [ read-png-chunks ] unless ;
 
-: find-chunk ( image string -- chunk )
+: find-chunk ( loading-png string -- chunk )
     [ chunks>> ] dip '[ type>> _ = ] find nip ;
 
-: parse-ihdr-chunk ( image -- image )
+: parse-ihdr-chunk ( loading-png -- loading-png )
     dup "IHDR" find-chunk data>> {
         [ [ 0 4 ] dip subseq be> >>width ]
         [ [ 4 8 ] dip subseq be> >>height ]
@@ -59,44 +59,44 @@ ERROR: bad-checksum ;
         [ [ 12 ] dip nth >>interlace-method ]
     } cleave ;
 
-: find-compressed-bytes ( image -- bytes )
+: find-compressed-bytes ( loading-png -- bytes )
     chunks>> [ type>> "IDAT" = ] filter
     [ data>> ] map concat ;
 
-: fill-image-data ( image -- image )
-    dup [ width>> ] [ height>> ] bi 2array >>dim ;
 
-: zlib-data ( png-image -- bytes ) 
+: zlib-data ( loading-png -- bytes ) 
     chunks>> [ type>> "IDAT" = ] find nip data>> ;
 
 ERROR: unknown-color-type n ;
 ERROR: unimplemented-color-type image ;
 
-: inflate-data ( image -- bytes )
+: inflate-data ( loading-png -- bytes )
     zlib-data zlib-inflate ; 
 
-: decode-greyscale ( image -- image )
+: decode-greyscale ( loading-png -- loading-png )
     unimplemented-color-type ;
 
-: decode-truecolor ( image -- image )
+: png-image-bytes ( loading-png -- byte-array )
-    {
+    [ inflate-data ] [ width>> 3 * 1 + ] bi group
-        [ inflate-data ]
+    reverse-png-filter ;
-        [ dim>> first 3 * 1 + group reverse-png-filter ]
+
-        [ swap >byte-array >>bitmap drop ]
+: decode-truecolor ( loading-png -- loading-png )
-        [ RGB >>component-order drop ]
+    [ <image> ] dip {
-        [ ]
+        [ png-image-bytes >>bitmap ]
+        [ [ width>> ] [ height>> ] bi 2array >>dim ]
+        [ drop RGB >>component-order ]
     } cleave ;
     
-: decode-indexed-color ( image -- image )
+: decode-indexed-color ( loading-png -- loading-png )
     unimplemented-color-type ;
 
-: decode-greyscale-alpha ( image -- image )
+: decode-greyscale-alpha ( loading-png -- loading-png )
     unimplemented-color-type ;
 
-: decode-truecolor-alpha ( image -- image )
+: decode-truecolor-alpha ( loading-png -- loading-png )
     unimplemented-color-type ;
 
-: decode-png ( image -- image ) 
+: decode-png ( loading-png -- loading-png ) 
     dup color-type>> {
         { 0 [ decode-greyscale ] }
         { 2 [ decode-truecolor ] }
@@ -112,7 +112,6 @@ ERROR: unimplemented-color-type image ;
         read-png-header
         read-png-chunks
         parse-ihdr-chunk
-        fill-image-data
         decode-png
     ] with-input-stream ;
 

basis/images/tiff/tiff.factor

@@ -443,7 +443,7 @@ ERROR: unhandled-compression compression ;
     '[
         _ group
         [ _ group unclip [ v+ ] accumulate swap suffix concat ] map
-        concat >byte-array
+        B{ } concat-as
     ] change-bitmap ;
 
 : strips-predictor ( ifd -- ifd )
@@ -492,11 +492,11 @@ ERROR: unknown-component-order ifd ;
     } case ;
 
 : ifd>image ( ifd -- image )
-    {
+    [ <image> ] dip {
-        [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
+        [ [ image-width find-tag ] [ image-length find-tag ] bi 2array >>dim ]
-        [ ifd-component-order f ]
+        [ ifd-component-order >>component-order ]
-        [ bitmap>> ]
+        [ bitmap>> >>bitmap ]
-    } cleave image boa ;
+    } cleave ;
 
 : tiff>image ( image -- image )
     ifds>> [ ifd>image ] map first ;

basis/io/servers/connection/connection.factor

@@ -11,17 +11,17 @@ combinators.short-circuit ;
 IN: io.servers.connection
 
 TUPLE: threaded-server
-name
+{ name initial: "server" }
-log-level
+{ log-level initial: DEBUG }
 secure insecure
-secure-config
+{ secure-config initial-quot: [ <secure-config> ] }
-sockets
+{ sockets initial-quot: [ V{ } clone ] }
 max-connections
 semaphore
-timeout
+{ timeout initial-quot: [ 1 minutes ] }
 encoding
-handler
+{ handler initial: [ "No handler quotation" throw ] }
-ready ;
+{ ready initial-quot: [ <flag> ] } ;
 
 : local-server ( port -- addrspec ) "localhost" swap <inet> ;
 
@@ -29,14 +29,7 @@ ready ;
 
 : new-threaded-server ( encoding class -- threaded-server )
     new
-        swap >>encoding
+        swap >>encoding ;
-        "server" >>name
-        DEBUG >>log-level
-        1 minutes >>timeout
-        V{ } clone >>sockets
-        <secure-config> >>secure-config
-        [ "No handler quotation" throw ] >>handler
-        <flag> >>ready ; inline
 
 : <threaded-server> ( encoding -- threaded-server )
     threaded-server new-threaded-server ;

basis/io/sockets/sockets.factor

@@ -117,7 +117,7 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ;
     <byte-array> glue ;
 
 : inet6-bytes ( seq -- bytes )
-    [ 2 >be ] { } map-as concat >byte-array ;
+    [ 2 >be ] { } map-as B{ } concat-as ;
 
 PRIVATE>
 

basis/math/functions/functions-tests.factor

@@ -22,6 +22,7 @@ IN: math.functions.tests
 [ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test
 
 [ t ] [ 0 0 ^ fp-nan? ] unit-test
+[ 0.0 ] [ 0.0 1.0 ^ ] unit-test
 [ 1/0. ] [ 0 -2 ^ ] unit-test
 [ t ] [ 0 0.0 ^ fp-nan? ] unit-test
 [ 1/0. ] [ 0 -2.0 ^ ] unit-test

basis/math/functions/functions.factor

@@ -89,7 +89,7 @@ PRIVATE>
 
 : ^ ( x y -- z )
     {
-        { [ over zero? ] [ nip 0^ ] }
+        { [ over 0 = ] [ nip 0^ ] }
         { [ dup integer? ] [ integer^ ] }
         { [ 2dup real^? ] [ fpow ] }
         [ ^complex ]

basis/math/matrices/matrices.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.order math.vectors
+USING: accessors arrays columns kernel math math.bits
-sequences sequences.private accessors columns ;
+math.order math.vectors sequences sequences.private fry ;
 IN: math.matrices
 
 ! Matrices
 : zero-matrix ( m n -- matrix )
-    [ nip 0 <array> ] curry map ;
+    '[ _ 0 <array> ] replicate ;
 
 : identity-matrix ( n -- matrix )
     #! Make a nxn identity matrix.
@@ -61,3 +61,7 @@ PRIVATE>
 
 : cross-zip ( seq1 seq2 -- seq1xseq2 )
     [ [ 2array ] with map ] curry map ;
+    
+: m^n ( m n -- n ) 
+    make-bits over first length identity-matrix
+    [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ;

basis/opengl/textures/textures.factor

@@ -50,7 +50,7 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
         [ dup 1 = [ next-power-of-2 ] unless ] map
     ] unless ;
 
-: (tex-image) ( image bitmap -- )
+: tex-image ( image bitmap -- )
     [
         [ GL_TEXTURE_2D 0 GL_RGBA ] dip
         [ dim>> adjust-texture-dim first2 0 ]
@@ -58,9 +58,11 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
     ] dip
     glTexImage2D ;
 
-: (tex-sub-image) ( image -- )
+: tex-sub-image ( image -- )
     [ GL_TEXTURE_2D 0 0 0 ] dip
-    [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri
+    [ dim>> first2 ]
+    [ component-order>> component-order>format ]
+    [ bitmap>> ] tri
     glTexSubImage2D ;
 
 : init-texture ( -- )
@@ -173,8 +175,8 @@ PRIVATE>
         GL_TEXTURE_BIT [
             GL_TEXTURE_2D swap glBindTexture
             non-power-of-2-textures? get
-            [ dup bitmap>> (tex-image) ]
+            [ dup bitmap>> tex-image ]
-            [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if
+            [ [ f tex-image ] [ tex-sub-image ] bi ] if
         ] do-attribs
     ] keep ;
 

basis/porter-stemmer/porter-stemmer.factor

@@ -1,5 +1,5 @@
+USING: combinators kernel math parser sequences splitting ;
 IN: porter-stemmer
-USING: kernel math parser sequences combinators splitting ;
 
 : consonant? ( i str -- ? )
     2dup nth dup "aeiou" member? [

basis/tools/hexdump/hexdump.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io io.streams.string kernel math math.parser
+USING: arrays ascii byte-arrays byte-vectors grouping io
-namespaces sequences splitting grouping strings ascii
+io.encodings.binary io.files io.streams.string kernel math
-byte-arrays byte-vectors ;
+math.parser namespaces sequences splitting strings ;
 IN: tools.hexdump
 
 <PRIVATE
@@ -42,3 +42,6 @@ M: byte-vector hexdump. hexdump-bytes ;
 
 : hexdump ( byte-array -- str )
     [ hexdump. ] with-string-writer ;
+
+: hexdump-file ( path -- )
+    binary file-contents hexdump. ;

core/bootstrap/syntax.factor

@@ -80,6 +80,7 @@ IN: bootstrap.syntax
     ">>"
     "call-next-method"
     "initial:"
+    "initial-quot:"
     "read-only"
     "call("
     "execute("

core/classes/tuple/parser/parser-tests.factor

@@ -1,7 +1,7 @@
 IN: classes.tuple.parser.tests
 USING: accessors classes.tuple.parser lexer words classes
 sequences math kernel slots tools.test parser compiler.units
-arrays classes.tuple eval ;
+arrays classes.tuple eval multiline ;
 
 TUPLE: test-1 ;
 
@@ -142,3 +142,11 @@ TUPLE: parsing-corner-case x ;
         "    x 3 }"
     } "\n" join eval( -- tuple )
 ] [ error>> unexpected-eof? ] must-fail-with
+
+
+[ ] [
+    <" USE: sequences
+    IN: classes.tuple.tests
+    TUPLE: book { name initial-quot: [ "Lord of the " "Rings" append ] } ;">
+    eval( -- )
+] unit-test

core/classes/tuple/tuple-tests.factor

@@ -1,11 +1,12 @@
-USING: definitions generic kernel kernel.private math math.constants
+USING: accessors arrays assocs calendar classes classes.algebra
-parser sequences tools.test words assocs namespaces quotations
+classes.private classes.tuple classes.tuple.private columns
-sequences.private classes continuations generic.single
+compiler.errors compiler.units continuations definitions
-generic.standard effects classes.tuple classes.tuple.private arrays
+effects eval generic generic.single generic.standard grouping
-vectors strings compiler.units accessors classes.algebra calendar
+io.streams.string kernel kernel.private math math.constants
-prettyprint io.streams.string splitting summary columns math.order
+math.order namespaces parser parser.notes prettyprint
-classes.private slots slots.private eval see words.symbol
+quotations random see sequences sequences.private slots
-compiler.errors parser.notes ;
+slots.private splitting strings summary threads tools.test
+vectors vocabs words words.symbol ;
 IN: classes.tuple.tests
 
 TUPLE: rect x y w h ;
@@ -421,7 +422,6 @@ TUPLE: redefinition-problem-2 ;
 [ t ] [ 3 redefinition-problem'? ] unit-test
 
 ! Hardcore unit tests
-USE: threads
 
 \ thread "slots" word-prop "slots" set
 
@@ -439,8 +439,6 @@ USE: threads
     ] with-compilation-unit
 ] unit-test
 
-USE: vocabs
-
 \ vocab "slots" word-prop "slots" set
 
 [ ] [
@@ -731,3 +729,18 @@ DEFER: redefine-tuple-twice
 [ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test
 
 [ t ] [ \ redefine-tuple-twice symbol? ] unit-test
+
+TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } ;
+SLOT: winner?
+
+[ f ] [ 100 [ lucky-number new ] replicate all-equal? ] unit-test
+
+! Reshaping initial-quot:
+lucky-number new dup n>> 2array "luckiest-number" set
+
+[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test
+
+[ ] [ "USING: accessors random ; IN: classes.tuple.tests TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } { winner? initial-quot: [ t ] } ;" eval( -- ) ] unit-test
+
+[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test
+[ t ] [ "luckiest-number" get first winner?>> ] unit-test

core/classes/tuple/tuple.factor

@@ -50,6 +50,9 @@ M: tuple class layout-of 2 slot { word } declare ;
 
 PRIVATE>
 
+: initial-quots? ( class -- ? )
+    all-slots [ initial-quot>> ] any? ;
+
 : initial-values ( class -- slots )
     all-slots [ initial>> ] map ;
 
@@ -66,7 +69,7 @@ PRIVATE>
 
 GENERIC: slots>tuple ( seq class -- tuple )
 
-M: tuple-class slots>tuple
+M: tuple-class slots>tuple ( seq class -- tuple )
     check-slots pad-slots
     tuple-layout <tuple> [
         [ tuple-size ]
@@ -146,12 +149,22 @@ ERROR: bad-superclass class ;
 : define-boa-check ( class -- )
     dup boa-check-quot "boa-check" set-word-prop ;
 
+: tuple-initial-quots-quot ( class -- quot )
+    all-slots [ initial-quot>> ] filter
+    [
+        [
+            [ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ]
+            [ offset>> , ] bi \ set-slot ,
+        ] each
+    ] [ ] make f like ;
+
 : tuple-prototype ( class -- prototype )
-    [ initial-values ] keep
+    [ initial-values ] [ over [ ] any? ] [ initial-quots? or ] tri
-    over [ ] any? [ slots>tuple ] [ 2drop f ] if ;
+    [ slots>tuple ] [ 2drop f ] if ;
 
 : define-tuple-prototype ( class -- )
-    dup tuple-prototype "prototype" set-word-prop ;
+    dup [ tuple-prototype ] [ tuple-initial-quots-quot ] bi 2array
+    dup [ ] any? [ drop f ] unless "prototype" set-word-prop ;
 
 : prepare-slots ( slots superclass -- slots' )
     [ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
@@ -173,10 +186,21 @@ ERROR: bad-superclass class ;
 : define-tuple-layout ( class -- )
     dup make-tuple-layout "layout" set-word-prop ;
 
+: calculate-initial-value ( slot-spec -- value )
+    dup initial>> [
+        nip
+    ] [
+        dup initial-quot>> [
+            nip call( -- obj )
+        ] [
+            drop f
+        ] if*
+    ] if* ;
+
 : compute-slot-permutation ( new-slots old-slots -- triples )
     [ [ [ name>> ] map ] bi@ [ index ] curry map ]
     [ drop [ class>> ] map ]
-    [ drop [ initial>> ] map ]
+    [ drop [ calculate-initial-value ] map ]
     2tri 3array flip ;
 
 : update-slot ( old-values n class initial -- value )
@@ -340,8 +364,11 @@ M: tuple tuple-hashcode
 M: tuple hashcode* tuple-hashcode ;
 
 M: tuple-class new
-    dup "prototype" word-prop
+    dup "prototype" word-prop [
-    [ (clone) ] [ tuple-layout <tuple> ] ?if ;
+        first2 [ (clone) ] dip [ call( obj -- obj ) ] when*
+    ] [
+        tuple-layout <tuple>
+    ] ?if ;
 
 M: tuple-class boa
     [ "boa-check" word-prop [ call ] when* ]

core/destructors/destructors-docs.factor

@@ -8,16 +8,16 @@ HELP: dispose
 $nl
 "No further operations can be performed on a disposable object after this call."
 $nl
-"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $snippet "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
+"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $slot "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
 { $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word."
 $nl
-"The default implementation assumes the object has a " { $snippet "disposable" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link t } "." } ;
+"The default implementation assumes the object has a " { $snippet "disposed" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link t } "." } ;
 
 HELP: dispose*
 { $values { "disposable" "a disposable object" } }
 { $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." }
 { $notes
-    "This word should not be called directly. It can be implemented on objects with a " { $snippet "disposable" } " slot to ensure that the object is only disposed once."
+    "This word should not be called directly. It can be implemented on objects with a " { $slot "disposed" } " slot to ensure that the object is only disposed once."
 } ;
 
 HELP: with-disposal

core/slots/slots.factor

@@ -6,7 +6,7 @@ classes classes.algebra slots.private combinators accessors
 words sequences.private assocs alien quotations hashtables ;
 IN: slots
 
-TUPLE: slot-spec name offset class initial read-only ;
+TUPLE: slot-spec name offset class initial initial-quot read-only ;
 
 PREDICATE: reader < word "reader" word-prop ;
 
@@ -190,6 +190,7 @@ ERROR: bad-slot-attribute key ;
     dup empty? [
         unclip {
             { initial: [ [ first >>initial ] [ rest ] bi ] }
+            { initial-quot: [ [ first >>initial-quot ] [ rest ] bi ] }
             { read-only [ [ t >>read-only ] dip ] }
             [ bad-slot-attribute ]
         } case
@@ -197,7 +198,14 @@ ERROR: bad-slot-attribute key ;
 
 ERROR: bad-initial-value name ;
 
+ERROR: duplicate-initial-values slot ;
+
+: check-duplicate-initial-values ( slot-spec -- slot-spec )
+    dup [ initial>> ] [ initial-quot>> ] bi and
+    [ duplicate-initial-values ] when ;
+
 : check-initial-value ( slot-spec -- slot-spec )
+    check-duplicate-initial-values
     dup initial>> [
         [ ] [
             dup [ initial>> ] [ class>> ] bi instance?

core/syntax/syntax.factor

@@ -246,6 +246,8 @@ IN: bootstrap.syntax
     
     "initial:" "syntax" lookup define-symbol
 
+    "initial-quot:" "syntax" lookup define-symbol
+
     "read-only" "syntax" lookup define-symbol
 
     "call(" [ \ call-effect parse-call( ] define-core-syntax

extra/cursors/cursors-tests.factor

@@ -19,3 +19,21 @@ IN: cursors.tests
 [ f ] [ { 2 4 6 } [ odd? ] any? ] unit-test
 
 [ { 1 3 5 } ] [ { 1 2 3 4 5 6 } [ odd? ] filter ] unit-test
+
+[ { } ]
+[ { 1 2 } { } [ + ] 2map ] unit-test
+
+[ { 11 } ]
+[ { 1 2 } { 10 } [ + ] 2map ] unit-test
+
+[ { 11 22 } ]
+[ { 1 2 } { 10 20 } [ + ] 2map ] unit-test
+
+[ { } ]
+[ { 1 2 } { } { } [ + + ] 3map ] unit-test
+
+[ { 111 } ]
+[ { 1 2 } { 10 } { 100 200 } [ + + ] 3map ] unit-test
+
+[ { 111 222 } ]
+[ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ] unit-test

extra/cursors/cursors.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math sequences sequences.private ;
+USING: accessors arrays generalizations kernel math sequences
+sequences.private ;
 IN: cursors
 
 GENERIC: cursor-done? ( cursor -- ? )
@@ -99,3 +100,53 @@ M: to-sequence cursor-write
 
 : map ( seq quot -- ) [ cursor-map ] transform ; inline
 : filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline
+
+: find-done2? ( cursor cursor quot -- ? )
+    2over [ cursor-done? ] either?
+    [ 3drop t ] [ [ [ cursor-get-unsafe ] bi@ ] dip call ] if ; inline
+
+: cursor-until2 ( cursor cursor quot -- )
+    [ find-done2? not ]
+    [ drop [ cursor-advance ] bi@ ] bi-curry bi-curry bi-curry while ; inline
+
+: cursor-each2 ( cursor cursor quot -- )
+    [ f ] compose cursor-until2 ; inline
+
+: cursor-map2 ( from to quot -- )
+    swap cursor-map-quot cursor-each2 ; inline
+
+: iterate2 ( seq1 seq2 quot iterator -- )
+    [ [ >input ] bi@ ] 2dip call ; inline
+
+: transform2 ( seq1 seq2 quot transformer -- newseq )
+    [ over >output [ [ >input ] [ >input ] bi* ] dip ] 2dip
+    [ call ]
+    [ 2drop nip freeze ] 4 nbi ; inline
+
+: 2each ( seq1 seq2 quot -- ) [ cursor-each2 ] iterate2 ; inline
+: 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline
+
+: find-done3? ( cursor1 cursor2 cursor3 quot -- ? )
+    3 nover 3array [ cursor-done? ] any?
+    [ 4 ndrop t ] [ [ [ cursor-get-unsafe ] tri@ ] dip call ] if ; inline
+
+: cursor-until3 ( cursor cursor quot -- )
+    [ find-done3? not ]
+    [ drop [ cursor-advance ] tri@ ] bi-curry bi-curry bi-curry bi-curry while ; inline
+
+: cursor-each3 ( cursor cursor quot -- )
+    [ f ] compose cursor-until3 ; inline
+
+: cursor-map3 ( from to quot -- )
+    swap cursor-map-quot cursor-each3 ; inline
+
+: iterate3 ( seq1 seq2 seq3 quot iterator -- )
+    [ [ >input ] tri@ ] 2dip call ; inline
+
+: transform3 ( seq1 seq2 seq3 quot transformer -- newseq )
+    [ pick >output [ [ >input ] [ >input ] [ >input ] tri* ] dip ] 2dip
+    [ call ]
+    [ 2drop 2nip freeze ] 5 nbi ; inline
+
+: 3each ( seq1 seq2 seq3 quot -- ) [ cursor-each3 ] iterate3 ; inline
+: 3map ( seq1 seq2 seq3 quot -- ) [ cursor-map3 ] transform3 ; inline

extra/half-floats/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/half-floats/half-floats-tests.factor

@@ -0,0 +1,46 @@
+USING: alien.c-types alien.syntax half-floats kernel math tools.test ;
+IN: half-floats.tests
+
+[ HEX: 0000 ] [  0.0  half>bits ] unit-test
+[ HEX: 8000 ] [ -0.0  half>bits ] unit-test
+[ HEX: 3e00 ] [  1.5  half>bits ] unit-test
+[ HEX: be00 ] [ -1.5  half>bits ] unit-test
+[ HEX: 7c00 ] [  1/0. half>bits ] unit-test
+[ HEX: fc00 ] [ -1/0. half>bits ] unit-test
+[ HEX: 7eaa ] [ HEX: aaaaaaaaaaaaa <fp-nan> half>bits ] unit-test
+
+! too-big floats overflow to infinity
+[ HEX: 7c00 ] [   65536.0 half>bits ] unit-test
+[ HEX: fc00 ] [  -65536.0 half>bits ] unit-test
+[ HEX: 7c00 ] [  131072.0 half>bits ] unit-test
+[ HEX: fc00 ] [ -131072.0 half>bits ] unit-test
+
+! too-small floats flush to zero
+[ HEX: 0000 ] [  1.0e-9 half>bits ] unit-test
+[ HEX: 8000 ] [ -1.0e-9 half>bits ] unit-test
+
+[  0.0  ] [ HEX: 0000 bits>half ] unit-test
+[ -0.0  ] [ HEX: 8000 bits>half ] unit-test
+[  1.5  ] [ HEX: 3e00 bits>half ] unit-test
+[ -1.5  ] [ HEX: be00 bits>half ] unit-test
+[  1/0. ] [ HEX: 7c00 bits>half ] unit-test
+[ -1/0. ] [ HEX: fc00 bits>half ] unit-test
+[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
+
+C-STRUCT: halves
+    { "half" "tom" }
+    { "half" "dick" }
+    { "half" "harry" }
+    { "half" "harry-jr" } ;
+
+[ 8 ] [ "halves" heap-size ] unit-test
+
+[ 3.0 ] [
+    "halves" <c-object>
+    3.0 over set-halves-dick
+    halves-dick
+] unit-test
+
+[ half-array{ 1.0 2.0 3.0 1/0. -1/0. } ]
+[ { 1.0 2.0 3.0 1/0. -1/0. } >half-array ] unit-test
+

extra/half-floats/half-floats.factor

@@ -0,0 +1,42 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors alien.c-types alien.syntax kernel math math.order
+specialized-arrays.direct.functor specialized-arrays.functor ;
+IN: half-floats
+
+: half>bits ( float -- bits )
+    float>bits
+    [ -31 shift 15 shift ] [
+        HEX: 7fffffff bitand
+        dup zero? [
+            dup HEX: 7f800000 >= [ -13 shift HEX: 7fff bitand ] [
+                -13 shift
+                112 10 shift -
+                0 HEX: 7c00 clamp
+            ] if
+        ] unless
+    ] bi bitor ;
+
+: bits>half ( bits -- float )
+    [ -15 shift 31 shift ] [
+        HEX: 7fff bitand
+        dup zero? [
+            dup HEX: 7c00 >= [ 13 shift HEX: 7f800000 bitor ] [
+                13 shift
+                112 23 shift + 
+            ] if
+        ] unless
+    ] bi bitor bits>float ;
+
+C-STRUCT: half { "ushort" "(bits)" } ;
+
+<<
+
+"half" c-type
+    [ half>bits <ushort> ] >>unboxer-quot
+    [ *ushort bits>half ] >>boxer-quot
+    drop
+
+"half" define-array
+"half" define-direct-array
+
+>>

extra/half-floats/summary.txt

@@ -0,0 +1 @@
+Half-precision float support for FFI

extra/nested-comments/nested-comments.factor

@@ -0,0 +1,20 @@
+! by blei on #concatenative
+USING: kernel sequences math locals make multiline ;
+IN: nested-comments
+
+:: (subsequences-at) ( sseq seq n -- )
+    sseq seq n start*
+    [ dup , sseq length + [ sseq seq ] dip (subsequences-at) ]
+    when* ;
+
+: subsequences-at ( sseq seq -- indices )
+    [ 0 (subsequences-at) ] { } make ;
+
+: count-subsequences ( sseq seq -- i )
+    subsequences-at length ;
+
+: parse-all-(* ( parsed-vector left-to-parse -- parsed-vector )
+    1 - "*)" parse-multiline-string [ "(*" ] dip
+    count-subsequences + dup 0 > [ parse-all-(* ] [ drop ] if ;
+
+SYNTAX: (* 1 parse-all-(* ;

extra/noise/noise.factor

@@ -1,8 +1,9 @@
-USING: byte-arrays combinators fry images kernel locals math
+USING: accessors arrays byte-arrays combinators
+combinators.short-circuit fry hints images kernel locals math
 math.affine-transforms math.functions math.order
-math.polynomials math.vectors random random.mersenne-twister
+math.polynomials math.private math.vectors random
-sequences sequences.product hints arrays sequences.private
+random.mersenne-twister sequences sequences.private
-combinators.short-circuit math.private ;
+sequences.product ;
 IN: noise
 
 : <perlin-noise-table> ( -- table )
@@ -60,7 +61,10 @@ HINTS: hashes { byte-array fixnum fixnum fixnum } ;
     [ 255.0 * >fixnum ] B{ } map-as ;
 
 : >image ( bytes dim -- image )
-    swap [ L f ] dip image boa ;
+    image new
+        swap >>dim
+        swap >>bitmap
+        L >>component-order ;
 
 :: perlin-noise-unsafe ( table point -- value )
     point unit-cube :> cube

extra/sequence-parser/sequence-parser-tests.factor

@@ -118,10 +118,10 @@ IN: sequence-parser.tests
 [ "abcd e \\\"f g" ]
 [ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
 
-[ "" ]
+[ f ]
 [ "" <sequence-parser> take-rest ] unit-test
 
-[ "" ]
+[ f ]
 [ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
 
 [ f ]

extra/sequence-parser/sequence-parser.factor

@@ -35,6 +35,8 @@ TUPLE: sequence-parser sequence n ;
 : advance* ( sequence-parser -- )
     advance drop ; inline
 
+: next ( sequence-parser -- obj ) [ current ] [ advance* ] bi ;
+
 : get+increment ( sequence-parser -- char/f )
     [ current ] [ advance drop ] bi ; inline
 
@@ -148,7 +150,7 @@ TUPLE: sequence-parser sequence n ;
     2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
 
 : take-rest ( sequence-parser -- sequence )
-    [ take-rest-slice ] [ sequence>> like ] bi ;
+    [ take-rest-slice ] [ sequence>> like ] bi f like ;
 
 : take-until-object ( sequence-parser obj -- sequence )
     '[ current _ = ] take-until ;
@@ -190,7 +192,7 @@ TUPLE: sequence-parser sequence n ;
 
 :: take-n ( sequence-parser n -- seq/f )
     n sequence-parser [ n>> + ] [ sequence>> length ] bi > [
-        f
+        sequence-parser take-rest
     ] [
         sequence-parser n>> dup n + sequence-parser sequence>> subseq
         sequence-parser [ n + ] change-n drop

extra/terrain/generation/generation.factor

@@ -1,6 +1,7 @@
-USING: accessors arrays byte-arrays combinators fry grouping
+USING: accessors arrays byte-arrays combinators
-images kernel math math.affine-transforms math.order
+combinators.smart fry grouping images kernel math
-math.vectors noise random sequences ;
+math.affine-transforms math.order math.vectors noise random
+sequences ;
 IN: terrain.generation
 
 CONSTANT: terrain-segment-size { 512 512 }
@@ -31,15 +32,21 @@ TUPLE: terrain big-noise-table small-noise-table tiny-noise-seed ;
 
 TUPLE: segment image ;
 
+: <terrain-image> ( bytes -- image )
+    <image>
+        swap >>bitmap
+        RGBA >>component-order
+        terrain-segment-size >>dim ;
+
 : terrain-segment ( terrain at -- image )
+    [
         {
             [ big-noise-segment ]
             [ small-noise-segment ]
             [ tiny-noise-segment ]
             [ padding ]
         } 2cleave
-    4array flip concat >byte-array
+    ] output>array flip B{ } concat-as <terrain-image> ;
-    [ terrain-segment-size RGBA f ] dip image boa ;
 
 : 4max ( a b c d -- max )
     max max max ; inline

unmaintained/images/processing/rotation/rotation-tests.factor

@@ -21,23 +21,17 @@ IN: images.processing.rotation.tests
 
 >>
 
-CONSTANT: pasted-image
+: pasted-image ( -- image )
-    $[
     "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"
-        load-image clone-image
+    load-image clone-image ;
-    ]
 
-CONSTANT: pasted-image90
+: pasted-image90 ( -- image )
-    $[
     "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"
-        load-image clone-image
+    load-image clone-image ;
-    ]
 
-CONSTANT: lake-image
+: lake-image ( -- image )
-    $[
     "vocab:images/processing/rotation/test-bitmaps/lake.bmp"
-        load-image preprocess
+    load-image clone-image image>pixel-rows ;
-    ]
 
 [ t ] [ pasted-image dup clone-image 4 [ 90 rotate ] times = ] unit-test
 [ t ] [ pasted-image dup clone-image 2 [ 180 rotate ] times = ] unit-test

unmaintained/images/processing/rotation/rotation.factor

@@ -40,20 +40,17 @@ ERROR: unsupported-rotation degrees ;
 : flatten-table ( seq^3 -- seq )
     [ concat ] map concat ;
 
-: preprocess ( image -- pixelrows )
-    normalize-image image>pixel-rows ;
-
 : ?reverse-dimensions ( image n -- )
     { 270 90 } member? [ [ reverse ] change-dim ] when drop ;
 
 :  normalize-degree ( n -- n' ) 360 rem ;
 
 : processing-effect ( image quot -- image' )
-    '[ preprocess @ flatten-table ] [ (>>bitmap) ] [ ] tri ; inline
+    '[ image>pixel-rows @ flatten-table ] [ (>>bitmap) ] [ ] tri ; inline
 
 :: rotate' ( image n -- image )
     n normalize-degree :> n'
-    image preprocess :> pixel-table
+    image image>pixel-rows :> pixel-table
     image n' ?reverse-dimensions
     pixel-table n' (rotate) :> table-rotated
     image table-rotated flatten-table >>bitmap ;