EdVisualCursor.icl 12.6 KB
Newer Older
Diederik van Arkel's avatar
Diederik van Arkel committed
1
2
implementation module EdVisualCursor

3
// visual operations on the cursor
Diederik van Arkel's avatar
Diederik van Arkel committed
4
5
6
7
8
9
10
11

import StdInt, StdClass, StdBool, StdFunc
import StdPicture, StdWindow, StdPSt, StdList
import EdSelection, EdVisualText, EdMovement, EdTab
import ioutil, StrictList

//--

Diederik van Arkel's avatar
Diederik van Arkel committed
12
vCenterCursor :: EditMonad (PSt .l) nothing
Diederik van Arkel's avatar
Diederik van Arkel committed
13
vCenterCursor = vMakeCursorVisible True Nothing
Diederik van Arkel's avatar
Diederik van Arkel committed
14

Diederik van Arkel's avatar
Diederik van Arkel committed
15
vScrollToCursor :: EditMonad (PSt .l) nothing
Diederik van Arkel's avatar
Diederik van Arkel committed
16
vScrollToCursor = vMakeCursorVisible False Nothing
Diederik van Arkel's avatar
Diederik van Arkel committed
17

Diederik van Arkel's avatar
Diederik van Arkel committed
18
19
20
21
22
vDragCursor :: !Point2 -> EditMonad (PSt .l) nothing
vDragCursor point = vMakeCursorVisible False (Just point)

vMakeCursorVisible :: !Bool !(Maybe Point2) -> EditMonad (PSt .l) nothing
vMakeCursorVisible center drag =
Diederik van Arkel's avatar
Diederik van Arkel committed
23
24
	getWindowId					>>>= \windowId ->
	accEnv (accPIO (getWindowViewFrame windowId))		>>>= \viewFrame -> 
Diederik van Arkel's avatar
Diederik van Arkel committed
25
26
//	accEnv (accPIO (getWindowViewDomain windowId))		>>>= \viewDomain -> 
	getSelection				>>>= \{start,end} ->
Diederik van Arkel's avatar
Diederik van Arkel committed
27
	getText						>>>= \text ->
Diederik van Arkel's avatar
Diederik van Arkel committed
28
	getFontInfo					>>>= \fontInfo=:{FontInfo | lineHeight,charWidth} ->
Diederik van Arkel's avatar
Diederik van Arkel committed
29
30
31
32
33
34
35
36
37
	let // give names to the components of the view frame
		cursorPoint = positionToPoint end text fontInfo
		left	 = viewFrame.corner1.x
		right	 = viewFrame.corner2.x
		top		 = viewFrame.corner1.y
		bottom	 = viewFrame.corner2.y
		
		// determine whether the cursor is on the 
		// correct (visible) side of the borders
Diederik van Arkel's avatar
Diederik van Arkel committed
38
39
40
41
42
		leftOk	 = cursorPoint.x - charWidth >= left
//		leftOk	 = case end.col of
//					0	-> (fromJust viewDomain).corner1.x = left
//					_	-> cursorPoint.x - charWidth >= left
		rightOk	 = cursorPoint.x + charWidth <= right
Diederik van Arkel's avatar
Diederik van Arkel committed
43
44
		topOk	 = cursorPoint.y >= top
		bottomOk = cursorPoint.y + lineHeight <= bottom
Diederik van Arkel's avatar
Diederik van Arkel committed
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
		cursorOk = leftOk && rightOk && topOk && bottomOk
		
		singleline= end.row - start.row == 0
		(dontMove,nrHPixels) 
				 = case drag of
					Just point  #
									hslop`     = charWidth
									vslop`     = lineHeight
