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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2 - (view) (download)

1 : monnier 2 (* bitmap.sml
2 :     *
3 :     * COPYRIGHT (c) 1996 AT&T Research.
4 :     *)
5 :    
6 :     signature BITMAP =
7 :     sig
8 :     structure W : WIDGET
9 :     structure CML : CONCUR_ML
10 :    
11 :     exception BadParam
12 :    
13 :     type bitmap
14 :    
15 :     val mkBitmap : W.root -> {
16 :     backgrnd : W.EXB.color option,
17 :     foregrnd : W.EXB.color option,
18 :     horzCells : int,
19 :     vertCells : int
20 :     } -> bitmap
21 :    
22 :     val widgetOf : bitmap -> W.widget
23 :     val setPixel : bitmap -> (bool * W.G.point) -> unit
24 :     val imageOf : bitmap -> W.EXB.image
25 :    
26 :     end
27 :    
28 :     structure Bitmap : BITMAP =
29 :     struct
30 :     structure W = Widget
31 :     structure CML = CML
32 :     structure EXB = EXeneBase
33 :    
34 :     open CML Geometry EXeneBase EXeneWin Interact Drawing Widget
35 :    
36 :     exception BadParam
37 :    
38 :     type pixchange = bool * point
39 :    
40 :     datatype rqst =
41 :     DoRealize of {
42 :     env : in_env,
43 :     win : window,
44 :     sz : size
45 :     }
46 :     | Set of pixchange
47 :     | ImageOf of image chan
48 :    
49 :     datatype bitmap = BM of {widget : widget, setChan : rqst chan}
50 :    
51 :     fun setColor scr (SOME c, _) = c
52 :     | setColor scr (NONE, dflt) = dflt
53 :    
54 :     fun mkBitmap root {horzCells, vertCells, foregrnd, backgrnd} = let
55 :     val scr = screenOf root
56 :     val setChan = channel ()
57 :     val psize = SIZE{wid=horzCells,ht=vertCells}
58 :     val pixMap = createPixmap scr (psize,1)
59 :     val pm = drawableOfPM pixMap
60 :     val prect = mkRect(originPt,psize)
61 :     val _ = clearDrawable pm
62 :     val size = fixBounds (horzCells, vertCells)
63 :     val maxX = horzCells-1
64 :     val maxY = vertCells-1
65 :     val forec = setColor scr (foregrnd, blackOfScr scr)
66 :     val backc = setColor scr (backgrnd, whiteOfScr scr)
67 :    
68 :     val onPen = newPen [PV_Foreground color1]
69 :     val offPen = newPen [PV_Foreground color0]
70 :     val copyPen = newPen [PV_Foreground forec, PV_Background backc]
71 :    
72 :     fun set (true, pt) = drawPt pm onPen pt
73 :     | set (false, pt) = drawPt pm offPen pt
74 :    
75 :     fun blt dw r = bitBlt dw copyPen {src=PMSRC pixMap, src_rect=r, dst_pos=originOfRect r}
76 :    
77 :     fun redraw(dw,rlist) = app (blt dw) rlist
78 :    
79 :     fun sendImage rchan = send(rchan, createImageFromPixmap pixMap)
80 :    
81 :     fun realize {env, win, sz} = let
82 :     val InEnv{ci,...} = ignoreInput env
83 :     val mChan = channel ()
84 :     val dw = drawableOfWin win
85 :    
86 :     fun handleCI (CI_Resize (RECT{x,y,wid,ht})) = ()
87 :     | handleCI (CI_Redraw rlist) = (redraw (dw,rlist); ())
88 :     | handleCI CI_OwnDeath = ()
89 :     | handleCI _ = ()
90 :    
91 :     fun handleSet (DoRealize _) = ()
92 :     | handleSet (ImageOf arg) = (sendImage arg; ())
93 :     | handleSet (Set arg) = (set arg; redraw(dw,[prect]); ())
94 :    
95 :     fun loop () =
96 :     loop(select [
97 :     wrap (ci, fn evt => (handleCI (msgBodyOf evt))),
98 :     wrap (receive setChan, fn evt => (handleSet evt))
99 :     ])
100 :     in
101 :     loop ()
102 :     end
103 :    
104 :     fun initLoop () =
105 :     case (accept setChan) of
106 :     DoRealize arg => realize arg
107 :     | Set arg => (set arg; initLoop ())
108 :     | ImageOf arg => (sendImage arg; initLoop ())
109 :     in
110 :     spawn initLoop;
111 :     BM {
112 :     widget = mkWidget{
113 :     root=root,
114 :     boundsOf = fn () => size,
115 :     realize= fn arg => send(setChan, DoRealize arg)
116 :     },
117 :     setChan = setChan
118 :     }
119 :     end
120 :    
121 :     fun widgetOf (BM{widget,...}) = widget
122 :     fun setPixel (BM{setChan,...}) arg = send(setChan,Set arg)
123 :     fun imageOf (BM{setChan,...}) = let
124 :     val retChan = channel ()
125 :     in
126 :     send(setChan,ImageOf retChan);
127 :     accept retChan
128 :     end
129 :     end

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