extra/graphics/bitmap/bitmap.factor

   1 ! Copyright (C) 2007 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 USING: alien arrays byte-arrays combinators summary
   5 io.backend graphics.viewer io io.binary io.files kernel libc
   6 math math.functions namespaces opengl opengl.gl prettyprint
   7 sequences strings ui ui.gadgets.panes io.encodings.binary ;
   8 IN: graphics.bitmap
   9
  10 ! Currently can only handle 24bit bitmaps.
  11 ! Handles row-reversed bitmaps (their height is negative)
  12
  13 TUPLE: bitmap magic size reserved offset header-length width
  14     height planes bit-count compression size-image
  15     x-pels y-pels color-used color-important rgb-quads color-index array ;
  16
  17 : raw-bitmap>string ( str n -- str )
  18     {
  19         { 32 [ "32bit" throw ] }
  20         { 24 [ ] }
  21         { 16 [ "16bit" throw ] }
  22         { 8 [ "8bit" throw ] }
  23         { 4 [ "4bit" throw ] }
  24         { 2 [ "2bit" throw ] }
  25         { 1 [ "1bit" throw ] }
  26     } case ;
  27
  28 ERROR: bitmap-magic ;
  29
  30 M: bitmap-magic summary
  31     drop "First two bytes of bitmap stream must be 'BM'" ;
  32
  33 : parse-file-header ( bitmap -- )
  34     2 read >string dup "BM" = [ bitmap-magic ] unless
  35         over set-bitmap-magic
  36     4 read le> over set-bitmap-size
  37     4 read le> over set-bitmap-reserved
  38     4 read le> swap set-bitmap-offset ;
  39
  40 : parse-bitmap-header ( bitmap -- )
  41     4 read le> over set-bitmap-header-length
  42     4 read le> over set-bitmap-width
  43     4 read le> over set-bitmap-height
  44     2 read le> over set-bitmap-planes
  45     2 read le> over set-bitmap-bit-count
  46     4 read le> over set-bitmap-compression
  47     4 read le> over set-bitmap-size-image
  48     4 read le> over set-bitmap-x-pels
  49     4 read le> over set-bitmap-y-pels
  50     4 read le> over set-bitmap-color-used
  51     4 read le> swap set-bitmap-color-important ;
  52
  53 : rgb-quads-length ( bitmap -- n )
  54     [ bitmap-offset 14 - ] keep bitmap-header-length - ;
  55
  56 : color-index-length ( bitmap -- n )
  57     [ bitmap-width ] keep [ bitmap-planes * ] keep
  58     [ bitmap-bit-count * 31 + 32 /i 4 * ] keep
  59     bitmap-height abs * ;
  60
  61 : parse-bitmap ( bitmap -- )
  62     dup rgb-quads-length read over set-bitmap-rgb-quads
  63     dup color-index-length read swap set-bitmap-color-index ;
  64
  65 : load-bitmap ( path -- bitmap )
  66     normalize-path binary [
  67         T{ bitmap } clone
  68         dup parse-file-header
  69         dup parse-bitmap-header
  70         dup parse-bitmap
  71     ] with-file-reader
  72     dup bitmap-color-index over bitmap-bit-count
  73     raw-bitmap>string >byte-array over set-bitmap-array ;
  74
  75 : save-bitmap ( bitmap path -- )
  76     binary [
  77         "BM" write
  78         dup bitmap-array length 14 + 40 + 4 >le write
  79         0 4 >le write
  80         54 4 >le write
  81
  82         40 4 >le write
  83         dup bitmap-width 4 >le write
  84         dup bitmap-height 4 >le write
  85         dup bitmap-planes 1 or 2 >le write
  86         dup bitmap-bit-count 24 or 2 >le write
  87         dup bitmap-compression 0 or 4 >le write
  88         dup bitmap-size-image 4 >le write
  89         dup bitmap-x-pels 4 >le write
  90         dup bitmap-y-pels 4 >le write
  91         dup bitmap-color-used 4 >le write
  92         dup bitmap-color-important 4 >le write
  93         dup bitmap-rgb-quads write
  94         bitmap-color-index write
  95     ] with-file-writer ;
  96
  97 M: bitmap draw-image ( bitmap -- )
  98     dup bitmap-height 0 < [
  99         0 0 glRasterPos2i
 100         1.0 -1.0 glPixelZoom
 101     ] [
 102         0 over bitmap-height abs glRasterPos2i
 103         1.0 1.0 glPixelZoom
 104     ] if
 105     [ bitmap-width ] keep
 106     [
 107         [ bitmap-height abs ] keep
 108         bitmap-bit-count {
 109             ! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken
 110             { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
 111         } case
 112     ] keep bitmap-array glDrawPixels ;
 113
 114 M: bitmap width ( bitmap -- ) bitmap-width ;
 115 M: bitmap height ( bitmap -- ) bitmap-height ;
 116
 117 : bitmap. ( path -- )
 118     load-bitmap <graphics-gadget> gadget. ;
 119
 120 : bitmap-window ( path -- gadget )
 121     load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;
 122
 123 : test-bitmap24 ( -- )
 124     "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;
 125
 126 : test-bitmap8 ( -- )
 127     "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;
 128
 129 : test-bitmap4 ( -- )
 130     "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;
 131
 132 : test-bitmap1 ( -- )
 133     "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;
 134