extra/images/pgm/pgm.factor

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