controlpos.icl 6.86 KB
Newer Older
Peter Achten's avatar
Peter Achten committed
1
2
3
4
5
implementation module controlpos


//	Clean Object I/O library version 1.2

6
import	StdBool, StdFunc, StdInt, StdList, StdMisc, StdTuple
Peter Achten's avatar
Peter Achten committed
7
import	commondef, windowaccess
8
from	controllayout	import layoutControls
Peter Achten's avatar
Peter Achten committed
9
10
from	controlrelayout	import relayoutControls
from	windowclipstate	import forceValidWindowClipState
11
from	windowdraw		import drawwindowlook`
Peter Achten's avatar
Peter Achten committed
12
from	windowupdate	import updatewindowbackgrounds
13
14
from	ospicture		import pictscroll
from	osrgn			import osgetrgnbox
Peter Achten's avatar
Peter Achten committed
15
16
17
18
19
from	ostypes			import Rect
from	ostoolbox		import OSToolbox
from	oswindow		import OSWindowMetrics, OSscrollbarsAreVisible, OSsetWindowSliderThumb, toOSscrollbarRange, OSMinWindowSize


20
21
22
23
controlposFatalError :: String String -> .x
controlposFatalError function error
	= FatalError function "controlpos" error

Peter Achten's avatar
Peter Achten committed
24
25
26
27
/*	movewindowviewframe moves the current view frame of the WindowHandle by the given Vector2. 
	movewindowviewframe assumes that the argument WindowHandle is a Window.
*/
movewindowviewframe :: !OSWindowMetrics !Vector2 !WIDS !(WindowHandle .ls .pst) !*OSToolbox -> (!WindowHandle .ls .pst,!*OSToolbox)
28
movewindowviewframe wMetrics v wids=:{wPtr} wH=:{whWindowInfo,whItems=oldItems,whSize,whAtts,whSelect,whShow} tb
29
	| newOrigin==oldOrigin		// origin has not changed
Peter Achten's avatar
Peter Achten committed
30
		= (wH,tb)
31
32
33
34
35
36
37
38
39
40
41
	| isEmpty oldItems			// there are no controls: do only visual updates
		# tb					= setsliderthumb hasHScroll wMetrics wPtr True  (minx,newOrigin.x,maxx) vieww (toTuple whSize) tb
		# tb					= setsliderthumb hasVScroll wMetrics wPtr False (miny,newOrigin.y,maxy) viewh (toTuple whSize) tb
		  windowInfo			= {windowInfo & windowOrigin=newOrigin}
		  wH					= {wH & whWindowInfo=WindowInfo windowInfo}
		  (updArea,updAction)	= if (not lookInfo.lookSysUpdate || toMuch)
		  							([newFrame],return []) (calcScrollUpdateArea oldOrigin newOrigin contentRect)
		  updState				= {oldFrame=PosSizeToRectangle oldOrigin contentSize,newFrame=newFrame,updArea=updArea}
		# (wH,tb)				= drawwindowlook` wMetrics wPtr updAction updState wH tb
		= (wH,tb)
	| otherwise					// there are controls: recalculate layout and do visual updates
42
43
		# tb					= setsliderthumb hasHScroll wMetrics wPtr True  (minx,newOrigin.x,maxx) vieww (toTuple whSize) tb
		# tb					= setsliderthumb hasVScroll wMetrics wPtr False (miny,newOrigin.y,maxy) viewh (toTuple whSize) tb
Peter Achten's avatar
Peter Achten committed
44
45
46
47
48
		  reqSize				= {w=contentSize.w-fst hMargins-snd hMargins,h=contentSize.h-fst vMargins-snd vMargins}
		# (_,newItems,tb)		= layoutControls wMetrics hMargins vMargins spaces reqSize minSize [(domain,newOrigin)] oldItems tb
		  windowInfo			= {windowInfo & windowOrigin=newOrigin}
		  wH					= {wH & whItems=newItems,whWindowInfo=WindowInfo windowInfo}
		# (wH,tb)				= forceValidWindowClipState wMetrics True wPtr wH tb
49
50
51
		# (isRect,areaRect,tb)	= case wH.whWindowInfo of
		  							WindowInfo {windowClip={clipRgn}} -> osgetrgnbox clipRgn tb
		  							_                                 -> controlposFatalError "movewindowviewframe" "unexpected whWindowInfo field"
52
		# (updRgn,tb)			= relayoutControls wMetrics whSelect whShow contentRect contentRect zero zero wPtr wH.whDefaultId oldItems wH.whItems tb
Peter Achten's avatar
Peter Achten committed
53
		# (wH,tb)				= updatewindowbackgrounds wMetrics updRgn wids wH tb
54
55
56
57
		  (updArea,updAction)	= if (not lookInfo.lookSysUpdate || toMuch || not isRect)
		  							([newFrame],return []) (calcScrollUpdateArea oldOrigin newOrigin areaRect)
		  updState				= {oldFrame=PosSizeToRectangle oldOrigin contentSize,newFrame=newFrame,updArea=updArea}
		# (wH,tb)				= drawwindowlook` wMetrics wPtr updAction updState wH tb
