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