extra/images/pbm/pbm.factor

   1 ! Copyright (C) 2010 Erik Charlebois.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays ascii bit-arrays byte-arrays combinators
   4 continuations grouping images images.loader io io.encodings.ascii
   5 io.encodings.string kernel locals make math math.functions math.parser
   6 sequences io.streams.throwing ;
   7 IN: images.pbm
   8
   9 SINGLETON: pbm-image
  10 "pbm" pbm-image ?register-image-class
  11
  12 <PRIVATE
  13 : read-token ( -- token )
  14     [
  15         read1 dup blank?
  16         [ t ]
  17         [
  18             dup CHAR: # =
  19             [ "\n" read-until 2drop t ]
  20             [ f ] if
  21         ] if
  22     ] [ drop ] while
  23     " \n\r\t" read-until drop swap
  24     prefix ascii decode ;
  25
  26 : read-number ( -- number )
  27     read-token string>number ;
  28
  29 : read-ascii-bits ( -- )
  30     read1 {
  31         { CHAR: 1 [ 0 , read-ascii-bits ] }
  32         { CHAR: 0 [ 255 , read-ascii-bits ] }
  33         { f [ ] }
  34         [ drop read-ascii-bits ]
  35     } case ;
  36
  37 :: read-binary-bits ( width height -- )
  38     width 8 align 8 / height * read
  39     width 8 align 8 / <groups> [| row |
  40         width <iota> [| n |
  41             n 8 / floor row nth
  42             n 8 mod 7 swap - bit?
  43             [ 0 ] [ 255 ] if ,
  44         ] each
  45     ] each ;
  46
  47 :: write-binary-bits ( bitmap width -- )
  48     bitmap width <groups> [
  49         width 8 align 255 pad-tail
  50         8 <groups> [
  51             [ 255 = [ f ] [ t ] if ] { } map-as
  52             >bit-array reverse bit-array>integer
  53             1array >byte-array write
  54         ] each
  55     ] each ;
  56
  57 :: read-pbm ( -- image )
  58     read-token     :> type
  59     read-number    :> width
  60     read-number    :> height
  61
  62     type {
  63         { "P1" [ [ [ read-ascii-bits ] ignore-errors ] B{ } make ] }
  64         { "P4" [ [ width height read-binary-bits ] B{ } make ] }
  65     } case :> data
  66
  67     image new
  68     L                >>component-order
  69     { width height } >>dim
  70     f                >>upside-down?
  71     data             >>bitmap
  72     ubyte-components >>component-type ;
  73 PRIVATE>
  74
  75 M: pbm-image stream>image*
  76     drop [ [ read-pbm ] throw-on-eof ] with-input-stream ;
  77
  78 M: pbm-image image>stream
  79     2drop {
  80         [ drop "P4\n" ascii encode write ]
  81         [ dim>> first number>string " " append ascii encode write ]
  82         [ dim>> second number>string "\n" append ascii encode write ]
  83         [ [ bitmap>> ] [ dim>> first ] bi write-binary-bits ]
  84     } cleave ;