//									leftOk`	  = point.x - hslop` >= left
//									rightOk`  = point.x + hslop` <= right
									leftOk`	  = point.x >= left
									rightOk`  = point.x <= right
									topOk`	  = point.y >= top
									bottomOk` = point.y <= bottom
									mouseOk   = leftOk` && rightOk` && topOk` && bottomOk`

									hslop``     = charWidth * 8
									vslop``     = lineHeight
									leftOk``	 = cursorPoint.x - hslop`` >= left
									rightOk``	 = cursorPoint.x + hslop`` <= right
									topOk``	 	 = cursorPoint.y >= top
									bottomOk``   = cursorPoint.y + vslop`` <= bottom
									cursorOk``   = leftOk`` && rightOk`` && topOk`` && bottomOk``
/*
									nrHPixels	= if (leftOk`` && rightOk``)
													0
													(if rightOk``
													   ( point.x - hslop` - left )
													   ( point.x + hslop` - right )
													)
*/
									nrHPixels``	= if (leftOk`` && rightOk``)
														0
														(if rightOk``
														   (~charWidth)//( point.x - hslop` - left )
														   charWidth//( point.x + hslop` - right )
														)

									nrHPixels	= if (leftOk && rightOk)
													0
													(if rightOk
													   ( cursorPoint.x - charWidth - left )
													   ( cursorPoint.x + charWidth - right )
													)
/*									nrHPixels = if (leftOk`` && rightOk``)
														0
														(if rightOk``
														   ( cursorPoint.x - hslop`` - left )
														   ( cursorPoint.x + hslop`` - right )
														)
*/
//								-> (if singleline (mouseOk || cursorOk``) (cursorOk``), nrHPixels)
								-> if singleline
									(mouseOk || cursorOk``,nrHPixels``)
									(cursorOk``,nrHPixels)
					Nothing		#
									nrHPixels	= if (leftOk && rightOk)
													0
													(if rightOk
													   ( cursorPoint.x - charWidth - left )
													   ( cursorPoint.x + charWidth - right )
													)
								-> (cursorOk, nrHPixels)
Diederik van Arkel's avatar
Diederik van Arkel committed
108
109
110
	in
	
	// if cursor is visible, nothing has to be done
Diederik van Arkel's avatar
Diederik van Arkel committed
111
	IF (dontMove)	   
Diederik van Arkel's avatar
Diederik van Arkel committed
112
113
114
115
116
117
118
119
	THEN  
	  ( skip )
	ELSE
	  (
		let halfHeight	= ( bottom - top ) / 2
			halfWidth	= ( right - left ) / 2
			newTop		= if (topOk && bottomOk) top  (cursorPoint.y - halfHeight)
			newLeft		= if (leftOk && rightOk) left (cursorPoint.x - halfWidth)
Diederik van Arkel's avatar
Diederik van Arkel committed
120
			nrVPixels	= if (topOk && bottomOk)
Diederik van Arkel's avatar
Diederik van Arkel committed
121
122
123
124
125
126
127
							0											// if visible do nothing
							(if bottomOk 
							   ( cursorPoint.y - top )					// if move up move to top...
							   ( cursorPoint.y + lineHeight - bottom )	// if move down move to bottom...
							)
			vector		= if center
							{ vx = newLeft - left, vy = newTop - top }
Diederik van Arkel's avatar
Diederik van Arkel committed
128
							{ vx = nrHPixels, vy = nrVPixels }
Diederik van Arkel's avatar
Diederik van Arkel committed
129
130
131
132
		in
		appEnv (appPIO (moveWindowViewFrame windowId vector))
	  )

