Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/eXene/widgets/composite/box-layout.sml
ViewVC logotype

Annotation of /sml/trunk/src/eXene/widgets/composite/box-layout.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (view) (download)

1 : monnier 2 (* box-layout.sml
2 :     *
3 :     * COPYRIGHT (c) 1991, 1992 by AT&T Bell Laboratories
4 :     *
5 :     * Code for laying out box widgets.
6 :     *)
7 :    
8 :     signature BOX_LAYOUT =
9 :     sig
10 :    
11 :     structure G : GEOMETRY
12 :     structure W : WIDGET
13 :    
14 :     datatype box_item =
15 :     G of { x_dim : W.dim, y_dim : W.dim } (* should be G of W.bounds *)
16 :     | W of W.widget
17 :     | HB of (W.valign * box_item list)
18 :     | VB of (W.valign * box_item list)
19 :    
20 :     val compLayout : (G.rect * box_item) -> (bool * (W.widget * G.rect) list)
21 :    
22 :     val compSize : box_item -> W.bounds
23 :    
24 :     end (* BOX_LAYOUT *)
25 :    
26 :     structure BoxLayout : BOX_LAYOUT = struct
27 :    
28 :     structure G = Geometry
29 :     structure W = Widget
30 :    
31 :     open Geometry Widget
32 :    
33 :     val min = Int.min
34 :     val max = Int.max
35 :    
36 :     datatype box_item =
37 :     G of bounds
38 :     | W of widget
39 :     | HB of (valign * box_item list)
40 :     | VB of (valign * box_item list)
41 :    
42 :     datatype bnds_tree =
43 :     BT_G of bounds
44 :     | BT_W of (bounds * widget)
45 :     | BT_HB of (bounds * valign * bnds_tree list)
46 :     | BT_VB of (bounds * valign * bnds_tree list)
47 :    
48 :     val MAXX = 65535 (* Maximum dimension of an X window. *)
49 :    
50 :     fun flipBnds ({x_dim,y_dim} : bounds) = {x_dim=y_dim,y_dim=x_dim}
51 :    
52 :     fun bndsOf (BT_G b) = b
53 :     | bndsOf (BT_W (b,_)) = b
54 :     | bndsOf (BT_HB (b,_,_)) = b
55 :     | bndsOf (BT_VB (b,_,_)) = b
56 :    
57 :     fun flipBT (BT_G b) = BT_G (flipBnds b)
58 :     | flipBT (BT_W (b,tw)) = BT_W (flipBnds b,tw)
59 :     | flipBT (BT_HB (b,a,l)) = BT_HB (flipBnds b,a,l)
60 :     | flipBT (BT_VB (b,a,l)) = BT_VB (flipBnds b,a,l)
61 :    
62 :     fun getBnds (DIM{base,incr,min,nat,max=NONE}) =
63 :     (base+incr*nat,base+incr*min,NONE,incr)
64 :     | getBnds (DIM{base,incr,min,nat,max=SOME max}) =
65 :     (base+incr*nat,base+incr*min,SOME(base+incr*max),incr)
66 :     fun xBnds ({x_dim,...} : bounds) = getBnds x_dim
67 :     fun yBnds ({y_dim,...} : bounds) = getBnds y_dim
68 :    
69 :     fun comp_size cl = let
70 :     fun doX (NONE, _) = NONE
71 :     | doX (_, NONE) = NONE
72 :     | doX (SOME cx, SOME sx) = SOME(cx + sx)
73 :     fun doY (cy, NONE) = cy
74 :     | doY (NONE, SOME sy) = SOME sy
75 :     | doY (SOME cy, SOME sy) = SOME(max(cy,sy))
76 :     fun tight (_, NONE) = false
77 :     | tight (mn, SOME mx) = (mn = mx)
78 :     fun maxDim (DIM{base,incr,max=NONE,...}) = NONE
79 :     | maxDim (DIM{base,incr,max=SOME max,...}) = SOME(base + incr*max)
80 :    
81 :     fun accBnds ({x_dim,y_dim}, (nx,ny,mnx,mny,mxx,mxy,ix,iy)) = let
82 :     val DIM{base=basex,incr=incx,min=minx,nat=natx,max=maxx} = x_dim
83 :     val DIM{base=basey,incr=incy,min=miny,nat=naty,max=maxy} = y_dim
84 :     in
85 :     (
86 :     nx + basex + incx*natx,
87 :     max(ny, basey + incy*naty),
88 :     mnx + basex + incx*minx,
89 :     max(mny, basey + incy*miny),
90 :     doX (mxx, maxDim x_dim),
91 :     doY (mxy, maxDim y_dim),
92 :     if tight (minx,maxx) then ix else min(ix, incx),
93 :     if tight (miny,maxy) orelse incy = 1 then iy
94 :     else min(iy, incy)
95 :     )
96 :     end
97 :    
98 :     val (natx,naty,minx,miny,maxx,maxy,incx,incy) =
99 :     List.foldl accBnds (0,0,0,0,SOME 0,NONE,MAXX,MAXX) cl
100 :    
101 :     (* Guarantee increment > 0 *)
102 :     fun adjustIncr i = if i = MAXX orelse i <= 0 then 1 else i
103 :     val incx = adjustIncr incx
104 :     val incy = adjustIncr incy
105 :    
106 :     (* Guarantee maxy >= naty *)
107 :     val maxy = case maxy of NONE => NONE | SOME my => SOME(max(my,naty))
108 :    
109 :     (* Return least f such that min + f*inc >= v *)
110 :     fun factor (min,1) v = v - min
111 :     | factor (min,inc) v = ((v - min + inc - 1) div inc)
112 :     val xfact = factor (minx,incx)
113 :     val yfact = factor (miny,incy)
114 :     in
115 :     {
116 :     x_dim = DIM{
117 :     base=minx,
118 :     incr=incx,
119 :     min=0,
120 :     nat=xfact natx,
121 :     max=case maxx of NONE => NONE | SOME v => SOME(xfact v)
122 :     },
123 :     y_dim = DIM{
124 :     base=miny,
125 :     incr=incy,
126 :     min=0,
127 :     nat=yfact naty,
128 :     max=case maxy of NONE => NONE | SOME v => SOME(yfact v)
129 :     }
130 :     }
131 :     end
132 :    
133 :     fun compSize (G bnds) = bnds
134 :     | compSize (W widget) = boundsOf widget
135 :     | compSize (HB(_,boxes)) = comp_size (map compSize boxes)
136 :     | compSize (VB(_,boxes)) =
137 :     flipBnds (comp_size (map (flipBnds o compSize) boxes))
138 :    
139 :     fun flr (v : int, base, inc) =
140 :     (if v = base then v else base + ((v - base) div inc)*inc)
141 :     handle Div => raise BadIncrement
142 :     fun ceil (v : int, base, inc) =
143 :     (if v = base then v else base + ((v - base + inc - 1) div inc)*inc)
144 :     handle Div => raise BadIncrement
145 :    
146 :     fun setMinors (yo, ys, bndl, align) = let
147 :     fun setM bnd = let
148 :     val sz = (case yBnds (bndsOf bnd) of
149 :     (nat, mn, NONE, 1) => max (ys, mn)
150 :     | (nat, mn, SOME mx, 1) => min (mx, max(ys,mn))
151 :     | (nat, mn, NONE, incy) => max (flr(ys,nat,incy), ceil(mn,nat,incy))
152 :     | (nat, mn, SOME mx, incy) =>
153 :     min (flr(mx,nat,incy), max (flr(ys,nat,incy), ceil(mn,nat,incy)))
154 :     )
155 :     in
156 :     case align of
157 :     VCenter => (yo + ((ys - sz) div 2), sz)
158 :     | VTop => (yo, sz)
159 :     | VBottom => (yo + ys - sz, sz)
160 :     end
161 :     in
162 :     map setM bndl
163 :     end
164 :    
165 :     fun setMajors (xo, xs, bndl) = let
166 :     fun mkQuad (BT_G b) =
167 :     (case xBnds b of
168 :     (nat, mn, NONE, inc) => (nat, nat-mn, MAXX-nat, inc)
169 :     | (nat, mn, SOME mx, inc) => (nat, nat-mn, mx-nat, inc)
170 :     )
171 :     | mkQuad bnd =
172 :     (case xBnds (bndsOf bnd) of
173 :     (nat, mn, NONE, inc) => (nat, nat-max(1,mn), MAXX-nat, inc)
174 :     | (nat, mn, SOME mx, inc) => (nat, nat-max(1,mn), mx-nat, inc)
175 :     )
176 :    
177 :     val szList = map mkQuad bndl
178 :    
179 :     fun addCnt ((s:int,0,0,_),(cs,sh_cnt,st_cnt)) = (cs+s,sh_cnt,st_cnt)
180 :     | addCnt ((s,0,_,_),(cs,sh_cnt,st_cnt)) = (cs+s,sh_cnt,st_cnt+1)
181 :     | addCnt ((s,_,0,_),(cs,sh_cnt,st_cnt)) = (cs+s,sh_cnt+1,st_cnt)
182 :     | addCnt ((s,_,_,_),(cs,sh_cnt,st_cnt)) = (cs+s,sh_cnt+1,st_cnt+1)
183 :     val (sz, shr_cnt, str_cnt) = List.foldl addCnt (0,0,0) szList
184 :    
185 :     fun addWd (l, amt, cnt) = let
186 :     fun dst ([], amt, _, cnt, l) = (rev l, amt, cnt)
187 :     | dst ((v as (s,_,0,_))::tl, amt, per, cnt, l) = dst(tl, amt, per, cnt, v::l)
188 :     | dst ((s,sh,st,inc)::tl, amt, per, cnt, l) = let
189 :     val delta =
190 :     if inc = 1 then min(amt,min(per,st))
191 :     else inc*(min(amt,min(per,st)) div inc)
192 :     in
193 :     if delta = amt then ((rev l)@((s+delta,sh,st-delta,inc)::tl), 0, 0)
194 :     else if delta = st orelse delta = 0 then
195 :     dst (tl, amt-delta, per, cnt, (s+delta,sh,0,inc)::l)
196 :     else dst (tl, amt-delta, per, cnt+1, (s+delta,sh,st-delta,inc)::l)
197 :     end
198 :     in
199 :     if amt <= 0 orelse cnt = 0 then l
200 :     else addWd (dst (l, amt, max(1,amt div cnt), 0, []))
201 :     end
202 :    
203 :     fun subWd (l, amt, cnt) = let
204 :     fun dst ([], amt, _, cnt, l) = (rev l, amt, cnt)
205 :     | dst ((v as (s,0,_,_))::tl, amt, per, cnt, l) = dst(tl, amt, per, cnt, v::l)
206 :     | dst ((s,sh,st,inc)::tl, amt, per, cnt, l) = let
207 :     val delta =
208 :     if inc = 1 then min(amt,min(per,sh))
209 :     else inc*(min(amt,min(per,sh)) div inc)
210 :     in
211 :     if delta = amt then ((rev l)@((s-delta,sh-delta,st,inc)::tl), 0, 0)
212 :     else if delta = sh orelse delta = 0 then
213 :     dst (tl, amt-delta, per, cnt, (s-delta,0,st,inc)::l)
214 :     else dst (tl, amt-delta, per, cnt+1, (s-delta,sh-delta,st,inc)::l)
215 :     end
216 :     in
217 :     if amt <= 0 orelse cnt = 0 then l
218 :     else subWd (dst (l, amt, max(1,amt div cnt), 0, []))
219 :     end
220 :    
221 :     fun distrib () =
222 :     if sz = xs then szList
223 :     else if sz < xs then addWd (szList, xs-sz, str_cnt)
224 :     else subWd (szList, sz-xs, shr_cnt)
225 :    
226 :     fun addOr (curo, ((wd : int,_,_,_)::tl)) = (curo,wd)::(addOr (curo+wd,tl))
227 :     | addOr (curo, []) = []
228 :    
229 :     in
230 :     addOr(xo, distrib ())
231 :     end
232 :    
233 :     fun bndsTree (G bnds) = BT_G bnds
234 :     | bndsTree (W tw) = BT_W(boundsOf tw,tw)
235 :     | bndsTree (HB(a,boxes)) = let
236 :     val tree = map bndsTree boxes
237 :     in
238 :     BT_HB(comp_size (map bndsOf tree),a,tree)
239 :     end
240 :     | bndsTree (VB(a,boxes)) = let
241 :     val tree = map (flipBT o bndsTree) boxes
242 :     in
243 :     BT_VB(flipBnds (comp_size (map bndsOf tree)),a,tree)
244 :     end
245 :    
246 :     (* Given a rectangle and the bounds tree for the layout,
247 :     * compute the layout, which consists of a
248 :     * list of widgets and their new rectangles.
249 :     *)
250 :     local
251 :     fun merge ([],[],[]) = []
252 :     | merge ((x,w)::xs,(y,h)::ys,b::bs) =
253 :     (RECT{x=x,y=y,wid=w,ht=h},b)::(merge(xs,ys,bs))
254 :     | merge _ = raise LibBase.Impossible "BoxLayout.HB"
255 :    
256 :     in
257 :     fun comp_layout (_, BT_G _) = []
258 :     | comp_layout (r, BT_W (_,w)) = [(w,r)]
259 :     | comp_layout (RECT{x,y,wid,ht}, BT_HB(_,a,bl)) = let
260 :     val l = merge(setMajors(x,wid,bl),setMinors(y,ht,bl,a),bl)
261 :     in
262 :     List.foldl (fn(bx,bl) => (comp_layout bx)@bl) [] l
263 :     end
264 :     | comp_layout (r as RECT{x,y,wid,ht}, BT_VB(_,a,bl)) = let
265 :     val l = merge(setMinors(x,wid,bl,a),setMajors(y,ht,bl),bl)
266 :     in
267 :     List.foldl (fn(bx,bl) => (comp_layout bx)@bl) [] l
268 :     end
269 :     end (* local *)
270 :    
271 :     fun compLayout (rect, boxes) = let
272 :     val bndsT = bndsTree boxes
273 :     val fits = compatibleSize(bndsOf bndsT,sizeOfRect rect)
274 :     val l = case bndsT of
275 :     BT_G _ => []
276 :     | (v as BT_W (bnds,w)) =>
277 :     comp_layout(rect,BT_HB(bnds,VCenter,[v]))
278 :     | bt => comp_layout(rect,bt)
279 :     in
280 :     (fits,l)
281 :     end
282 :    
283 :     end (* BoxLayout *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0