pickRGB.icl 5.66 KB
Newer Older
Peter Achten's avatar
Peter Achten 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
module pickRGB


//	**************************************************************************************************
//
//	This program creates a windows that allows a user to create a RGB colour.
//
//	The program has been written in Clean 1.3.2 and uses the Clean Standard Object I/O library 1.2
//	
//	**************************************************************************************************


import StdEnv, StdIO


Start :: *World -> *World
Start world
	# (rgbid,world)		= openR2Id  world
	# (ids,  world)		= openIds 7 world
	# pickcontrol		= ColourPickControl rgbid ids initrgb Nothing
	= startColourPicker rgbid pickcontrol world
where
 	initrgb				= {r=MaxRGB,g=MaxRGB,b=MaxRGB}
	startColourPicker rgbid pickcontrol world
Peter Achten's avatar
Peter Achten committed
25
		= startIO SDI Void initialise [ProcessClose closeProcess] world
Peter Achten's avatar
Peter Achten committed
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
	where
		initialise pst
			# (rgbsize,pst)	= controlSize pickcontrol True Nothing Nothing Nothing pst
			# wdef			= Window "Pick a colour" pickcontrol
								[	WindowViewSize   rgbsize
								,	WindowPen        [PenBack LightGrey]
								]
			# mdef			= Menu "PickRGB"
								(	MenuItem "MinRGB" [	MenuFunction (noLS (set rgbid BlackRGB))
													  ,	MenuShortKey 'n'
													  ]
								:+:	MenuItem "MaxRGB" [	MenuFunction (noLS (set rgbid WhiteRGB))
													  ,	MenuShortKey 'm'
													  ]
								:+:	MenuSeparator     []
								:+:	MenuItem "Quit"   [	MenuFunction (noLS closeProcess)
													  ,	MenuShortKey 'q'
													  ]
								)	[]
			# (_,pst)		= openWindow undef wdef pst
			# (_,pst)		= openMenu   undef mdef pst
			= pst

		set rid rgb pst		= snd (syncSend2 rid (InSet rgb) pst)


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

54
55
::	RGBPickControl ls pst
	:==	:+: SliderControl TextControl ls pst
Peter Achten's avatar
Peter Achten committed
56
57
58

RGBPickControl :: RGBColour (String,Id,Id) Id (RGBColour->Int) (Int->RGBColour->RGBColour)
				 (Maybe ItemPos)
59
	-> RGBPickControl RGBColour (PSt .l)
Peter Achten's avatar
Peter Achten committed
60
61
62
63
64
65
66
67
68
69
70
RGBPickControl rgb (text,sid,tid) did get set maybePos
	=	  SliderControl Horizontal length sliderstate slideraction
													[ControlId sid:controlPos]
	  :+: TextControl   (ColourText text (get rgb))	[ControlId tid]
where
	controlPos	= case maybePos of
					Just pos	-> [ControlPos pos]
					_			-> []
	length		= PixelWidth (MaxRGB-MinRGB+1)
	sliderstate	= {sliderMin=MinRGB, sliderMax=MaxRGB, sliderThumb=get rgb}
	
71
	slideraction :: SliderMove (RGBColour,PSt .l) -> (RGBColour,PSt .l)