Diederik van Arkel's avatar
Diederik van Arkel committed
133
vMoveCursor :: !Movement -> EditMonad (PSt .l) nothing
Diederik van Arkel's avatar
Diederik van Arkel committed
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
vMoveCursor move =
	getWindowId					>>>= \windowId ->
	accEnv (accPIO (getWindowViewFrame windowId))		>>>= \viewFrame -> 
	getSelection				>>>= \{end} ->
	getFontInfo					>>>= \fontInfo=:{FontInfo | lineHeight} ->
	getText						>>>= \text ->
	let // give names to the components of the view frame
		cursorPoint		= positionToPoint end text fontInfo
		left	 		= viewFrame.corner1.x
		right	 		= viewFrame.corner2.x
		top		 		= viewFrame.corner1.y
		bottom	 		= viewFrame.corner2.y
		
		// determine whether the cursor is on the 
		// correct (visible) side of the borders
		leftOk	 		= cursorPoint.x >= left 
		rightOk	 		= cursorPoint.x <= right
		halfWidth		= ( right - left ) / 2
		newLeft			= if (leftOk && rightOk) left (cursorPoint.x - halfWidth)
    	linesInFrame	= (bottom - top) / lineHeight
        pagePixels		= (linesInFrame - 1) * lineHeight 
        topPixel		= 0
        botPixel		= textLength text * lineHeight
        movePixel		= case move of
							PageUp          -> (max topPixel (top - pagePixels)) - top
							PageDown        -> (min botPixel (bottom + pagePixels)) - bottom
							_				-> 0
		vector			= { vx = newLeft - left, vy = movePixel }
	in
	appEnv (appPIO (moveWindowViewFrame windowId vector))

//---

Diederik van Arkel's avatar
Diederik van Arkel committed
167
vDoCursorSafe :: (EditMonad (PSt .l) a) -> EditMonad (PSt .l) a
Diederik van Arkel's avatar
Diederik van Arkel committed
168
169
170
171
172
vDoCursorSafe operation =
	vHideCursor						>>>
	operation						>>>
	vShowCursor

Diederik van Arkel's avatar
Diederik van Arkel committed
173
vShowCursor :: EditMonad (PSt .l) nothing
Diederik van Arkel's avatar
Diederik van Arkel committed
174
175
176
177
178
179
180
181
182
183
184
185
186
187
vShowCursor =
	getSelection					>>>= \selection=:{end} ->
	IF (isEmptySelection selection)
	THEN (
		getCursorVisibility				>>>= \visible ->
		IF visible
		THEN
		  ( skip)
		ELSE
		  (
			getCursorHeight				>>>= \height ->
			getFontInfo					>>>= \fontInfo ->
			getText						>>>= \text ->
			setCursorVisibility True	>>>
188
			vDraw (vDrawCursor True end height text fontInfo)
Diederik van Arkel's avatar
Diederik van Arkel committed
189
190
191
192
		  )
		)
	ELSE (skip)
  
Diederik van Arkel's avatar
Diederik van Arkel committed
193
vHideCursor :: EditMonad (PSt .l) nothing
Diederik van Arkel's avatar
Diederik van Arkel committed
194
195
196
197
198
199
200
201
202
203
vHideCursor =
	getCursorVisibility				>>>= \visible ->
	IF visible
	THEN
	  (
		getCursorHeight				>>>= \height ->			//  == lineHeight from fontInfo
		getFontInfo					>>>= \fontInfo ->
		getText						>>>= \text ->
		getSelection				>>>= \{end} ->
		setCursorVisibility False	>>>
204
		vDraw (vDrawCursor False end height text fontInfo)
Diederik van Arkel's avatar
Diederik van Arkel committed
205
206
207
208
209
210
211
212
213
214
	  )
	ELSE
	  ( skip )

vUpdateCursor :: !Bool !Position !Int !FontInfo !Text !ViewFrame ![Rectangle] -> (*Picture -> *Picture)
vUpdateCursor visible end height fontInfo text viewFrame rectangles =
	IF visible 
	THEN 
	  (
		let
215
216
			point	= positionToPoint end text fontInfo
			{x,y}	= point
Diederik van Arkel's avatar
Diederik van Arkel committed
217
218
		in
		IF (any (isCursorInRectangle point height) rectangles)
Diederik van Arkel's avatar
Diederik van Arkel committed
219
220
//		THEN (seq
		THEN (appXorPicture (seq
221
222
223
		  [ setPenColour Black
		  , drawLine	{ x=x, y=y }
		  				{ x=x, y=y+height - 1 }
Diederik van Arkel's avatar
Diederik van Arkel committed
224
225
//		  ])
		  ]))
Diederik van Arkel's avatar
Diederik van Arkel committed
226
227
228
229
230
231
		ELSE
		  id
	  )
	ELSE
	  id

