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
   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 <sliced-groups>
  38     [ 255 suffix ] map concat ;
  39
  40 : normalize-floats ( byte-array -- byte-array )
  41     byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
  42
  43 : normalize-component-order ( image -- image )
  44     dup component-order>>
  45     {
  46         { RGBA [ ] }
  47         { R32G32B32A32 [
  48             [ normalize-floats ] change-bitmap
  49         ] }
  50         { R32G32B32 [
  51             [ normalize-floats add-dummy-alpha ] change-bitmap
  52         ] }
  53         { R16G16B16A16 [
  54             [ byte-array>ushort-array [ -8 shift ] B{ } map-as ] change-bitmap
  55         ] }
  56         { R16G16B16 [
  57             [
  58                 byte-array>ushort-array [ -8 shift ] B{ } map-as add-dummy-alpha
  59             ] change-bitmap
  60         ] }
  61         { BGRA [
  62             [
  63                 4 <sliced-groups> dup [ 3 head-slice reverse-here ] each
  64             ] change-bitmap
  65         ] }
  66         { RGB [ [ add-dummy-alpha ] change-bitmap ] }
  67         { BGR [
  68             [
  69                 3 <sliced-groups>
  70                 [ [ 3 head-slice reverse-here ] each ]
  71                 [ [ 255 suffix ] map ] bi concat
  72             ] change-bitmap
  73         ] }
  74     } case
  75     RGBA >>component-order ;
  76
  77 GENERIC: normalize-scan-line-order ( image -- image )
  78
  79 M: image normalize-scan-line-order ;
  80
  81 : normalize-image ( image -- image )
  82     [ >byte-array ] change-bitmap
  83     normalize-component-order
  84     normalize-scan-line-order ;