ListBox.icl 14.5 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
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
implementation module ListBox


/*	Definition of the list box control.
	This definition uses the Object I/O library, version 1.2
	The list box control is constructed out of predefined control elements, and is therefore platform independent.
	In future versions it will be added as a standard library component.
*/


import StdBool, StdEnum, StdFunc, StdList, StdMisc, StdOrdList, StdTuple
import StdControl, StdControlReceiver, StdId, StdPicture, StdPSt, StdReceiver, StdWindow


::	ListBoxControl ls ps
	=	{	listboxState	:: ListBoxState
		,	listboxAtts		:: [ControlAttribute *(ls,ps)]
		}
::	ListBoxState
	=	{	maxNrItems		:: Int							// The maximum number of items (in future version superfluous)
		,	items			:: [String]						// All items to be displayed
		,	selection		:: [Index]						// The current selection
		,	size			:: Size							// The size of the custom control that displays all items
		,	listboxId		:: ListBoxId					// The ids related to this list box
		,	fontInfo		:: ListBoxFontInfo				// The font information used to display the control
		}
::	ListBoxId
	=	{	outerCompoundId	:: !Id							// The Id of the outmost CompoundControl
		,	innerCompoundId	:: !Id							// The Id of the innermost CompoundControl
		,	customId		:: !Id							// The Id of the CustomControl that renders the items
		,	r2Id			:: !R2Id MessageIn MessageOut	// The Id of the Receiver2Control that handles message passing
		}
::	MessageIn
	=	InGetSelection										// Request to retrieve current selection
	|	InSetSelection		[Index]							// Request to set the selection to the given index
	|	InGetItems											// Request to retrieve all current items
	|	InOpenItems			Index [String]					// Request to add items behind the element with the given index
	|	InCloseItems		[Index]							// Request to remove items at the given index positions
::	MessageOut
	=	OutGetSelection		[(String,Index)]				// Reply to retrieve the current selection
	|	OutSetSelection										// Reply to set the selection
	|	OutGetItems			[String]						// Reply to get all items
	|	OutOpenItems										// Reply to add items
	|	OutCloseItems										// Reply to remove items
::	ListBoxFontInfo
	=	{	font			:: Font							// The font to draw the items of a listbox
		,	metrics			:: FontMetrics					// The metrics of that font
		}

ListBoxControl :: Int [String] [Index] ListBoxId [ControlAttribute *(.ls,.ps)] !*env
				-> (!ListBoxControl .ls .ps,!*env) | accScreenPicture env
ListBoxControl maxNrItems items selection listboxid atts env
	# (dialogFont,env)	= accScreenPicture openDialogFont env
	# (metrics,   env)	= accScreenPicture (getFontMetrics dialogFont) env
	# listboxfontinfo	= {	font		= dialogFont
						  ,	metrics		= metrics
						  }
	# maxNrItems		= max 1 maxNrItems
	# items				= items%(0,maxNrItems-1)
	# (itemWidths,env)	= accScreenPicture (getFontStringWidths dialogFont items) env
	# itemsSize			= {	w=if (isEmpty items) 100 (maxList itemWidths)
//						  ,	h=(length items)*(fontLineHeight metrics)	// the initial size
						  ,	h=maxNrItems*(fontLineHeight metrics)		// fix the maximum size of the control
						  }
	# nrItems			= length items
	# selection			= if (nrItems==0)
							 []
							 (removeDup (filter (isBetween 1 nrItems) selection))
	= (	{	listboxState= {	maxNrItems	= maxNrItems	// In future version with resizeable controls superfluous
						  ,	items		= items
						  ,	selection	= selection
						  ,	size		= itemsSize
						  ,	listboxId	= listboxid
						  ,	fontInfo	= listboxfontinfo
						  }
		,	listboxAtts	= filter isListBoxControlAttribute atts
		}
	  , env
	  )
where
	isListBoxControlAttribute :: !(ControlAttribute .ps) -> Bool
	isListBoxControlAttribute (ControlFunction _)		= True
	isListBoxControlAttribute ControlHide				= True
	isListBoxControlAttribute (ControlPos _)			= True
	isListBoxControlAttribute (ControlSelectState _)	= True
	isListBoxControlAttribute (ControlViewSize _)		= True
	isListBoxControlAttribute _							= False

instance Controls ListBoxControl where
90
	controlToHandles :: !(ListBoxControl .ls (PSt .l)) (PSt .l) -> ([ControlState .ls (PSt .l)],PSt .l)
