extra/images/pgm/pgm.factor

   1 ! Copyright (C) 2010 Erik Charlebois.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types ascii combinators images images.loader
   4 io io.encodings.ascii io.encodings.string kernel locals make math
   5 math.parser sequences specialized-arrays io.streams.throwing ;
   6 SPECIALIZED-ARRAY: ushort
   7 IN: images.pgm
   8
   9 SINGLETON: pgm-image
  10 "pgm" pgm-image ?register-image-class
  11
  12 : read-token ( -- token )
  13     [ read1 dup blank?
  14       [ t ]
  15       [ dup CHAR: # =
  16         [ "\n" read-until 2drop t ]
  17         [ f ] if
  18       ] if
  19     ] [ drop ] while
  20     " \n\r\t" read-until drop swap
  21     prefix ascii decode ;
  22
  23 : read-number ( -- number )
  24     read-token string>number ;
  25
  26 :: read-numbers ( n lim -- )
  27     n lim = [
  28         read-number ,
  29         n 1 + lim read-numbers
  30     ] unless ;
  31
  32 :: read-pgm ( -- image )
  33     read-token         :> type
  34     read-number        :> width
  35     read-number        :> height
  36     read-number        :> max
  37     width height *     :> npixels
  38     max 256 >=         :> wide
  39
  40     type {
  41         { "P2" [ [ 0 npixels read-numbers ] wide [ ushort-array{ } ] [ B{ } ] if make ] }
  42         { "P5" [ wide [ 2 ] [ 1 ] if npixels * read ] }
  43     } case :> data
  44
  45     image new
  46     L                                                  >>component-order
  47     { width height }                                   >>dim
  48     f                                                  >>upside-down?
  49     data                                               >>bitmap
  50     wide [ ushort-components ] [ ubyte-components ] if >>component-type ;
  51
  52 M: pgm-image stream>image*
  53     drop [ [ read-pgm ] throw-on-eof ] with-input-stream ;
  54
  55 M: pgm-image image>stream
  56     2drop {
  57         [ drop "P5\n" ascii encode write ]
  58         [ dim>> first number>string " " append ascii encode write ]
  59         [ dim>> second number>string "\n" append ascii encode write ]
  60         [ component-type>> ubyte-components = [ "255\n" ] [ "65535\n" ] if ascii encode write ]
  61         [ bitmap>> write ]
  62     } cleave ;