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

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,7 +203,6 @@ CONSTANT: dist-table
 
 PRIVATE>
 
-! for debug -- shows residual values
 : reverse-png-filter' ( lines -- byte-array )
     [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
     concat [ 128 + ] B{ } map-as ;

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/math/matrices/matrices.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays fry 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
@@ -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 ;

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 f } "." } ;
+"The default implementation assumes the object has a " { $slot "disposed" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link f } "." } ;
 
 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

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-(* ;