Peter Achten's avatar
Peter Achten committed
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
157
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
	controlToHandles {listboxState=listboxState=:{items,size,listboxId,fontInfo},listboxAtts} pst
		= controlToHandles imp pst
	where
		imp = {	addLS	= listboxState
			  ,	addDef	= CompoundControl
			  				(	CompoundControl 
							(	CustomControl size (customlook listboxState)	[	ControlId		listboxId.customId
																				,	ControlMouse	mouseFilter Able (mouse customAtt)
																				,	ControlPos		(Fix,zero)
																				]
							)
							[	ControlId			listboxId.innerCompoundId
							,	ControlItemSpace	0 0							// No itemspaces
							,	ControlHMargin		0 0							// No horizontal margins
							,	ControlVMargin		0 0							// No vertical margins
							,	ControlHScroll		hscroll
							,	ControlVScroll		(vscroll (fontLineHeight fontInfo.metrics))
							,	ControlViewDomain	{corner1=zero,corner2={x=size.w,y=size.h}}
							:	innerCompoundAtts
							]
							)
							[	ControlLook			True (\_ {newFrame}->draw newFrame)
							,	ControlHMargin		1 1
							,	ControlVMargin		1 1
							,	ControlId			listboxId.outerCompoundId
							:	outerCompoundAtts
							]
						  :+:	Receiver2 listboxId.r2Id receiver []
			  }
		
		//	The look of the custom control lists all items and the current selection
		customlook :: ListBoxState SelectState UpdateState *Picture -> *Picture
		customlook {items,selection,fontInfo} _ {newFrame} picture
			# picture		= clearlines picture
			# picture		= setfont    picture
			# picture		= drawlines  picture
			# picture		= drawselection picture
			= picture
		where
			metrics			= fontInfo.metrics
			height			= fontLineHeight metrics
			lines			= items
			(x1,x2)			= (newFrame.corner1.x,newFrame.corner2.x)
			
			clearlines		= unfill newFrame
			
			setfont			= setPenFont fontInfo.font
			
			drawlines		= seq (fst (smap (\line y->(drawAt {x=0,y=y} line,y+height)) lines (metrics.fAscent+metrics.fLeading)))
			
			drawselection	= seq (map (\i->hilite {corner1={x=x1,y=(i-1)*height},corner2={x=x2,y=i*height-1}}) selection)
		
		
		//	The only attribute for the CustomControl is the ControlFunction.
		customAtt
			# (hasFunAtt,funAtt)	= select (\att->case att of (ControlFunction f) -> True; _ -> False) undef listboxAtts
			| hasFunAtt
				= case funAtt of (ControlFunction f) -> f; _ -> id
			| otherwise
				= id
			
		//	The only optional attribute for the inner CompoundControl is the size.
		innerCompoundAtts
			# (hasSizeAtt,sizeAtt)	= select (\att->case att of (ControlViewSize _) -> True; _ -> False) undef listboxAtts
			| hasSizeAtt
				= [case sizeAtt of (ControlViewSize s) -> ControlViewSize s; _ -> undef]
			| otherwise
				= []
		
		//	The optional attributes for the outer CompoundControl are ControlSelectState, ControlPos, and ControlHide.
		outerCompoundAtts
			# (hasIt,att)	= select (\att->case att of (ControlSelectState _) -> True; _ -> False) undef listboxAtts
			# selectState	= if hasIt [case att of (ControlSelectState s) -> ControlSelectState s; _ -> undef] []
			# (hasIt,att)	= select (\att->case att of (ControlPos _) -> True; _ -> False) undef listboxAtts
			# pos			= if hasIt [case att of (ControlPos s) -> ControlPos s; _ -> undef] []
			# hasIt			= any (\att->case att of ControlHide -> True; _ -> False) listboxAtts
			# hide			= if hasIt [ControlHide] []
			= flatten [selectState,pos,hide]
		
		//	Scrolling through the compound control horizontally.
		hscroll :: ViewFrame SliderState SliderMove -> Int
		hscroll {corner1,corner2} {sliderThumb} action
			= case action of
				SliderIncSmall	-> sliderThumb+10
				SliderDecSmall	-> sliderThumb-10
				SliderIncLarge	-> sliderThumb+width
				SliderDecLarge	-> sliderThumb-width
				SliderThumb x	-> x
		where
			width	= abs (corner2.x-corner1.x-10)
		
		//	Scrolling through the compound control vertically.
		vscroll :: Int ViewFrame SliderState SliderMove -> Int
		vscroll lineHeight {corner1,corner2} {sliderThumb} action
			= case action of
				SliderIncSmall	-> sliderThumb+lineHeight
				SliderDecSmall	-> sliderThumb-lineHeight
				SliderIncLarge	-> sliderThumb+height
				SliderDecLarge	-> sliderThumb-height
				SliderThumb x	-> x/lineHeight*lineHeight
		where
			height	= abs (corner2.y-corner1.y-lineHeight)
		
		
		//	The mouse responds only to MouseDowns:
		mouseFilter :: MouseState -> Bool
		mouseFilter (MouseDown _ _ ddown)	= ddown==1
		mouseFilter _						= False
		
		//	The mouse either sets, adds, or removes items to the selection:
