--- /dev/null
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: alien arrays byte-arrays combinators summary
+io.backend graphics.viewer io io.binary io.files kernel libc
+math math.functions namespaces opengl opengl.gl prettyprint
+sequences strings ui ui.gadgets.panes io.encodings.binary
+accessors ;
+IN: graphics.bitmap
+
+! Currently can only handle 24bit bitmaps.
+! Handles row-reversed bitmaps (their height is negative)
+
+TUPLE: bitmap magic size reserved offset header-length width
+ height planes bit-count compression size-image
+ x-pels y-pels color-used color-important rgb-quads color-index array ;
+
+: raw-bitmap>string ( str n -- str )
+ {
+ { 32 [ "32bit" throw ] }
+ { 24 [ ] }
+ { 16 [ "16bit" throw ] }
+ { 8 [ "8bit" throw ] }
+ { 4 [ "4bit" throw ] }
+ { 2 [ "2bit" throw ] }
+ { 1 [ "1bit" throw ] }
+ } case ;
+
+ERROR: bitmap-magic ;
+
+M: bitmap-magic summary
+ drop "First two bytes of bitmap stream must be 'BM'" ;
+
+: parse-file-header ( bitmap -- )
+ 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
+ 4 read le> >>size
+ 4 read le> >>reserved
+ 4 read le> >>offset drop ;
+
+: parse-bitmap-header ( bitmap -- )
+ 4 read le> >>header-length
+ 4 read le> >>width
+ 4 read le> >>height
+ 2 read le> >>planes
+ 2 read le> >>bit-count
+ 4 read le> >>compression
+ 4 read le> >>size-image
+ 4 read le> >>x-pels
+ 4 read le> >>y-pels
+ 4 read le> >>color-used
+ 4 read le> >>color-important drop ;
+
+: rgb-quads-length ( bitmap -- n )
+ [ offset>> 14 - ] keep header-length>> - ;
+
+: color-index-length ( bitmap -- n )
+ [ width>> ] keep [ planes>> * ] keep
+ [ bit-count>> * 31 + 32 /i 4 * ] keep
+ height>> abs * ;
+
+: parse-bitmap ( bitmap -- )
+ dup rgb-quads-length read >>rgb-quads
+ dup color-index-length read >>color-index drop ;
+
+: load-bitmap ( path -- bitmap )
+ normalize-path binary [
+ T{ bitmap } clone
+ dup parse-file-header
+ dup parse-bitmap-header
+ dup parse-bitmap
+ ] with-file-reader
+ dup color-index>> over bit-count>>
+ raw-bitmap>string >byte-array >>array ;
+
+: save-bitmap ( bitmap path -- )
+ binary [
+ "BM" write
+ dup array>> length 14 + 40 + 4 >le write
+ 0 4 >le write
+ 54 4 >le write
+
+ 40 4 >le write
+ {
+ [ width>> 4 >le write ]
+ [ height>> 4 >le write ]
+ [ planes>> 1 or 2 >le write ]
+ [ bit-count>> 24 or 2 >le write ]
+ [ compression>> 0 or 4 >le write ]
+ [ size-image>> 4 >le write ]
+ [ x-pels>> 4 >le write ]
+ [ y-pels>> 4 >le write ]
+ [ color-used>> 4 >le write ]
+ [ color-important>> 4 >le write ]
+ [ rgb-quads>> write ]
+ [ color-index>> write ]
+ } cleave
+ ] with-file-writer ;
+
+M: bitmap draw-image ( bitmap -- )
+ dup height>> 0 < [
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ ] [
+ 0 over height>> abs glRasterPos2i
+ 1.0 1.0 glPixelZoom
+ ] if
+ [ width>> ] keep
+ [
+ [ height>> abs ] keep
+ bit-count>> {
+ ! { 32 [ GL_BGRA GL_UNSIGNED_INT_8_8_8_8 ] } ! broken
+ { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
+ } case
+ ] keep array>> glDrawPixels ;
+
+M: bitmap width ( bitmap -- ) width>> ;
+M: bitmap height ( bitmap -- ) height>> ;
+
+: bitmap. ( path -- )
+ load-bitmap <graphics-gadget> gadget. ;
+
+: bitmap-window ( path -- gadget )
+ load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;
+
+: test-bitmap24 ( -- )
+ "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ;
+
+: test-bitmap8 ( -- )
+ "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ;
+
+: test-bitmap4 ( -- )
+ "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ;
+
+: test-bitmap1 ( -- )
+ "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ;
+
--- /dev/null
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel math math.functions namespaces opengl
+ui.gadgets ui.render accessors ;
+IN: graphics.viewer
+
+TUPLE: graphics-gadget < gadget image ;
+
+GENERIC: draw-image ( image -- )
+GENERIC: width ( image -- w )
+GENERIC: height ( image -- h )
+
+M: graphics-gadget pref-dim*
+ image>> [ width ] keep height abs 2array ;
+
+M: graphics-gadget draw-gadget* ( gadget -- )
+ origin get [ image>> draw-image ] with-translation ;
+
+: <graphics-gadget> ( bitmap -- gadget )
+ \ graphics-gadget new-gadget
+ swap >>image ;