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/pixmap.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (view) (download)

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

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