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

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators grouping kernel locals math
   4 math.matrices math.order multiline sequences.parser sequences
   5 tools.continuations ;
   6 IN: compression.run-length
   7
   8 : run-length-uncompress ( byte-array -- byte-array' )
   9     2 group [ first2 <array> ] map B{ } concat-as ;
  10
  11 : 8hi-lo ( byte -- hi lo )
  12     [ 0xf0 bitand -4 shift ] [ 0xf bitand ] bi ; inline
  13
  14 :: run-length-uncompress-bitmap4 ( byte-array m n -- byte-array' )
  15     byte-array <sequence-parser> :> sp
  16     m  1 + n zero-matrix :> matrix
  17     n 4 mod n + :> stride
  18     0 :> i!
  19     0 :> j!
  20     f :> done?!
  21     [
  22         ! i j [ number>string ] bi@ " " glue .
  23         sp next dup 0 = [
  24             sp next dup 0x03 0xff between? [
  25                 nip [ sp ] dip dup odd?
  26                 [ 1 + take-n but-last ] [ take-n ] if
  27                 [ j matrix i swap nth copy ] [ length j + j! ] bi
  28             ] [
  29                 nip {
  30                     { 0 [ i 1 + i!  0 j! ] }
  31                     { 1 [ t done?! ] }
  32                     { 2 [ sp next j + j!  sp next i + i! ] }
  33                 } case
  34             ] if
  35         ] [
  36             [ sp next 8hi-lo 2array <repetition> concat ] [ head ] bi
  37             [ j matrix i swap nth copy ] [ length j + j! ] bi
  38         ] if
  39
  40         ! j stride >= [ i 1 + i!  0 j! ] when
  41         j stride >= [ 0 j! ] when
  42         done? not
  43     ] loop
  44     matrix B{ } concat-as ;
  45
  46 :: run-length-uncompress-bitmap8 ( byte-array m n -- byte-array' )
  47     byte-array <sequence-parser> :> sp
  48     m  1 + n zero-matrix :> matrix
  49     n 4 mod n + :> stride
  50     0 :> i!
  51     0 :> j!
  52     f :> done?!
  53     [
  54         ! i j [ number>string ] bi@ " " glue .
  55         sp next dup 0 = [
  56             sp next dup 0x03 0xff between? [
  57                 nip [ sp ] dip dup odd?
  58                 [ 1 + take-n but-last ] [ take-n ] if
  59                 [ j matrix i swap nth copy ] [ length j + j! ] bi
  60             ] [
  61                 nip {
  62                     { 0 [ i 1 + i!  0 j! ] }
  63                     { 1 [ t done?! ] }
  64                     { 2 [ sp next j + j!  sp next i + i! ] }
  65                 } case
  66             ] if
  67         ] [
  68             sp next <array> [ j matrix i swap nth copy ] [ length j + j! ] bi
  69         ] if
  70
  71         ! j stride >= [ i 1 + i!  0 j! ] when
  72         j stride >= [ 0 j! ] when
  73         done? not
  74     ] loop
  75     matrix B{ } concat-as ;