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     RGBA >>component-order ;
  47
  48 M: RGBA normalize-component-order* drop ;
  49
  50 M: R32G32B32A32 normalize-component-order*
  51     drop normalize-floats ;
  52
  53 M: R32G32B32 normalize-component-order*
  54     drop normalize-floats add-dummy-alpha ;
  55
  56 : RGB16>8 ( bitmap -- bitmap' )
  57     byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
  58
  59 M: R16G16B16A16 normalize-component-order*
  60     drop RGB16>8 ;
  61
  62 M: R16G16B16 normalize-component-order*
  63     drop RGB16>8 add-dummy-alpha ;
  64
  65 : BGR>RGB ( bitmap bytes-per-pixel -- pixels )
  66     <groups> [ 3 cut [ reverse ] dip append ] map B{ } join ; inline
  67
  68 M: BGRA normalize-component-order*
  69     drop 4 BGR>RGB ;
  70
  71 M: RGB normalize-component-order*
  72     drop add-dummy-alpha ;
  73
  74 M: BGR normalize-component-order*
  75     drop 3 BGR>RGB add-dummy-alpha ;
  76
  77 : ARGB>RGBA ( bitmap -- bitmap' )
  78     4 <groups> [ unclip suffix ] map B{ } join ;
  79
  80 M: ARGB normalize-component-order*
  81     drop ARGB>RGBA ;
  82
  83 M: ABGR normalize-component-order*
  84     drop ARGB>RGBA 4 BGR>RGB ;
  85
  86 GENERIC: normalize-scan-line-order ( image -- image )
  87
  88 M: image normalize-scan-line-order ;
  89
  90 : normalize-image ( image -- image )
  91     [ >byte-array ] change-bitmap
  92     normalize-component-order
  93     normalize-scan-line-order ;