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 ;
   6 IN: images
   7
   8 SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
   9 R16G16B16 R32G32B32 ;
  10
  11 TUPLE: image dim component-order bitmap ;
  12
  13 : <image> ( -- image ) image new ; inline
  14
  15 GENERIC: load-image* ( path tuple -- image )
  16
  17 : add-dummy-alpha ( seq -- seq' )
  18     3 <sliced-groups>
  19     [ 255 suffix ] map concat ;
  20
  21 : normalize-component-order ( image -- image )
  22     dup component-order>>
  23     {
  24         { RGBA [ ] }
  25         { R32G32B32 [
  26             [
  27                 dup length 4 / <direct-uint-array>
  28                 [ bits>float 255.0 * >integer ] map
  29                 >byte-array add-dummy-alpha
  30             ] change-bitmap
  31         ] }
  32         { R16G16B16 [
  33             [
  34                 dup length 2 / <direct-ushort-array>
  35                 [ -8 shift ] map
  36                 >byte-array add-dummy-alpha
  37             ] change-bitmap
  38         ] }
  39         { BGRA [
  40             [
  41                 4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
  42             ] change-bitmap
  43         ] }
  44         { RGB [ [ add-dummy-alpha ] change-bitmap ] }
  45         { BGR [
  46             [
  47                 3 <sliced-groups>
  48                 [ [ [ 0 3 ] dip <slice> reverse-here ] each ]
  49                 [ add-dummy-alpha ] bi
  50             ] change-bitmap
  51         ] }
  52     } case
  53     RGBA >>component-order ;
  54
  55 GENERIC: normalize-scan-line-order ( image -- image )
  56
  57 M: image normalize-scan-line-order ;
  58
  59 : normalize-image ( image -- image )
  60     [ >byte-array ] change-bitmap
  61     normalize-component-order
  62     normalize-scan-line-order ;