232
233
vDrawCursor :: Bool Position Int Text FontInfo -> (*Picture -> *Picture)
vDrawCursor show end cursorHeight text fontInfo =
Diederik van Arkel's avatar
Diederik van Arkel committed
234
235
236
237
	let
		p		= positionToPoint end text fontInfo
		{x,y}	= p
	in
238
239
//		( appXorPicture (seq
//			[ setPenColour Black
Diederik van Arkel's avatar
Diederik van Arkel committed
240
/*
241
242
		( (seq
			[ setPenColour (if show Black fontInfo.syntaxColours.backgroundColour)
Diederik van Arkel's avatar
Diederik van Arkel committed
243
244
245
246
			, drawLine	{ x=x, y=y }
						{ x=x, y=y+cursorHeight - 1 }
			])
		)
Diederik van Arkel's avatar
Diederik van Arkel committed
247
248
249
250
251
252
253
254
*/ 
		( if show
		  (appXorPicture (seq
			[ setPenColour Black
			, drawLine	{ x=x, y=y }
						{ x=x, y=y+cursorHeight - 1 }
			]))
		  (seq
255
			[ setPenColour (backcolour x fontInfo)
Diederik van Arkel's avatar
Diederik van Arkel committed
256
257
258
259
			, drawLine	{ x=x, y=y }
						{ x=x, y=y+cursorHeight - 1 }
			])
		)
260
261
262
263
264
265
266
	where
		backcolour :: Int FontInfo -> Colour
		backcolour x {charWidth, marginWidth, syntaxColours}
			| marginWidth > 0 && x >= charWidth * marginWidth
				=	syntaxColours.marginColour
			// otherwise
				=	syntaxColours.backgroundColour
Diederik van Arkel's avatar
Diederik van Arkel committed
267
268
269
270
271
272
273
274
275
276
277
//--- Visual Selection Stuff

vUpdateSelection :: !Selection FontInfo Text ViewFrame [Rectangle] -> (*Picture -> *Picture)
vUpdateSelection selection fontInfo text frame rects =
	IF (isEmptySelection selection) THEN id ELSE (
	let orderedSelection = orderSelection selection
		clippedSelection = clipSelection frame fontInfo orderedSelection
	in
	vHiliteSelection frame rects text fontInfo clippedSelection
	)
 
Diederik van Arkel's avatar
Diederik van Arkel committed
278
vChangeSelectionTo :: Selection -> EditMonad (PSt .l) nothing
Diederik van Arkel's avatar
Diederik van Arkel committed
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
vChangeSelectionTo newSelection =
	// retrieve the current selection from the state and then
	// update the state with the new selection
	
	getSelection									>>>= \oldSelection ->
	setSelection newSelection						>>>
	
	// compute the selections that have to hilited and discard
	// those that are not visible
	
	getViewFrame									>>>= \frame ->
	getText											>>>= \text ->
	getFontInfo										>>>= \fontInfo ->
	let hiliteSels = changeSelection oldSelection newSelection
		visibleHiliteSels = map (clipSelection frame fontInfo) hiliteSels
	in

	// draw the visibile hilite selections
	
	vDraw ((seqmap (vHiliteSelection frame [frame] text fontInfo) 
						visibleHiliteSels))			>>>
	skip

vHiliteSelection :: ViewFrame [Rectangle] Text FontInfo Selection *Picture -> *Picture
vHiliteSelection frame upds text fontInfo selection pic
	# rects = selToRects selection frame text fontInfo
	= appClipPicture (toRegion upds)(seq(map hilite rects) ) pic

