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/examples/bitmap/bitmapedit.sml
ViewVC logotype

Annotation of /sml/trunk/src/eXene/examples/bitmap/bitmapedit.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (view) (download)

1 : monnier 2 (* bitmap-edit.sml
2 :     *
3 :     * COPYRIGHT (c) 1996 AT&T Research.
4 :     *)
5 :    
6 :     signature BITMAP_EDIT =
7 :     sig
8 :     structure W : WIDGET
9 :    
10 :     exception BadParam
11 :    
12 :     type bitmapedit
13 :    
14 :     val mkBitmapEdit : W.root -> {
15 :     horzCells : int,
16 :     vertCells : int,
17 :     cellSize : int
18 :     } -> bitmapedit
19 :    
20 :     val widgetOf : bitmapedit -> W.widget
21 :     val evtOf : bitmapedit -> (bool * W.G.point) CML.event
22 :    
23 :     end
24 :    
25 :     structure BitmapEdit : BITMAP_EDIT =
26 :     struct
27 :     structure W = Widget
28 :    
29 :     open CML Geometry EXeneBase EXeneWin Interact Drawing Widget
30 :    
31 :     exception BadParam
32 :    
33 :     type pixchange = bool * point
34 :    
35 :     datatype bitmapedit = BME of {widget : widget, evt : pixchange event}
36 :     datatype cellChange = Draw of point | Undraw of point | Flip of point
37 :    
38 :     fun mseReader (m, transFn, mChan) = let
39 :     fun track msg pt = let
40 :     val p = transFn pt
41 :    
42 :     fun next () =
43 :     case msgBodyOf (sync m) of
44 :     MOUSE_Motion {pt,...} => (transFn pt, false)
45 :     | MOUSE_LastUp {pt,...} => (transFn pt, true)
46 :     | MOUSE_Down {pt,...} => (transFn pt, false)
47 :     | MOUSE_Up {pt,...} => (transFn pt, false)
48 :     | _ => next ()
49 :    
50 :     fun loop p = let
51 :     val (p',done) = next ()
52 :     in
53 :     if p <> p' then send(mChan, msg p') else ();
54 :     if done then () else loop p'
55 :     end
56 :    
57 :     in
58 :     send(mChan, msg p);
59 :     loop p
60 :     end
61 :    
62 :     fun handleMse(MOUSE_FirstDown{but,pt,...}) =
63 :     (case but of
64 :     MButton 1 => track Draw pt
65 :     | MButton 2 => track Undraw pt
66 :     | _ => track Flip pt
67 :     )
68 :     | handleMse(_) = ()
69 :    
70 :     fun loop () = loop(handleMse(msgBodyOf (sync m)))
71 :    
72 :     in
73 :     loop ()
74 :     end
75 :    
76 :     fun mkBitmapEdit root {horzCells, vertCells, cellSize} = let
77 :     val scr = screenOf root
78 :     val evtChan = channel ()
79 :     val pixWid = horzCells*cellSize + 1
80 :     val pixHt = vertCells*cellSize + 1
81 :     val pixMap = createPixmap scr (SIZE{wid=pixWid,ht=pixHt},1)
82 :     val pm = drawableOfPM pixMap
83 :     val cellMap = Array.array(horzCells*vertCells,false)
84 :     val size = {
85 :     x_dim=DIM{base=1,incr=cellSize,min=2,nat=horzCells,max=SOME horzCells},
86 :     y_dim=DIM{base=1,incr=cellSize,min=2,nat=vertCells,max=SOME vertCells}
87 :     }
88 :     val maxX = horzCells-1
89 :     val maxY = vertCells-1
90 :     val drawSz = cellSize - 3
91 :    
92 :     val onPen = newPen [PV_Foreground color1, PV_LineStyle_OnOffDash,
93 :     PV_DashOffset 0, PV_Dash_Fixed 1]
94 :     val offPen = newPen [PV_Foreground color0]
95 :     val copyPen = newPen [PV_Foreground (blackOfScr scr), PV_Background (whiteOfScr scr)]
96 :    
97 :     fun fillPixMap pm = let
98 :     val pwid = pixWid-1
99 :     val pht = pixHt-1
100 :     fun mkHzSeg i = let val y = i*cellSize in LINE(PT{x=0,y=y},PT{x=pwid,y=y}) end
101 :     fun mkVtSeg i = let val x = i*cellSize in LINE(PT{x=x,y=0},PT{x=x,y=pht}) end
102 :     fun mkSegs segFn (i,bnd,l) =
103 :     if i = bnd then (segFn i)::l
104 :     else mkSegs segFn (i+1,bnd,(segFn i)::l)
105 :     in
106 :     clearDrawable pm;
107 :     drawSegs pm onPen (mkSegs mkVtSeg (0,horzCells+1,(mkSegs mkHzSeg (0,vertCells+1,[]))))
108 :     end
109 :    
110 :     fun transFn (PT{x,y}) = PT{
111 :     x=Int.max(0,Int.min(x div cellSize, maxX)),
112 :     y=Int.max(0,Int.min(y div cellSize, maxY))
113 :     }
114 :     fun index (PT{x,y}) = x + y*horzCells
115 :     fun ptToRect (PT{x,y}) = RECT{
116 :     x=2+x*cellSize,
117 :     y=2+y*cellSize,
118 :     wid=drawSz,
119 :     ht=drawSz
120 :     }
121 :    
122 :     fun blt dw r = bitBlt dw copyPen {src=PMSRC pixMap, src_rect=r, dst_pos=originOfRect r}
123 :    
124 :     fun redraw(dw, rlist) = app (ignore o (blt dw)) rlist
125 :    
126 :     fun drawCell (dw,pt,turnOn,pen) = let
127 :     val indx = index pt
128 :     in
129 :     if turnOn = Array.sub(cellMap,indx) then NONE
130 :     else (
131 :     Array.update(cellMap,indx,turnOn);
132 :     let
133 :     val r = ptToRect pt
134 :     in
135 :     fillRect pm pen r;
136 :     redraw (dw,[r])
137 :     end;
138 :     SOME(turnOn,pt)
139 :     )
140 :     end
141 :    
142 :     fun realize {env, win, sz} = let
143 :     val InEnv{ci,m,...} = Interact.ignoreKey env
144 :     val mChan = channel ()
145 :     val dw = drawableOfWin win
146 :    
147 :     fun handleCI (CI_Resize (RECT{x,y,wid,ht})) = ()
148 :     | handleCI (CI_Redraw rlist) = (redraw (dw,rlist); ())
149 :     | handleCI CI_OwnDeath = ()
150 :     | handleCI _ = ()
151 :    
152 :     fun handleMse (Draw pt) = drawCell (dw,pt,true,onPen)
153 :     | handleMse (Undraw pt) = drawCell (dw,pt,false,offPen)
154 :     | handleMse (Flip pt) =
155 :     (case Array.sub(cellMap,index pt) of
156 :     true => drawCell (dw,pt,false,offPen)
157 :     | _ => drawCell (dw,pt,true,onPen))
158 :    
159 :     fun loop () = let
160 :     fun ifChange NONE = ()
161 :     | ifChange (SOME v) = send(evtChan, v)
162 :     in
163 :     loop(select [
164 :     wrap (ci, fn evt => (handleCI (msgBodyOf evt))),
165 :     wrap (CML.recvEvt mChan, fn evt => ifChange(handleMse evt))
166 :     ])
167 :     end
168 :     in
169 :     spawn (fn () => mseReader(m,transFn,mChan));
170 :     spawn loop;
171 :     ()
172 :     end
173 :     in
174 :     fillPixMap pm;
175 :     BME {
176 :     widget = mkWidget{
177 :     root=root,
178 :     boundsOf = fn () =>size,
179 :     realize=realize
180 :     },
181 :     evt = CML.recvEvt evtChan
182 :     }
183 :     end
184 :    
185 :     fun widgetOf (BME{widget,...}) = widget
186 :     fun evtOf (BME{evt,...}) = evt
187 :     end

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