Merge branch 'master' of git://factorcode.org/git/factor

basis/bitstreams/bitstreams.factor

@@ -158,3 +158,9 @@ M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
         writer bytes>> swap push
     ] unless
     writer bytes>> ;
+
+:: byte-array-n>seq ( byte-array n -- seq )
+    byte-array length 8 * n / iota
+    byte-array <msb0-bit-reader> '[
+        drop n _ read
+    ] { } map-as ;

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

@@ -3,5 +3,5 @@
 USING: arrays grouping sequences ;
 IN: compression.run-length
 
-: run-length-uncompress8 ( byte-array -- byte-array' )
+: run-length-uncompress ( byte-array -- byte-array' )
     2 group [ first2 <array> ] map concat ;

basis/images/bitmap/bitmap.factor

@@ -2,14 +2,14 @@
 ! 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 kernel
+images.loader io io.binary io.encodings.binary io.files
-locals macros math math.bitwise math.functions namespaces
+io.streams.limited kernel locals macros math math.bitwise
-sequences strings summary ;
+math.functions namespaces sequences specialized-arrays.uint
+specialized-arrays.ushort strings summary io.encodings.8-bit
+io.encodings.string ;
+QUALIFIED-WITH: bitstreams b
 IN: images.bitmap
 
-: assert-sequence= ( a b -- )
-    2dup sequence= [ 2drop ] [ assert ] if ;
-
 : read2 ( -- n ) 2 read le> ;
 : read4 ( -- n ) 4 read le> ;
 : write2 ( n -- ) 2 >le write ;
@@ -17,62 +17,130 @@ IN: images.bitmap
 
 TUPLE: bitmap-image < image ;
 
-! Used to construct the final bitmap-image
-
 TUPLE: loading-bitmap 
-size reserved offset header-length width
+magic size reserved1 reserved2 offset header-length width
 height planes bit-count compression size-image
-x-pels y-pels color-used color-important color-palette color-index
+x-pels y-pels color-used color-important
-uncompressed-bytes ;
+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 ;
 
-ERROR: bitmap-magic magic ;
+! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint
-
-M: bitmap-magic summary
-    drop "First two bytes of bitmap stream must be 'BM'" ;
 
 <PRIVATE
 
-: 8bit>buffer ( bitmap -- array )
+: os2-color-lookup ( loading-bitmap -- seq )
-    [ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ]
+    [ color-index>> >array ]
-    [ color-index>> >array ] bi [ swap nth ] with map concat ;
+    [ 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 ;
 
-: reverse-lines ( byte-array width -- byte-array )
+: uncompress-bitfield ( seq masks -- bytes' )
-    <sliced-groups> <reversed> concat ; inline
+    '[
+        _ [
+            [ bitand ] [ bit-count ] [ log2 ] tri - shift
+        ] with map
+    ] { } map-as B{ } concat-as ;
 
-: bitmap>bytes ( loading-bitmap -- array )
+: bitmap>bytes ( loading-bitmap -- byte-array )
     dup bit-count>>
     {
         { 32 [ color-index>> ] }
-        { 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] }
+        { 24 [ color-index>> ] }
-        { 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] }
+        { 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-uncompress8 ] change-color-index ] }
+        { 1 [ [ run-length-uncompress ] change-color-index ] }
-        { 2 [ "run-length encoding 4" unsupported-bitmap-compression ] }
+        { 2 [ [ 4 b:byte-array-n>seq run-length-uncompress >byte-array ] change-color-index ] }
-        { 3 [ "bitfields" unsupported-bitmap-compression ] }
+        { 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 ;
+    uncompress-bitmap
+    bitmap>bytes ;
 
 : parse-file-header ( loading-bitmap -- loading-bitmap )
-    2 read "BM" assert-sequence=
+    2 read latin1 decode >>magic
     read4 >>size
-    read4 >>reserved
+    read2 >>reserved1
+    read2 >>reserved2
     read4 >>offset ;
 
-: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
+: read-v3-header ( loading-bitmap -- loading-bitmap )
-    read4 >>header-length
     read4 >>width
     read4 32 >signed >>height
     read2 >>planes
@@ -84,6 +152,50 @@ ERROR: unsupported-bitmap-compression compression ;
     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 - ;
 
@@ -98,53 +210,54 @@ ERROR: unsupported-bitmap-compression compression ;
 : image-size ( loading-bitmap -- n )
     [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
 
-: bitmap-padding ( width -- n )
-    3 * 4 mod 4 swap - 4 mod ; inline
-
-:: fixup-color-index ( loading-bitmap -- loading-bitmap )
-    loading-bitmap width>> :> width
-    width 3 * :> width*3
-    loading-bitmap width>> bitmap-padding :> padding
-    loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride
-    loading-bitmap
-    padding 0 > [
-        [
-            stride <sliced-groups>
-            [ width*3 head-slice ] map concat
-        ] change-color-index
-    ] when ;
-
 : parse-bitmap ( loading-bitmap -- loading-bitmap )
     dup color-palette-length read >>color-palette
-    dup color-index-length read >>color-index
+    dup size-image>> [
-    fixup-color-index ;
+        read >>color-index
+    ] [
+        dup color-index-length read >>color-index
+    ] if* ;
+
+ERROR: unsupported-bitmap-file magic ;
 
 : load-bitmap ( path -- loading-bitmap )
-    binary [
+    binary stream-throws <limited-file-reader> [
         loading-bitmap new
-        parse-file-header parse-bitmap-header parse-bitmap
+        parse-file-header dup magic>> {
-    ] with-file-reader ;
+            { "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 [ BGRA ] }
+        { 32 [ BGR ] }
         { 24 [ BGR ] }
+        { 16 [ BGR ] }
         { 8 [ BGR ] }
+        { 4 [ BGR ] }
+        { 1 [ BGR ] }
         [ unknown-component-order ]
     } case ;
 
-: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
+: loading-bitmap>image ( image loading-bitmap -- bitmap-image )
     {
         [ loading-bitmap>bytes >>bitmap ]
         [ [ width>> ] [ height>> abs ] bi 2array >>dim ]
-        [ height>> 0 < [ t >>upside-down? ] when ]
+        [ height>> 0 < not >>upside-down? ]
+        [ compression>> 3 = [ t >>upside-down? ] when ]
         [ bitmap>component-order >>component-order ]
     } cleave ;
 
 M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
-    swap load-bitmap loading-bitmap>bitmap-image ;
+    swap load-bitmap loading-bitmap>image ;
 
 "bmp" bitmap-image register-image-class
 
@@ -165,6 +278,9 @@ PRIVATE>
         ] 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

basis/images/png/png.factor

@@ -104,8 +104,7 @@ ERROR: unimplemented-color-type image ;
     } case ;
 
 : load-png ( path -- image )
-    [ binary <file-reader> ] [ file-info size>> ] bi
+    binary stream-throws <limited-file-reader> [
-    stream-throws <limited-stream> [
         <png-image>
         read-png-header
         read-png-chunks

basis/io/streams/limited/limited.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math io io.encodings destructors accessors
+USING: accessors byte-vectors combinators destructors fry io
-sequences namespaces byte-vectors fry combinators ;
+io.encodings io.files io.files.info kernel math namespaces
+sequences ;
 IN: io.streams.limited
 
 TUPLE: limited-stream stream count limit mode stack ;
@@ -16,6 +17,12 @@ SINGLETONS: stream-throws stream-eofs ;
         swap >>stream
         0 >>count ;
 
+: <limited-file-reader> ( path encoding mode -- stream' )
+    [
+        [ <file-reader> ]
+        [ drop file-info size>> ] 2bi
+    ] dip <limited-stream> ;
+
 GENERIC# limit 2 ( stream limit mode -- stream' )
 
 M: decoder limit ( stream limit mode -- stream' )

extra/game-loop/game-loop.factor

@@ -1,5 +1,5 @@
-USING: accessors calendar destructors kernel math math.order namespaces
+USING: accessors calendar continuations destructors kernel math
-system threads ;
+math.order namespaces system threads ui ui.gadgets.worlds ;
 IN: game-loop
 
 TUPLE: game-loop
@@ -27,6 +27,16 @@ SYMBOL: game-loop
 
 CONSTANT: MAX-FRAMES-TO-SKIP 5
 
+DEFER: stop-loop
+
+TUPLE: game-loop-error game-loop error ;
+
+: ?ui-error ( error -- )
+    ui-running? [ ui-error ] [ rethrow ] if ;
+
+: game-loop-error ( game-loop error -- )
+    [ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
+
 <PRIVATE
 
 : redraw ( loop -- )
@@ -54,7 +64,9 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5
     [ drop ] if ;
 
 : run-loop ( loop -- )
-    dup game-loop [ (run-loop) ] with-variable ;
+    dup game-loop
+    [ [ (run-loop) ] [ game-loop-error ] recover ]
+    with-variable ;
 
 : benchmark-millis ( loop -- millis )
     millis swap benchmark-time>> - ;
@@ -91,3 +103,6 @@ PRIVATE>
 M: game-loop dispose
     stop-loop ;
 
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "game-loop.prettyprint" require ] when

extra/game-loop/prettyprint/prettyprint.factor

@@ -0,0 +1,9 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors debugger game-loop io ;
+IN: game-loop.prettyprint
+
+M: game-loop-error error.
+    "An error occurred inside a game loop." print
+    "The game loop has been stopped to prevent runaway errors." print
+    "The error was:" print nl
+    error>> error. ;