refactoring graphics.bitmap

extra/graphics/bitmap/bitmap-tests.factor

@@ -0,0 +1,15 @@
+USING: graphics.bitmap ;
+IN: graphics.bitmap.tests
+
+: 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. ;
+

extra/graphics/bitmap/bitmap.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: alien arrays byte-arrays combinators summary
-graphics.viewer io io.binary io.files kernel libc math
+io io.binary io.files kernel libc math
 math.functions math.bitwise namespaces opengl opengl.gl
 prettyprint sequences strings ui ui.gadgets.panes fry
 io.encodings.binary accessors grouping macros alien.c-types ;
@@ -12,10 +12,11 @@ IN: graphics.bitmap
 ! Handles row-reversed bitmaps (their height is negative)
 
 TUPLE: bitmap magic size reserved offset header-length width
-    height planes bit-count compression size-image
+height planes bit-count compression size-image
-    x-pels y-pels color-used color-important rgb-quads color-index array ;
+x-pels y-pels color-used color-important rgb-quads color-index
+array ;
 
-: (array-copy) ( bitmap array -- bitmap array' )
+: array-copy ( bitmap array -- bitmap array' )
     over size-image>> abs memory>byte-array ;
 
 MACRO: (nbits>bitmap) ( bits -- )
@@ -24,7 +25,7 @@ MACRO: (nbits>bitmap) ( bits -- )
             2over * _ * >>size-image
             swap >>height
             swap >>width
-            swap (array-copy) [ >>array ] [ >>color-index ] bi
+            swap array-copy [ >>array ] [ >>color-index ] bi
             _ >>bit-count
     ] ;
 
@@ -45,7 +46,7 @@ MACRO: (nbits>bitmap) ( bits -- )
 : raw-bitmap>array ( bitmap -- array )
     dup bit-count>>
     {
-        { 32 [ "32bit" throw ] }
+        { 32 [ color-index>> ] }
         { 24 [ color-index>> ] }
         { 16 [ "16bit" throw ] }
         { 8 [ 8bit>array ] }
@@ -59,107 +60,75 @@ ERROR: bitmap-magic ;
 M: bitmap-magic summary
     drop "First two bytes of bitmap stream must be 'BM'" ;
 
-: parse-file-header ( bitmap -- )
+: read2 ( -- n ) 2 read le> ;
-    2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
+: read4 ( -- n ) 4 read le> ;
-    4 read le> >>size
-    4 read le> >>reserved
-    4 read le> >>offset drop ;
 
-: parse-bitmap-header ( bitmap -- )
+: parse-file-header ( bitmap -- bitmap )
-    4 read le> >>header-length
+    2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
-    4 read signed-le> >>width
+    read4 >>size
-    4 read signed-le> >>height
+    read4 >>reserved
-    2 read le> >>planes
+    read4 >>offset ;
-    2 read le> >>bit-count
+
-    4 read le> >>compression
+: parse-bitmap-header ( bitmap -- bitmap )
-    4 read le> >>size-image
+    read4 >>header-length
-    4 read le> >>x-pels
+    read4 >>width
-    4 read le> >>y-pels
+    read4 >>height
-    4 read le> >>color-used
+    read2 >>planes
-    4 read le> >>color-important drop ;
+    read2 >>bit-count
+    read4 >>compression
+    read4 >>size-image
+    read4 >>x-pels
+    read4 >>y-pels
+    read4 >>color-used
+    read4 >>color-important ;
 
 : rgb-quads-length ( bitmap -- n )
-    [ offset>> 14 - ] keep header-length>> - ;
+    [ offset>> 14 - ] [ header-length>> ] bi - ;
 
 : color-index-length ( bitmap -- n )
-    [ width>> ] keep [ planes>> * ] keep
+    {
-    [ bit-count>> * 31 + 32 /i 4 * ] keep
+        [ width>> ]
-    height>> abs * ;
+        [ planes>> * ]
+        [ bit-count>> * 31 + 32 /i 4 * ]
+        [ height>> abs * ]
+    } cleave ;
 
-: parse-bitmap ( bitmap -- )
+: parse-bitmap ( bitmap -- bitmap )
     dup rgb-quads-length read >>rgb-quads
-    dup color-index-length read >>color-index drop ;
+    dup color-index-length read >>color-index ;
 
 : load-bitmap ( path -- bitmap )
     binary [
         bitmap new
-            dup parse-file-header
+        parse-file-header parse-bitmap-header parse-bitmap
-            dup parse-bitmap-header
-            dup parse-bitmap
     ] with-file-reader
     dup raw-bitmap>array >>array ;
 
+: write2 ( n -- ) 2 >le write ;
+: write4 ( n -- ) 4 >le write ;
+
 : save-bitmap ( bitmap path -- )
     binary [
-        "BM" >byte-array write
+        B{ CHAR: B CHAR: M } write
-        dup array>> length 14 + 40 + 4 >le write
+        [
-        0 4 >le write
+            array>> length 14 + 40 + write4
-        54 4 >le write
+            0 write4
-
+            54 write4
-        40 4 >le write
+            40 write4
-        {
+        ] [
-            [ width>> 4 >le write ]
+            {
-            [ height>> 4 >le write ]
+                [ width>> write4 ]
-            [ planes>> 1 or 2 >le write ]
+                [ height>> write4 ]
-            [ bit-count>> 24 or 2 >le write ]
+                [ planes>> 1 or write2 ]
-            [ compression>> 0 or 4 >le write ]
+                [ bit-count>> 24 or write2 ]
-            [ size-image>> 4 >le write ]
+                [ compression>> 0 or write4 ]
-            [ x-pels>> 0 or 4 >le write ]
+                [ size-image>> write4 ]
-            [ y-pels>> 0 or 4 >le write ]
+                [ x-pels>> 0 or write4 ]
-            [ color-used>> 0 or 4 >le write ]
+                [ y-pels>> 0 or write4 ]
-            [ color-important>> 0 or 4 >le write ]
+                [ color-used>> 0 or write4 ]
-            [ rgb-quads>> write ]
+                [ color-important>> 0 or write4 ]
-            [ color-index>> write ]
+                [ rgb-quads>> write ]
-        } cleave
+                [ color-index>> write ]
+            } cleave
+        ] bi
     ] 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_BYTE ] }
-            { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
-            { 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
-            { 4 [ 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. ;
-

extra/graphics/viewer/viewer.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions namespaces opengl
+USING: accessors arrays combinators graphics.bitmap kernel math
-ui.gadgets ui.render accessors ;
+math.functions namespaces opengl opengl.gl ui ui.gadgets
+ui.gadgets.panes ui.render ;
 IN: graphics.viewer
 
 TUPLE: graphics-gadget < gadget image ;
@@ -19,3 +20,31 @@ M: graphics-gadget draw-gadget* ( gadget -- )
 : <graphics-gadget> ( bitmap -- gadget )
     \ graphics-gadget new-gadget
         swap >>image ;
+
+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_BYTE ] }
+            { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
+            { 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
+            { 4 [ 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 ;