miw@mucs.UUCP (02/06/87)
This is the fourth Manchester Smalltalk goodie. It provides a mechanism
for writing out Forms or bits of the screen in PostScript format.
The comment at the head of the file describes the operation in more detail.
Mario
------------------------------------------------------------------------
Dept. of Computer Science ARPA: miw%uk.ac.man.cs.ux@cs.ucl.ac.uk
The University USENET: mcvax!ukc!man.cs.ux!miw
Manchester M13 9PL JANET: miw@uk.ac.man.cs.ux
U.K. 061-273 7121 x 5699
------------------------------------------------------------------------
----------------------------------------------------------------
"This package enables one to write Forms out in PostScript format. Two
mechanism are provided:
1. Ability to write out a Form using
aForm psWriteOn: 'aFileName'
2. Ability to dump a section of the display screen. Hit shift-control-d:
you will be asked to designate an area of the screen, whether you want the
cursor to appear in the screen dump, and what file name to write to. "
'From Smalltalk-80, version 2, of April 1, 1983 on 23 January 1987 at 6:49:57 pm'!
!Character class methodsFor: 'accessing untypeable characters'!
lf
"Answer the Character representing a line feed."
^self value: 10! !
!Form methodsFor: 'fileIn/Out'!
dumpHexBytesOn: aFile invert: invert
"write out the bitmap data to the file in hex, rounding up to byte boundaries,
and complementing the bits if necessary"
| count bytesPerLine word byte |
count _ 0.
bytesPerLine _ width + 7 // 8.
height timesRepeat:
[(bytesPerLine // 2) timesRepeat:
[word _ bits at: (count _ count + 1).
invert ifTrue: [word _ word bitXor: -1].
aFile nextPutAll: word printHexWord].
bytesPerLine even "do the last byte"
ifFalse: [byte _ (bits at: (count _ count + 1)) bitShift: -8.
invert ifTrue: [byte _ byte bitXor: -1].
aFile nextPutAll: byte printHexByte].
aFile lf.
Processor yield].! !
!SmallInteger methodsFor: 'printing'!
printHexByte
"print the receiver as two hex chars"
| s |
s _ String new: 2.
s at: 1 put: (Character digitValue: ((self bitAnd: 16rF0) bitShift: -4)).
s at: 2 put: (Character digitValue: (self bitAnd: 16r0F)).
^s!
printHexWord
"print the receiver as four hex chars"
| s |
s _ String new: 4.
s at: 1 put: (Character digitValue: ((self bitAnd: 16rF000) bitShift: -12)).
s at: 2 put: (Character digitValue: ((self bitAnd: 16r0F00) bitShift: -8)).
s at: 3 put: (Character digitValue: ((self bitAnd: 16r00F0) bitShift: -4)).
s at: 4 put: (Character digitValue: (self bitAnd: 16r000F)).
^s! !
!WriteStream methodsFor: 'character writing'!
lf
"Append a linefeed character to the receiver."
self nextPut: Character lf! !
!Form methodsFor: 'conversion to/from PostScript'!
psWriteFileOn: fileName
"Saves the receiver on the file fileName in PostScript format"
" Form fromUser psWriteOn: 'mypic.ps' "
self psWriteFileOn: fileName scaleFactor: 1 "seems a reasonable default"!
psWriteFileOn: fileName scaleFactor: scaleFactor
"Saves the receiver on the file fileName in PostScript format,
mapping one Smalltalk bitmap pixel onto 'scaleFactor' PostScript pixels"
| file |
file _ FileStream fileNamed: fileName.
file text.
file nextPutAll: '%!!'. file lf.
"write the PostScript prologue for this image on the stream.
The transformation matrix is chosen so that the reference point of the
image is at bottom left."
"There are two sensible choices for the transformation matrix:
[width 0 0 height 0 0] (for inclusion in TeX files),
and [width 0 0 -height 0 height] (for straight output to a PostScript device)"
file nextPutAll: ((width*scaleFactor) printString, ' ',
(height*scaleFactor) printString, ' scale').
file lf. "assume a unix file"
file nextPutAll: (width printString, ' ' , height printString, ' 1 [',
width printString, ' 0 0 ',
height negated printString, ' 0 ', height printString, '] {<').
file lf.
"now dump the image data"
self dumpHexBytesOn: file invert: true.
"and end the thing off"
file nextPutAll: '>} image'; lf.
file nextPutAll: 'showpage'.
file lf.
file close!
psWriteOn: fileName
"Saves the receiver on the file fileName in PostScript format"
" Form fromUser psWriteOn: 'mypic.ps' "
self psWriteOn: fileName scaleFactor: 1 "seems a reasonable default"! !
!InputState methodsFor: 'private'!
doScreenDump
| activeProcess currentCursor currentPoint area rect filename |
activeProcess _ ScheduledControllers activeControllerProcess.
(Processor includes: activeProcess) ifTrue: [activeProcess suspend].
currentCursor _ Sensor currentCursor.
currentPoint _ Sensor cursorPoint.
rect _ Rectangle fromUser.
area _ Form fromDisplay: rect.
BinaryChoice
message: 'OR in cursor?'
displayAt: Sensor cursorPoint
centered: true
ifTrue: [area
copyBits: currentCursor boundingBox
from: currentCursor
at: currentPoint - rect origin
clippingBox: area boundingBox
rule: Form paint
mask: Form black]
ifFalse: [].
filename _ FillInTheBlank request: 'Enter filename for bitmap'
initialAnswer: 'filename.ps'.
filename isEmpty
ifFalse: [[Transcript show: 'dumping to file ', filename, '...'.
area psWriteFileOn: filename.
Transcript show: 'done' ; cr] forkAt: Processor userSchedulingPriority].
(Processor includes: activeProcess) ifFalse: [ScheduledControllers activeControllerProcess resume]!
keyAt: keyNumber put: value
| index mask |
index _ keyNumber < 8r200 ifTrue: [KeyboardMap at: keyNumber + 1] ifFalse: [keyNumber].
index < 8r200
ifTrue: "Not a potential special character"
[value ~= 0 ifTrue:
[(ctrlState ~= 0 and: [index = LetterCKey or: [index = $d asciiValue]])
ifTrue: [index = LetterCKey
ifTrue: [lshiftState ~= 0
ifTrue: [self forkEmergencyEvaluatorAt: Processor userInterruptPriority]
ifFalse: [[ScheduledControllers interruptName: 'User Interrupt'] fork]]
ifFalse: [lshiftState ~= 0
ifTrue: [[self doScreenDump] forkAt: Processor userInterruptPriority]]]
ifFalse: [^keyboardQueue nextPut:
(KeyboardEvent code: keyNumber
meta: metaState)]]]
ifFalse:
[index = CtrlKey
ifTrue: [ctrlState _ value bitShift: 1]
ifFalse:
[index = LshiftKey
ifTrue: [lshiftState _ value]
ifFalse:
[index = RshiftKey
ifTrue: [rshiftState _ value]
ifFalse:
[index = LockKey
ifTrue: [lockState _ value bitShift: 2]
ifFalse:
[(index >= BitMin and: [index <= BitMax])
ifTrue:
[mask _ 1 bitShift: index - BitMin.
value = 1
ifTrue: [bitState _ bitState bitOr: mask]
ifFalse: [bitState _ bitState bitAnd: -1 - mask]]
ifFalse:
[value ~= 0 ifTrue:
[keyboardQueue nextPut:
(KeyboardEvent code: keyNumber meta: metaState)]]]]]].
metaState _ (ctrlState bitOr: (lshiftState bitOr: rshiftState)) bitOr: lockState]! !
!ProcessorScheduler methodsFor: 'accessing'!includes: aProcess
"Has aProcess been suspended?"
^(quiescentProcessLists at: aProcess priority) includes: aProcess! !
----------------------------------------------------------------
--
------------------------------------------------------------------------
Dept. of Computer Science ARPA: miw%uk.ac.man.cs.ux@cs.ucl.ac.uk
The University USENET: mcvax!ukc!man.cs.ux!miw
Manchester M13 9PL JANET: miw@uk.ac.man.cs.ux
U.K. 061-273 7121 x 5699
------------------------------------------------------------------------miw@mucs.UUCP (04/03/87)
Here's another Smalltalk goodie (no 5 in a series). This is rather larger than the previous postings, but has been in use for a number of months so hopefully has been shaken down. It (re-)implements the user interface to Smalltalk scrollbars, (hopefully) making them easier to use (judge for yourselves). It replaces some of the existing code in the system, so make sure you have a backup image before you file this in and check out whether you like it or not. More explanation is given in the introductory comment. The first part is a small package that implements vertical and horizontal arrows (the vertical ones are used when scrolling). After that comes the scrollbar stuff proper. Incidentally, this package suffers from a problem which seems (at least to me) difficult to solve. A number of methods in the system are modified in different ways by everybody, e.g. the methods that define pop-up menus, and in this case, the set of different cursors. The problem occurs when you want to file in more than one goodie---you have to ensure that later ones don't undo the work others. Does anyone have any ideas on how we might get round this problem? Mario ------------------------------------------------------------------------ Dept. of Computer Science ARPA: miw%uk.ac.man.cs.ux@cs.ucl.ac.uk The University USENET: mcvax!ukc!man.cs.ux!miw Manchester M13 9PL JANET: miw@uk.ac.man.cs.ux U.K. 061-273 7121 x 5699 ------------------------------------------------------------------------ 'From Smalltalk-80, version 2, of April 1, 1983 on 2 October 1986 at 5:04:36 pm'! DisplayObject subclass: #Arrow instanceVariableNames: 'origin length ' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! Arrow comment: 'I am the abstract superclass of arrows. I have two instance variables, origin <aPoint> where the arrow begins, and length <aNumber> the length of the arrows. My subclasses add direction. '! !Arrow methodsFor: 'accessing'! length ^length! origin ^origin! origin: aPoint length: aNumber origin _ aPoint. length _ aNumber! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Arrow class instanceVariableNames: ''! !Arrow class methodsFor: 'instance creation'! origin: aPoint length: aNumber ^self new origin: aPoint length: aNumber! ! 'From Smalltalk-80, version 2, of April 1, 1983 on 2 October 1986 at 5:04:38 pm'! Arrow subclass: #HorizontalArrow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! HorizontalArrow comment: 'I am the class of arrows drawn in the x-direction. If my instance''s length is negative, it goes leftwards. '! !HorizontalArrow methodsFor: 'display box access'! computeBoundingBox "this method assumes that a cursor with its hotspot at the centre will be used as the arrow head" ^Rectangle origin: (origin x min: origin x + length) @ (origin y - 8) extent: length abs @ 16! ! !HorizontalArrow methodsFor: 'displaying'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm | lineform arrowHead arrowHeadPoint line originPoint lineLength | length = 0 ifTrue: [^self]. "zero length arrows can't be seen" "this is the form we're going to use to draw the arrow line" lineform _ ((Form extent: 2@2) offset: 0@-1) black. "here we fiddle with the length because of the non-zero line thickness" length positive ifTrue: [originPoint _ origin. lineLength _ length] ifFalse: [originPoint _ origin - (lineform width@0). lineLength _ length + 2]. "this is the form we're going to use as the head of the arrow" arrowHead _ lineLength positive ifTrue: [Cursor rightArrowHead] ifFalse: [Cursor leftArrowHead]. "Calculate where the arrow head should go. This assumes that the base of the arrow is at 8@8" arrowHeadPoint _ originPoint + (((lineLength abs - 8 max: 0) * lineLength sign)@0). "display the parts of the arrow" arrowHead displayOn: aDisplayMedium at: arrowHeadPoint+aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm. line _ Line from: originPoint to: arrowHeadPoint withForm: lineform. line displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm! ! !HorizontalArrow methodsFor: 'accessing'! offset ^(length min: 0) @ -8! ! 'From Smalltalk-80, version 2, of April 1, 1983 on 2 October 1986 at 5:04:43 pm'! Arrow subclass: #VerticalArrow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! VerticalArrow comment: 'I am the class of arrows drawn in the y-direction. If my instance''s length is negative, it goes upwards. '! !VerticalArrow methodsFor: 'displaying'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm | lineform arrowHead arrowHeadPoint line originPoint lineLength | length = 0 ifTrue: [^self]. "zero length arrows can't be seen" "this is the form we're going to use to draw the arrow line" lineform _ ((Form extent: 2@2) offset: -1@0) black. "here we fiddle with the length because of the non-zero line thickness" length positive ifTrue: [originPoint _ origin. lineLength _ length] ifFalse: [originPoint _ origin - (0@lineform height). lineLength _ length + 2]. "this is the form we're going to use as the head of the arrow" arrowHead _ lineLength positive ifTrue: [Cursor downArrowHead] ifFalse: [Cursor upArrowHead]. "Calculate where the arrow head should go. This assumes that the base of the arrow is at 8@8" arrowHeadPoint _ originPoint + (0@((lineLength abs - 8 max: 0) * lineLength sign)). "display the parts of the arrow" arrowHead displayOn: aDisplayMedium at: arrowHeadPoint+aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm. line _ Line from: originPoint to: arrowHeadPoint withForm: lineform. line displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger mask: aForm! ! !VerticalArrow methodsFor: 'display box access'! computeBoundingBox "this method assumes that a cursor with its hotspot at the centre will be used as the arrow head" ^Rectangle origin: (origin x - 8) @ (origin x min: origin x + length) extent: 16 @ length abs! ! !VerticalArrow methodsFor: 'accessing'! offset ^-8 @(length min: 0)! ! ------------------------------------------------------------------------ "This package implements a new user interface for the scrolling mechanism in ScrollController. Whereas the old user interface divided a scroll bar into three different areas, this package uses different buttons to select the different scrolling functions, and makes the scroll bar area uniform. The left button provides rate-controlled continuous scrolling. Pressing the left button down while over the scroll bar causes an up-down arrow cursor to appear. Moving the cursor upwards causes it to change into an uparrow, and drags the 'visible' box within the scroll bar upwards. The speed at which the view and the 'visible' box scroll is governed by the distance the cursor is moved. Moving it downwards causes scrolling in the opposite direction. Thus, to make a text view scroll slowly upwards, press the left button down while over the scroll bar, and move it a short distance downwards. The middle button provides absolute scrolling. While the middle button is held down over the scroll bar, the 'visible' box will follow it, scrolling the view to the corresponding position. The right button provides a jump scroll. Holding it down over the scroll bar cause an uparrow to appear, connecting the current cursor position to the top of the scroll bar. When the button is released, the line in the view next to the tail of the arrow will jump to the top of the view. Extra points to note: While a button is held down over the scroll bar, that is, while scrolling is taking place, all horizontal movements of the mouse are ignored. This means that you need not look at the scroll bar while scrolling, as the cursor cannot wander off it. Various aspects of the scroll bar can be customised. The width of the scroll bar, the width and color of the visible box, and the sensitivity of the left button continuous scroll can all be changed. See the protocol in ScrollController for initialisation. " 'From Smalltalk-80, version 2, of April 1, 1983 on 2 October 1986 at 5:24:35 pm'! !Behavior methodsFor: 'enumerating'! allInstancesAndSubInstancesDo: aBlock "evaluate the block for all instances of this class and its subclasses" self allInstancesDo: aBlock. self allSubInstancesDo: aBlock! ! Cursor addClassVarName: 'DownArrowHeadCursor'! Cursor addClassVarName: 'LeftArrowHeadCursor'! Cursor addClassVarName: 'RightArrowHeadCursor'! Cursor addClassVarName: 'UpArrowHeadCursor'! Cursor addClassVarName: 'UpDownCursor'! !Cursor methodsFor: 'displaying'! show "Make the current cursor shape be the receiver." Sensor currentCursor ~= self ifTrue: [Sensor currentCursor: self]! ! 'From Smalltalk-80, version 2, of April 1, 1983 on 2 October 1986 at 5:24:39 pm'! !Cursor class methodsFor: 'class initialization'! initializeOthers "initialize any new, non-standard cursors" UpDownCursor _ (Cursor extent: 16@16 fromArray: #( 2r110000000 2r1111000000 2r11111100000 2r111111110000 2r1111111111000 2r110000000 2r110000000 2r110000000 2r110000000 2r110000000 2r110000000 2r1111111111000 2r111111110000 2r11111100000 2r1111000000 2r110000000) offset: -8@-8). UpArrowHeadCursor _ (Cursor extent: 16@16 fromArray: #( 2r110000000 2r1111000000 2r11111100000 2r111111110000 2r1111111111000 2r110000000 2r110000000 2r110000000 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0) offset: -8@-8). DownArrowHeadCursor _ (Cursor extent: 16@16 fromArray: #( 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r0 2r110000000 2r110000000 2r110000000 2r1111111111000 2r111111110000 2r11111100000 2r1111000000 2r110000000) offset: -8@-8). LeftArrowHeadCursor _ (Cursor extent: 16@16 fromArray: #( 2r0 2r0 2r0 2r100000000000 2r1100000000000 2r11100000000000 2r111100000000000 2r1111111100000000 2r1111111100000000 2r111100000000000 2r11100000000000 2r1100000000000 2r100000000000 2r0 2r0 2r0) offset: -8@-8). RightArrowHeadCursor _ (Cursor extent: 16@16 fromArray: #( 2r0 2r0 2r0 2r10000 2r11000 2r11100 2r11110 2r11111111 2r11111111 2r11110 2r11100 2r11000 2r10000 2r0 2r0 2r0) offset: -8@-8) "Cursor initializeOthers"! !Cursor initializeOthers! !Cursor class methodsFor: 'constants'! leftArrowHead ^LeftArrowHeadCursor! rightArrowHead ^RightArrowHeadCursor! upArrowHead ^UpArrowHeadCursor! downArrowHead ^DownArrowHeadCursor! upDown "Answer the instance of me that is the shape of an up-down double-headed arrow. " ^UpDownCursor! ! 'From Smalltalk-80, version 2, of April 1, 1983 on 2 October 1986 at 5:24:43 pm'! !DisplayObject methodsFor: 'displaying-Display'! backgroundAt: location "Answer a Form containing the contents of the Display which will be altered if I am displayed at location. The Form remembers location in its offset" | backgroundOrigin | backgroundOrigin _ location + self offset. ^ (Form fromDisplay: (backgroundOrigin extent: self extent)) offset: backgroundOrigin! moveTo: newLoc restoring: background "Move an image to a new location on the Display, restoring the background without causing flashing. Background must be a Form containing the bits to be restored at the previous location (its offset), and this method will update its bits and offset appropriately" | location saveAll rect1 rect2 bothRects | "This method should be rewritten to use the offset in background directly" (location _ background offset) = (newLoc + self offset) ifTrue: [^background]. background offset: 0@0. rect1 _ location extent: self extent. rect2 _ newLoc + self offset extent: self extent. bothRects _ rect1 merge: rect2. (rect1 intersects: rect2) ifTrue: "When overlap, buffer background for both rectangles" [saveAll _ Form fromDisplay: bothRects. background displayOn: saveAll at: rect1 origin - bothRects origin. "now saveAll is clean background; get new bits for background" background copy: (0@0 extent: self extent) from: rect2 origin - bothRects origin in: saveAll rule: Form over. self displayOn: saveAll at: rect2 origin - bothRects origin - self offset. saveAll displayOn: Display at: bothRects origin] ifFalse: "If no overlap, do the simple thing (bothrects might be too big)" [background displayOn: Display at: location. background fromDisplay: rect2. self displayOn: Display at: newLoc]. ^ background offset: newLoc + self offset! ! 'From Smalltalk-80, version 2, of April 1, 1983 on 2 October 1986 at 5:24:47 pm'! !InputSensor methodsFor: 'mouse'! waitForMouseChange "Wait for the button state or the current mouse point to change, then report the mouse point." | position buttons | position _ self cursorPoint. buttons _ self buttons. [(self cursorPoint = position) & (self buttons = buttons)] whileTrue: [Processor yield]. ^self cursorPoint! ! !Magnitude methodsFor: 'comparing'! max: maxVal min: minVal "return self constrained to lie between min and max" ^(self max: maxVal) min: minVal! ! 'From Smalltalk-80, version 2, of April 1, 1983 on 2 October 1986 at 5:24:48 pm'! !OpaqueForm methodsFor: 'accessing'! offset: aPoint figure offset: aPoint! ! 'From Smalltalk-80, version 2, of April 1, 1983 on 2 October 1986 at 5:24:50 pm'! !Point methodsFor: 'comparing'! max: maxPoint min: minPoint "Answer self, constrained to lie between minPoint and maxPoint" ^Point x: (x max: minPoint x min: maxPoint x) y: (y max: minPoint y min: maxPoint y)! ! !Point methodsFor: 'arithmetic'! negated ^x negated @ y negated! ! 'From Smalltalk-80, version 2, of April 1, 1983 on 2 October 1986 at 5:24:51 pm'! ScrollController addClassVarName: 'InsideColorMask'! ScrollController addClassVarName: 'MarkerRegionWidth'! ScrollController addClassVarName: 'RegionWidth'! ScrollController addClassVarName: 'ScrollSpeed'! ScrollController comment: 'I represent control for scrolling using a scrollBar. I am a MouseMenuController that creates a scrollBar, rather than menus. My subclasses add the button menus. I keep control as long as the cursor is inside the view or the scrollBar area. A scrollBar is a rectangular area representing the length of the information being viewed. It contains an inner rectangle whose top y-coordinate represents the relative position of the information visible on the screen with respect to all of the information, and whose size represents the relative amount of that information visible on the screen. The user controls which part of the information is visible by pressing the red button. If the user drags the scroll bar up or down (using the red button), the view scrolls up or down accordingly. The greater the drag, the faster the view scrolls. The yellow button positions the view absolutely. The blue button jumps the line nearest the cursor to the top of the view. Instance Variables: scrollBar <Quadrangle> inside white, the outer rectangle marker <Quadrangle> inside color is InsideColorMask, the inner rectangle savedArea <Form> the area the scrollBar overlaps, restored whenever the scrollBar is hidden Class Variables: InsideColorMask <Form> indicating the color of the inner rectangle RegionWidth <Integer> indicating the width of the outer rectangle MarkerregionWidth <Integer> indicating the width of the inner rectangle '! !ScrollController methodsFor: 'arrow access/display'! displayArrowAt: aPoint "make an arrow based on the position of aPoint relative to the scroll bar, save the background behind it, display the arrow, and return the background." | arrow background | arrow _ self makeArrowFromPoint: aPoint. background _ arrow backgroundAt: aPoint. arrow displayAt: aPoint. ^background! makeArrowFromPoint: aPoint "make an arrow marker of the appropriate length (difference in y between aPoint and the top of the marker, and display it." | length arrow form opaqueArrow | length _ scrollBar inside top - aPoint y. "now make the arrow, and thence an OpaqueForm from it:" arrow _ VerticalArrow origin: 0@0 length: length. "paint the arrow onto a Form" form _ (Form new extent: arrow extent) offset: arrow offset. arrow displayOn: form at: arrow offset negated. "make the Form into an OpaqueForm" opaqueArrow _ OpaqueForm shape: form. ^opaqueArrow! ! !ScrollController methodsFor: 'initialize-release'! initialize super initialize. scrollBar _ Quadrangle new. scrollBar borderWidthLeft: 2 right: 0 top: 2 bottom: 2. marker _ Quadrangle new. marker insideColor: InsideColorMask! ! !ScrollController methodsFor: 'basic control sequence'! controlInitialize "The scrollbar has a two-pixel border, and for alignment it assumes that this sub-view has a one-pixel border and shares another one-pixel border from its neighbor/super view" super controlInitialize. scrollBar region: (0 @ 0 extent: RegionWidth @ (view displayBox height + 2)). marker region: self computeMarkerRegion. scrollBar _ scrollBar align: scrollBar topRight with: view displayBox topLeft - (0@1). marker _ marker align: marker topCenter with: scrollBar inside topCenter. savedArea _ Form fromDisplay: scrollBar. scrollBar displayOn: Display. self moveMarker! ! !ScrollController methodsFor: 'scrolling'! canScrollInDirection: plusOrMinus "answer whether the receiver can scroll in the direction indicated by plusOrMinus: up if <0, down if >0" ^plusOrMinus strictlyPositive ifTrue: [marker top > scrollBar inside top] ifFalse: [marker bottom < scrollBar inside bottom]! scroll "Check to see whether the user wishes to jump, scroll up, or scroll down. " Cursor upDown showWhile: [[self scrollBarContainsCursor] whileTrue: [Processor yield. self scrollAsNecessary]]! scrollAbsolute | scrollingStartLocation cursorPoint oldCursorPt xAxis | scrollingStartLocation _ cursorPoint _ sensor cursorPoint. xAxis _ marker center x. "we constrain the cursor to fall on this xAxis, and within the scroll bar" Cursor cursorLink: false. Cursor marker showWhile: [ [sensor yellowButtonPressed] whileTrue: [ cursorPoint ~= oldCursorPt ifTrue: [oldCursorPt _ cursorPoint. sensor cursorPoint: xAxis @ (cursorPoint y max: scrollBar inside top min: scrollBar inside bottom). self scrollAbsoluteFrom: scrollingStartLocation to: cursorPoint]. cursorPoint _ sensor cursorPoint "could use sensor waitForMouseChange on really fast systems" ] ]. scrollBar display. self moveMarker. Cursor cursorLink: true. "ensure the cursor doesn't leap out of the scroll bar" sensor cursorPoint: xAxis @ cursorPoint y! scrollAbsoluteFrom: scrollingStartLocation to: aPoint | oldMarker | oldMarker _ marker. marker _ marker translateBy: 0 @ ((aPoint y - marker center y) max: (scrollBar inside top - marker top) min: (scrollBar inside bottom - marker bottom)). (oldMarker areasOutside: marker) , (marker areasOutside: oldMarker) do: [:region | Display fill: region rule: Form reverse mask: Form gray]. self scrollView! scrollAmountFrom: aPoint relativeTo: startPoint "answer the number of bits of y-coordinate to scroll relative to aPoint" ^((aPoint - startPoint) y) quo: ScrollSpeed! scrollAsNecessary "scroll relative if the red button is used, absolute if the yellow button is used" sensor redButtonPressed ifTrue: [self scrollRelative]. sensor yellowButtonPressed ifTrue: [self scrollAbsolute]. sensor blueButtonPressed ifTrue: [self scrollJumpUp]! scrollFrom: aPoint relativeTo: startPoint "scroll the view by an amount dictated by the difference between aPoint and startPoint" | scrollAmount | scrollAmount _ self scrollAmountFrom: aPoint relativeTo: startPoint. scrollAmount ~= 0 ifTrue: [ (self canScrollInDirection: scrollAmount) ifTrue: [ self scrollView: scrollAmount. self moveMarker]]! scrollRelative | scrollingStartLocation cursorPoint oldCursorPt xAxis | scrollingStartLocation _ sensor cursorPoint. xAxis _ marker center x. "we constrain the cursor to fall on this xAxis" Cursor cursorLink: false. Cursor upDown showWhile: [ [sensor redButtonPressed] whileTrue: [ cursorPoint _ sensor cursorPoint. cursorPoint ~= oldCursorPt ifTrue: [oldCursorPt _ cursorPoint. sensor cursorPoint: xAxis @ cursorPoint y]. cursorPoint y = scrollingStartLocation y ifTrue: [Cursor upDown show] ifFalse: [cursorPoint y < scrollingStartLocation y ifTrue: [Cursor upArrowHead show] ifFalse: [Cursor downArrowHead show]. self scrollFrom: scrollingStartLocation relativeTo: cursorPoint]. Processor yield ] ]. Cursor cursorLink: true. "ensure the cursor doesn't leap out of the scroll bar" sensor cursorPoint: xAxis @ cursorPoint y! scrollView: anInteger "If anInteger is not zero, tell the reciever's view to scroll by anInteger amount." anInteger ~= 0 ifTrue: [view scrollBy: 0 @ (anInteger max: (view window top - view boundingBox bottom) min: (view window top - view boundingBox top)). view clearInside. view display]! ! !ScrollController methodsFor: 'marker adjustment'! computeMarkerRegion "Answer the rectangular area in which the gray area of the scroll bar should be displayed." ^0@0 extent: MarkerRegionWidth @ ((view window height asFloat / view boundingBox height * scrollBar inside height) rounded min: scrollBar inside height)! moveMarker: anInteger "Update the marker so that is is translated by an amount corresponding to a distance of anInteger, constrained within the boundaries of the scroll bar." Display fill: marker mask: scrollBar insideColor. marker _ marker translateBy: 0 @ (anInteger max: (scrollBar inside top - marker top) min: (scrollBar inside bottom - marker bottom)). marker displayOn: Display! ! !ScrollController methodsFor: 'private'! scrollJumpUp | cursorPoint oldCursorPoint xAxis arrow background | xAxis _ marker center x. oldCursorPoint _ xAxis @ sensor cursorPoint y. background _ self displayArrowAt: oldCursorPoint. Cursor blank showWhile: [ [sensor blueButtonPressed] whileTrue: [ cursorPoint _ xAxis @ (sensor waitForMouseChange y max: scrollBar inside top min: scrollBar inside bottom). cursorPoint ~= oldCursorPoint ifTrue:[ background display. background _ self displayArrowAt: cursorPoint. oldCursorPoint _ cursorPoint]. ] ]. background display. sensor cursorPoint: oldCursorPoint. self canScroll ifTrue: [self scrollViewUp. self moveMarker]! setInsideColor: aMask marker insideColor: aMask! ! !ScrollController class methodsFor: 'initialize'! initializePreferences "This sets up the class variables which are used for widths, colour" self regionWidth: 20. self insideColorMask: Form lightGray. self scrollSpeed: 3 "ScrollController initializePreferences"! insideColorMask: aMask InsideColorMask _ aMask. ScrollController allInstancesAndSubInstancesDo: [:aScrollController | aScrollController setInsideColor: aMask] "ScrollController insideColorMask: Form lightGray"! regionWidth: aWidth RegionWidth _ aWidth. MarkerRegionWidth _ aWidth - 2. "ScrollController regionWidth: 25"! scrollSpeed: anInteger "change this constant to suit: it affects the speed of the scroll" ScrollSpeed _ anInteger "ScrollController scrollSpeed: 3"! ! !ParagraphEditor methodsFor: 'marker adjustment'! computeMarkerRegion paragraph compositionRectangle height = 0 ifTrue: [^0@0 extent: MarkerRegionWidth @ scrollBar inside height] ifFalse: [^0@0 extent: MarkerRegionWidth @ ((paragraph clippingRectangle height asFloat / self scrollRectangleHeight * scrollBar inside height) rounded min: scrollBar inside height)]! ! !ListController methodsFor: 'marker adjustment'! computeMarkerRegion | viewList | viewList _ view list. ^ 0@0 extent: MarkerRegionWidth@ ((viewList clippingRectangle height asFloat / viewList compositionRectangle height * scrollBar inside height) rounded min: scrollBar inside height)! !ScrollController initializePreferences! -------------------------------------------------------------------------- ------------------------------------------------------------------------ Dept. of Computer Science ARPA: miw%uk.ac.man.cs.ux@cs.ucl.ac.uk The University USENET: mcvax!ukc!man.cs.ux!miw Manchester M13 9PL JANET: miw@uk.ac.man.cs.ux U.K. 061-273 7121 x 5699 ------------------------------------------------------------------------