extra/images/atlas/atlas.factor

   1 ! Copyright (C) 2010 Joe Groff.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs byte-arrays images kernel math
   4 math.functions math.order math.vectors sequences sorting ;
   5 IN: images.atlas
   6
   7 ! sort rects by height/width/whatever
   8 ! use least power of two greater than k * greatest width for atlas width
   9 ! pack stripes(y 0):
  10 !   place first rect at x 0
  11 !   place rects that fit in remaining stripe
  12 !   pack stripes(y + height)
  13 ! if height > max height
  14
  15 TUPLE: image-placement
  16     { image read-only }
  17     loc ;
  18
  19 CONSTANT: atlas-waste-factor 1.25
  20 CONSTANT: atlas-padding 1
  21
  22 ERROR: atlas-image-formats-dont-match images ;
  23
  24 <PRIVATE
  25
  26 : width  ( dim -- width  ) first  atlas-padding + ; inline
  27 : height ( dim -- height ) second atlas-padding + ; inline
  28 : area   ( dim -- area   ) [ width ] [ height ] bi * ; inline
  29
  30 :: (pack-stripe) ( image-placements atlas-width @y -- stripe-height/f )
  31     0 :> @x!
  32     f :> stripe-height!
  33     image-placements [| ip |
  34         ip loc>> [
  35             ip image>> dim>> :> dim
  36             stripe-height [ dim height stripe-height 0 or max stripe-height! ] unless
  37             dim width :> w
  38             atlas-width w @x + >= [
  39                 ip { @x @y } >>loc drop
  40                 @x w + @x!
  41             ] when
  42         ] unless
  43     ] each
  44     stripe-height ;
  45
  46 :: (pack-images) ( images atlas-width sort-quot -- placements )
  47     images sort-quot inv-sort-with [ f image-placement boa ] map :> image-placements
  48     0 :> @y!
  49     [ image-placements atlas-width @y (pack-stripe) ] [ @y + @y! ] while*
  50     image-placements ; inline
  51
  52 : atlas-image-format ( image-placements -- component-order component-type upside-down? )
  53     [ image>> ] map dup unclip '[ _
  54         [ [ component-order>> ] same? ]
  55         [ [ component-type>>  ] same? ]
  56         [ [ upside-down?>>    ] same? ] 2tri and and
  57     ] all?
  58     [ first [ component-order>> ] [ component-type>> ] [ upside-down?>> ] tri ]
  59     [ atlas-image-formats-dont-match ] if ; inline
  60
  61 : atlas-dim ( image-placements -- dim )
  62     [ [ loc>> ] [ image>> dim>> ] bi v+ atlas-padding v+n ] [ vmax ] map-reduce
  63     [ next-power-of-2 ] map ; inline
  64
  65 :: <atlas-image> ( image-placements component-order component-type upside-down? -- atlas )
  66     image-placements atlas-dim :> dim
  67     <image>
  68         dim >>dim
  69         component-order >>component-order
  70         component-type >>component-type
  71         upside-down? >>upside-down?
  72         dim product component-order component-type (bytes-per-pixel) * <byte-array> >>bitmap ; inline
  73
  74 :: copy-image-into-atlas ( image-placement atlas -- )
  75     image-placement image>> :> image
  76     image dim>> first2 :> ( w h )
  77     image-placement loc>> first2 :> ( x y )
  78
  79     h <iota> [| row |
  80         0  row      w  image pixel-row-slice-at
  81         x  y row +  w  atlas set-pixel-row-at
  82     ] each ; inline
  83
  84 : copy-images-into-atlas ( image-placements atlas -- )
  85     '[ _ copy-image-into-atlas ] each ; inline
  86
  87 PRIVATE>
  88
  89 : (guess-atlas-dim) ( images -- width )
  90     [ dim>> area ] [ + ] map-reduce sqrt
  91     atlas-waste-factor *
  92     .5 + >integer ;
  93
  94 : guess-atlas-dim ( images -- width )
  95     [ (guess-atlas-dim) ] [ [ dim>> width ] [ max ] map-reduce ] bi max next-power-of-2 ;
  96
  97 : pack-images ( images atlas-width -- placements )
  98     [ dim>> second ] (pack-images) ;
  99
 100 : pack-atlas ( images -- image-placements )
 101     dup guess-atlas-dim pack-images ;
 102
 103 : (make-atlas) ( image-placements -- image )
 104     dup dup atlas-image-format <atlas-image> [ copy-images-into-atlas ] keep ;
 105
 106 :: image-placement>texcoords ( image-placement atlas-image -- image texcoords )
 107     atlas-image dim>> first2 :> ( aw ah )
 108     image-placement image>> :> image
 109     image-placement loc>> first2 :> ( x y )
 110     image dim>> first2 :> ( w h )
 111
 112     x     aw /f :> left-u
 113     y     ah /f :> top-v
 114     x w + aw /f :> right-u
 115     y h + ah /f :> bottom-v
 116
 117     image dup upside-down?>>
 118     [ left-u top-v    right-u bottom-v ]
 119     [ left-u bottom-v right-u top-v    ] if 4array ; inline
 120
 121 : make-atlas ( images -- image-texcoords atlas-image )
 122     pack-atlas dup (make-atlas) [ '[ _ image-placement>texcoords ] H{ } map>assoc ] keep ;
 123
 124 : make-atlas-assoc ( image-assoc -- texcoord-assoc atlas-image )
 125     dup values make-atlas [ '[ _ at ] assoc-map ] dip ;