basis/images/bitmap/bitmap.factor

   1 ! Copyright (C) 2007, 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types arrays byte-arrays columns
   4 combinators compression.run-length endian fry grouping images
   5 images.bitmap.loading images.loader io io.binary
   6 io.encodings.binary io.encodings.string io.files
   7 io.streams.limited kernel locals macros math math.bitwise
   8 math.functions namespaces sequences specialized-arrays.uint
   9 specialized-arrays.ushort strings summary ;
  10 IN: images.bitmap
  11
  12 : write2 ( n -- ) 2 >le write ;
  13 : write4 ( n -- ) 4 >le write ;
  14
  15 : save-bitmap ( image path -- )
  16     binary [
  17         B{ CHAR: B CHAR: M } write
  18         [
  19             bitmap>> length 14 + 40 + write4
  20             0 write4
  21             54 write4
  22             40 write4
  23         ] [
  24             {
  25                 ! width height
  26                 [ dim>> first2 [ write4 ] bi@ ]
  27
  28                 ! planes
  29                 [ drop 1 write2 ]
  30
  31                 ! bit-count
  32                 [ drop 24 write2 ]
  33
  34                 ! compression
  35                 [ drop 0 write4 ]
  36
  37                 ! image-size
  38                 [ bitmap>> length write4 ]
  39
  40                 ! x-pels
  41                 [ drop 0 write4 ]
  42
  43                 ! y-pels
  44                 [ drop 0 write4 ]
  45
  46                 ! color-used
  47                 [ drop 0 write4 ]
  48
  49                 ! color-important
  50                 [ drop 0 write4 ]
  51
  52                 ! color-palette
  53                 [ bitmap>> write ]
  54             } cleave
  55         ] bi
  56     ] with-file-writer ;