basis/images/images.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel accessors grouping sequences combinators
   4 math specialized-arrays.direct.uint byte-arrays fry
   5 specialized-arrays.direct.ushort specialized-arrays.uint
   6 specialized-arrays.ushort specialized-arrays.float ;
   7 IN: images
   8
   9 SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
  10 R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
  11
  12 : bytes-per-pixel ( component-order -- n )
  13     {
  14         { BGR [ 3 ] }
  15         { RGB [ 3 ] }
  16         { BGRA [ 4 ] }
  17         { RGBA [ 4 ] }
  18         { ABGR [ 4 ] }
  19         { ARGB [ 4 ] }
  20         { RGBX [ 4 ] }
  21         { XRGB [ 4 ] }
  22         { BGRX [ 4 ] }
  23         { XBGR [ 4 ] }
  24         { R16G16B16 [ 6 ] }
  25         { R32G32B32 [ 12 ] }
  26         { R16G16B16A16 [ 8 ] }
  27         { R32G32B32A32 [ 16 ] }
  28     } case ;
  29
  30 TUPLE: image dim component-order bitmap ;
  31
  32 : <image> ( -- image ) image new ; inline
  33
  34 GENERIC: load-image* ( path tuple -- image )
  35
  36 : add-dummy-alpha ( seq -- seq' )
  37     3 <groups> [ 255 suffix ] map concat ;
  38
  39 : normalize-floats ( byte-array -- byte-array )
  40     byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
  41
  42 GENERIC: normalize-component-order* ( image component-order -- image )
  43
  44 : normalize-component-order ( image -- image )
  45     dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
  46
  47 M: RGBA normalize-component-order* drop ;
  48
  49 M: R32G32B32A32 normalize-component-order*
  50     drop normalize-floats ;
  51
  52 M: R32G32B32 normalize-component-order*
  53     drop normalize-floats add-dummy-alpha ;
  54
  55 : RGB16>8 ( bitmap -- bitmap' )
  56     byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
  57
  58 M: R16G16B16A16 normalize-component-order*
  59     drop RGB16>8 ;
  60
  61 M: R16G16B16 normalize-component-order*
  62     drop RGB16>8 add-dummy-alpha ;
  63
  64 : BGR>RGB ( bitmap bytes-per-pixel -- pixels )
  65     <groups> [ 3 cut [ reverse ] dip append ] map B{ } join ; inline
  66
  67 M: BGRA normalize-component-order*
  68     drop 4 BGR>RGB ;
  69
  70 M: RGB normalize-component-order*
  71     drop add-dummy-alpha ;
  72
  73 M: BGR normalize-component-order*
  74     drop 3 BGR>RGB add-dummy-alpha ;
  75
  76 : ARGB>RGBA ( bitmap -- bitmap' )
  77     4 <groups> [ unclip suffix ] map B{ } join ;
  78
  79 M: ARGB normalize-component-order*
  80     drop ARGB>RGBA ;
  81
  82 M: ABGR normalize-component-order*
  83     drop ARGB>RGBA 4 BGR>RGB ;
  84
  85 GENERIC: normalize-scan-line-order ( image -- image )
  86
  87 M: image normalize-scan-line-order ;
  88
  89 : normalize-image ( image -- image )
  90     [ >byte-array ] change-bitmap
  91     normalize-component-order
  92     normalize-scan-line-order ;