colorpickcontrol.icl 9.23 KB
Newer Older
Diederik van Arkel's avatar
Diederik van Arkel committed
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
implementation module colorpickcontrol

import StdControl, StdControlReceiver, StdReceiver
import ioutil

::	NoState
	= NoState

/*	The definition of the text-slider component:	*/

::	RGBPickControl ls ps
	:==	:+: SliderControl TextControl ls ps

RGBPickControl
	:: RGBColour (String,Id,Id) (RGBColour->Int) (Int->RGBColour->RGBColour) (Maybe ItemPos)
	-> RGBPickControl (RGBColour,Id) (PSt .l)
RGBPickControl rgb (text,sid,tid) get set maybePos
	=	SliderControl Horizontal (PixelWidth length) sliderstate slideraction
		[ ControlId sid
		: controlPos
		]
	:+: TextControl   (ColourText text  (get rgb))
		[ ControlWidth (ContentWidth "Green 1000")
		, ControlId tid
		]
where
	controlPos	= case maybePos of
					Just pos	-> [ControlPos pos]
					_			-> []
	length		= MaxRGB-MinRGB+1
	sliderstate	= {sliderMin=MinRGB, sliderMax=MaxRGB, sliderThumb=get rgb}//, sliderSize = 0}
	
	slideraction :: SliderMove ((RGBColour,Id),PSt .l) -> ((RGBColour,Id),PSt .l)
	slideraction move ((rgb,did),pst)
		= ((	newrgb
		  , did
		  ),	appListPIO [ setSliderThumbs [(sid,y)]
		  			   , setControlTexts [(tid,ColourText text y)]
		  			   , SetColourBox did newrgb
		  			   ] pst
		  )
	where
		y		= case move of
					SliderIncSmall	-> min (get rgb+1 ) MaxRGB

					SliderDecSmall	-> max (get rgb-1 ) MinRGB
					SliderIncLarge	-> min (get rgb+10) MaxRGB
					SliderDecLarge	-> max (get rgb-10) MinRGB
					SliderThumb x	-> x
		newrgb	= set y rgb
	
RGBPickControl`
	:: RGBColour (String,Id,Id) (RGBColour->Int) (Int->RGBColour->RGBColour) (Maybe ItemPos)
	-> RGBPickControl (RGBColour,Id) (PSt .l)
RGBPickControl` rgb (text,sid,tid) get set maybePos
	=	SliderControl Horizontal (PixelWidth length) sliderstate slideraction
		[ ControlId sid
		: controlPos
		]
	:+: TextControl   (ColourText text  (get rgb))
		[ ControlWidth (ContentWidth "Green 1000")
		, ControlId tid
		]
