refactoring bitmap to bitmap.loading and bitmap.saving vocabs

basis/images/bitmap/bitmap.factor

@@ -2,34 +2,23 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types arrays byte-arrays columns
 combinators compression.run-length endian fry grouping images
-images.loader io io.binary io.encodings.binary io.files
+images.bitmap.loading images.loader io io.binary
-io.streams.limited kernel locals macros math math.bitwise
+io.encodings.8-bit io.encodings.binary io.encodings.string
-math.functions namespaces sequences specialized-arrays.uint
+io.files io.streams.limited kernel locals macros math
-specialized-arrays.ushort strings summary io.encodings.8-bit
+math.bitwise math.functions namespaces sequences
-io.encodings.string ;
+specialized-arrays.uint specialized-arrays.ushort strings
+summary ;
 QUALIFIED-WITH: bitstreams b
 IN: images.bitmap
 
-: read2 ( -- n ) 2 read le> ;
-: read4 ( -- n ) 4 read le> ;
-: write2 ( n -- ) 2 >le write ;
-: write4 ( n -- ) 4 >le write ;
-
 SINGLETON: bitmap-image
 "bmp" bitmap-image register-image-class
 
-TUPLE: loading-bitmap 
-magic size reserved1 reserved2 offset header-length width
-height planes bit-count compression size-image
-x-pels y-pels color-used color-important
-red-mask green-mask blue-mask alpha-mask
-cs-type end-points
-gamma-red gamma-green gamma-blue
-intent profile-data profile-size reserved3
-color-palette color-index bitfields ;
-
 ! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint
 
+: write2 ( n -- ) 2 >le write ;
+: write4 ( n -- ) 4 >le write ;
+
 <PRIVATE
 
 : os2-color-lookup ( loading-bitmap -- seq )
@@ -48,7 +37,7 @@ color-palette color-index bitfields ;
     '[ _ nth ] map concat ;
 
 : color-lookup ( loading-bitmap -- seq )
-    dup header-length>> {
+    dup file-header>> header-length>> {
         { 12 [ os2-color-lookup ] }
         { 64 [ os2v2-color-lookup ] }
         { 40 [ v3-color-lookup ] }
@@ -66,7 +55,7 @@ ERROR: bmp-not-supported n ;
     ] { } map-as B{ } concat-as ;
 
 : bitmap>bytes ( loading-bitmap -- byte-array )
-    dup bit-count>>
+    dup header>> bit-count>>
     {
         { 32 [ color-index>> ] }
         { 24 [ color-index>> ] }
@@ -82,13 +71,13 @@ ERROR: bmp-not-supported n ;
             color-index>>
         ] }
         { 8 [ color-lookup ] }
