basis/images/images.factor

   1 ! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: combinators kernel accessors sequences math arrays ;
   4 IN: images
   5
   6 SINGLETONS: L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
   7 R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
   8
   9 UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
  10
  11 : bytes-per-pixel ( component-order -- n )
  12     {
  13         { L [ 1 ] }
  14         { LA [ 2 ] }
  15         { BGR [ 3 ] }
  16         { RGB [ 3 ] }
  17         { BGRA [ 4 ] }
  18         { RGBA [ 4 ] }
  19         { ABGR [ 4 ] }
  20         { ARGB [ 4 ] }
  21         { RGBX [ 4 ] }
  22         { XRGB [ 4 ] }
  23         { BGRX [ 4 ] }
  24         { XBGR [ 4 ] }
  25         { R16G16B16 [ 6 ] }
  26         { R32G32B32 [ 12 ] }
  27         { R16G16B16A16 [ 8 ] }
  28         { R32G32B32A32 [ 16 ] }
  29     } case ;
  30
  31 TUPLE: image dim component-order upside-down? bitmap ;
  32
  33 : <image> ( -- image ) image new ; inline
  34
  35 : has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
  36
  37 GENERIC: load-image* ( path class -- image )
  38
  39 <PRIVATE
  40
  41 : pixel@ ( x y image -- start end bitmap )
  42     [ dim>> first * + ]
  43     [ component-order>> bytes-per-pixel [ * dup ] keep + ]
  44     [ bitmap>> ] tri ;
  45
  46 : set-subseq ( new-value from to victim -- )
  47     <slice> 0 swap copy ; inline
  48
  49 PRIVATE>
  50
  51 : pixel-at ( x y image -- pixel )
  52     pixel@ subseq ;
  53
  54 : set-pixel-at ( pixel x y image -- )
  55     pixel@ set-subseq ;