201
		mouse :: (IdFun *(.x,PSt .l)) MouseState *(*(ListBoxState,.x),PSt .l) -> *(*(ListBoxState,.x),PSt .l)
Peter Achten's avatar
Peter Achten committed
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
		mouse f (MouseDown pos {shiftDown} _) ((listboxState,ls),pState)
			# listboxState	= {listboxState & selection=okSelection}
			# newLook		= customlook listboxState
			# pState		= appPIO (setControlLooks [(customId,True,(True,newLook))]) pState
			# (ls,pState)	= f (ls,pState)
			= ((listboxState,ls),pState)
		where
			items		= listboxState.items
			nrItems		= length items
			selection	= listboxState.selection
			metrics		= listboxState.fontInfo.metrics
			lineHeight	= fontLineHeight metrics
			newIndex	= pos.y/lineHeight+1
			newSelection= if (not shiftDown)				[newIndex]
						 (if (isMember newIndex selection)	(removeMembers selection [newIndex])
															(merge [newIndex] selection))
			okSelection	= filter (isBetween 1 nrItems) newSelection
			customId	= listboxState.listboxId.customId
		
		
		//	The receiver function:
223
		receiver :: MessageIn *(*(ListBoxState,.x),PSt .l) -> (MessageOut,*(*(ListBoxState,.x),PSt .l))
Peter Achten's avatar
Peter Achten committed
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
282
283
284
285
286
287
288
289
290
291
292
		
		//	Return the current selection:
		receiver InGetSelection ((listboxState=:{items,selection},ls),pState)
			= (OutGetSelection (map (\index->(items!!(index-1),index)) selection),((listboxState,ls),pState))
		
		//	Set a new selection:
		receiver (InSetSelection newSelection) ((listboxState,ls),pState)
			# listboxState	= {listboxState & selection=newSelection}
			# newLook		= customlook listboxState
			# pState		= appPIO (setControlLooks [(customId,True,(True,newLook))]) pState
			= (OutSetSelection,((listboxState,ls),pState))
		where
			customId		= listboxState.listboxId.customId
		
		//	Return the current elements:
		receiver InGetItems ((listboxState=:{items},ls),pState)
			= (OutGetItems items,((listboxState,ls),pState))
		
		//	Insert elements:
		receiver (InOpenItems behindIndex newItems) ((listboxState=:{maxNrItems,items,selection},ls),pState)
			| nrNewItems==0
				= (OutOpenItems,((listboxState,ls),pState))
			# listboxState	= {listboxState & items=allItems, selection=newSelection}
			# newLook		= customlook listboxState
			# pState		= appPIO (setControlLooks [(customId,True,(True,newLook))]) pState
			| otherwise
				= (OutOpenItems,((listboxState,ls),pState))
		where
			customId				= listboxState.listboxId.customId
			nrCurItems				= length items
//			nrNewItems				= length newItems									// Add any number of new items
			nrNewItems				= min (maxNrItems-nrCurItems) (length newItems)		// Add only items upto maxNrItems
			okNewItems				= newItems%(0,nrNewItems-1)							// These are the proper new items
			okBehindIndex			= setBetween 0 (length items) behindIndex
			(itemsBefore,itemsAfter)= splitAt (okBehindIndex-1) items
			allItems				= if (okBehindIndex==0)
										 (okNewItems++items)
										 (itemsBefore++okNewItems++itemsAfter)
			(selecBefore,selecAfter)= span (\index->index<=okBehindIndex) (sort selection)
			newSelection			= selecBefore++map ((+) nrNewItems) selecAfter
		
		//	Remove elements:
		receiver (InCloseItems closeItems) ((listboxState=:{items,selection},ls),pState)
			| nrCloseItems==0
				= (OutCloseItems,((listboxState,ls),pState))
			# listboxState	= {listboxState & items=allItems, selection=newSelection}
			# newLook		= customlook listboxState
			# pState		= appPIO (setControlLooks [(customId,True,(True,newLook))]) pState
			| otherwise
				= (OutCloseItems,((listboxState,ls),pState))
		where
			customId				= listboxState.listboxId.customId
			nrCloseItems			= length closeItems
			allItems				= [ item \\ item <- items & i <- [1..] | not (isMember i closeItems) ]
			newSelection			= removeMembers selection closeItems
	
	getControlType _ = "ListBoxControl"

