1 ! (c)2010 Joe Groff bsd license
2 USING: accessors arrays assocs byte-arrays fry images kernel
3 locals math math.functions math.order math.vectors namespaces
7 ! sort rects by height/width/whatever
8 ! use least power of two greater than k * greatest width for atlas width
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
15 TUPLE: image-placement
19 CONSTANT: atlas-waste-factor 1.25
20 CONSTANT: atlas-padding 1
22 ERROR: atlas-image-formats-dont-match images ;
26 : width ( dim -- width ) first atlas-padding + ; inline
27 : height ( dim -- height ) second atlas-padding + ; inline
28 : area ( dim -- area ) [ width ] [ height ] bi * ; inline
30 :: (pack-stripe) ( image-placements atlas-width @y -- stripe-height/f )
33 image-placements [| ip |
35 ip image>> dim>> :> dim
36 stripe-height [ dim height stripe-height 0 or max stripe-height! ] unless
38 atlas-width w @x + >= [
39 ip { @x @y } >>loc drop
46 :: (pack-images) ( images atlas-width sort-quot -- placements )
47 images sort-quot inv-sort-with [ f image-placement boa ] map :> image-placements
49 [ image-placements atlas-width @y (pack-stripe) dup ] [ @y + @y! ] while drop
50 image-placements ; inline
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
58 [ first [ component-order>> ] [ component-type>> ] [ upside-down?>> ] tri ]
59 [ throw-atlas-image-formats-dont-match ] if ; inline
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
65 :: <atlas-image> ( image-placements component-order component-type upside-down? -- atlas )
66 image-placements atlas-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
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 )
80 0 row w image pixel-row-slice-at
81 x y row + w atlas set-pixel-row-at
84 : copy-images-into-atlas ( image-placements atlas -- )
85 '[ _ copy-image-into-atlas ] each ; inline
89 : (guess-atlas-dim) ( images -- width )
90 [ dim>> area ] [ + ] map-reduce sqrt
94 : guess-atlas-dim ( images -- width )
95 [ (guess-atlas-dim) ] [ [ dim>> width ] [ max ] map-reduce ] bi max next-power-of-2 ;
97 : pack-images ( images atlas-width -- placements )
98 [ dim>> second ] (pack-images) ;
100 : pack-atlas ( images -- image-placements )
101 dup guess-atlas-dim pack-images ;
103 : (make-atlas) ( image-placements -- image )
104 dup dup atlas-image-format <atlas-image> [ copy-images-into-atlas ] keep ;
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 )
114 x w + aw /f :> right-u
115 y h + ah /f :> bottom-v
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
121 : make-atlas ( images -- image-texcoords atlas-image )
122 pack-atlas dup (make-atlas) [ '[ _ image-placement>texcoords ] H{ } map>assoc ] keep ;
124 : make-atlas-assoc ( image-assoc -- texcoord-assoc atlas-image )
125 dup values make-atlas [ '[ _ at ] assoc-map ] dip ;