Peter Achten's avatar
Peter Achten committed
72
73
	slideraction move (rgb,pst)
		= (	newrgb
74
75
		  ,	appListPIO [ setSliderThumb sid y
		  			   , setControlText tid (ColourText text y)
Peter Achten's avatar
Peter Achten committed
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
		  			   , 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:		*/

97
98
::	ColourBoxControl ls pst
	:==	CustomControl ls pst
Peter Achten's avatar
Peter Achten committed
99

100
ColourBoxControl :: RGBColour Id (Maybe ItemPos) -> ColourBoxControl .ls .pst
Peter Achten's avatar
Peter Achten committed
101
102
103
104
105
106
107
108
109
110
111
112
113
114
ColourBoxControl rgb did maybePos
	= CustomControl {w=40,h=40} (ColourBoxLook rgb)
			[	ControlId did
			:	case maybePos of (Just pos) -> [ControlPos pos];_->[]
			]

ColourBoxLook :: RGBColour SelectState UpdateState *Picture -> *Picture
ColourBoxLook colour _ {newFrame} picture
	# picture	= setPenColour	(RGB colour) picture
	# picture	= fill			newFrame	 picture
	# picture	= setPenColour	Black		 picture
	# picture	= draw			newFrame	 picture
	= picture

115
SetColourBox :: Id RGBColour (IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
116
SetColourBox id rgb iost
117
	= setControlLook id True (True,ColourBoxLook rgb) iost
Peter Achten's avatar
Peter Achten committed
118
119
120
121
122
123
124
125
126



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

::	In		=	InGet				| InSet RGBColour
::	Out		=	OutGet RGBColour	| OutSet
::	RGBId	:==	R2Id In Out

127
::	ColourPickAccess pst	:==	Receiver2 In Out RGBColour pst
Peter Achten's avatar
Peter Achten committed
128

129
ColourPickAccess :: RGBId [(String,Id,Id)] Id -> ColourPickAccess (PSt .l)
Peter Achten's avatar
Peter Achten committed
130
131
132
ColourPickAccess rid rgbpicks did
	= Receiver2 rid accessRGB []
where
133
134
135
136
	accessRGB :: In (RGBColour,PSt .l) -> (Out,(RGBColour,PSt .l))
	accessRGB InGet (rgb,pst)
		= (OutGet rgb,(rgb,pst))
	accessRGB (InSet rgb=:{r,g,b}) (_,pst=:{io})
Peter Achten's avatar
Peter Achten committed
137
138
139
		# 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
140
		= (OutSet,(rgb,{pst & io=io}))
Peter Achten's avatar
Peter Achten committed
141
142
143
144
145
146
147
	where
		settings= zip2 [r,g,b] rgbpicks



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

148
::	ColourPickControl ls pst
Peter Achten's avatar
Peter Achten committed
149
150
151
152
153
/*	:==	(	CompoundControl
			(	:+: (CompoundControl (ListLS RGBPickControl)))
			(	:+:	ColourBoxControl
					ColourPickAccess
			))
154
		) ls pst
Peter Achten's avatar
Peter Achten committed
155
156
157
158
159
160
*/	:==	NewLS
		(	CompoundControl
			(	:+:	(CompoundControl (ListLS (:+: SliderControl TextControl)))
			(	:+:	CustomControl
					(Receiver2 In Out)
			))
161
		)	ls	pst
Peter Achten's avatar
Peter Achten committed
162

163
ColourPickControl :: RGBId [Id] RGBColour (Maybe ItemPos) -> ColourPickControl .ls (PSt .l)
Peter Achten's avatar
Peter Achten committed
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
ColourPickControl rgbid ids initrgb maybePos
	= {	newLS = initrgb
	  ,	newDef= CompoundControl
					(	CompoundControl
					(	ListLS
					[	RGBPickControl initrgb rpicks did (\rgb->rgb.r) (\x rgb->{rgb&r=x}) left
					,	RGBPickControl initrgb gpicks did (\rgb->rgb.g) (\x rgb->{rgb&g=x}) left
					,	RGBPickControl initrgb bpicks did (\rgb->rgb.b) (\x rgb->{rgb&b=x}) left
					])	[ControlHMargin 0 0,ControlVMargin 0 0]
					:+: ColourBoxControl initrgb did Nothing
					:+:	ColourPickAccess rgbid [rpicks,gpicks,bpicks] did
					)	(case maybePos of (Just pos) -> [ControlPos pos]; _->[])
	  }
where	
	[rid,rtid,gid,gtid,bid,btid,did:_]	= ids
	(rtext,gtext,btext)					= ("Red","Green","Blue")
	(rpicks,gpicks,bpicks)				= ((rtext,rid,rtid),(gtext,gid,gtid),(btext,bid,btid))
	left								= Just (Left,NoOffset)