-        { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
+        { 4 [ B [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
         { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
         [ bmp-not-supported ]
     } case >byte-array ;
 
 : set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
-    dup bit-count>> {
+    dup header>> bit-count>> {
         { 16 [ dup color-palette>> 4 group [ le> ] map ] }
         { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
     } case reverse >>bitfields ;
@@ -100,7 +89,7 @@ M: unsupported-bitfield-widths summary
 
 : uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
     set-bitfield-widths
-    dup bit-count>> {
+    dup header>> bit-count>> {
         { 16 [
             dup bitfields>> '[
                 byte-array>ushort-array _ uncompress-bitfield
@@ -116,8 +105,16 @@ M: unsupported-bitfield-widths summary
 
 ERROR: unsupported-bitmap-compression compression ;
 
-: uncompress-bitmap ( loading-bitmap -- loading-bitmap' )
+GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
-    dup compression>> {
+
+: uncompress-bitmap ( loading-bitmap -- loading-bitmap )
+    dup header>> uncompress-bitmap* ;
+
+M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
+    drop ;
+
+M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
+    compression>> {
         { f [ ] }
         { 0 [ ] }
         { 1 [ [ run-length-uncompress ] change-color-index ] }
@@ -134,73 +131,11 @@ ERROR: unsupported-bitmap-compression compression ;
     uncompress-bitmap
     bitmap>bytes ;
 
-: parse-file-header ( loading-bitmap -- loading-bitmap )
-    2 read latin1 decode >>magic
-    read4 >>size
-    read2 >>reserved1
-    read2 >>reserved2
-    read4 >>offset ;
-
-: read-v3-header ( loading-bitmap -- loading-bitmap )
-    read4 >>width
-    read4 32 >signed >>height
-    read2 >>planes
-    read2 >>bit-count
-    read4 >>compression
-    read4 >>size-image
-    read4 >>x-pels
-    read4 >>y-pels
-    read4 >>color-used
-    read4 >>color-important ;
-
-: read-v4-header ( loading-bitmap -- loading-bitmap )
-    read-v3-header
-    read4 >>red-mask
-    read4 >>green-mask
-    read4 >>blue-mask
-    read4 >>alpha-mask
-    read4 >>cs-type
-    read4 read4 read4 3array >>end-points
-    read4 >>gamma-red
-    read4 >>gamma-green
-    read4 >>gamma-blue ;
-
-: read-v5-header ( loading-bitmap -- loading-bitmap )
-    read-v4-header
-    read4 >>intent
-    read4 >>profile-data
-    read4 >>profile-size
-    read4 >>reserved3 ;
-
-: read-os2-header ( loading-bitmap -- loading-bitmap )
-    read2 >>width
-    read2 16 >signed >>height
-    read2 >>planes
-    read2 >>bit-count ;
-
-: read-os2v2-header ( loading-bitmap -- loading-bitmap )
-    read4 >>width
-    read4 32 >signed >>height
-    read2 >>planes
-    read2 >>bit-count ;
-
-ERROR: unknown-bitmap-header n ;
-
-: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
-    read4 [ >>header-length ] keep
-    {
-        { 12 [ read-os2-header ] }
-        { 64 [ read-os2v2-header ] }
-        { 40 [ read-v3-header ] }
-        { 108 [ read-v4-header ] }
-        { 124 [ read-v5-header ] }
-        [ unknown-bitmap-header ]
-    } case ;
-
 : color-palette-length ( loading-bitmap -- n )
+    file-header>>
     [ offset>> 14 - ] [ header-length>> ] bi - ;
 
-: color-index-length ( loading-bitmap -- n )
+: color-index-length ( header -- n )
     {
         [ width>> ]
         [ planes>> * ]
@@ -208,57 +143,8 @@ ERROR: unknown-bitmap-header n ;
         [ height>> abs * ]
     } cleave ;
 
-: image-size ( loading-bitmap -- n )
-    [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
-
-: parse-bitmap ( loading-bitmap -- loading-bitmap )
-    dup color-palette-length read >>color-palette
-    dup size-image>> dup 0 > [
-        read >>color-index
-    ] [
-        drop dup color-index-length read >>color-index
-    ] if ;
-
 ERROR: unsupported-bitmap-file magic ;
 
-: load-bitmap ( path -- loading-bitmap )
-    binary stream-throws <limited-file-reader> [
-        loading-bitmap new
-        parse-file-header dup magic>> {
-            { "BM" [ parse-bitmap-header parse-bitmap ] }
-            ! { "BA" [ parse-os2-bitmap-array ] }
-            ! { "CI" [ parse-os2-color-icon ] }
-            ! { "CP" [ parse-os2-color-pointer ] }
-            ! { "IC" [ parse-os2-icon ] }
-            ! { "PT" [ parse-os2-pointer ] }
-            [ unsupported-bitmap-file ]
-        } case 
-    ] with-input-stream ;
-
-ERROR: unknown-component-order bitmap ;
-
-: bitmap>component-order ( loading-bitmap -- object )
-    bit-count>> {
-        { 32 [ BGR ] }
-        { 24 [ BGR ] }
-        { 16 [ BGR ] }
-        { 8 [ BGR ] }
-        { 4 [ BGR ] }
-        { 1 [ BGR ] }
-        [ unknown-component-order ]
-    } case ;
-
-M: bitmap-image load-image* ( path bitmap-image -- bitmap )
-    drop load-bitmap
-    [ image new ] dip
-    {
-        [ loading-bitmap>bytes >>bitmap ]
-        [ [ width>> ] [ height>> abs ] bi 2array >>dim ]
-        [ height>> 0 < not >>upside-down? ]
-        [ compression>> 3 = [ t >>upside-down? ] when ]
-        [ bitmap>component-order >>component-order ]
-    } cleave ;
-
 PRIVATE>
 
 : bitmap>color-index ( bitmap -- byte-array )
@@ -301,7 +187,7 @@ PRIVATE>
                 ! compression
                 [ drop 0 write4 ]
 
-                ! size-image
+                ! image-size
                 [ bitmap>color-index length write4 ]
 
                 ! x-pels

basis/images/bitmap/loading/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/images/bitmap/loading/loading.factor

@@ -0,0 +1,197 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators images images.bitmap
+images.bitmap.private io io.binary io.encodings.8-bit
+io.encodings.binary io.encodings.string io.streams.limited
+kernel math math.bitwise ;
+IN: images.bitmap.loading
+
+! http://www.fileformat.info/format/bmp/egff.htm
+
+ERROR: unknown-component-order bitmap ;
+ERROR: unknown-bitmap-header n ;
+
+: read2 ( -- n ) 2 read le> ;
+: read4 ( -- n ) 4 read le> ;
+
+TUPLE: loading-bitmap
+    file-header header
+    color-palette color-index bitfields ;
+
+TUPLE: file-header
+    magic size reserved1 reserved2 offset header-length ;
+
+TUPLE: v3-header
+    width height planes bit-count
+    compression image-size x-resolution y-resolution
+    colors-used colors-important ;
+
+TUPLE: v4-header < v3-header
+    red-mask green-mask blue-mask alpha-mask
+    cs-type end-points
+    gamma-red gamma-green gamma-blue ;
+
+TUPLE: v5-header < v4-header
+    intent profile-data profile-size reserved3 ;
+
+TUPLE: os2v1-header width height planes bit-count ;
+TUPLE: os2v2-header < os2v1-header
+    compression image-size x-resolution y-resolution
+    colors-used colors-important units reserved
+    recording rendering size1 size2 color-encoding identifier ;
+
+UNION: v-header v3-header v4-header v5-header ;
+UNION: os2-header os2v1-header os2v2-header ;
+
+: parse-file-header ( -- file-header )
+    \ file-header new
+        2 read latin1 decode >>magic
+        read4 >>size
+        read2 >>reserved1
+        read2 >>reserved2
+        read4 >>offset
+        read4 >>header-length ;
+
+: read-v3-header-data ( header -- header )
+    read4 >>width
+    read4 32 >signed >>height
+    read2 >>planes
+    read2 >>bit-count
+    read4 >>compression
+    read4 >>image-size
+    read4 >>x-resolution
+    read4 >>y-resolution
+    read4 >>colors-used
+    read4 >>colors-important ;
+
+: read-v3-header ( -- header )
+    \ v3-header new
+        read-v3-header-data ;
+
+: read-v4-header-data ( header -- header )
+    read4 >>red-mask
+    read4 >>green-mask
+    read4 >>blue-mask
+    read4 >>alpha-mask
+    read4 >>cs-type
+    read4 read4 read4 3array >>end-points
+    read4 >>gamma-red
+    read4 >>gamma-green
+    read4 >>gamma-blue ;
+
+: read-v4-header ( -- v4-header )
+    \ v4-header new
+        read-v3-header-data
+        read-v4-header-data ;
+
+: read-v5-header-data ( v5-header -- v5-header )
+    read4 >>intent
+    read4 >>profile-data
+    read4 >>profile-size
+    read4 >>reserved3 ;
+
+: read-v5-header ( -- loading-bitmap )
+    \ v5-header new
+        read-v3-header-data
+        read-v4-header-data
+        read-v5-header-data ;
+
+: read-os2v1-header ( -- os2v1-header )
+    \ os2v1-header new
+        read2 >>width
+        read2 16 >signed >>height
+        read2 >>planes
+        read2 >>bit-count ;
+
+: read-os2v2-header-data ( os2v2-header -- os2v2-header )
+    read4 >>width
+    read4 32 >signed >>height
+    read2 >>planes
+    read2 >>bit-count
+    read4 >>compression
+    read4 >>image-size
+    read4 >>x-resolution
+    read4 >>y-resolution
+    read4 >>colors-used
+    read4 >>colors-important
+    read2 >>units
+    read2 >>reserved
+    read2 >>recording
+    read2 >>rendering
+    read4 >>size1
+    read4 >>size2
+    read4 >>color-encoding
+    4 read >>identifier ;
+
+: read-os2v2-header ( -- os2v2-header )
+    \ os2v2-header new
+        read-os2v2-header-data ;
+
+: parse-header ( n -- header )
+    {
+        { 12 [ read-os2v1-header ] }
+        { 64 [ read-os2v2-header ] }
+        { 40 [ read-v3-header ] }
+        { 108 [ read-v4-header ] }
+        { 124 [ read-v5-header ] }
+        [ unknown-bitmap-header ]
+    } case ;
+
+: parse-color-palette ( loading-bitmap -- loading-bitmap )
+    dup color-palette-length read >>color-palette ;
+
+GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
+
+: parse-color-data ( loading-bitmap -- loading-bitmap )
+    dup header>> parse-color-data* ;
+
+M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
+    color-index-length read >>color-index ;
+
+M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
+    dup image-size>> [
+        nip
+    ] [
+        color-index-length
+    ] if* read >>color-index ;
+
+: bitmap>component-order ( loading-bitmap -- object )
+    header>> bit-count>> {
+        { 32 [ BGR ] }
+        { 24 [ BGR ] }
+        { 16 [ BGR ] }
+        { 8 [ BGR ] }
+        { 4 [ BGR ] }
+        { 1 [ BGR ] }
+        [ unknown-component-order ]
+    } case ;
+
+ERROR: unsupported-bitmap-file magic ;
+
+: load-bitmap ( path -- loading-bitmap )
+    binary stream-throws <limited-file-reader> [
+        \ loading-bitmap new
+        parse-file-header [ >>file-header ] [ ] bi magic>> {
+            { "BM" [
+                dup file-header>> header-length>> parse-header >>header
+                parse-color-palette
+                parse-color-data
+            ] }
+            ! { "BA" [ parse-os2-bitmap-array ] }
+            ! { "CI" [ parse-os2-color-icon ] }
+            ! { "CP" [ parse-os2-color-pointer ] }
+            ! { "IC" [ parse-os2-icon ] }
+            ! { "PT" [ parse-os2-pointer ] }
+            [ unsupported-bitmap-file ]
+        } case
+    ] with-input-stream ;
+
+M: bitmap-image load-image* ( path bitmap-image -- bitmap )
+    drop load-bitmap
+    [ image new ] dip
+    {
+        [ loading-bitmap>bytes >>bitmap ]
+        [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
+        [ header>> height>> 0 < not >>upside-down? ]
+        [ bitmap>component-order >>component-order ]
+    } cleave ;