working on rle uncompresion for bitmaps

diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor
index 43be6ccf36daec040572f125ba7d65ba3802de2f..cde2a7e1134c537cb7b00a93b9434b17c60ecb75 100644 (file)
--- a/basis/compression/run-length/run-length.factor
+++ b/basis/compression/run-length/run-length.factor
@@ -5,7 +5,71 @@ 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 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 ;

diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor
index cf75a40d979f5cac55fbc54cddfd2433d4222066..a8d7dae3732c5e530f529bc4683cab280a217b07 100755 (executable)
--- a/basis/images/bitmap/bitmap.factor
+++ b/basis/images/bitmap/bitmap.factor
@@ -102,20 +102,18 @@ GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
 M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
     drop ;
 
-: do-run-length-uncompress ( loading-bitmap -- loading-bitmap )
-    dup '[
+: do-run-length-uncompress ( loading-bitmap word -- loading-bitmap )
+    dupd '[
         _ header>> [ width>> ] [ height>> ] bi
-        run-length-uncompress-bitmap
-    ] change-color-index ;
+        _ execute
+    ] change-color-index ; inline
 
 M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
     compression>> {
         { f [ ] }
         { 0 [ ] }
-        { 1 [ [ run-length-uncompress ] change-color-index ] }
-        { 2 [ [ 4 b:byte-array-n>seq run-length-uncompress ] change-color-index ] }
-        ! { 1 [ do-run-length-uncompress ] }
-        ! { 2 [ [ 4 b:byte-array-n>seq ] change-color-index do-run-length-uncompress ] }
+        { 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 ] }