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 graphics.viewer io io.binary io.files kernel libc math
   6 math.functions math.bitwise namespaces opengl opengl.gl
   7 prettyprint sequences strings ui ui.gadgets.panes fry
   8 io.encodings.binary accessors grouping macros alien.c-types ;
   9 IN: graphics.bitmap
  10
  11 ! Currently can only handle 24/32bit bitmaps.
  12 ! Handles row-reversed bitmaps (their height is negative)
  13
  14 TUPLE: bitmap magic size reserved offset header-length width
  15     height planes bit-count compression size-image
  16     x-pels y-pels color-used color-important rgb-quads color-index array ;
  17
  18 : (array-copy) ( bitmap array -- bitmap array' )
  19     over size-image>> abs memory>byte-array ;
  20
  21 MACRO: (nbits>bitmap) ( bits -- )
  22     [ -3 shift ] keep '[
  23         bitmap new
  24             2over * _ * >>size-image
  25             swap >>height
  26             swap >>width
  27             swap (array-copy) [ >>array ] [ >>color-index ] bi
  28             _ >>bit-count
  29     ] ;
  30
  31 : bgr>bitmap ( array height width -- bitmap )
  32     24 (nbits>bitmap) ;
  33
  34 : bgra>bitmap ( array height width -- bitmap )
  35     32 (nbits>bitmap) ;
  36
  37 : 8bit>array ( bitmap -- array )
  38     [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
  39     [ color-index>> >array ] bi [ swap nth ] with map concat ;
  40
  41 : 4bit>array ( bitmap -- array )
  42     [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
  43     [ color-index>> >array ] bi [ swap nth ] with map concat ;
  44
  45 : raw-bitmap>array ( bitmap -- array )
  46     dup bit-count>>
  47     {
  48         { 32 [ "32bit" throw ] }
  49         { 24 [ color-index>> ] }
  50         { 16 [ "16bit" throw ] }
  51         { 8 [ 8bit>array ] }
  52         { 4 [ 4bit>array ] }
  53         { 2 [ "2bit" throw ] }
  54         { 1 [ "1bit" throw ] }
  55     } case >byte-array ;
  56
  57 ERROR: bitmap-magic ;
  58
  59 M: bitmap-magic summary
  60     drop "First two bytes of bitmap stream must be 'BM'" ;
  61
  62 : parse-file-header ( bitmap -- )
  63     2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
  64     4 read le> >>size
  65     4 read le> >>reserved
  66     4 read le> >>offset drop ;
  67
  68 : parse-bitmap-header ( bitmap -- )
  69     4 read le> >>header-length
  70     4 read signed-le> >>width
  71     4 read signed-le> >>height
  72     2 read le> >>planes
  73     2 read le> >>bit-count
  74     4 read le> >>compression
  75     4 read le> >>size-image
  76     4 read le> >>x-pels
  77     4 read le> >>y-pels
  78     4 read le> >>color-used
  79     4 read le> >>color-important drop ;
  80
  81 : rgb-quads-length ( bitmap -- n )
  82     [ offset>> 14 - ] keep header-length>> - ;
  83
  84 : color-index-length ( bitmap -- n )
  85     [ width>> ] keep [ planes>> * ] keep
  86     [ bit-count>> * 31 + 32 /i 4 * ] keep
  87     height>> abs * ;
  88
  89 : parse-bitmap ( bitmap -- )
  90     dup rgb-quads-length read >>rgb-quads
  91     dup color-index-length read >>color-index drop ;
  92
  93 : load-bitmap ( path -- bitmap )
  94     binary [
  95         bitmap new
  96             dup parse-file-header
  97             dup parse-bitmap-header
  98             dup parse-bitmap
  99     ] with-file-reader
 100     dup raw-bitmap>array >>array ;
 101
 102 : save-bitmap ( bitmap path -- )
 103     binary [
 104         "BM" >byte-array write
 105         dup array>> length 14 + 40 + 4 >le write
 106         0 4 >le write
 107         54 4 >le write
 108
 109         40 4 >le write
 110         {
 111             [ width>> 4 >le write ]
 112             [ height>> 4 >le write ]
 113             [ planes>> 1 or 2 >le write ]
 114             [ bit-count>> 24 or 2 >le write ]
 115             [ compression>> 0 or 4 >le write ]
 116             [ size-image>> 4 >le write ]
 117             [ x-pels>> 0 or 4 >le write ]
 118             [ y-pels>> 0 or 4 >le write ]
 119             [ color-used>> 0 or 4 >le write ]
 120             [ color-important>> 0 or 4 >le write ]
 121             [ rgb-quads>> write ]
 122             [ color-index>> write ]
 123         } cleave
 124     ] with-file-writer ;
 125
 126 M: bitmap draw-image ( bitmap -- )
 127     dup height>> 0 < [
 128         0 0 glRasterPos2i
 129         1.0 -1.0 glPixelZoom
 130     ] [
 131         0 over height>> abs glRasterPos2i
 132         1.0 1.0 glPixelZoom
 133     ] if
 134     [ width>> ] keep
 135     [
 136         [ height>> abs ] keep
 137         bit-count>> {
 138             { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
 139             { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
 140             { 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
 141             { 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
 142         } case
 143     ] keep array>> glDrawPixels ;
 144
 145 M: bitmap width ( bitmap -- ) width>> ;
 146 M: bitmap height ( bitmap -- ) height>> ;
 147
 148 : bitmap. ( path -- )
 149     load-bitmap <graphics-gadget> gadget. ;
 150
 151 : bitmap-window ( path -- gadget )
 152     load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;
 153
 154 : test-bitmap24 ( -- )
 155     "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;
 156
 157 : test-bitmap8 ( -- )
 158     "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;
 159
 160 : test-bitmap4 ( -- )
 161     "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;
 162
 163 : test-bitmap1 ( -- )
 164     "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;
 165