where
	controlPos	= case maybePos of
					Just pos	-> [ControlPos pos]
					_			-> []
	length		= MaxRGB-MinRGB+1
	sliderstate	= {sliderMin=MinRGB, sliderMax=MaxRGB, sliderThumb=get rgb}//, sliderSize = 0}
	
	slideraction :: SliderMove ((RGBColour,Id),PSt .l) -> ((RGBColour,Id),PSt .l)
	slideraction move ((rgb,did),pst)
		= ((	newrgb
		  , did
		  ),	appListPIO [ setSliderThumbs [(sid,y)]
		  			   , setControlTexts [(tid,ColourText text y)]
		  			   , SetColourBox` did newrgb
		  			   ] pst
		  )
	where
		y		= case move of
					SliderIncSmall	-> min (get rgb+1 ) MaxRGB

					SliderDecSmall	-> max (get rgb-1 ) MinRGB
					SliderIncLarge	-> min (get rgb+10) MaxRGB
					SliderDecLarge	-> max (get rgb-10) MinRGB
					SliderThumb x	-> x
		newrgb	= set y rgb
	
ColourText :: String Int -> String
ColourText text x
	= text+++" "+++toString x



/*	The definition of a colour box:		*/
:: ColourBoxControl ls ps = ColourBoxControl RGBColour Id (Maybe ItemPos)

instance Controls ColourBoxControl
where
	getControlType _ = "ColourBoxControl"
	controlToHandles (ColourBoxControl rgb cId maybePos) ps
		= controlToHandles imp ps
	where
		imp = CustomControl {w=40,h=40} (ColourBoxLook False rgb)
			[	ControlId cId
			:	case maybePos of (Just pos) -> [ControlPos pos];_->[]
			]

ColourBoxLook :: Bool RGBColour SelectState UpdateState *Picture -> *Picture
ColourBoxLook focus colour _ {newFrame} picture
	# picture	= setPenColour	(RGB colour) picture
	# picture	= fill			newFrame	 picture
	// now build frame...
	| focus
		# picture	= setPenSize	3			picture
		# picture	= setPenColour	Black		picture
		# picture	= draw			newFrame	picture
		# picture	= setPenSize	2			picture
		# picture	= setPenColour	LightGrey	picture
		# picture	= draw			newFrame	picture
		# picture	= setPenSize	1			picture
		# picture	= setPenColour	Black		picture
		# picture	= draw			newFrame	picture
		= picture
	# picture	= setPenSize	1			 picture
	# picture	= setPenColour	Black		 picture
	# picture	= draw			newFrame	 picture
	= picture

SetColourBox :: Id RGBColour !*(IOSt .l) -> *IOSt .l
SetColourBox id rgb iost
	= setControlLooks [(id,True,(True,ColourBoxLook False rgb))] iost

//--
:: ColourBoxControl` ls ps = ColourBoxControl` RGBColour Id (MouseStateFilter,MouseFunction *(ls,ps)) (Maybe ItemPos)

instance Controls ColourBoxControl`
where
	getControlType _ = "ColourBoxControl`"
	controlToHandles (ColourBoxControl` rgb cId (mfilter,mfunction) maybePos) ps
		= controlToHandles imp ps
	where
		imp = CustomControl {w=40,h=40} (ColourBoxLook False rgb)
			[	ControlId cId
			, ControlMouse mfilter Able mfunction
			:	case maybePos of (Just pos) -> [ControlPos pos];_->[]
			]

SetColourBox` :: Id RGBColour !*(IOSt .l) -> *IOSt .l
SetColourBox` id rgb iost
	= setControlLooks [(id,True,(True,ColourBoxLook True rgb))] iost

/*	The definition of the RGB access control:	*/

:: In l
157
	= InGet ((Maybe Colour) l -> l)
Diederik van Arkel's avatar
Diederik van Arkel committed
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
	| InSetI Id
	| InSetC Colour
	| InSetC` Colour


::	RGBId l	:==	RId (In l)

openRGBId :: !*env -> (!RGBId .l,!*env) | Ids env
openRGBId env = openRId env

::	ColourPickAccess ls ps	:==	Receiver (In ls) RGBColour ps

//ColourPickAccess :: (RGBId (PSt .l)) [(String,Id,Id)] Id -> ColourPickAccess .l (PSt .l)
ColourPickAccess rid rgbpicks
	= Receiver rid accessRGB []
where
	//accessRGB :: (In .l) (RGBColour,PSt .l) -> PSt .l
	accessRGB (InGet cont) ((rgb,did),ps)
		# col	= RGB rgb
		# ps	= cont (Just col) ps
		= ((rgb,did),ps)
	accessRGB (InSetC col) ((_,did),ps=:{io})
		# rgb		= toRGBColour col
		# {r,g,b}	= rgb
		# settings	= zip2 [r,g,b] rgbpicks
		# io		= SetColourBox    did rgb io
		# io		= setSliderThumbs (map (\(y,(_,sid,_))->(sid,y)) settings) io
		# io		= setControlTexts (map (\(y,(text,_,tid))->(tid,ColourText text y)) settings) io
		= ((rgb,did),{ps & io=io})
	accessRGB (InSetC` col) ((_,did),ps=:{io})
		# rgb		= toRGBColour col
		# {r,g,b}	= rgb
		# settings	= zip2 [r,g,b] rgbpicks
		# io		= SetColourBox`    did rgb io
		# io		= setSliderThumbs (map (\(y,(_,sid,_))->(sid,y)) settings) io
		# io		= setControlTexts (map (\(y,(text,_,tid))->(tid,ColourText text y)) settings) io
		= ((rgb,did),{ps & io=io})
	accessRGB (InSetI did) ((rgb,_),ps=:{io})
		# {r,g,b}	= rgb
		# settings	= zip2 [r,g,b] rgbpicks
		# io		= SetColourBox    did rgb io
		# io		= setSliderThumbs (map (\(y,(_,sid,_))->(sid,y)) settings) io
		# io		= setControlTexts (map (\(y,(text,_,tid))->(tid,ColourText text y)) settings) io
		= ((rgb,did),{ps & io=io})


/*	The definition of the assembled colour picking control:	*/

::	RGBColourPickControl ls ps
	= RGBColourPickControl (RGBId ps) Colour (Maybe ItemPos)

::	RGBColourPickControl` ls ps
	= RGBColourPickControl` (RGBId ps) Colour Id (Maybe ItemPos)

instance Controls RGBColourPickControl
where
	getControlType _ = "ColourPickControl"
	controlToHandles (RGBColourPickControl rgbid initcol maybePos) ps
		# initrgb					= toRGBColour initcol
		# (rid,ps)					= openId ps
		# (rtid,ps)					= openId ps
		# (gid,ps)					= openId ps
		# (gtid,ps)					= openId ps
		# (bid,ps)					= openId ps
		# (btid,ps)					= openId ps
		# (did,ps)					= openId ps
		# (rpicks,gpicks,bpicks)	= ((rtext,rid,rtid),(gtext,gid,gtid),(btext,bid,btid))
		= controlToHandles
			{ newLS 	= (initrgb,did)
		  	, newDef	= LayoutControl
						(	LayoutControl
						(	ListLS
						[	RGBPickControl initrgb rpicks (\rgb->rgb.r) (\x rgb->{rgb&r=x}) left
						,	RGBPickControl initrgb gpicks (\rgb->rgb.g) (\x rgb->{rgb&g=x}) left
						,	RGBPickControl initrgb bpicks (\rgb->rgb.b) (\x rgb->{rgb&b=x}) left
						])	[ControlHMargin 0 0,ControlVMargin 0 0]
						:+: ColourBoxControl initrgb did Nothing
						:+:	ColourPickAccess rgbid [rpicks,gpicks,bpicks]
						)	(case maybePos of (Just pos) -> [ControlPos pos]; _->[])
		  } ps
	where	
		(rtext,gtext,btext)					= ("Red","Green","Blue")
		left								= Just (Left,NoOffset)

instance Controls RGBColourPickControl`
where
	getControlType _ = "ColourPickControl"
	controlToHandles (RGBColourPickControl` rgbid initcol did maybePos) ps
		# initrgb					= toRGBColour initcol
		# (rid,ps)					= openId ps
		# (rtid,ps)					= openId ps
		# (gid,ps)					= openId ps
		# (gtid,ps)					= openId ps
		# (bid,ps)					= openId ps
		# (btid,ps)					= openId ps
		# (rpicks,gpicks,bpicks)	= ((rtext,rid,rtid),(gtext,gid,gtid),(btext,bid,btid))
		= controlToHandles
			{ newLS 	= (initrgb,did)
		  	, newDef	= LayoutControl
						(	LayoutControl
						(	ListLS
						[	RGBPickControl` initrgb rpicks (\rgb->rgb.r) (\x rgb->{rgb&r=x}) left
						,	RGBPickControl` initrgb gpicks (\rgb->rgb.g) (\x rgb->{rgb&g=x}) left
						,	RGBPickControl` initrgb bpicks (\rgb->rgb.b) (\x rgb->{rgb&b=x}) left
						])	[ControlHMargin 0 0,ControlVMargin 0 0]
						:+:	ColourPickAccess rgbid [rpicks,gpicks,bpicks]
						)	(case maybePos of (Just pos) -> [ControlPos pos]; _->[])
		  } ps
	where	
		(rtext,gtext,btext)					= ("Red","Green","Blue")
		left								= Just (Left,NoOffset)

//--

setColourBoxColour :: !(RGBId (PSt .l)) Colour !*(PSt .l) -> *PSt .l
setColourBoxColour rgbId colour ps
	# (_,ps) = asyncSend rgbId (InSetC colour) ps
	= ps

setColourBoxColour` :: !(RGBId (PSt .l)) Colour !*(PSt .l) -> *PSt .l
setColourBoxColour` rgbId colour ps
	# (_,ps) = asyncSend rgbId (InSetC` colour) ps
	= ps

282
getColourBoxColour :: !(RGBId (PSt .l`)) ((Maybe Colour) *(PSt .l`) -> PSt .l`) !*(PSt .l) -> *PSt .l
Diederik van Arkel's avatar
Diederik van Arkel committed
283
284
285
286
287
288
289
290
getColourBoxColour rgbId cont ps
	# (_,ps) = asyncSend rgbId (InGet cont) ps
	= ps

setColourBoxId :: !(RGBId (PSt .l)) Id !*(PSt .l) -> *PSt .l
setColourBoxId rgbId cbId ps
	# (_,ps) = asyncSend rgbId (InSetI cbId) ps
	= ps