basis/images/images.factor

   1 ! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: combinators kernel accessors sequences math arrays ;
   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     u-9-9-9-e5-components
  18     float-11-11-10-components ;
  19
  20 UNION: component-order
  21     A L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
  22     INTENSITY DEPTH DEPTH-STENCIL R RG ;
  23
  24 UNION: component-type
  25     ubyte-components ushort-components
  26     half-components float-components
  27     byte-integer-components ubyte-integer-components
  28     short-integer-components ushort-integer-components
  29     int-integer-components uint-integer-components
  30     u-5-5-5-1-components u-5-6-5-components
  31     u-10-10-10-2-components
  32     u-24-components u-24-8-components
  33     u-9-9-9-e5-components
  34     float-11-11-10-components ;
  35
  36 UNION: unnormalized-integer-components
  37     byte-integer-components ubyte-integer-components
  38     short-integer-components ushort-integer-components
  39     int-integer-components uint-integer-components ;
  40
  41 UNION: packed-components
  42     u-5-5-5-1-components u-5-6-5-components
  43     u-10-10-10-2-components
  44     u-24-components u-24-8-components
  45     u-9-9-9-e5-components
  46     float-11-11-10-components ;
  47
  48 UNION: alpha-channel BGRA RGBA ABGR ARGB LA A INTENSITY ;
  49
  50 UNION: alpha-channel-precedes-colors ABGR ARGB XBGR XRGB ;
  51
  52 TUPLE: image dim component-order component-type upside-down? bitmap ;
  53
  54 : <image> ( -- image ) image new ; inline
  55
  56 : has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
  57
  58 GENERIC: load-image* ( path class -- image )
  59
  60 : bytes-per-component ( component-type -- n )
  61     {
  62         { ubyte-components [ 1 ] }
  63         { ushort-components [ 2 ] }
  64         { uint-components [ 4 ] }
  65         { half-components [ 2 ] }
  66         { float-components [ 4 ] }
  67         { byte-integer-components [ 1 ] }
  68         { ubyte-integer-components [ 1 ] }
  69         { short-integer-components [ 2 ] }
  70         { ushort-integer-components [ 2 ] }
  71         { int-integer-components [ 4 ] }
  72         { uint-integer-components [ 4 ] }
  73     } case ;
  74
  75 : bytes-per-packed-pixel ( component-type -- n )
  76     {
  77         { u-5-5-5-1-components [ 2 ] }
  78         { u-5-6-5-components [ 2 ] }
  79         { u-10-10-10-2-components [ 4 ] }
  80         { u-24-components [ 4 ] }
  81         { u-24-8-components [ 4 ] }
  82         { u-9-9-9-e5-components [ 4 ] }
  83         { float-11-11-10-components [ 4 ] }
  84     } case ;
  85
  86 : component-count ( component-order -- n )
  87     {
  88         { A [ 1 ] }
  89         { L [ 1 ] }
  90         { LA [ 2 ] }
  91         { BGR [ 3 ] }
  92         { RGB [ 3 ] }
  93         { BGRA [ 4 ] }
  94         { RGBA [ 4 ] }
  95         { ABGR [ 4 ] }
  96         { ARGB [ 4 ] }
  97         { RGBX [ 4 ] }
  98         { XRGB [ 4 ] }
  99         { BGRX [ 4 ] }
 100         { XBGR [ 4 ] }
 101         { INTENSITY [ 1 ] }
 102         { DEPTH [ 1 ] }
 103         { DEPTH-STENCIL [ 1 ] }
 104         { R [ 1 ] }
 105         { RG [ 2 ] }
 106     } case ;
 107
 108 : bytes-per-pixel ( image -- n )
 109     dup component-type>> packed-components?
 110     [ component-type>> bytes-per-packed-pixel ] [
 111         [ component-order>> component-count ]
 112         [ component-type>>  bytes-per-component ] bi *
 113     ] if ;
 114
 115 <PRIVATE
 116
 117 : pixel@ ( x y image -- start end bitmap )
 118     [ dim>> first * + ]
 119     [ bytes-per-pixel [ * dup ] keep + ]
 120     [ bitmap>> ] tri ;
 121
 122 : set-subseq ( new-value from to victim -- )
 123     <slice> 0 swap copy ; inline
 124
 125 PRIVATE>
 126
 127 : pixel-at ( x y image -- pixel )
 128     pixel@ subseq ;
 129
 130 : set-pixel-at ( pixel x y image -- )
 131     pixel@ set-subseq ;