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 TUPLE: image dim component-order bitmap ;
  13
  14 : <image> ( -- image ) image new ; inline
  15
  16 GENERIC: load-image* ( path tuple -- image )
  17
  18 : add-dummy-alpha ( seq -- seq' )
  19     3 <sliced-groups>
  20     [ 255 suffix ] map concat ;
  21
  22 : normalize-floats ( byte-array -- byte-array )
  23     byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
  24
  25 : normalize-component-order ( image -- image )
  26     dup component-order>>
  27     {
  28         { RGBA [ ] }
  29         { R32G32B32A32 [
  30             [ normalize-floats ] change-bitmap
  31         ] }
  32         { R32G32B32 [
  33             [ normalize-floats add-dummy-alpha ] change-bitmap
  34         ] }
  35         { R16G16B16A16 [
  36             [ byte-array>ushort-array [ -8 shift ] B{ } map-as ] change-bitmap
  37         ] }
  38         { R16G16B16 [
  39             [
  40                 byte-array>ushort-array [ -8 shift ] B{ } map-as add-dummy-alpha
  41             ] change-bitmap
  42         ] }
  43         { BGRA [
  44             [
  45                 4 <sliced-groups> dup [ 3 head-slice reverse-here ] each
  46             ] change-bitmap
  47         ] }
  48         { RGB [ [ add-dummy-alpha ] change-bitmap ] }
  49         { BGR [
  50             [
  51                 3 <sliced-groups>
  52                 [ [ 3 head-slice reverse-here ] each ]
  53                 [ add-dummy-alpha ] bi
  54             ] change-bitmap
  55         ] }
  56     } case
  57     RGBA >>component-order ;
  58
  59 GENERIC: normalize-scan-line-order ( image -- image )
  60
  61 M: image normalize-scan-line-order ;
  62
  63 : normalize-image ( image -- image )
  64     [ >byte-array ] change-bitmap
  65     normalize-component-order
  66     normalize-scan-line-order ;