StdIOCommon.icl 21.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
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
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
201
202
203
204
205
implementation module StdIOCommon


//	********************************************************************************
//	Clean Standard Object I/O library, version 1.2
//	
//	StdIOCommon defines common types and access functions for the I/O library.
//	********************************************************************************


import	StdBool, StdFunc, StdInt, StdList, StdOverloaded, StdString
import	StdBitmap, StdIOBasic, StdKey, StdMaybe
from	commondef	import StateMap2
from	id			import Id, WindowMenuId, toId, RId, R2Id, RIdtoId, R2IdtoId, toString


/*	The SelectState type.								*/

::	SelectState		=	Able | Unable

instance == SelectState where
	(==) :: !SelectState !SelectState -> Bool
	(==) Able	select = enabled select
	(==) Unable	select = not (enabled select)
instance ~ SelectState where
	(~) :: !SelectState -> SelectState
	(~) Able	= Unable
	(~) Unable	= Able
instance toString SelectState where
	toString :: !SelectState -> {#Char}
	toString Able   = "Able"
	toString Unable = "Unable"

enabled :: !SelectState -> Bool
enabled Able	= True
enabled _		= False


/*	The MarkState type.									*/

::	MarkState		=	Mark | NoMark

instance == MarkState where
	(==) :: !MarkState	!MarkState	-> Bool
	(==) Mark	mark = marked mark
	(==) NoMark	mark = not (marked mark)
instance ~ MarkState where
	(~) :: !MarkState -> MarkState
	(~) Mark	= NoMark
	(~) _		= Mark
instance toString MarkState where
	toString :: !MarkState -> {#Char}
	toString Mark   = "Mark"
	toString NoMark = "NoMark"

marked :: !MarkState -> Bool
marked Mark   	= True
marked _		= False


/*	The KeyboardState type.								*/

::	KeyboardState
	=	CharKey		Char		KeyState			// ASCII character input
	|	SpecialKey	SpecialKey	KeyState Modifiers	// Special key input
	|	KeyLost										// Key input lost while key was down
::	KeyState
	=	KeyDown		IsRepeatKey						// Key is down
	|	KeyUp										// Key goes up
::	IsRepeatKey										// Flag on key down:
	:==	Bool										// True iff key is repeating
::	Key
	=	IsCharKey	 Char
	|	IsSpecialKey SpecialKey
::	KeyboardStateFilter								// Predicate on KeyboardState:
	:==	KeyboardState -> Bool						// evaluate KeyFunction only if predicate holds and SelectState is Able

getKeyboardStateKeyState :: !KeyboardState -> KeyState
getKeyboardStateKeyState (CharKey    _ kstate  ) = kstate
getKeyboardStateKeyState (SpecialKey _ kstate _) = kstate
getKeyboardStateKeyState KeyLost                 = KeyUp

getKeyboardStateKey :: !KeyboardState -> Maybe Key
getKeyboardStateKey (CharKey    char  _) = Just (IsCharKey   char)
getKeyboardStateKey (SpecialKey key _ _) = Just (IsSpecialKey key)
getKeyboardStateKey KeyLost              = Nothing

instance == KeyboardState where
	(==) :: !KeyboardState !KeyboardState -> Bool
	(==) (CharKey char key) keySt			= case keySt of
												(CharKey char` key`)			-> char==char` && key==key`
												_								-> False
	(==) (SpecialKey spec key mods) keySt	= case keySt of
												(SpecialKey spec` key` mods`)	-> spec==spec` && key==key` && mods==mods`
												_								-> False
	(==) KeyLost					keySt	= case keySt of
												KeyLost							-> True
												_								-> False
instance == KeyState where
	(==) :: !KeyState !KeyState -> Bool
	(==) KeyUp				key	= case key of
									KeyUp				-> True
									_					-> False
	(==) (KeyDown repeat)	key	= case key of
									(KeyDown repeat`)	-> repeat==repeat`
									_					-> False
instance toString KeyboardState where
	toString :: !KeyboardState -> {#Char}
	toString (CharKey char keystate)
		= brackify ("CharKey "+++fromChar char+++" "+++brackify ("ASCII: "+++toString (toInt char))+++" "+++toString keystate)
	toString (SpecialKey special keystate modifiers)
		= brackify ("SpecialKey "+++itemsList " " [toString special,toString keystate,toString modifiers])
	toString KeyLost
		= "KeyLost"
instance toString KeyState where
	toString :: !KeyState -> {#Char}
	toString (KeyDown isRepeat)	= brackify ("KeyDown "+++toString isRepeat)
	toString KeyUp				= "KeyUp"


/*	The MouseState type.								*/

::	MouseState
	=	MouseMove	Point2 Modifiers			// Mouse is up		(position & modifiers)
	|	MouseDown	Point2 Modifiers Int		// Mouse goes down	(position & modifiers & nr double down)
	|	MouseDrag	Point2 Modifiers			// Mouse is down	(position & modifiers)
	|	MouseUp		Point2 Modifiers			// Mouse goes up	(position & modifiers)
	|	MouseLost								// Mouse input lost while mouse was down
::	ButtonState
 	=	ButtonStillUp							// MouseMove
 	|	ButtonDown								// MouseDown 1
	|	ButtonDoubleDown						//			 2
	|	ButtonTripleDown						//           >2
	|	ButtonStillDown							// MouseDrag
 	|	ButtonUp								// MouseUp
::	MouseStateFilter							// Predicate on MouseState:
	:==	MouseState -> Bool						// Evaluate MouseFunction only if predicate holds and SelectState is Able

getMouseStatePos :: !MouseState -> Point2
getMouseStatePos (MouseMove pos _)			= pos
getMouseStatePos (MouseDown pos _ _)		= pos
getMouseStatePos (MouseDrag pos _)			= pos
getMouseStatePos (MouseUp   pos _)			= pos
getMouseStatePos MouseLost					= zero

getMouseStateModifiers :: !MouseState -> Modifiers
getMouseStateModifiers (MouseMove _ mods)	= mods
getMouseStateModifiers (MouseDown _ mods _)	= mods
getMouseStateModifiers (MouseDrag _ mods)	= mods
getMouseStateModifiers (MouseUp   _ mods)	= mods
getMouseStateModifiers MouseLost			= NoModifiers

getMouseStateButtonState:: !MouseState	-> ButtonState
getMouseStateButtonState (MouseMove _ _)	= ButtonStillUp
getMouseStateButtonState (MouseDown _ _ nr)	= if (nr==1) ButtonDown 
											 (if (nr==2) ButtonDoubleDown
											 			 ButtonTripleDown
											 )
getMouseStateButtonState (MouseDrag _ _)	= ButtonStillDown
getMouseStateButtonState (MouseUp   _ _)	= ButtonUp
getMouseStateButtonState MouseLost			= ButtonUp

instance == MouseState where
	(==) :: !MouseState !MouseState -> Bool
	(==) (MouseMove pos mods)	 mouseSt	= case mouseSt of
												(MouseMove pos` mods`)		-> pos==pos` && mods==mods`
												_							-> False
	(==) (MouseDown pos mods nr) mouseSt	= case mouseSt of
												(MouseDown pos` mods` nr`)	-> pos==pos` && mods==mods` && nr==nr`
												_							-> False
	(==) (MouseDrag pos mods)	 mouseSt	= case mouseSt of
												(MouseDrag pos` mods`)		-> pos==pos` && mods==mods`
												_							-> False
	(==) (MouseUp   pos mods)	 mouseSt	= case mouseSt of
												(MouseUp pos` mods`)		-> pos==pos` && mods==mods`
												_							-> False
	(==) MouseLost				 mouseSt	= case mouseSt of
												MouseLost					-> True
												_							-> False
instance == ButtonState where
	(==) :: !ButtonState	!ButtonState					-> Bool
	(==) ButtonStillUp		button	= case button of
										ButtonStillUp		-> True
										_					-> False
	(==) ButtonDown			button	= case button of
										ButtonDown			-> True
										_					-> False
	(==) ButtonDoubleDown	button	= case button of
										ButtonDoubleDown	-> True
										_					-> False
	(==) ButtonTripleDown	button	= case button of
										ButtonTripleDown	-> True
										_					-> False
	(==) ButtonStillDown	button	= case button of
										ButtonStillDown		-> True
										_					-> False
	(==) ButtonUp			button	= case button of
										ButtonUp			-> True
										_					-> False
instance toString MouseState where
	toString (MouseMove	pos modifiers)		= brackify ("MouseMove "+++itemsList " " [toString pos,toString modifiers])
	toString (MouseDown	pos modifiers nr)	= brackify ("MouseDown "+++itemsList " " [toString pos,toString modifiers,toString nr])
	toString (MouseDrag	pos modifiers)		= brackify ("MouseDrag "+++itemsList " " [toString pos,toString modifiers])
	toString (MouseUp   pos modifiers)		= brackify ("MouseUp "  +++itemsList " " [toString pos,toString modifiers])
	toString MouseLost						= "MouseLost"
206
207
208
209
210
211
212
213
instance toString ButtonState where
	toString ButtonStillUp					= "ButtonStillUp"
	toString ButtonDown						= "ButtonDown"
	toString ButtonDoubleDown				= "ButtonDoubleDown"
	toString ButtonTripleDown				= "ButtonTripleDown"
	toString ButtonStillDown				= "ButtonStillDown"
	toString ButtonUp						= "ButtonUp"

Peter Achten's avatar
Peter Achten committed
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


/*	The SliderState type.								*/

::	SliderState
	=	{	sliderMin	:: !Int
		,	sliderMax	:: !Int
		,	sliderThumb	:: !Int
		}

instance == SliderState where								// Equality on SliderState
	(==) :: !SliderState !SliderState -> Bool
	(==) s1 s2 = s1.sliderMin==s2.sliderMin && s1.sliderMax==s2.sliderMax && s1.sliderThumb==s2.sliderThumb
instance toString SliderState where
	toString :: !SliderState -> {#Char}
	toString {sliderMin,sliderThumb,sliderMax}
		= curlify (itemsList "," (map recordFieldtoString (zip2	["sliderMin","sliderThumb","sliderMax"]
																[ sliderMin,  sliderThumb,  sliderMax ])))


/*	The UpdateState type.								*/

::	UpdateState
	=	{	oldFrame	:: !ViewFrame
		,	newFrame	:: !ViewFrame
		,	updArea		:: !UpdateArea
		}
::	ViewDomain			:==	Rectangle
::	ViewFrame			:==	Rectangle
::	UpdateArea			:==	[ViewFrame]

instance toString UpdateState where
	toString :: !UpdateState -> {#Char}
	toString {oldFrame,newFrame,updArea}
		= curlify (itemsList "," ["oldFrame="+++toString oldFrame
								 ,"newFrame="+++toString newFrame
								 ,"updArea=" +++squarify (itemsList "," (map toString updArea))
								 ]
				  )

RectangleToUpdateState :: !Rectangle -> UpdateState
RectangleToUpdateState frame
	= {oldFrame=frame,newFrame=frame,updArea=[frame]}

/*	viewDomainRange defines the minimum and maximum values for ViewDomains.
	viewFrameRange  defines the minimum and maximum values for ViewFrames.
*/
viewDomainRange			:== {	corner1 = {x = 0-(2^30),y = 0-(2^30)}
							,	corner2 = {x =    2^30 ,y =    2^30 }
							}
viewFrameRange			:==	{	corner1 = {x = 1-(2^31),y = 1-(2^31)}
							,	corner2 = {x = (2^31)-1,y = (2^31)-1}
							}


/*	Modifiers indicates the meta keys that have been pressed (True) or not (False).	*/

::	Modifiers
	=	{	shiftDown	:: !Bool
		,	optionDown	:: !Bool
		,	commandDown	:: !Bool
		,	controlDown	:: !Bool
		,	altDown		:: !Bool
		}

NoModifiers	:==	{shiftDown=False,optionDown=False,commandDown=False,controlDown=False,altDown=False}
ShiftOnly	:==	{shiftDown=True	,optionDown=False,commandDown=False,controlDown=False,altDown=False}
Peter Achten's avatar
Peter Achten committed
281
282
283
284
OptionOnly	:== {shiftDown=False,optionDown=True, commandDown=False,controlDown=False,altDown=True }
CommandOnly	:== {shiftDown=False,optionDown=False,commandDown=True, controlDown=True, altDown=False}
ControlOnly	:== {shiftDown=False,optionDown=False,commandDown=True, controlDown=True, altDown=False}
AltOnly		:==	{shiftDown=False,optionDown=True, commandDown=False,controlDown=False,altDown=True }
Peter Achten's avatar
Peter Achten committed
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
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
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547

instance == Modifiers where
	(==) :: !Modifiers !Modifiers -> Bool
	(==) m1 m2 = m1.shiftDown   == m2.shiftDown
			  && m1.optionDown  == m2.optionDown
			  && m1.commandDown == m2.commandDown
			  && m1.controlDown == m2.controlDown
			  && m1.altDown     == m2.altDown
instance toString Modifiers where
	toString :: !Modifiers -> {#Char}
	toString {shiftDown,optionDown,commandDown,controlDown,altDown}
		= curlify (itemsList "," (flatten [	if shiftDown   ["shiftDown"]   []
										  ,	if optionDown  ["optionDown"]  []
										  ,	if commandDown ["commandDown"] []
										  ,	if controlDown ["controlDown"] []
										  ,	if altDown     ["altDown"]     []
										  ]))


/*	The layout language used for windows and controls.	*/

::	ItemPos
	:==	(	ItemLoc
		,	ItemOffset
		)
::	ItemLoc
 //	Absolute:
	=	Fix
 //	Relative to corner:
	|	LeftTop
	|	RightTop
	|	LeftBottom
	|	RightBottom
 //	Relative in next line:
	|	Left
	|	Center
	|	Right
 //	Relative to other item:
	|	LeftOf	Id
	|	RightTo	Id
	|	Above	Id
	|	Below	Id
 //	Relative to previous item:
	|	LeftOfPrev
	|	RightToPrev
	|	AbovePrev
	|	BelowPrev
::	ItemOffset
	=	NoOffset							// Shorthand for OffsetVector zero
	|	OffsetVector Vector2				// A constant offset vector
	|	OffsetFun    ParentIndex OffsetFun	// Offset depends on orientation
::	ParentIndex
	:== Int									// The number of parents (1..)
::	OffsetFun
	:==	(ViewDomain,Point2) -> Vector2		// Current view domain and origin

instance zero ItemOffset where
	zero :: ItemOffset
	zero = NoOffset

instance == ItemLoc where
	(==) :: !ItemLoc		!ItemLoc -> Bool
	(==) Fix				itemLoc	= case itemLoc of
										Fix				-> True
										_				-> False
	(==) LeftTop			itemLoc	= case itemLoc of
										LeftTop			-> True
										_				-> False
	(==) RightTop			itemLoc	= case itemLoc of
										RightTop		-> True
										_				-> False
	(==) LeftBottom			itemLoc	= case itemLoc of
										LeftBottom		-> True
										_				-> False
	(==) RightBottom		itemLoc	= case itemLoc of
										RightBottom		-> True
										_				-> False
	(==) Left				itemLoc	= case itemLoc of
										Left			-> True
										_				-> False
	(==) Center				itemLoc	= case itemLoc of
										Center			-> True
										_				-> False
	(==) Right				itemLoc	= case itemLoc of
										Right			-> True
										_				-> False
	(==) (LeftOf	id1)	itemLoc	= case itemLoc of
										LeftOf	id2		-> id1==id2
										_				-> False
	(==) (RightTo	id1)	itemLoc	= case itemLoc of
										RightTo	id2		-> id1==id2
										_				-> False
	(==) (Above		id1)	itemLoc	= case itemLoc of
										Above	id2		-> id1==id2
										_				-> False
	(==) (Below		id1)	itemLoc	= case itemLoc of
										Below	id2		-> id1==id2
										_				-> False
	(==) LeftOfPrev			itemLoc	= case itemLoc of
										LeftOfPrev		-> True
										_				-> False
	(==) RightToPrev		itemLoc	= case itemLoc of
										RightToPrev		-> True
										_				-> False
	(==) AbovePrev			itemLoc	= case itemLoc of
										AbovePrev		-> True
										_				-> False
	(==) BelowPrev			itemLoc	= case itemLoc of
										BelowPrev		-> True
										_				-> False
instance toString ItemLoc where
	toString :: !ItemLoc -> {#Char}
	toString Fix			= "Fix"
	toString LeftTop		= "LeftTop"
	toString RightTop		= "RightTop"
	toString LeftBottom		= "LeftBottom"
	toString RightBottom	= "RightBottom"
	toString Left			= "Left"
	toString Center			= "Center"
	toString Right			= "Right"
	toString (LeftOf  id)	= brackify ("LeftOf " +++ toString id)
	toString (RightTo id)	= brackify ("RightTo "+++ toString id)
	toString (Above   id)	= brackify ("Above "  +++ toString id)
	toString (Below   id)	= brackify ("Below "  +++ toString id)
	toString LeftOfPrev		= "LeftOfPrev"
	toString RightToPrev	= "RightToPrev"
	toString AbovePrev		= "AbovePrev"
	toString BelowPrev		= "BelowPrev"


/*	The Direction type.									*/

::	Direction
	=	Horizontal
	|	Vertical

instance == Direction where
	(==) :: !Direction !Direction -> Bool
	(==) Horizontal direction	= case direction of
									Horizontal	-> True
									_			-> False
	(==) Vertical	direction	= case direction of
									Vertical	-> True
									_			-> False
instance toString Direction where
	toString :: !Direction -> {#Char}
	toString Horizontal = "Horizontal"
	toString Vertical   = "Vertical"


/*	The CursorShape type.							*/

::	CursorShape
	=	StandardCursor
	|	BusyCursor
	|	IBeamCursor
	|	CrossCursor
	|	FatCrossCursor
	|	ArrowCursor
	|	HiddenCursor

instance == CursorShape where
	(==) :: !CursorShape !CursorShape -> Bool
	(==) StandardCursor	cursor	= case cursor of
									StandardCursor	-> True
									_				-> False
	(==) BusyCursor		cursor	= case cursor of
									BusyCursor		-> True
									_				-> False
	(==) IBeamCursor	cursor	= case cursor of
									IBeamCursor		-> True
									_				-> False
	(==) CrossCursor	cursor	= case cursor of
									CrossCursor		-> True
									_				-> False
	(==) FatCrossCursor	cursor	= case cursor of
									FatCrossCursor	-> True
									_				-> False
	(==) ArrowCursor	cursor	= case cursor of
									ArrowCursor		-> True
									_				-> False
	(==) HiddenCursor	cursor	= case cursor of
									HiddenCursor	-> True
									_				-> False
instance toString CursorShape where
	toString :: !CursorShape -> {#Char}
	toString StandardCursor	= "StandardCursor"
	toString BusyCursor		= "BusyCursor"
	toString IBeamCursor	= "IBeamCursor"
	toString CrossCursor	= "CrossCursor"
	toString FatCrossCursor	= "FatCrossCursor"
	toString ArrowCursor	= "ArrowCursor"
	toString HiddenCursor	= "HiddenCursor"


/*	Document interface type of interactive processes.	*/

::	DocumentInterface
	=	NDI														// No       Document Interface
	|	SDI														// Single   Document Interface
	|	MDI														// Multiple Document Interface

instance == DocumentInterface where
	(==) :: !DocumentInterface !DocumentInterface -> Bool
	(==) NDI xdi	= case xdi of
						NDI	-> True
						_	-> False
	(==) SDI xdi	= case xdi of
						SDI	-> True
						_	-> False
	(==) MDI xdi	= case xdi of
						MDI	-> True
						_	-> False
instance toString DocumentInterface where
	toString :: !DocumentInterface -> {#Char}
	toString NDI = "NDI"
	toString SDI = "SDI"
	toString MDI = "MDI"


/*	Process attributes.									*/

::	ProcessAttribute st									// Default:
	=	ProcessActivate		(IdFun st)					// No action on activate
	|	ProcessDeactivate	(IdFun st)					// No action on deactivate
	|	ProcessClose		(IdFun st)					// Process is closed
 //	Attributes for (M/S)DI process only:
	|	ProcessOpenFiles	(ProcessOpenFilesFunction st)
														// Request to open files
	|	ProcessWindowPos	ItemPos						// Platform dependent
	|	ProcessWindowSize	Size						// Platform dependent
	|	ProcessWindowResize	(ProcessWindowResizeFunction st)
														// Platform dependent
 	|	ProcessToolbar		[ToolbarItem st]			// Process has no toolbar
 //	Attributes for MDI processes only:
	|	ProcessNoWindowMenu								// Process has WindowMenu

::	ProcessWindowResizeFunction st
	:==	Size											// Old ProcessWindow size
	 ->	Size											// New ProcessWindow size
	 ->	st -> st
::	ProcessOpenFilesFunction st
	:==	[String]										// The file names to open
	 -> st -> st

::	ToolbarItem st
	=	ToolbarItem Bitmap (Maybe String) (IdFun st)
	|	ToolbarSeparator


/*	Frequently used function types.						*/

::	ModifiersFunction	st	:==	Modifiers		->	st -> st
::	MouseFunction		st	:== MouseState		->	st -> st
::	KeyboardFunction	st	:== KeyboardState	->	st -> st
::	SliderAction		st	:==	SliderMove		->	st -> st
::	SliderMove
	=	SliderIncSmall
	|	SliderDecSmall
	|	SliderIncLarge
	|	SliderDecLarge
	|	SliderThumb Int

548
549
550
551
552
553
554
instance toString SliderMove where
	toString SliderIncSmall  = "SliderIncSmall"
	toString SliderDecSmall  = "SliderDecSmall"
	toString SliderIncLarge  = "SliderIncLarge"
	toString SliderDecLarge  = "SliderDecLarge"
	toString (SliderThumb x) = brackify ("SliderThumb "+++toString x)

Peter Achten's avatar
Peter Achten committed
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601

/*	Scrolling function.									*/

::	ScrollFunction
	:==	ViewFrame		->					// Current	view
		SliderState		->					// Current	state of scrollbar
		SliderMove		->					// Action of the user
		Int									// New thumb value

stdScrollFunction :: !Direction !Int -> ScrollFunction
stdScrollFunction direction d
	= stdScrollFunction` direction d
where
	stdScrollFunction` :: !Direction !Int !ViewFrame !SliderState !SliderMove -> Int
	stdScrollFunction` direction d viewFrame {sliderThumb=x} move
		# d				= abs d
		  viewFrameSize	= rectangleSize viewFrame
		  edge			= if (direction==Horizontal) viewFrameSize.w viewFrameSize.h
		= case move of
			SliderIncSmall	-> x+d
			SliderDecSmall	-> x-d
			SliderIncLarge	-> x+edge/d*d
			SliderDecLarge	-> x-edge/d*d
			SliderThumb x	-> x/d*d


/*	Standard GUI object rendering function.				*/

::	Look
	:==	SelectState ->						// Current SelectState of GUI object
		UpdateState ->						// The area to be rendered
		*Picture	-> *Picture				// The rendering action

stdUnfillNewFrameLook :: SelectState !UpdateState !*Picture -> *Picture
stdUnfillNewFrameLook _ {newFrame} picture = unfill newFrame picture

stdUnfillUpdAreaLook :: SelectState !UpdateState !*Picture -> *Picture
stdUnfillUpdAreaLook _ {updArea} picture = StateMap2 unfill updArea picture


/*	Common error report types.							*/

::	ErrorReport													// Usual cause:
	=	NoError													// No error
	|	ErrorViolateDI											// Violation against document interface kind
	|	ErrorIdsInUse											// Object definition contains Ids that are already in use
	|	ErrorUnknownObject										// Object can not be found
602
	|	ErrorNotifierOpen										// It was tried to open a second send notifier // MW0++
Peter Achten's avatar
Peter Achten committed
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
	|	OtherError !String										// Other kind of error

instance == ErrorReport where
	(==) :: !ErrorReport !ErrorReport -> Bool
	(==) NoError			error	= case error of
										NoError				-> True
										_					-> False
	(==) ErrorViolateDI		error	= case error of
										ErrorViolateDI		-> True
										_					-> False
	(==) ErrorIdsInUse		error	= case error of
										ErrorIdsInUse		-> True
										_					-> False
	(==) ErrorUnknownObject	error	= case error of
										ErrorUnknownObject	-> True
										_					-> False
619
620
621
622
623
// MW11..
	(==) ErrorNotifierOpen	error	= case error of
										ErrorNotifierOpen	-> True
										_					-> False
// ..MW11
Peter Achten's avatar
Peter Achten committed
624
625
626
627
628
629
630
631
632
	(==) (OtherError e1)	error	= case error of
										OtherError e2		-> e1==e2
										_					-> False
instance toString ErrorReport where
	toString :: !ErrorReport -> {#Char}
	toString NoError			= "NoError"
	toString ErrorViolateDI		= "ErrorViolateDI"
	toString ErrorIdsInUse		= "ErrorIdsInUse"
	toString ErrorUnknownObject	= "ErrorUnknownObject"
633
	toString ErrorNotifierOpen	= "ErrorNotifierOpen" // MW11++
Peter Achten's avatar
Peter Achten committed
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
	toString (OtherError s)		= brackify ("OtherError "+++toString s)


//	Some handy functions for toString:
curlify  x = "{"+++x+++"}"
brackify x = "("+++x+++")"
squarify x = "["+++x+++"]"

recordFieldtoString :: (String,a) -> String | toString a	// recordFieldtoString f v -> f=v
recordFieldtoString (field,value) = field+++"="+++toString value

itemsList :: !String ![String] -> String	// itemsList c [a0,...an] -> a0 c a1 c ... c an
itemsList separator [x:xs]
	= x+++itemsList` xs
where
	itemsList` [x:xs]	= separator+++x+++itemsList` xs
	itemsList` _		= ""
itemsList _ _
	= ""
653
654
655
656
657

// MW11..
::	OkBool									// iff True, the operation was successful
	:==	Bool
// ..MW11