basis/images/images.factor

   1 ! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators kernel math sequences ;
   4 IN: images
   5
   6 SINGLETONS:
   7     A L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
   8     INTENSITY DEPTH DEPTH-STENCIL R RG
   9     ubyte-components ushort-components uint-components
  10     half-components float-components
  11     byte-integer-components ubyte-integer-components
  12     short-integer-components ushort-integer-components
  13     int-integer-components uint-integer-components
  14     u-5-5-5-1-components u-5-6-5-components
  15     u-10-10-10-2-components
  16     u-24-components u-24-8-components
  17     float-32-u-8-components
  18     u-9-9-9-e5-components
  19     float-11-11-10-components ;
  20
  21 UNION: component-order
  22     A L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
  23     INTENSITY DEPTH DEPTH-STENCIL R RG ;
  24
  25 UNION: component-type
  26     ubyte-components ushort-components uint-components
  27     half-components float-components
  28     byte-integer-components ubyte-integer-components
  29     short-integer-components ushort-integer-components
  30     int-integer-components uint-integer-components
  31     u-5-5-5-1-components u-5-6-5-components
  32     u-10-10-10-2-components
  33     u-24-components u-24-8-components
  34     float-32-u-8-components
  35     u-9-9-9-e5-components
  36     float-11-11-10-components ;
  37
  38 UNION: unnormalized-integer-components
  39     byte-integer-components ubyte-integer-components
  40     short-integer-components ushort-integer-components
  41     int-integer-components uint-integer-components ;
  42
  43 UNION: signed-unnormalized-integer-components
  44     byte-integer-components
  45     short-integer-components
  46     int-integer-components ;
  47
  48 UNION: unsigned-unnormalized-integer-components
  49     ubyte-integer-components
  50     ushort-integer-components
  51     uint-integer-components ;
  52
  53 UNION: packed-components
  54     u-5-5-5-1-components u-5-6-5-components
  55     u-10-10-10-2-components
  56     u-24-components u-24-8-components
  57     float-32-u-8-components
  58     u-9-9-9-e5-components
  59     float-11-11-10-components ;
  60
  61 UNION: alpha-channel BGRA RGBA ABGR ARGB LA A INTENSITY ;
  62
  63 UNION: alpha-channel-precedes-colors ABGR ARGB XBGR XRGB ;
  64
  65 TUPLE: image
  66     dim component-order component-type
  67     upside-down? premultiplied-alpha?
  68     bitmap 2x? ;
  69
  70 : <image> ( -- image ) image new ; inline
  71
  72 : image-dim ( image -- dim )
  73     [ dim>> ] [ 2x?>> ] bi [ [ 2.0 / ] map ] when ;
  74
  75 : has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
  76
  77 : bytes-per-component ( component-type -- n )
  78     {
  79         { ubyte-components [ 1 ] }
  80         { ushort-components [ 2 ] }
  81         { uint-components [ 4 ] }
  82         { half-components [ 2 ] }
  83         { float-components [ 4 ] }
  84         { byte-integer-components [ 1 ] }
  85         { ubyte-integer-components [ 1 ] }
  86         { short-integer-components [ 2 ] }
  87         { ushort-integer-components [ 2 ] }
  88         { int-integer-components [ 4 ] }
  89         { uint-integer-components [ 4 ] }
  90     } case ;
  91
  92 : bytes-per-packed-pixel ( component-type -- n )
  93     {
  94         { u-5-5-5-1-components [ 2 ] }
  95         { u-5-6-5-components [ 2 ] }
  96         { u-10-10-10-2-components [ 4 ] }
  97         { u-24-components [ 4 ] }
  98         { u-24-8-components [ 4 ] }
  99         { u-9-9-9-e5-components [ 4 ] }
 100         { float-11-11-10-components [ 4 ] }
 101         { float-32-u-8-components [ 8 ] }
 102     } case ;
 103
 104 : component-count ( component-order -- n )
 105     {
 106         { A [ 1 ] }
 107         { L [ 1 ] }
 108         { LA [ 2 ] }
 109         { BGR [ 3 ] }
 110         { RGB [ 3 ] }
 111         { BGRA [ 4 ] }
 112         { RGBA [ 4 ] }
 113         { ABGR [ 4 ] }
 114         { ARGB [ 4 ] }
 115         { RGBX [ 4 ] }
 116         { XRGB [ 4 ] }
 117         { BGRX [ 4 ] }
 118         { XBGR [ 4 ] }
 119         { INTENSITY [ 1 ] }
 120         { DEPTH [ 1 ] }
 121         { DEPTH-STENCIL [ 1 ] }
 122         { R [ 1 ] }
 123         { RG [ 2 ] }
 124     } case ;
 125
 126 : (bytes-per-pixel) ( component-order component-type -- n )
 127     dup packed-components?
 128     [ nip bytes-per-packed-pixel ] [
 129         [ component-count ] [ bytes-per-component ] bi* *
 130     ] if ;
 131
 132 : bytes-per-pixel ( image -- n )
 133     [ component-order>> ] [ component-type>> ] bi (bytes-per-pixel) ;
 134
 135 : bytes-per-image ( image -- n )
 136     [ dim>> product ] [ bytes-per-pixel ] bi * ;
 137
 138 : rowstride ( image -- n )
 139     [ dim>> first ] [ bytes-per-pixel ] bi * ;
 140
 141 <PRIVATE
 142
 143 :: pixel@ ( x y w image -- start end bitmap )
 144     image dim>> first y * x + :> start
 145     start w [ image bytes-per-pixel * ] bi@ :> ( start' w' )
 146     start'  start' w' +  image bitmap>> ; inline
 147
 148 : set-subseq ( new-value from to victim -- )
 149     <slice> 0 swap copy ; inline
 150
 151 PRIVATE>
 152
 153 : pixel-row-at ( x y w image -- pixels )
 154     pixel@ subseq ; inline
 155
 156 : pixel-row-slice-at ( x y w image -- pixels )
 157     pixel@ <slice> ; inline
 158
 159 : set-pixel-row-at ( pixel x y w image -- )
 160     pixel@ set-subseq ; inline
 161
 162 : pixel-at ( x y image -- pixel )
 163     [ 1 ] dip pixel-row-at ; inline
 164
 165 : pixel-slice-at ( x y image -- pixels )
 166     [ 1 ] dip pixel-row-slice-at ; inline
 167
 168 : set-pixel-at ( pixel x y image -- )
 169     [ 1 ] dip set-pixel-row-at ; inline
 170
 171 :: each-pixel ( ... image quot: ( ... x y pixel -- ... ) -- ... )
 172     image dim>> first2 :> ( width height )
 173     image bytes-per-pixel :> n
 174     height width [ <iota> ] bi@ [| y x |
 175         y width * x + :> start
 176         start n * :> from
 177         from n + :> to
 178         x y from to image bitmap>> <slice> quot call
 179     ] cartesian-each ; inline