Peter Achten's avatar
Peter Achten committed
58
59
		= (wH,tb)
where
60
61
62
	windowInfo					= getWindowInfoWindowData whWindowInfo
	(oldOrigin,domainRect,hasHScroll,hasVScroll,lookInfo)
								= (windowInfo.windowOrigin,windowInfo.windowDomain,isJust windowInfo.windowHScroll,isJust windowInfo.windowVScroll,windowInfo.windowLook)
Peter Achten's avatar
Peter Achten committed
63
	domain						= RectToRectangle domainRect
64
65
66
67
68
69
70
71
72
	visScrolls					= OSscrollbarsAreVisible wMetrics domainRect (toTuple whSize) (hasHScroll,hasVScroll)
	contentRect					= getWindowContentRect wMetrics visScrolls (SizeToRect whSize)
	contentSize					= RectSize contentRect
	{w=w`,h=h`}					= contentSize
	(minx,maxx,vieww)			= (domainRect.rleft,domainRect.rright, contentSize.w)
	(miny,maxy,viewh)			= (domainRect.rtop, domainRect.rbottom,contentSize.h)
	newOrigin					= {	x = SetBetween (oldOrigin.x+v.vx) minx (max minx (maxx-vieww))
								  ,	y = SetBetween (oldOrigin.y+v.vy) miny (max miny (maxy-viewh))
								  }
73
74
	newFrame					= PosSizeToRectangle newOrigin contentSize
	toMuch						= (abs (newOrigin.x-oldOrigin.x)>=w`) || (abs (newOrigin.y-oldOrigin.y)>=h`)
Peter Achten's avatar
Peter Achten committed
75
76
	(defMinW,defMinH)			= OSMinWindowSize
	minSize						= {w=defMinW,h=defMinH}
77
78
79
	hMargins					= getWindowHMargins   IsWindow wMetrics whAtts
	vMargins					= getWindowVMargins   IsWindow wMetrics whAtts
	spaces						= getWindowItemSpaces IsWindow wMetrics whAtts
Peter Achten's avatar
Peter Achten committed
80
	
81
	setsliderthumb :: !Bool !OSWindowMetrics !OSWindowPtr !Bool !(!Int,!Int,!Int) !Int !(!Int,!Int) !*OSToolbox -> *OSToolbox
Peter Achten's avatar
Peter Achten committed
82
83
84
85
86
	setsliderthumb hasScroll wMetrics wPtr isHScroll scrollValues viewSize maxcoords tb
		| hasScroll				= OSsetWindowSliderThumb wMetrics wPtr isHScroll osThumb maxcoords True tb
		| otherwise				= tb
	where
		(_,osThumb,_,_)			= toOSscrollbarRange scrollValues viewSize
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
	
/*	calcScrollUpdateArea p1 p2 area calculates the new update area that has to be updated. 
	Assumptions: p1 is the origin before scrolling,
	             p2 is the origin after  scrolling,
	             area is the visible area of the window view frame.
*/
	calcScrollUpdateArea :: !Point2 !Point2 !Rect -> (![Rectangle],!St *Picture [Rect])
	calcScrollUpdateArea oldOrigin newOrigin areaRect
		= (map RectToRectangle updArea,scroll {newOriginAreaRect & rright=rright+1,rbottom=rbottom+1} restArea v)
	where
		newOriginAreaRect			= addVector (toVector newOrigin) areaRect
		{rleft,rtop,rright,rbottom}	= newOriginAreaRect
		v							= toVector (oldOrigin-newOrigin)
		{vx,vy}						= v
		(updArea,restArea)			= if (vx<=0 && vy<=0)
										(	[{newOriginAreaRect & rleft=rright+vx,rbottom=rbottom+vy},{newOriginAreaRect & rtop=rbottom+vy}]
										,	 {newOriginAreaRect & rright=rright+vx,rbottom=rbottom+vy}
										)
									 (if (vx<=0 && vy>=0)
									 	(	[{newOriginAreaRect & rbottom=rtop+vy},{newOriginAreaRect & rleft=rright+vx,rtop=rtop+vy}]
									 	,	 {newOriginAreaRect & rtop=rtop+vy,rright=rright+vx}
									 	)
									 (if (vx>=0 && vy<=0)
									 	(	[{newOriginAreaRect & rright=rleft+vx,rbottom=rbottom+vy},{newOriginAreaRect & rtop=rbottom+vy}]
									 	,	 {newOriginAreaRect & rleft=rleft+vx,rbottom=rbottom+vy}
									 	)
								//	  if (vx>=0 && vy>=0)
									 	(	[{newOriginAreaRect & rbottom=rtop+vy},{newOriginAreaRect & rtop=rtop+vy,rright=rleft+vx}]
									 	,	 {newOriginAreaRect & rleft=rleft+vx,rtop=rtop+vy}
									 	)))
		
		scroll :: !Rect !Rect !Vector2 !*Picture -> (![Rect],!*Picture)
		scroll scrollRect restRect v picture
			# (updRect,picture)	= pictscroll scrollRect v picture
			| updRect==zero
				= ([],picture)
			| otherwise
				= ([restRect],picture)