Diederik van Arkel's avatar
Diederik van Arkel committed
307
vRemoveSelection :: EditMonad (PSt .l) nothing
Diederik van Arkel's avatar
Diederik van Arkel committed
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
vRemoveSelection =
	getSelection										>>>= \selection ->
	let orderedSelection = orderSelection selection
	in
    IF (isEmptySelection selection)
    THEN
	  ( skip )
	ELSE   
	  (
		let
			pos = orderedSelection.start
		in
		vChangeSelectionTo {start=pos,end=pos}	>>>
		vRemoveText orderedSelection
	  )

//--

// clipSelectionToRectangle takes a selection and a rectangle and
// determines the part of the selection that is visible within
// the rectangle.

clipSelection :: Rectangle FontInfo Selection -> Selection
clipSelection
		{ corner1 = { x = x1, y = y1 }, corner2 = { x = x2, y = y2 } }
		fontInfo=:{FontInfo | lineHeight}
		{ start = { col = col1, row = row1 }, end = { col = col2, row = row2 } }
	#	firstLineNr	= y1     / lineHeight
	#	lastLineNr	= (y2-1) / lineHeight
	| (   row1 < firstLineNr && row2 < firstLineNr		// selection above...
		|| row1 > lastLineNr  && row2 > lastLineNr		// ...or below rectangle?
	   )
		= emptySelection
	# startVisible	= row1 >= firstLineNr && row1 <= lastLineNr
	#		endVisible		= row2 >= firstLineNr && row2 <= lastLineNr
	#		newCol1			= if startVisible col1 0
	#		newRow1			= if startVisible row1 firstLineNr
	#		newCol2			= if endVisible   col2 0
	#		newRow2			= if endVisible   row2 (lastLineNr+1)
	= { start = { col = newCol1, row = newRow1 }
	  		   , end   = { col = newCol2, row = newRow2 }
	  		   }
	 
selToRects :: Selection ViewFrame Text FontInfo -> [Rectangle]
selToRects selection frame text fontInfo=:{FontInfo | lineHeight}
	// get the first line of the selection and split it into the part to the left
	// of the selection start and the part to the right
	# { start={ col=col1, row=row1 }, end=end=:{ col=col2, row=row2 } }
								= orderSelection selection
	# (strings, _)				= getTextFragment {start={col=0,row=row1},end=end} text
	# firstString				= slHead strings
	# firstLeft					= firstString % (0, col1 - 1)
	# firstRight				= firstString % (col1, col2 - 1) 
	# firstY					= row1 * lineHeight
	# firstLeftWidth			= tabStringWidth 0 (splitAtTabs firstLeft) fontInfo
	| row1 == row2
		// selection within one line
		# firstRightWidth		= tabStringWidth firstLeftWidth (splitAtTabs firstRight) fontInfo
		=	[	{ corner1 = { x = firstLeftWidth, y = firstY }
				, corner2 = { x = firstLeftWidth + firstRightWidth, y = firstY + lineHeight }
				}
		  	]
	// selection contains more than one line
	# lastString				= slLast strings
	# lastLeft					= lastString % (0, col2 - 1)
	# lastY						= row2 * lineHeight
	# lastLeftWidth				= tabStringWidth 0 (splitAtTabs lastLeft) fontInfo
	# firstRect					=
			{ corner1 = {x = firstLeftWidth,			y = firstY}
			, corner2 = {x = frame.corner2.x,			y = firstY + lineHeight}
			}
	# middleRect				= 
			{ corner1 = {x = max frame.corner1.x 0,		y = firstY + lineHeight}
			, corner2 = {x = frame.corner2.x,			y = lastY}
			}
	# lastRect					=
			{ corner1 = {x = 0,							y = lastY}
			, corner2 = {x = lastLeftWidth,				y = lastY + lineHeight}
			}
	= [ firstRect, middleRect, lastRect ]

isCursorInRectangle :: !Point2 !Int !Rectangle -> Bool
isCursorInRectangle {x,y} height {corner1={x=x1,y=y1},corner2={x=x2,y=y2}}
  = not ( x < x1 || x >= x2 || y >= y2 || y + height <= y1 )