openListBoxId :: !*env -> (!ListBoxId,!*env)	| Ids env
openListBoxId env
	# (id1, env)	= openId env
	# (id2, env)	= openId env
	# (id3, env)	= openId env
	# (r2id,env)	= openR2Id env
	= ({outerCompoundId=id1,innerCompoundId=id2,customId=id3,r2Id=r2id},env)


//	The functions below take care of the proper communication with the receiver that
//	belongs to the listbox control.
293
getListBoxSelection :: !ListBoxId !(PSt .l) -> (!(!Bool,![(String,!Index)]),!PSt .l)
Peter Achten's avatar
Peter Achten committed
294
295
296
297
298
299
300
301
302
303
getListBoxSelection {r2Id} pState
	# ((_,maybe_out),pState)	= syncSend2 r2Id InGetSelection pState
	| isNothing maybe_out
		= ((False,[]),pState)
	# result					= case (fromJust maybe_out) of
									(OutGetSelection selection)	-> (True,selection)
									_							-> (False,[])
	| otherwise
		= (result,pState)

304
setListBoxSelection :: !ListBoxId ![Index] !(PSt .l) -> PSt .l
Peter Achten's avatar
Peter Achten committed
305
306
307
setListBoxSelection {r2Id} selection pState
	= snd (syncSend2 r2Id (InSetSelection selection) pState)

308
getListBoxItems :: !ListBoxId !(PSt .l) -> (!(!Bool,![String]),!PSt .l)
Peter Achten's avatar
Peter Achten committed
309
310
311
312
313
314
315
316
317
318
getListBoxItems {r2Id} pState
	# ((_,maybe_out),pState)	= syncSend2 r2Id InGetItems pState
	| isNothing maybe_out
		= ((False,[]),pState)
	# result					= case (fromJust maybe_out) of
									(OutGetItems items)	-> (True,items)
									_					-> (False,[])
	| otherwise
		= (result,pState)

319
openListBoxItems :: !ListBoxId !Index ![String] !(PSt .l) -> PSt .l
Peter Achten's avatar
Peter Achten committed
320
321
322
openListBoxItems {r2Id} index items pState
	= snd (syncSend2 r2Id (InOpenItems index items) pState)

323
closeListBoxItems :: !ListBoxId ![Index] !(PSt .l) -> PSt .l
Peter Achten's avatar
Peter Achten committed
324
325
326
closeListBoxItems {r2Id} items pState
	= snd (syncSend2 r2Id (InCloseItems items) pState)

327
showListBoxControl :: !ListBoxId !(IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
328
329
showListBoxControl {outerCompoundId} ioState = showControls [outerCompoundId] ioState

330
hideListBoxControl :: !ListBoxId !(IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
331
332
hideListBoxControl {outerCompoundId} ioState = hideControls [outerCompoundId] ioState

333
enableListBoxControl :: !ListBoxId !(IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
334
335
enableListBoxControl {outerCompoundId} ioState = enableControls [outerCompoundId] ioState

336
disableListBoxControl :: !ListBoxId !(IOSt .l) -> IOSt .l
Peter Achten's avatar
Peter Achten committed
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
disableListBoxControl {outerCompoundId} ioState = disableControls [outerCompoundId] ioState


//	Auxiliary functions:

smap :: (x -> s -> (y, s)) [x] s -> ([y],s)
smap f [x:xs] s
	# (y,s)	= f x s
	# (ys,s)= smap f xs s
	= ([y:ys],s)
smap _ _ s
	= ([],s)

select :: (x -> Bool) x [x] -> (Bool,x)
select pred dummy [x:xs]
	| pred x
		= (True,x)
	| otherwise
		= select pred dummy xs
select _ dummy _
	= (False,dummy)

isBetween :: x x x -> Bool	| Ord x
isBetween low up x
	= low<=x && x<=up

setBetween :: x x x -> x | Ord x
setBetween low up x
	| x<low		= low
	| x<up		= x
	| otherwise	= up