--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Button.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,784 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Label subclass:#Button
+ instanceVariableNames:'pressActionBlock releaseActionBlock
+ enabled pressed active
+ autoRepeat repeatBlock
+ onLevel offLevel
+ initialDelay repeatDelay
+ disabledFgColor
+ activeFgColor activeBgColor
+ enteredFgColor enteredBgColor
+ isReturnButton
+ shadowForm lightForm
+ formColor formShadowColor formLightColor'
+ classVariableNames:'returnForm returnLightForm returnShadowForm'
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+Button comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+
+written spring/summer 89 by claus
+'!
+
+!Button class methodsFor:'documentation'!
+
+documentation
+"
+ Buttons are Labels which do something when pressed/released.
+
+ Instance variables:
+
+ pressActionBlock <Block> block to evaluate when pressed
+ releaseActionBlock <Block> block to evaluate when released
+ enabled <Boolean> pressing is allowed
+ active <Boolean> true during action evaluation (internal)
+ pressed <Boolean> true if currently pressed
+ autoRepeat <Boolean> allows auto-repeat when pressed long enough
+ repeatBlock <Block> block evaluated for auto-repeat
+ onLevel <Number> level when pressed (3D only)
+ offLevel <Number> level when released (3D only)
+ initialDelay <Number> seconds till first auto-repeat
+ repeatDelay <Number> seconds of repeat intervall
+ disabledFgColor <Color> color used to draw logo when disabled
+ activeFgColor <Color> color to draw logo when pressed
+ activeBgColor <Color> bg color when pressed
+ enteredFgColor <Color> color to draw logo when cursor entered
+ enteredBgColor <Color> bg color when cursor entered
+
+ isReturnButton <Boolean> true if this button is also activated by the
+ return key
+ shadowForm <Form> form to display in addition to buttons label
+ lightForm <Form> light part of shadowForm
+ formColor <Color> color to draw form with
+ formShadowColor <Color> color for shadowing the form (3D only)
+ formLightColor <Color> color for lighting the form (3D only)
+"
+! !
+
+!Button class methodsFor:'defaults'!
+
+defaultInitialDelay
+ "when autorepeat is enabled, and button is not released,
+ start repeating after initialDelay seconds"
+
+ ^ 0.2
+!
+
+defaultRepeatDelay
+ "when autorepeat is enabled, and button is not released,
+ repeat every repeatDelay seconds"
+
+ ^ 0.025
+!
+
+returnFormOn:aDevice
+ "return the form used for the return arrow in non-3D;
+ cache the one for Display for the next round."
+
+ |f|
+
+ ((aDevice == Display) and:[returnForm notNil]) ifTrue:[
+ ^ returnForm
+ ].
+ f := Form fromFile:'Return.xbm' resolution:100 on:aDevice.
+ f isNil ifTrue:[
+ f := Form width:24 height:16 fromArray:#(2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000011 2r11100000
+ 2r00000001 2r10000011 2r11100000
+ 2r00000011 2r10000011 2r11100000
+ 2r00000111 2r11111111 2r11100000
+ 2r00001111 2r11111111 2r11100000
+ 2r00011111 2r11111111 2r11100000
+ 2r00001111 2r11111111 2r11100000
+ 2r00000111 2r11111111 2r11100000
+ 2r00000011 2r10000000 2r00000000
+ 2r00000001 2r10000000 2r00000000
+ 2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00000000)
+ on:aDevice
+ ].
+ (aDevice == Display) ifTrue:[
+ returnForm := f
+ ].
+ ^ f
+!
+
+returnShadowFormOn:aDevice
+ "return the form used for the return arrow shadow pixels (3D only);
+ cache the one for Display for the next round."
+
+ |f|
+
+ ((aDevice == Display) and:[returnShadowForm notNil]) ifTrue:[
+ ^ returnShadowForm
+ ].
+ f := Form fromFile:'ReturnShadow.xbm' resolution:100 on:aDevice.
+ f isNil ifTrue:[
+ f := Form width:24 height:16 fromArray:#(2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000011 2r11100000
+ 2r00000001 2r10000010 2r00000000
+ 2r00000010 2r10000010 2r00000000
+ 2r00000100 2r11111110 2r00000000
+ 2r00001000 2r00000000 2r00000000
+ 2r00010000 2r00000000 2r00000000
+ 2r00001000 2r00000000 2r00000000
+ 2r00000100 2r00000000 2r00000000
+ 2r00000010 2r00000000 2r00000000
+ 2r00000001 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00000000)
+ on:aDevice
+ ].
+ (aDevice == Display) ifTrue:[
+ returnShadowForm := f
+ ].
+ ^ f
+!
+
+returnLightFormOn:aDevice
+ "return the form used for the return arrow light pixels (3D only);
+ cache the one for Display for the next round"
+
+ |f|
+
+ ((aDevice == Display) and:[returnLightForm notNil]) ifTrue:[
+ ^ returnLightForm
+ ].
+ f := Form fromFile:'ReturnLight.xbm' resolution:100 on:aDevice.
+ f isNil ifTrue:[
+ f := Form width:24 height:16 fromArray:#(2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00100000
+ 2r00000000 2r00000000 2r00100000
+ 2r00000000 2r00000000 2r00100000
+ 2r00000000 2r00000000 2r00100000
+ 2r00000000 2r00000000 2r00100000
+ 2r00000000 2r00000000 2r00100000
+ 2r00000000 2r11111111 2r11100000
+ 2r00000000 2r10000000 2r00000000
+ 2r00000000 2r10000000 2r00000000
+ 2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00000000
+ 2r00000000 2r00000000 2r00000000)
+ on:aDevice
+ ].
+ (aDevice == Display) ifTrue:[
+ returnLightForm := f
+ ].
+ ^ f
+! !
+
+!Button class methodsFor:'instance creation'!
+
+label:aLabel action:aBlock in:aView
+ "create and return a new Button with text-label, aString
+ and pressAction, aBlock. Button is placed into aView."
+
+ ^ ((self in:aView) label:aLabel) action:aBlock
+!
+
+form:aForm action:aBlock in:aView
+ "create and return a new Button with icon-label, aForm
+ and pressAction, aBlock. Button is placed into aView."
+
+ ^ ((self in:aView) form:aForm) action:aBlock
+! !
+
+!Button methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ enabled := true.
+ active := false.
+ autoRepeat := false.
+ initialDelay := self class defaultInitialDelay.
+ repeatDelay := self class defaultRepeatDelay.
+ pressed := false.
+ isReturnButton := false.
+
+ self initStyle
+!
+
+initStyle
+ super initStyle.
+
+ onLevel := -1.
+ offLevel := 1.
+
+ disabledFgColor := Color grey.
+ enteredFgColor := fgColor.
+ enteredBgColor := bgColor.
+
+ (style == #next) ifTrue:[
+ softEdge := true.
+ onLevel := 1.
+ offLevel := 2.
+ device hasGreyscales ifTrue:[
+ activeFgColor := Black.
+ activeBgColor := White.
+ enteredFgColor := fgColor.
+ enteredBgColor := Color lightGrey.
+ halfShadowColor := Color darkGrey.
+ shadowColor := Black.
+ ]
+ ] ifFalse:[
+ (style == #openwin) ifTrue:[
+ device hasGreyscales ifTrue:[
+ activeFgColor := Black.
+ activeBgColor := Color grey
+ ]
+ ] ifFalse:[
+ (style == #mswindows) ifTrue:[
+ disabledFgColor := Color darkGrey.
+ device hasGreyscales ifTrue:[
+ offLevel := 3.
+ onLevel := -1.
+ softEdge := true.
+ fgColor := Black.
+ bgColor := Grey.
+ halfShadowColor := Color darkGrey.
+ shadowColor := Black.
+ activeFgColor := fgColor.
+ activeBgColor := bgColor
+ ]
+ ] ifFalse:[
+ (style == #iris) ifTrue:[
+ offLevel := 3.
+ onLevel := -1.
+ softEdge := true.
+ halfShadowColor := Color darkGrey.
+ shadowColor := Black.
+ disabledFgColor := Color darkGrey.
+ enteredFgColor := fgColor.
+ device hasGreyscales ifTrue:[
+ enteredBgColor := Color lightGrey.
+ activeBgColor := enteredBgColor.
+ activeFgColor := enteredFgColor.
+ ] ifFalse:[
+ enteredBgColor := Color veryLightGrey.
+ activeBgColor := Black.
+ activeFgColor := White.
+ ].
+ ] ifFalse:[
+ device hasColors ifTrue:[
+ activeFgColor := Color red:100 green:100 blue:0 "yellow"
+ ] ifFalse:[
+ activeFgColor := White
+ ].
+ device hasGreyscales ifTrue:[
+ activeBgColor := bgColor
+ ] ifFalse:[
+ activeBgColor := Black
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ "default for mono-displays and non-3D"
+ activeFgColor isNil ifTrue:[
+ activeFgColor := White.
+ activeBgColor := Black
+ ].
+ self level:offLevel.
+ margin := (onLevel abs) max:(offLevel abs).
+
+ self is3D ifTrue:[
+ shadowForm := self class returnShadowFormOn:device.
+ lightForm := self class returnLightFormOn:device.
+ formColor := viewBackground.
+ formShadowColor := shadowColor.
+ formLightColor := lightColor
+ ] ifFalse:[
+ shadowForm := self class returnFormOn:device.
+ formColor := Black
+ ].
+
+!
+
+initCursor
+ "set up a hand cursor"
+
+ cursor := Cursor hand
+!
+
+initEvents
+ super initEvents.
+ self enableButtonEvents.
+ self enableEnterLeaveEvents
+!
+
+realize
+ super realize.
+ active := false.
+
+ fgColor := fgColor on:device.
+ bgColor := bgColor on:device.
+ activeFgColor := activeFgColor on:device.
+ activeBgColor := activeBgColor on:device.
+ enteredFgColor := enteredFgColor on:device.
+ enteredBgColor := enteredBgColor on:device.
+ formColor := formColor on:device.
+!
+
+reinitialize
+ super reinitialize.
+ active := false
+! !
+
+!Button methodsFor:'accessing'!
+
+is3D
+ "return true, if the receiver is a 3D style view"
+
+ style == #mswindows ifTrue:[^ true].
+ ^ super is3D
+!
+
+isReturnButton:aBoolean
+ "show/dont show a return-key image after the label"
+
+ isReturnButton ~~ aBoolean ifTrue:[
+ isReturnButton := aBoolean.
+ self newLayout
+ ]
+!
+
+disable
+ "disable the button"
+
+ enabled ifTrue:[
+ enabled := false.
+ self redraw
+ ]
+!
+
+enable
+ "enable the button"
+
+ enabled ifFalse:[
+ enabled := true.
+ self redraw
+ ]
+!
+
+turnOffWithoutRedraw
+ "turn the button off - no redraw"
+
+ pressed := false.
+ active := false.
+ self is3D ifTrue:[
+ "do not use super level:offLevel
+ - that one redraws the edges.
+ Shure, this is no good coding style"
+ level := offLevel.
+ margin := level abs
+ ]
+!
+
+turnOff
+ "turn the button off (if not already off)"
+
+ pressed ifTrue:[
+ active := false.
+ pressed := false.
+ self level:offLevel.
+ self redraw
+ ]
+!
+
+turnOn
+ "turn the button on (if not already on)"
+
+ pressed ifFalse:[
+ pressed := true.
+ self level:onLevel.
+ self redraw
+ ]
+!
+
+pressAction:aBlock
+ "define the action to be performed on press"
+
+ pressActionBlock := aBlock
+!
+
+releaseAction:aBlock
+ "define the action to be performed on release"
+
+ releaseActionBlock := aBlock
+!
+
+action:aBlock
+ "convenient method: define the press-action clear any release-action"
+
+ releaseActionBlock := nil.
+ pressActionBlock := aBlock
+!
+
+autoRepeat
+ "turn on autorepeat"
+
+ autoRepeat := true.
+ repeatBlock := [self repeat]
+!
+
+isOn
+ "return true, if this button is currently pressed"
+
+ ^ pressed
+!
+
+onLevel:aNumber
+ "set the level of the button when pressed (i.e. how deep)"
+
+ onLevel := aNumber.
+ pressed ifTrue:[
+ self level:onLevel.
+ margin := onLevel abs max:offLevel abs.
+ self redraw
+ ]
+!
+
+onLevel
+ "return the level of the button when pressed"
+
+ ^ onLevel
+!
+
+offLevel:aNumber
+ "set the level of the button when not pressed (i.e. how high)"
+
+ offLevel := aNumber.
+ pressed ifFalse:[
+ self level:offLevel.
+ margin := onLevel abs max:offLevel abs.
+ self redraw
+ ]
+!
+
+offLevel
+ "return the level of the button when released"
+
+ ^ offLevel
+!
+
+activeForegroundColor
+ "return the foreground color to be used when pressed"
+
+ ^ activeFgColor
+!
+
+activeForegroundColor:aColor
+ "set the foreground color to be used when pressed"
+
+ activeFgColor := aColor.
+ pressed ifTrue:[
+ self redraw
+ ]
+!
+
+activeBackgroundColor
+ "return the background color to be used when pressed"
+
+ ^ activeBgColor
+!
+
+activeBackgroundColor:aColor
+ "set the background color to be used when pressed"
+
+ activeBgColor := aColor.
+ pressed ifTrue:[
+ self redraw
+ ]
+!
+
+activeForegroundColor:fgColor backgroundColor:bgColor
+ "set the colors to be used when pressed"
+
+ activeFgColor := fgColor.
+ activeBgColor := bgColor.
+ pressed ifTrue:[
+ self redraw
+ ]
+!
+
+enteredForegroundColor
+ "return the foreground color to be used when the mouse
+ pointer enters the button area"
+
+ ^ enteredFgColor
+!
+
+enteredForegroundColor:aColor
+ "set the foreground color to be used when the mouse
+ pointer enters the button area"
+
+ enteredFgColor := aColor
+!
+
+enteredBackgroundColor
+ "return the background color to be used when the mouse
+ pointer enters the button area"
+
+ ^ enteredBgColor
+!
+
+enteredBackgroundColor:aColor
+ "set the background color to be used when the mouse
+ pointer enters the button area"
+
+ enteredBgColor := aColor
+! !
+
+!Button methodsFor:'private'!
+
+computeLabelSize
+ "compute the extent needed to hold the label plus the return form"
+
+ super computeLabelSize.
+ isReturnButton ifTrue:[
+ labelWidth := labelWidth + hSpace + shadowForm width.
+ labelHeight := labelHeight max: (shadowForm height + vSpace)
+ ]
+!
+
+resize
+ "resize myself to make logo fit into myself.
+ Redefined, since we add space for a frame around text when non-3D"
+
+ |extra|
+
+ logo isNil ifFalse:[
+ self computeLabelOrigin.
+ (relativeExtent isNil and:[extentRule isNil]) ifTrue:[
+ extra := (onLevel abs max:offLevel abs) * 2.
+ self is3D ifFalse:[
+ (logo isKindOf:Form) ifFalse:[
+ "add space for a frame around"
+ extra := extra + 2
+ ]
+ ].
+ self extent:(labelWidth + extra) @ (labelHeight + extra)
+ ]
+ ]
+! !
+
+!Button methodsFor:'redrawing'!
+
+drawWith:fg and:bg
+ "redraw myself with fg/bg. Use super to draw the label, add
+ the return-arrow here."
+
+ |x y|
+
+ super drawWith:fg and:bg. "this draws the text"
+
+ isReturnButton ifTrue:[
+ y := (height - shadowForm height) // 2.
+ x := width - shadowForm width - (hSpace // 2).
+
+ self is3D ifFalse:[
+ self paint:fg on:bg.
+ self background:bg.
+ self drawOpaqueForm:shadowForm x:x y:y
+ ] ifTrue:[
+ ((formShadowColor colorId notNil)
+ and:[(formLightColor colorId notNil)
+ and:[formColor colorId notNil]])
+ ifTrue:[
+ self foreground:formColor background:(Color noColor) function:#xor.
+ self drawOpaqueForm:shadowForm x:x y:y.
+ self foreground:formShadowColor function:#or.
+ self drawOpaqueForm:shadowForm x:x y:y.
+ self foreground:formColor function:#xor.
+ self drawOpaqueForm:lightForm x:x y:y.
+ self foreground:formLightColor function:#or.
+ self drawOpaqueForm:lightForm x:x y:y.
+ self foreground:fg background:bg function:#copy
+ ]
+ ]
+ ]
+!
+
+redraw
+ "like redrawing a label, but hilight when pressed
+ (lolight when disabled)"
+
+ |fg bg|
+
+ shown ifTrue:[
+ fg := fgColor.
+ bg := bgColor.
+ active ifFalse:[
+ self is3D ifTrue:[
+ enabled ifFalse:[
+ fg := disabledFgColor
+ ] ifTrue:[
+ pressed ifTrue:[
+ fg := activeFgColor.
+ bg := activeBgColor
+ ]
+ ].
+ self drawWith:fg and:bg
+ ] ifFalse:[
+ enabled ifFalse:[
+ fg := disabledFgColor.
+ self drawWith:fg and:bg
+ ] ifTrue:[
+ pressed ifTrue:[
+ self drawWith:bgColor and:fgColor.
+ (logo isKindOf:Form) ifFalse:[
+ self paint:bg.
+ self drawRectangleX:0 y:0 width:width height:height
+ ]
+ ] ifFalse:[
+ super redraw
+ ]
+ ]
+ ]
+ ]
+ ]
+! !
+
+!Button methodsFor:'event handling'!
+
+buttonPress:button x:x y:y
+ "button was pressed - if enabled, perform pressaction"
+
+ button == 1 ifFalse:[
+ ^ super buttonPress:button x:x y:y
+ ].
+ pressed ifFalse:[
+ enabled ifTrue:[
+ pressed := true.
+ self level:onLevel.
+ self redraw.
+ active := true.
+ pressActionBlock notNil ifTrue:[device synchronizeOutput.
+ pressActionBlock value].
+ active := false.
+ device synchronizeOutput.
+
+ autoRepeat ifTrue:[
+ device addTimedBlock:repeatBlock after:initialDelay
+ ]
+ ]
+ ]
+!
+
+buttonMultiPress:button x:x y:y
+ ^ self buttonPress:button x:x y:y
+!
+
+buttonRelease:button x:x y:y
+ "button was released - if enabled, perform releaseaction"
+
+ button == 1 ifFalse:[
+ ^ super buttonRelease:button x:x y:y
+ ].
+ pressed ifTrue:[
+ autoRepeat ifTrue:[
+ device removeTimedBlock:repeatBlock
+ ].
+ pressed := false.
+ self level:offLevel.
+ self redraw.
+ enabled ifTrue:[
+ active := true.
+ releaseActionBlock notNil ifTrue:[device synchronizeOutput.
+ releaseActionBlock value].
+ active := false.
+ enteredFgColor notNil ifTrue:[
+ self drawWith:enteredFgColor and:enteredBgColor
+ ]
+ ]
+ ]
+!
+
+pointerLeave:state
+ "redraw with normal colors if they differ from enteredColors"
+
+ pressed ifTrue:[
+ autoRepeat ifTrue:[
+ device removeTimedBlock:repeatBlock
+ ]
+ ] ifFalse:[
+ enabled ifTrue:[
+ enteredFgColor notNil ifTrue:[
+ (enteredFgColor ~~ fgColor
+ or:[enteredBgColor ~~ bgColor]) ifTrue:[
+ self drawWith:fgColor and:bgColor
+ ]
+ ]
+ ]
+ ]
+!
+
+pointerEnter:state x:x y:y
+ "redraw with enteredColors if they differ from the normal colors"
+
+ pressed ifTrue:[
+ enabled ifTrue:[
+ autoRepeat ifTrue:[
+ device addTimedBlock:repeatBlock after:initialDelay
+ ]
+ ]
+ ] ifFalse:[
+ enabled ifTrue:[
+ enteredFgColor notNil ifTrue:[
+ (enteredFgColor ~~ fgColor
+ or:[enteredBgColor ~~ bgColor]) ifTrue:[
+ self drawWith:enteredFgColor and:enteredBgColor
+ ]
+ ]
+ ]
+ ]
+!
+
+repeat
+ "this is sent from the autorepeat-block, when the button has been pressed long
+ enough; it simulates a release-press, thereby retriggering action."
+
+ pressed ifTrue:[
+ enabled ifTrue:[
+ active ifFalse:[
+ active := true.
+ releaseActionBlock notNil ifTrue:[releaseActionBlock value].
+ pressActionBlock notNil ifTrue:[pressActionBlock value].
+ active := false.
+ device synchronizeOutput.
+
+ autoRepeat ifTrue:[
+ device addTimedBlock:repeatBlock after:repeatDelay
+ ]
+ ]
+ ]
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ChckTggle.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,87 @@
+"
+ COPYRIGHT (c) 1991-92 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Toggle subclass:#CheckToggle
+ instanceVariableNames:'activeLogo'
+ classVariableNames:'defaultCheckForm'
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+CheckToggle comment:'
+
+COPYRIGHT (c) 1991-92 by Claus Gittinger
+ All Rights Reserved
+
+CheckButtons like Toggles do something when pressed/released;
+but show an ok-marker if on; nothing if off
+
+@(#)ChckTggle.st 3.2 92/09/07
+
+written spring 92 by claus
+'!
+
+!CheckToggle class methodsFor:'defaults'!
+
+checkFormOn:aDevice
+ "answer the form used when checkToggle is turned on"
+
+ defaultCheckForm isNil ifTrue:[
+ defaultCheckForm := Form fromFile:'CheckOn.xbm'
+ resolution:100
+ on:aDevice
+ ].
+ defaultCheckForm isNil ifTrue:[
+ defaultCheckForm :=
+ Form width:16 height:16 fromArray:#(2r00000000 2r00000000
+ 2r00000000 2r00000010
+ 2r00000000 2r00000010
+ 2r00000000 2r00000100
+ 2r00000000 2r00000100
+ 2r00000000 2r00001000
+ 2r00000000 2r00001000
+ 2r00000000 2r00010000
+ 2r01000000 2r00010000
+ 2r00100000 2r00100000
+ 2r00010000 2r00100000
+ 2r00001000 2r01000000
+ 2r00000100 2r01000000
+ 2r00000010 2r10000000
+ 2r00000001 2r10000000
+ 2r00000000 2r00000000)
+ on:aDevice
+ ].
+ ^ defaultCheckForm
+! !
+
+!CheckToggle methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ onLevel := offLevel.
+ activeLogo := self class checkFormOn:device.
+ self form:activeLogo
+! !
+
+!CheckToggle methodsFor:'redrawing'!
+
+redraw
+ pressed ifTrue:[
+ logo := activeLogo.
+ super redraw
+ ] ifFalse:[
+ logo := nil.
+ super redraw
+ ]
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/CheckToggle.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,87 @@
+"
+ COPYRIGHT (c) 1991-92 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Toggle subclass:#CheckToggle
+ instanceVariableNames:'activeLogo'
+ classVariableNames:'defaultCheckForm'
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+CheckToggle comment:'
+
+COPYRIGHT (c) 1991-92 by Claus Gittinger
+ All Rights Reserved
+
+CheckButtons like Toggles do something when pressed/released;
+but show an ok-marker if on; nothing if off
+
+@(#)ChckTggle.st 3.2 92/09/07
+
+written spring 92 by claus
+'!
+
+!CheckToggle class methodsFor:'defaults'!
+
+checkFormOn:aDevice
+ "answer the form used when checkToggle is turned on"
+
+ defaultCheckForm isNil ifTrue:[
+ defaultCheckForm := Form fromFile:'CheckOn.xbm'
+ resolution:100
+ on:aDevice
+ ].
+ defaultCheckForm isNil ifTrue:[
+ defaultCheckForm :=
+ Form width:16 height:16 fromArray:#(2r00000000 2r00000000
+ 2r00000000 2r00000010
+ 2r00000000 2r00000010
+ 2r00000000 2r00000100
+ 2r00000000 2r00000100
+ 2r00000000 2r00001000
+ 2r00000000 2r00001000
+ 2r00000000 2r00010000
+ 2r01000000 2r00010000
+ 2r00100000 2r00100000
+ 2r00010000 2r00100000
+ 2r00001000 2r01000000
+ 2r00000100 2r01000000
+ 2r00000010 2r10000000
+ 2r00000001 2r10000000
+ 2r00000000 2r00000000)
+ on:aDevice
+ ].
+ ^ defaultCheckForm
+! !
+
+!CheckToggle methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ onLevel := offLevel.
+ activeLogo := self class checkFormOn:device.
+ self form:activeLogo
+! !
+
+!CheckToggle methodsFor:'redrawing'!
+
+redraw
+ pressed ifTrue:[
+ logo := activeLogo.
+ super redraw
+ ] ifFalse:[
+ logo := nil.
+ super redraw
+ ]
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ClckMenuV.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,36 @@
+"
+ COPYRIGHT (c) 1991-92 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+MenuView subclass:#ClickMenuView
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Menus'
+!
+
+ClickMenuView comment:'
+
+COPYRIGHT (c) 1991-92 by Claus Gittinger
+ All Rights Reserved
+
+like a menuView - deselects after clicked on an entry
+
+@(#)ClckMenuV.st 3.1 92/08/23
+written spring 91 by claus
+'!
+
+!ClickMenuView methodsFor:'event handling'!
+
+buttonRelease:button x:x y:y
+ super buttonRelease:button x:x y:y.
+ self selection:nil
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ClickMenuView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,36 @@
+"
+ COPYRIGHT (c) 1991-92 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+MenuView subclass:#ClickMenuView
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Menus'
+!
+
+ClickMenuView comment:'
+
+COPYRIGHT (c) 1991-92 by Claus Gittinger
+ All Rights Reserved
+
+like a menuView - deselects after clicked on an entry
+
+@(#)ClckMenuV.st 3.1 92/08/23
+written spring 91 by claus
+'!
+
+!ClickMenuView methodsFor:'event handling'!
+
+buttonRelease:button x:x y:y
+ super buttonRelease:button x:x y:y.
+ self selection:nil
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/CodeView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,189 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Workspace subclass:#CodeView
+ instanceVariableNames:'acceptAction explainAction'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Workspace'
+!
+
+CodeView comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+a view for code which can recompile its contents. It adds accept and explain
+to the menu, and defines two actions: acceptAction to be performed for accept
+and explainAction to be performed for explain.
+
+%W% %E%
+written winter-89 by claus
+'!
+
+!CodeView methodsFor:'initialization'!
+
+initializeMiddleButtonMenu
+ |labels|
+
+ labels := resources array:#("
+ 'undo'
+ '-'
+ "
+ 'copy'
+ 'cut'
+ 'paste'
+ 'replace'
+ '-'
+ 'font'
+ '-'
+ 'search'
+ 'goto'
+ '-'
+ 'indent'
+ '-'
+ 'save'
+ 'print'
+ " 'filein' "
+ '-'
+ 'doIt'
+ 'printIt'
+ 'inspectIt'
+ '-'
+ 'explain'
+ '-'
+ 'accept').
+
+ self middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(copySelection
+ cut
+ paste
+ replace
+ nil
+ changeFont
+ nil
+ search
+ gotoLine
+ nil
+ indent
+ nil
+ save
+ print
+ " fileItIn "
+ nil
+ doIt
+ printIt
+ inspectIt
+ nil
+ explain
+ nil
+ accept)
+ receiver:self
+ for:self).
+
+! !
+
+!CodeView methodsFor:'accessing'!
+
+acceptAction:aBlock
+ "set the action to be performed on accept"
+
+ acceptAction := aBlock
+!
+
+explainAction:aBlock
+ "set the action to be performed on explain"
+
+ explainAction := aBlock
+! !
+
+!CodeView methodsFor:'selections'!
+
+disableSelectionMenuEntries
+ "disable relevant menu entries for a selection"
+
+ super disableSelectionMenuEntries.
+ middleButtonMenu disable:#explain
+!
+
+enableSelectionMenuEntries
+ "enable relevant menu entries for a selection"
+
+ super enableSelectionMenuEntries.
+ middleButtonMenu enable:#explain
+! !
+
+!CodeView methodsFor:'user actions'!
+
+accept
+ "accept action;
+ save cursor and selection; then execute the accept-action
+ and finally restore cursor and selection"
+
+ |selLine selCol endLine endCol|
+
+ acceptAction notNil ifTrue:[
+ codeStartPosition := 1.
+"
+ self cursor:Cursor wait.
+"
+ selLine := selectionStartLine.
+ selCol := selectionStartCol.
+ endLine := selectionEndLine.
+ endCol := selectionEndCol.
+ abortBlock := [
+ self cursor:Cursor normal.
+ "redraw selection in normal color"
+ self selectFromLine:selectionStartLine col:selectionStartCol
+ toLine:selectionEndLine col:selectionEndCol.
+ abortBlock := nil.
+ ^ nil
+ ].
+ [
+ acceptAction value:(self contents)
+ ] valueNowOrOnUnwindDo:[
+"
+ self cursor:Cursor normal.
+"
+ self unselect.
+ abortBlock := nil
+ ]
+ ]
+!
+
+explain
+ "explain action;
+ evaluate the explainBlock passing whole contents and
+ selection as arguments."
+
+ |text|
+
+ explainAction notNil ifTrue:[
+ text := self selection.
+ text notNil ifTrue:[
+ explainAction value:(self contents)
+ value:(text asString)
+ ]
+ ]
+! !
+
+!CodeView methodsFor:'events'!
+
+keyPress:key x:x y:y
+ "catch keyboard shortcut: control-a for accept"
+
+ (key == #Cmda) ifTrue:[^ self accept].
+ (key == #Cmde) ifTrue:[^ self explain].
+ (key == #Help) ifTrue:[^ self explain].
+ super keyPress:key x:x y:y
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/EFGroup.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,144 @@
+"
+ COPYRIGHT (c) 1992-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Controller subclass:#EnterFieldGroup
+ instanceVariableNames:'fields currentField leaveAction'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Support'
+!
+
+EnterFieldGroup comment:'
+
+COPYRIGHT (c) 1992-93 by Claus Gittinger
+ All Rights Reserved
+
+EnterFieldGroup controlls the interaction between EnterFields
+enabling next/prev field when a field is left. Instances of
+this class keep track of which field of the group is the currentField
+(i.e. the one getting keyboard input).
+The block accessable as leaveAction is evaluated when the last
+field of the group is left (by cursor-down or cr). Usually this block
+triggers some action on the fields.
+
+%W% %E%
+written nov 91 by claus
+'!
+
+!EnterFieldGroup methodsFor:'adding / removing'!
+
+add:aField
+ |thisIndex next|
+
+ fields isNil ifTrue:[
+ fields := OrderedCollection new
+ ].
+ fields add:aField.
+ thisIndex := fields size.
+ aField controller:self.
+ aField disable.
+
+ "set the fields enableAction to disable active field"
+
+ aField enableAction:[
+ currentField notNil ifTrue:[
+ currentField disable
+ ].
+ currentField := aField
+ ].
+
+ "set the fields leaveAction to enable next field"
+
+ aField leaveAction:[:key |
+ currentField notNil ifTrue:[
+ currentField disable
+ ].
+ (key == #Up) ifTrue:[
+ (thisIndex == 1) ifTrue:[
+ next := fields size
+ ] ifFalse:[
+ next := thisIndex - 1
+ ]
+ ].
+ (key == #Down) ifTrue:[
+ (thisIndex == (fields size)) ifTrue:[
+ next := 1
+ ] ifFalse:[
+ next := thisIndex + 1
+ ]
+ ].
+ (key == #Return) ifTrue:[
+ (thisIndex == (fields size)) ifTrue:[
+ leaveAction notNil ifTrue:[
+ leaveAction value.
+ currentField := nil
+ ] ifFalse:[
+ next := 1
+ ]
+ ] ifFalse:[
+ next := thisIndex + 1
+ ]
+ ].
+ next notNil ifTrue:[
+ (fields at:next) enable.
+ currentField := fields at:next
+ ]
+ ]
+! !
+
+!EnterFieldGroup methodsFor:'accessing'!
+
+leaveAction:aBlock
+ leaveAction := aBlock
+! !
+
+!EnterFieldGroup methodsFor:'controlling'!
+
+canHandle:aKey
+ ^ true
+!
+
+keyPress:key x:x y:y in:aView
+ "key-press in a field"
+
+ currentField notNil ifTrue:[
+ currentField keyPress:key x:0 y:0
+ ]
+!
+
+keyPress:key x:x y:y
+ "key-press in an outer view when keyHandler has been set"
+
+ currentField notNil ifTrue:[
+ currentField keyPress:key x:0 y:0
+ ]
+!
+
+buttonMotion:state x:x y:y in:aView
+ aView buttonMotion:state x:x y:y
+!
+
+buttonShiftPress:button x:x y:y in:aView
+ aView buttonShiftPress:button x:x y:y
+!
+
+buttonMultiPress:button x:x y:y in:aView
+ aView buttonMultiPress:button x:x y:y
+!
+
+buttonPress:button x:x y:y in:aView
+ aView buttonPress:button x:x y:y
+!
+
+buttonRelease:button x:x y:y in:aView
+ aView buttonRelease:button x:x y:y
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ETxtView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,1899 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+TextView subclass:#EditTextView
+ instanceVariableNames:'cursorLine cursorVisibleLine
+ cursorCol cursorShown prevCursorState
+ readOnly modified fixedSize
+ exceptionBlock
+ errorMessage
+ cursorFgColor cursorBgColor
+ undoAction redoAction'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Text'
+!
+
+EditTextView comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+
+written jun-89 by claus
+'!
+
+!EditTextView class methodsFor:'documentation'!
+
+documentation
+"
+ a view for editable text - adds editing functionality to TextView
+
+ Instance variables:
+
+ cursorLine <Number> line where cursor sits (1..)
+ cursorVisibleLine <Number> visible line where cursor sits (1..nLinesShown)
+ cursorCol <Number> col where cursor sits (1..)
+ cursorShown <Boolean> true, if cursor is currently shown
+ prevCursorState <Boolean> temporary
+ readOnly <Boolean> true, if text may not be edited
+ modified <Boolean> true, if text has been modified
+ fixedSize <Boolean> true, if no lines may be added/removed
+ exceptionBlock <Block> block to be evaluated when readonly text is about to be modified
+ errorMessage <String> message text
+ cursorFgColor <Color> color used for cursor drawing
+ cursorBgColor <Color> color used for cursor drawing
+"
+! !
+
+!EditTextView methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ self level:-1.
+ errorMessage := 'Text may not me changed'.
+ readOnly := false.
+ fixedSize := false.
+ exceptionBlock := [:errorText | ].
+ cursorShown := true.
+ cursorLine := 1.
+ cursorVisibleLine := 1.
+ cursorCol := 1.
+ modified := false
+!
+
+initStyle
+ super initStyle.
+ cursorFgColor := bgColor.
+ device hasColors ifTrue:[
+ cursorBgColor := Color red
+ ] ifFalse:[
+ cursorBgColor := fgColor
+ ]
+!
+
+initializeMiddleButtonMenu
+ |labels|
+
+ labels := resources array:#("
+ 'undo'
+ '-'
+ "
+ 'copy'
+ 'cut'
+ 'paste'
+ 'replace'
+ '-'
+ 'font'
+ '-'
+ 'search'
+ 'goto'
+ '-'
+ 'indent'
+ '-'
+ 'save'
+ 'print').
+
+ self middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#("undo
+ nil"
+ copySelection
+ cut
+ paste
+ replace
+ nil
+ changeFont
+ nil
+ search
+ gotoLine
+ nil
+ indent
+ nil
+ save
+ print)
+ receiver:self
+ for:self).
+
+ self enableOrDisableSelectionMenuEntries
+!
+
+realize
+ super realize.
+ cursorFgColor := cursorFgColor on:device.
+ cursorBgColor := cursorBgColor on:device.
+! !
+
+!EditTextView methodsFor:'accessing'!
+
+cursorForegroundColor:color1 backgroundColor:color2
+ "set both cursor foreground and cursor background colors"
+
+ self hideCursor.
+ cursorFgColor := color1 on:device.
+ cursorBgColor := color2 on:device.
+ self showCursor
+!
+
+contents
+ "answer the contents as a String"
+
+ list isNil ifTrue:[^ ''].
+ self removeTrailingBlankLines.
+ ^ list asString
+!
+
+list:something
+ "position cursor home when setting contents"
+
+ super list:something.
+ self cursorHome
+!
+
+readOnly
+ "make the text readonly"
+
+ readOnly := true
+!
+
+fixedSize
+ "make the texts size fixed (no lines may be added)"
+
+ readOnly ifFalse:[
+ readOnly := true.
+ middleButtonMenu disable:#cut.
+ middleButtonMenu disable:#paste.
+ middleButtonMenu disable:#replace.
+ middleButtonMenu disable:#indent
+ ]
+!
+
+exceptionBlock:aBlock
+ "define the action to be triggered when user tries to modify
+ readonly text"
+
+ exceptionBlock := aBlock
+!
+
+fromFile:aFileName
+ "take contents from a named file"
+
+ self contents:(FileText ofFile:aFileName)
+!
+
+modified:aBoolean
+ "set the modified flag"
+
+ modified := aBoolean
+!
+
+modified
+ "return true if text was modified"
+
+ ^ modified
+! !
+
+!EditTextView methodsFor:'private'!
+
+contentsChanged
+ "triggered whenever text is changed"
+
+ super contentsChanged.
+ modified := true.
+ contentsWasSaved := false
+! !
+
+!EditTextView methodsFor:'editing'!
+
+mergeLine:lineNr
+ "merge line lineNr with line lineNr+1"
+
+ |leftPart rightPart bothParts nextLineNr|
+
+ list isNil ifFalse:[
+ nextLineNr := lineNr + 1.
+ (nextLineNr > list size) ifFalse:[
+ (list at:lineNr) isNil ifTrue:[
+ leftPart := ''
+ ] ifFalse:[
+ leftPart := list at:lineNr
+ ].
+ (list at:nextLineNr) isNil ifTrue:[
+ rightPart := ''
+ ] ifFalse:[
+ rightPart := list at:nextLineNr
+ ].
+ bothParts := leftPart , rightPart.
+ bothParts isBlank ifTrue:[bothParts := nil].
+ list at:lineNr put:bothParts.
+ self redrawLine:lineNr.
+ self deleteLine:nextLineNr
+ ]
+ ]
+!
+
+splitLine:lineNr before:colNr
+ "split the line linNr before colNr; the right part (from colNr)
+ is cut off and inserted after lineNr; the view is redrawn"
+
+ |line lineSize leftRest rightRest visLine w
+ srcY "{ Class: SmallInteger }" |
+
+ list isNil ifFalse:[
+ lineNr > (list size) ifFalse:[
+ (colNr == 1) ifTrue:[
+ self insertLine:nil before:lineNr.
+ ^ self
+ ].
+ line := list at:lineNr.
+ line isNil ifFalse:[
+ lineSize := line size.
+ (colNr <= lineSize) ifTrue:[
+ rightRest := line copyFrom:colNr to:lineSize.
+ (colNr > 1) ifTrue:[
+ leftRest := line copyFrom:1 to:(colNr - 1)
+ ]
+ ] ifFalse:[
+ leftRest := line
+ ]
+ ].
+ leftRest notNil ifTrue:[
+ leftRest isBlank ifTrue:[leftRest := nil]
+ ].
+ list at:lineNr put:leftRest.
+ modified := true.
+ contentsWasSaved := false.
+ self withoutRedrawInsertLine:rightRest before:(lineNr + 1).
+
+ visLine := self listLineToVisibleLine:(lineNr).
+ visLine notNil ifTrue:[
+ w := self widthForScrollBetween:lineNr
+ and:(firstLineShown + nLinesShown).
+ srcY := topMargin + (visLine * fontHeight).
+ self copyFrom:self x:textStartLeft y:srcY
+ toX:textStartLeft y:(srcY + fontHeight)
+ width:w
+ height:((nLinesShown - visLine - 1) * fontHeight).
+ self redrawLine:lineNr.
+ self redrawLine:(lineNr + 1).
+ exposePending := true.
+ self waitForExpose
+ ]
+ ]
+ ]
+!
+
+withoutRedrawInsertLine:aString before:lineNr
+ "insert the argument, aString before line lineNr; the string
+ becomes line nileNr; everything else is moved down; the view
+ is not redrawn"
+
+ |line|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ line := aString.
+ line notNil ifTrue:[
+ line isBlank ifTrue:[
+ line := nil
+ ] ifFalse:[
+ (line occurrencesOf:(Character tab)) == 0 ifFalse:[
+ line := self withTabsExpanded:line
+ ]
+ ]
+ ].
+ list isNil ifTrue: [
+ list := Text new:lineNr
+ ] ifFalse: [
+ list grow:((list size + 1) max:lineNr)
+ ].
+
+ "I have changed 'replaceFrom:to:with:startingAt:' to correctly handle
+ overlapping copy - if it didn't, we had to use:"
+"
+ index := list size.
+ [index > lineNr] whileTrue: [
+ pIndex := index - 1.
+ list at:index put:(list at:pIndex).
+ index := pIndex
+ ].
+"
+ list replaceFrom:(lineNr + 1) to:(list size) with:list startingAt:lineNr.
+ list at:lineNr put:line.
+ self contentsChanged
+!
+
+insertLine:aString before:lineNr
+ "insert the line aString before line lineNr"
+
+ |visLine w
+ dstY "{ Class: SmallInteger }" |
+
+ self withoutRedrawInsertLine:aString before:lineNr.
+ visLine := self listLineToVisibleLine:lineNr.
+ visLine notNil ifTrue:[
+ w := self widthForScrollBetween:lineNr
+ and:(firstLineShown + nLinesShown).
+ dstY := topMargin + ((visLine ) * fontHeight).
+ self copyFrom:self x:textStartLeft y:(dstY - fontHeight)
+ toX:textStartLeft y:dstY
+ width:w
+ height:((nLinesShown - visLine "- 1") * fontHeight).
+ self redrawVisibleLine:visLine.
+ exposePending := true.
+ self waitForExpose
+ ]
+!
+
+insertLines:someText from:start to:end before:lineNr
+ "insert a bunch of lines before line lineNr"
+
+ |visLine w nLines "{ Class: SmallInteger }"
+ srcY "{ Class: SmallInteger }"
+ dstY "{ Class: SmallInteger }" |
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ self withoutRedrawInsertLines:someText
+ from:start to:end
+ before:lineNr.
+ visLine := self listLineToVisibleLine:lineNr.
+ visLine notNil ifTrue:[
+ nLines := end - start + 1.
+ ((visLine + nLines) >= nLinesShown) ifTrue:[
+ self redrawFromVisibleLine:visLine to:nLinesShown
+ ] ifFalse:[
+ w := self widthForScrollBetween:(lineNr + nLines)
+ and:(firstLineShown + nLines + nLinesShown).
+ srcY := topMargin + ((visLine - 1) * fontHeight).
+ dstY := srcY + (nLines * fontHeight).
+ self copyFrom:self x:textStartLeft y:srcY
+ toX:textStartLeft y:dstY
+ width:w
+ height:(height - dstY).
+ self redrawFromVisibleLine:visLine to:(visLine + nLines - 1).
+ exposePending := true.
+ self waitForExpose
+ ]
+ ]
+!
+
+insert:aCharacter atLine:lineNr col:colNr
+ "insert a single character at lineNr/colNr"
+
+ |line lineSize newLine drawCharacterOnly|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ aCharacter == (Character cr) ifTrue:[
+ self splitLine:lineNr before:colNr.
+ ^ self
+ ].
+ drawCharacterOnly := false.
+ self checkForExistingLine:lineNr.
+ line := list at:lineNr.
+ lineSize := line size.
+ (aCharacter == Character space) ifTrue:[
+ (colNr > lineSize) ifTrue:[
+ ^ self
+ ]
+ ].
+ (lineSize == 0) ifTrue: [
+ newLine := String new:colNr.
+ drawCharacterOnly := true
+ ] ifFalse: [
+ (colNr > lineSize) ifTrue: [
+ newLine := String new:colNr.
+ newLine replaceFrom:1 to:lineSize
+ with:line startingAt:1.
+ drawCharacterOnly := true
+ ] ifFalse: [
+ newLine := String new:(lineSize + 1).
+ newLine replaceFrom:1 to:(colNr - 1)
+ with:line startingAt:1.
+ newLine replaceFrom:(colNr + 1) to:(lineSize + 1)
+ with:line startingAt:colNr
+ ]
+ ].
+ newLine at:colNr put:aCharacter.
+ aCharacter == (Character tab) ifTrue:[
+ newLine := self withTabsExpanded:newLine.
+ drawCharacterOnly := false
+ ].
+ list at:lineNr put:newLine.
+ modified := true.
+ contentsWasSaved := false.
+ drawCharacterOnly ifTrue:[
+ self redrawLine:lineNr col:colNr
+ ] ifFalse:[
+ self redrawLine:lineNr from:colNr
+ ]
+!
+
+withoutRedrawInsertLines:lines from:start to:end before:lineNr
+ "insert a bunch of lines before line lineNr; the view
+ is not redrawn"
+
+ |newLine newLines nLines|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+
+ nLines := end - start + 1.
+ newLines := Array new:(lines size).
+ start to:end do:[:index |
+ newLine := lines at:index.
+ newLine notNil ifTrue:[
+ newLine isBlank ifTrue:[
+ newLine := nil
+ ] ifFalse:[
+ (newLine occurrencesOf:(Character tab)) == 0 ifFalse:[
+ newLine := self withTabsExpanded:newLine
+ ]
+ ]
+ ].
+ newLines at:index put:newLine
+ ].
+ list isNil ifTrue: [
+ list := Text new:(lineNr + nLines + 1)
+ ] ifFalse: [
+ list grow:((list size + nLines) max:(lineNr + nLines - 1))
+ ].
+
+ "I have changed 'replaceFrom:to:with:startingAt:' to correctly handle
+ overlapping copy - if it didn't, we had to use:"
+"
+ index := list size.
+ [index > lineNr] whileTrue: [
+ pIndex := index - 1.
+ list at:index put:(list at:pIndex).
+ index := pIndex
+ ].
+"
+ list replaceFrom:(lineNr + nLines) to:(list size) with:list startingAt:lineNr.
+ list replaceFrom:lineNr to:(lineNr + nLines - 1) with:newLines startingAt:start.
+ self contentsChanged
+!
+
+withoutRedrawInsertStringWithoutCRs:aString atLine:lineNr col:colNr
+ "insert aString (which has no crs) at lineNr/colNr"
+
+ |strLen line lineSize newLine|
+
+ aString isNil ifTrue:[^ self].
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ strLen := aString size.
+ self checkForExistingLine:lineNr.
+ line := list at:lineNr.
+ line notNil ifTrue:[
+ lineSize := line size
+ ] ifFalse:[
+ lineSize := 0
+ ].
+ ((colNr == 1) and:[lineSize == 0]) ifTrue: [
+ newLine := aString
+ ] ifFalse:[
+ (lineSize == 0) ifTrue: [
+ newLine := String new:(colNr + strLen - 1)
+ ] ifFalse: [
+ (colNr > lineSize) ifTrue: [
+ newLine := String new:(colNr + strLen - 1).
+ newLine replaceFrom:1 to:lineSize
+ with:line startingAt:1
+ ] ifFalse: [
+ newLine := String new:(lineSize + strLen).
+ newLine replaceFrom:1 to:(colNr - 1)
+ with:line startingAt:1.
+ newLine replaceFrom:(colNr + strLen) to:(lineSize + strLen)
+ with:line startingAt:colNr
+ ]
+ ].
+ newLine replaceFrom:colNr to:(colNr + strLen - 1)
+ with:aString startingAt:1
+ ].
+
+ (aString occurrencesOf:(Character tab)) == 0 ifFalse:[
+ newLine := self withTabsExpanded:newLine
+ ].
+
+ list at:lineNr put:newLine.
+ modified := true.
+ contentsWasSaved := false.
+!
+
+insertStringWithoutCRs:aString atLine:lineNr col:colNr
+ "insert aString (which has no crs) at lineNr/colNr"
+
+ self withoutRedrawInsertStringWithoutCRs:aString atLine:lineNr col:colNr.
+ self redrawLine:lineNr from:colNr
+!
+
+insertStringWithoutCRsAtCursor:aString
+ "insert a string (which has no crs) at cursor position
+ - advance cursor"
+
+ aString notNil ifTrue:[
+ self withCursorOffDo:[
+ self insertString:aString atLine:cursorLine col:cursorCol.
+ cursorCol := cursorCol + aString size
+ ]
+ ]
+!
+
+insertCharAtCursor:aCharacter
+ "insert a single character at cursor-position - advance cursor"
+
+ self withCursorOffDo:[
+ self insert:aCharacter atLine:cursorLine col:cursorCol.
+ aCharacter == (Character cr) ifTrue:[
+ self cursorReturn
+ ] ifFalse:[
+ cursorCol := cursorCol + 1
+ ]
+ ]
+!
+
+insertString:aString atLine:lineNr col:colNr
+ "insert the string, aString at line/col;
+ handle cr's correctly"
+
+ |start "{ Class: SmallInteger }"
+ stop "{ Class: SmallInteger }"
+ end "{ Class: SmallInteger }"
+ subString c
+ l "{ Class: SmallInteger }" |
+
+
+ aString isNil ifTrue:[^ self].
+ ((aString occurrencesOf:(Character cr)) == 0) ifTrue:[
+ ^ self insertStringWithoutCRs:aString atLine:lineNr col:colNr
+ ].
+ l := lineNr.
+ c := colNr.
+ start := 1.
+ end := aString size.
+ [start <= end] whileTrue:[
+ stop := aString indexOf:(Character cr)
+ startingAt:start
+ ifAbsent:[end + 1].
+ subString := aString copyFrom:start to:(stop - 1).
+ self insertStringWithoutCRs:subString atLine:l col:c.
+ (stop < end) ifTrue:[
+ c := c + subString size.
+ self insert:(Character cr) atLine:l col:c.
+ l := l + 1.
+ c := 1
+ ].
+ start := stop + 1
+ ]
+!
+
+insertStringAtCursor:aString
+ "insert the argument, aString at cursor position
+ handle cr's correctly"
+
+ |start " { Class: SmallInteger }"
+ stop " { Class: SmallInteger }"
+ end " { Class: SmallInteger }"
+ subString|
+
+ aString isNil ifTrue:[^ self].
+ ((aString occurrencesOf:(Character cr)) == 0) ifTrue:[
+ ^ self insertStringWithoutCRsAtCursor:aString
+ ].
+ start := 1.
+ end := aString size.
+
+ "insert the 1st line"
+ (cursorCol ~~ 1) ifTrue:[
+ stop := aString indexOf:(Character cr)
+ startingAt:start
+ ifAbsent:[end + 1].
+ subString := aString copyFrom:start to:(stop - 1).
+ self insertStringWithoutCRsAtCursor:subString.
+ self insertCharAtCursor:(Character cr).
+ start := stop + 1
+ ].
+ "insert the block of full lines"
+
+ [start <= end] whileTrue:[
+ stop := aString indexOf:(Character cr)
+ startingAt:start
+ ifAbsent:[end + 1].
+ subString := aString copyFrom:start to:(stop - 1).
+ self insertStringWithoutCRsAtCursor:subString.
+ (stop < end) ifTrue:[
+ self insertCharAtCursor:(Character cr)
+ ].
+ start := stop + 1
+ ]
+!
+
+insertSelectedStringAtCursor:aString
+ "insert the argument, aString at cursor position and select it"
+
+ |startLine startCol|
+
+ startLine := cursorLine.
+ startCol := cursorCol.
+ self insertStringAtCursor:aString.
+ self selectFromLine:startLine col:startCol
+ toLine:cursorLine col:(cursorCol - 1)
+!
+
+insertLines:lines withCr:withCr
+ "insert a bunch of lines at cursor position. Cursor
+ is moved behind insertion.
+ If withCr is true, append cr after last line"
+
+ |start end nLines|
+
+ lines notNil ifTrue:[
+ nLines := lines size.
+ (nLines == 1) ifTrue:[
+ self insertStringAtCursor:(lines at:1).
+ withCr ifTrue:[
+ self insertCharAtCursor:(Character cr)
+ ]
+ ] ifFalse:[
+ (cursorCol ~~ 1) ifTrue:[
+ self insertStringAtCursor:(lines at:1).
+ self insertCharAtCursor:(Character cr).
+ start := 2
+ ] ifFalse:[
+ start := 1
+ ].
+ withCr ifTrue:[
+ end := nLines
+ ] ifFalse:[
+ end := nLines - 1
+ ].
+ (start < nLines) ifTrue:[
+ (end >= start) ifTrue:[
+ self withCursorOffDo:[
+ self insertLines:lines
+ from:start to:end
+ before:cursorLine.
+ cursorLine := cursorLine + (end - start + 1).
+ cursorVisibleLine := self absoluteLineToVisibleLine:
+ cursorLine
+ ]
+ ]
+ ].
+ withCr ifFalse:[
+ "last line without cr"
+ self insertStringAtCursor:(lines at:nLines)
+ ]
+ ]
+ ]
+!
+
+deleteFromLine:startLine col:startCol toLine:endLine col:endCol
+ "delete all text from startLine/startCol to endLine/endCol -
+ joining lines if nescessary"
+
+ |line lineSize|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ list isNil ifTrue:[^ self].
+
+ (startLine == endLine) ifTrue:[
+ "delete chars within a line"
+ self deleteCharsAtLine:startLine fromCol:startCol toCol:endCol.
+ ^ self
+ ].
+
+ ((startCol == 1) and:[endCol == 0]) ifTrue:[
+ "delete full lines only"
+ endLine > startLine ifTrue:[
+ self deleteFromLine:startLine toLine:(endLine - 1)
+ ].
+ ^ self
+ ].
+
+ "delete right rest of 1st line"
+ self deleteCharsAtLine:startLine fromCol:startCol.
+
+ "delete the inner lines ..."
+ endLine > (startLine + 1) ifTrue:[
+ self deleteFromLine:(startLine + 1) toLine:(endLine - 1)
+ ].
+
+ (endCol ~~ 0) ifTrue:[
+ "delete the left rest of the last line"
+ self deleteCharsAtLine:(startLine + 1) toCol:endCol.
+
+ "must add blanks, if startCal lies behond end of startLine"
+ line := list at:startLine.
+ lineSize := line size.
+ (startCol > lineSize) ifTrue:[
+ line isNil ifTrue:[
+ line := String new:(startCol - 1)
+ ] ifFalse:[
+ line := line , (String new:(startCol - 1 - lineSize))
+ ].
+ list at:startLine put:line.
+ modified := true.
+ contentsWasSaved := false.
+ ]
+ ].
+
+ "merge the left rest of 1st line with right rest of last line into one"
+ self mergeLine:startLine
+!
+
+deleteFromLine:startLineNr toLine:endLineNr
+ "delete some lines"
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ list isNil ifTrue:[^ self].
+ list removeFromIndex:startLineNr toIndex:endLineNr.
+ self contentsChanged.
+ self redrawFromLine:startLineNr.
+ (firstLineShown >= list size) ifTrue:[
+ self makeLineVisible:(list size)
+ ]
+!
+
+deleteLineWithoutRedraw:lineNr
+ "delete line - no redraw;
+ answer true, if something was really deleted"
+
+ readOnly ifTrue:[
+ exceptionBlock value:errorMessage.
+ ^ false
+ ].
+ (list isNil or:[lineNr > list size]) ifTrue:[^ false].
+ list removeIndex:lineNr.
+ self contentsChanged.
+ ^ true
+!
+
+deleteLinesWithoutRedrawFrom:startLine to:endLine
+ "delete lines - no redraw;
+ answer true, if something was really deleted"
+
+ |lastLine|
+
+ readOnly ifTrue:[
+ exceptionBlock value:errorMessage.
+ ^ false
+ ].
+ (list isNil or:[startLine > list size]) ifTrue:[^ false].
+ (endLine > list size) ifTrue:[
+ lastLine := list size
+ ] ifFalse:[
+ lastLine := endLine
+ ].
+ list removeFromIndex:startLine toIndex:lastLine.
+ self contentsChanged.
+ ^ true
+!
+
+deleteLine:lineNr
+ "delete line"
+
+ |visLine w
+ srcY "{ Class: SmallInteger }" |
+
+ w := self widthForScrollBetween:lineNr
+ and:(firstLineShown + nLinesShown).
+ (self deleteLineWithoutRedraw:lineNr) ifFalse:[^ self].
+ visLine := self listLineToVisibleLine:lineNr.
+ visLine notNil ifTrue:[
+ srcY := margin + topMargin + (visLine * fontHeight).
+ self copyFrom:self x:textStartLeft y:srcY
+ toX:textStartLeft y:(srcY - fontHeight)
+ width:w height:((nLinesShown - visLine) * fontHeight).
+ self redrawVisibleLine:nFullLinesShown.
+ (nFullLinesShown ~~ nLinesShown) ifTrue:[
+ self redrawVisibleLine:nLinesShown
+ ].
+ exposePending := true.
+ self waitForExpose
+ ]
+!
+
+deleteCursorLine
+ "delete the line where the cursor sits"
+
+ self withCursorOffDo:[
+ self deleteLine:cursorLine
+ ]
+!
+
+removeTrailingBlankLines
+ "remove all blank lines at end of text"
+
+ |lastLine "{ Class: SmallInteger }"
+ line finished|
+
+ lastLine := list size.
+ finished := false.
+ [finished] whileFalse:[
+ (lastLine <= 1) ifTrue:[
+ finished := true
+ ] ifFalse:[
+ line := list at:lastLine.
+ line notNil ifTrue:[
+ line isBlank ifTrue:[
+ list at:lastLine put:nil.
+ line := nil
+ ]
+ ].
+ line notNil ifTrue:[
+ finished := true
+ ] ifFalse:[
+ lastLine := lastLine - 1
+ ]
+ ]
+ ].
+ (lastLine ~~ list size) ifTrue:[
+ list grow:lastLine.
+ self contentsChanged
+ ]
+!
+
+deleteCharsAtLine:lineNr toCol:colNr
+ "delete characters from start up to colNr in line lineNr"
+
+ |line lineSize newLine|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ list isNil ifTrue: [^self].
+ (list size < lineNr) ifTrue: [^ self].
+ line := list at:lineNr.
+ line isNil ifTrue: [^self].
+ lineSize := line size.
+ (colNr >= lineSize) ifTrue:[
+ newLine := nil
+ ] ifFalse:[
+ newLine := line copyFrom:(colNr + 1) to:lineSize.
+ newLine isBlank ifTrue:[
+ newLine := nil
+ ]
+ ].
+ list at:lineNr put:newLine.
+ modified := true.
+ contentsWasSaved := false.
+ self redrawLine:lineNr
+!
+
+deleteCharsAtLine:lineNr fromCol:colNr
+ "delete characters from colNr up to the end in line lineNr"
+
+ |line newLine|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ list isNil ifTrue: [^self].
+ (list size < lineNr) ifTrue: [^ self].
+ line := list at:lineNr.
+ line isNil ifTrue: [^self].
+ (colNr > line size) ifTrue: [^ self].
+ newLine := line copyFrom:1 to:(colNr - 1).
+ newLine isBlank ifTrue:[
+ newLine := nil
+ ].
+ list at:lineNr put:newLine.
+ modified := true.
+ contentsWasSaved := false.
+ self redrawLine:lineNr
+!
+
+deleteCharsAtLine:lineNr fromCol:startCol toCol:endCol
+ "delete characters from startCol to endCol in line lineNr"
+
+ |line lineSize newLine|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ list isNil ifTrue: [^self].
+ (list size < lineNr) ifTrue: [^ self].
+
+ line := list at:lineNr.
+ line isNil ifTrue: [^self].
+ lineSize := line size.
+ (startCol > lineSize) ifTrue: [^ self].
+ (endCol == 0) ifTrue:[^ self].
+ (endCol < startCol) ifTrue:[^ self].
+ (startCol == endCol) ifTrue:[
+ self deleteCharAtLine:lineNr col:startCol.
+ ^ self
+ ].
+ (endCol >= lineSize) ifTrue:[
+ self deleteCharsAtLine:lineNr fromCol:startCol.
+ ^ self
+ ].
+ (startCol <= 1) ifTrue:[
+ self deleteCharsAtLine:lineNr toCol:endCol.
+ ^ self
+ ].
+ newLine := (line copyFrom:1 to:(startCol - 1))
+ , (line copyFrom:(endCol + 1) to:lineSize).
+
+ newLine isBlank ifTrue:[
+ newLine := nil
+ ].
+ list at:lineNr put:newLine.
+ modified := true.
+ contentsWasSaved := false.
+ self redrawLine:lineNr
+!
+
+deleteCharAtLine:lineNr col:colNr
+ "delete single character at colNr in line lineNr"
+
+ |line lineSize newLine drawCharacterOnly|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ list isNil ifTrue: [^self].
+ (list size < lineNr) ifTrue: [^ self].
+
+ line := list at:lineNr.
+ line isNil ifTrue: [^self].
+ lineSize := line size.
+ (colNr > lineSize) ifTrue: [^ self].
+
+ drawCharacterOnly := false.
+ (colNr == lineSize) ifTrue:[
+ newLine := line copyFrom:1 to:(lineSize - 1).
+ fontIsFixedWidth ifTrue:[
+ drawCharacterOnly := true
+ ]
+ ] ifFalse:[
+ newLine := String new:(lineSize - 1).
+ newLine replaceFrom:1 to:(colNr - 1)
+ with:line startingAt:1.
+ newLine replaceFrom:colNr to:(lineSize - 1)
+ with:line startingAt:(colNr + 1)
+ ].
+
+ newLine isBlank ifTrue:[
+ newLine := nil
+ ].
+ list at:lineNr put:newLine.
+ modified := true.
+ contentsWasSaved := false.
+ drawCharacterOnly ifTrue:[
+ self redrawLine:lineNr col:colNr
+ ] ifFalse:[
+ self redrawLine:lineNr from:colNr
+ ]
+!
+
+deleteCharBeforeCursor
+ "delete single character to the left of cursor and move cursor to left"
+
+ |oldSize lineNrAboveCursor|
+
+ (cursorCol == 1) ifFalse:[
+ self withCursorOffDo:[
+ cursorCol := cursorCol - 1.
+ self deleteCharAtLine:cursorLine col:cursorCol
+ ]
+ ] ifTrue:[
+ (cursorLine == 1) ifFalse:[
+ oldSize := 0.
+ lineNrAboveCursor := cursorLine - 1.
+ list notNil ifTrue:[
+ (list size >= lineNrAboveCursor) ifTrue:[
+ (list at:lineNrAboveCursor) notNil ifTrue:[
+ oldSize := (list at:lineNrAboveCursor) size
+ ]
+ ]
+ ].
+ self mergeLine:lineNrAboveCursor.
+ self withCursorOffDo:[
+ cursorLine := lineNrAboveCursor.
+ cursorCol := oldSize + 1.
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine
+ ]
+ ]
+ ]
+!
+
+deleteCharAtCursor
+ "delete single character under cursor"
+
+ self withCursorOffDo:[
+ self deleteCharAtLine:cursorLine col:cursorCol
+ ]
+!
+
+deleteSelection
+ "delete the selection"
+
+ |startLine startCol endLine endCol|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ selectionStartLine notNil ifTrue:[
+ startLine := selectionStartLine.
+ startCol := selectionStartCol.
+ endLine := selectionEndLine.
+ endCol := selectionEndCol.
+ self withCursorOffDo:[
+ self unselectWithoutRedraw.
+ self deleteFromLine:startLine col:startCol
+ toLine:endLine col:endCol.
+ cursorCol := startCol.
+ cursorLine := startLine.
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine.
+ self makeLineVisible:cursorLine
+ ]
+ ]
+!
+
+replaceSelectionBy:something
+ "delete the selection (if any) and insert something, a character or string;
+ leave cursor after insertion"
+
+ self deleteSelection.
+ (something isMemberOf:Character) ifTrue:[
+ self insertCharAtCursor:something
+ ] ifFalse:[
+ self insertStringAtCursor:something
+ ]
+! !
+
+!EditTextView methodsFor:'formatting'!
+
+indent
+ "indent selected line-range"
+
+ |start end|
+
+ start := selectionStartLine.
+ end := selectionEndLine.
+ (selectionEndCol == 0) ifTrue:[
+ end := end - 1
+ ].
+ self unselect.
+ self indentFromLine:start toLine:end
+!
+
+indentFromLine:start toLine:end
+ "indent a line-range"
+
+ |leftStart s delta line spaces|
+
+ "find a line to base indent on..."
+ leftStart := 0.
+ s := start.
+ [(leftStart == 0) and:[s ~~ 1]] whileTrue:[
+ s := s - 1.
+ leftStart := self leftIndentOfLine:s
+ ].
+
+ (leftStart == 0) ifTrue:[^ self].
+
+ delta := leftStart - (self leftIndentOfLine:start).
+ (delta == 0) ifTrue:[^ self].
+ (delta > 0) ifTrue:[
+ spaces := String new:delta
+ ].
+ start to:end do:[:lineNr |
+ line := self listAt:lineNr.
+ line notNil ifTrue:[
+ line isBlank ifTrue:[
+ list at:lineNr put:nil
+ ] ifFalse:[
+ (delta > 0) ifTrue:[
+ line := spaces , line
+ ] ifFalse:[
+ line := line copyFrom:(delta negated + 1)
+ ].
+ list at:lineNr put:line.
+ modified := true.
+ contentsWasSaved := false.
+ ]
+ ]
+ ].
+ self redrawFromLine:start to:end
+! !
+
+!EditTextView methodsFor:'cursor handling'!
+
+makeCursorVisible
+ "scroll to make cursor visible"
+
+ cursorLine notNil ifTrue:[
+ self makeLineVisible:cursorLine
+ ]
+!
+
+drawCursorCharacter
+ "draw the cursor - helper for many below"
+
+ |oldFg oldBg|
+
+ oldFg := fgColor.
+ oldBg := bgColor.
+ fgColor := cursorFgColor.
+ bgColor := cursorBgColor.
+ super redrawVisibleLine:cursorVisibleLine col:cursorCol.
+ fgColor := oldFg.
+ bgColor := oldBg
+!
+
+drawCursor
+ "draw the cursor if shown and cursor is visible"
+
+ shown ifTrue:[
+ cursorVisibleLine notNil ifTrue:[
+ self drawCursorCharacter
+ ]
+ ]
+!
+
+undrawCursor
+ "undraw the cursor"
+
+ cursorVisibleLine notNil ifTrue:[
+ super redrawVisibleLine:cursorVisibleLine col:cursorCol
+ ]
+!
+
+hideCursor
+ "make cursor invisible if currently visible; return true if cursor
+ was visible"
+
+ cursorShown ifTrue: [
+ self undrawCursor.
+ cursorShown := false.
+ ^ true
+ ].
+ ^ false
+!
+
+showCursor
+ "make cursor visible if currently invisible"
+
+ cursorShown ifFalse: [
+ self drawCursor.
+ cursorShown := true
+ ]
+!
+
+withCursorOffDo:aBlock
+ "evaluate aBlock with cursor off"
+
+ |cShown|
+
+ shown ifFalse:[
+ aBlock value
+ ] ifTrue:[
+ cShown := self hideCursor.
+ aBlock value.
+ cShown ifTrue:[self showCursor]
+ ]
+!
+
+cursorHome
+ "scroll to top AND move cursor to first line of text"
+
+ self withCursorOffDo:[
+ self scrollToTop.
+ cursorCol := 1.
+ cursorVisibleLine := 1.
+ cursorLine := self visibleLineToAbsoluteLine:1.
+ self makeCursorVisible.
+ ]
+!
+
+cursorToBottom
+ "move cursor to last line of text"
+
+ |newTop|
+
+ self withCursorOffDo:[
+ newTop := list size - nFullLinesShown.
+ (newTop < 1) ifTrue:[
+ newTop := 1
+ ].
+ self scrollToLine:newTop.
+ cursorCol := 1.
+ cursorLine := list size.
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine.
+ self makeCursorVisible.
+ ]
+!
+
+cursorUp
+ "move cursor up; scroll if at start of visible text"
+
+ (cursorLine == 1) ifFalse: [
+ self withCursorOffDo:[
+ (cursorVisibleLine == 1) ifTrue:[self scrollUp].
+ cursorLine := cursorLine - 1.
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine.
+ ].
+ self makeCursorVisible.
+ ]
+!
+
+cursorDown
+ "move cursor down; scroll if at end of visible text"
+
+ cursorVisibleLine notNil ifTrue:[
+ self withCursorOffDo:[
+ (cursorVisibleLine >= nFullLinesShown) ifTrue:[self scrollDown].
+ cursorLine := cursorLine + 1.
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine
+ ]
+ ] ifFalse:[
+ cursorLine := cursorLine + 1.
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine
+ ].
+ self makeCursorVisible.
+!
+
+cursorLeft
+ "move cursor to left"
+
+ (cursorCol == 1) ifFalse: [
+ self withCursorOffDo:[cursorCol := cursorCol - 1]
+ ].
+ self makeCursorVisible.
+!
+
+cursorRight
+ "move cursor to right"
+
+ self withCursorOffDo:[cursorCol := cursorCol + 1].
+ self makeCursorVisible.
+!
+
+cursorToBeginOfLine
+ "move cursor to start of current line"
+
+ self withCursorOffDo:[
+ cursorCol := 1
+ ].
+ self makeCursorVisible.
+!
+
+cursorToEndOfLine
+ "move cursor to end of current line"
+
+ |line|
+
+ self withCursorOffDo:[
+ line := list at:cursorLine.
+ cursorCol := line size + 1
+ ].
+ self makeCursorVisible.
+!
+
+cursorTab
+ "move cursor to next tabstop"
+
+ self withCursorOffDo:[
+ cursorCol := self nextTabAfter:cursorCol
+ ].
+ self makeCursorVisible.
+!
+
+cursorBacktab
+ "move cursor to prev tabstop"
+
+ self withCursorOffDo:[
+ cursorCol := self prevTabBefore:cursorCol
+ ].
+ self makeCursorVisible.
+!
+
+cursorReturn
+ "move cursor to start of next line; scroll if at end of visible text"
+
+ self checkForExistingLine:(cursorLine + 1).
+ cursorVisibleLine notNil ifTrue:[
+ nFullLinesShown notNil ifTrue:[
+ (cursorVisibleLine >= nFullLinesShown) ifTrue:[self scrollDown]
+ ]
+ ].
+ self withCursorOffDo:[
+ cursorCol := 1.
+ cursorLine := cursorLine + 1.
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine
+ ].
+ self makeCursorVisible.
+!
+
+cursorVisibleLine:visibleLineNr col:colNr
+ "put cursor to visibleline/col"
+
+ self withCursorOffDo:[
+ cursorLine := self visibleLineToAbsoluteLine:visibleLineNr.
+ cursorVisibleLine := visibleLineNr.
+ cursorCol := colNr.
+ (cursorCol < 1) ifTrue:[
+ cursorCol := 1
+ ]
+ ].
+ self makeCursorVisible.
+!
+
+cursorX:x y:y
+ "put cursor to position next to x/y coordinate in view"
+
+ |line col|
+
+ line := self visibleLineOfY:y.
+ col := self colOfX:x inVisibleLine:line.
+ self cursorVisibleLine:line col:col.
+!
+
+cursorLine:line col:col
+ "this positions onto physical - not visible - line"
+
+ self withCursorOffDo:[
+ cursorLine := line.
+ cursorVisibleLine := self listLineToVisibleLine:line.
+ cursorCol := col.
+ (cursorCol < 1) ifTrue:[
+ cursorCol := 1
+ ]
+ ].
+ self makeCursorVisible.
+!
+
+cursorToTop
+ "move cursor to absolute home"
+
+ self cursorLine:1 col:1
+!
+
+gotoLine:aLineNumber
+ self makeLineVisible:aLineNumber.
+ self cursorLine:aLineNumber col:1
+! !
+
+!EditTextView methodsFor:'undo'!
+
+undo
+ "currently not implemented"
+
+ ^ self
+! !
+
+!EditTextView methodsFor:'cut & paste'!
+
+cut
+ "cut selection into copybuffer"
+
+ Smalltalk at:#CopyBuffer put:(self selection).
+ self deleteSelection
+!
+
+paste
+ "paste copybuffer at cursor"
+
+ |text|
+
+ text := Smalltalk at:#CopyBuffer.
+ text notNil ifTrue:[
+ self insertLines:text asText withCr:false
+ ]
+!
+
+replace
+ "replace selection by copybuffer"
+
+ self deleteSelection.
+ self paste
+! !
+
+!EditTextView methodsFor:'selections'!
+
+disableSelectionMenuEntries
+ "disable relevant menu entries for a selection"
+
+ middleButtonMenu notNil ifTrue:[
+ super disableSelectionMenuEntries.
+ middleButtonMenu disable:#cut.
+ middleButtonMenu disable:#replace.
+ middleButtonMenu disable:#indent
+ ]
+!
+
+enableSelectionMenuEntries
+ "enable relevant menu entries for a selection"
+
+ middleButtonMenu notNil ifTrue:[
+ readOnly ifTrue:[
+ super disableSelectionMenuEntries.
+ middleButtonMenu disable:#cut.
+ middleButtonMenu disable:#replace.
+ middleButtonMenu disable:#indent.
+ middleButtonMenu disable:#paste.
+ ] ifFalse:[
+ super enableSelectionMenuEntries.
+ middleButtonMenu enable:#cut.
+ middleButtonMenu enable:#replace.
+ middleButtonMenu enable:#indent.
+ ]
+ ]
+!
+
+unselect
+ "forget and unhilight selection - must take care of cursor here"
+
+ self withCursorOffDo:[
+ super unselect
+ ]
+!
+
+selectCursorLine
+ "select cursorline up to cursor position"
+
+ self selectFromLine:cursorLine col:1
+ toLine:cursorLine col:cursorCol
+!
+
+selectWordUnderCursor
+ "select the word under the cursor"
+
+ self selectWordAtLine:cursorLine col:cursorCol
+!
+
+selectFromLine:startLine col:startCol toLine:endLine col:endCol
+ "when a range is selected, position the cursor behind the selection
+ for easier editing"
+
+ super selectFromLine:startLine col:startCol toLine:endLine col:endCol.
+ self cursorLine:selectionEndLine col:(selectionEndCol + 1)
+! !
+
+!EditTextView methodsFor:'scrolling'!
+
+originWillChange
+ "sent before scrolling - have to hide the cursor"
+
+ prevCursorState := cursorShown.
+ cursorShown ifTrue:[
+ self hideCursor
+ ]
+!
+
+originChanged:delta
+ "sent after scrolling - have to show the cursor if it was on before"
+
+ super originChanged:delta.
+ "
+ should we move the cursor with the scroll - or leave it ?
+ "
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine.
+ prevCursorState ifTrue:[
+ self showCursor
+ ]
+!
+
+pageUp
+ "page up - to keep cursor on same visible line, it has to be moved
+ within the real text "
+
+ |prevCursorLine|
+
+ prevCursorLine := cursorVisibleLine.
+ super pageUp.
+ self cursorVisibleLine:prevCursorLine col:cursorCol
+!
+
+pageDown
+ "page down - to keep cursor on same visible line, it has to be moved
+ within the real text "
+
+ |prevCursorLine|
+
+ prevCursorLine := cursorVisibleLine.
+ super pageDown.
+ self cursorVisibleLine:prevCursorLine col:cursorCol
+! !
+
+!EditTextView methodsFor:'searching'!
+
+setSearchPattern
+ "set the searchpattern from the selection if there is one, and position
+ corsor to start of pattern"
+
+ |sel|
+
+ sel := self selection.
+ sel notNil ifTrue:[
+ self cursorLine:selectionStartLine col:selectionStartCol.
+ searchPattern := sel asString withoutSeparators
+ ]
+!
+
+searchFwd:pattern
+ "do the forward search"
+
+ self searchForwardFor:pattern startingAtLine:cursorLine col:cursorCol
+ ifFound:[:line :col |
+ self cursorLine:line col:col.
+ self selectFromLine:line col:col
+ toLine:line col:(col + pattern size - 1).
+ self makeLineVisible:cursorLine
+ ] else:[
+ self showNotFound
+ ]
+!
+
+searchBwd:pattern
+ "do the backward search"
+
+ self searchBackwardFor:pattern startingAtLine:cursorLine col:cursorCol
+ ifFound:[:line :col |
+ self cursorLine:line col:col.
+ self selectFromLine:line col:col
+ toLine:line col:(col + pattern size - 1).
+ self makeLineVisible:cursorLine
+ ] else:[
+ self showNotFound
+ ]
+!
+
+searchForMatchingParentesis:parChar
+ "search for a matching parenthesis, parChar is one of '$( $[ ${ $) $] $}'. Search
+ for the corresponding character is done forward if its an opening, backwards if
+ its a closing parenthesis.
+ Positions the cursor if found, peeps if not"
+
+ |i direction lineString line col charSet ignoreSet closingChar
+ ignoring delta endCol cc incSet decSet nesting|
+
+ charSet := #( $( $) $[ $] ${ $} ).
+ ignoreSet := #( $' $" ).
+
+ i := charSet indexOf:parChar.
+ i == 0 ifTrue:[
+ device beep.
+ ^ self
+ ].
+ direction := #( fwd bwd fwd bwd fwd bwd) at:i.
+ closingChar := #( $) $( $] $[ $} ${ ) at:i.
+
+ col := cursorCol.
+ line := cursorLine.
+ direction == #fwd ifTrue:[
+ delta := 1.
+ incSet := #( $( $[ ${ ).
+ decSet := #( $) $] $} ).
+ ] ifFalse:[
+ delta := -1.
+ incSet := #( $) $] $} ).
+ decSet := #( $( $[ ${ ).
+ ].
+
+ nesting := 1.
+ ignoring := false.
+ lineString := list at:line.
+
+ col := col + delta.
+ [nesting ~~ 0] whileTrue:[
+ lineString notNil ifTrue:[
+ direction == #fwd ifTrue:[
+ endCol := lineString size.
+ ] ifFalse:[
+ endCol := 1
+ ].
+ col to:endCol by:delta do:[:runCol |
+ cc := lineString at:runCol.
+
+ (ignoreSet includes:cc) ifTrue:[
+ ignoring := ignoring not
+ ].
+ ignoring ifFalse:[
+ (incSet includes:cc) ifTrue:[
+ nesting := nesting + 1
+ ] ifFalse:[
+ (decSet includes:cc) ifTrue:[
+ nesting := nesting - 1
+ ]
+ ]
+ ].
+ nesting == 0 ifTrue:[
+ "check if legal"
+
+ cc == closingChar ifFalse:[
+ device beep.
+ ] ifTrue:[
+ self cursorLine:line col:runCol.
+ ].
+ ^ self
+ ]
+ ].
+ ].
+ line := line + delta.
+ lineString := list at:line.
+ direction == #fwd ifTrue:[
+ col := 1
+ ] ifFalse:[
+ col := lineString size
+ ]
+ ].
+
+ self showNotFound
+!
+
+searchForMatchingParentesis
+ "search for a matching parenthesis if one is under cusor"
+
+ |line col lineString|
+
+ col := cursorCol.
+ line := cursorLine.
+ lineString := list at:line.
+ lineString notNil ifTrue:[
+ col <= lineString size ifTrue:[
+ self searchForMatchingParentesis:(lineString at:col).
+ ^ self
+ ]
+ ].
+ device beep
+! !
+
+!EditTextView methodsFor:'redrawing'!
+
+redrawCursorIfBetweenVisibleLine:startVisLine and:endVisLine
+ "redraw the cursor, if it sits in a line range"
+
+ cursorShown ifTrue:[
+ cursorVisibleLine notNil ifTrue:[
+ (cursorVisibleLine between:startVisLine and:endVisLine) ifTrue:[
+ self drawCursorCharacter
+ ]
+ ]
+ ]
+!
+
+redrawCursorIfInVisibleLine:visLine
+ "redraw the cursor, if it sits in visible line"
+
+ cursorShown ifTrue:[
+ (visLine == cursorVisibleLine) ifTrue:[
+ self drawCursorCharacter
+ ]
+ ]
+!
+
+redrawFromVisibleLine:startVisLine to:endVisLine
+ "redraw a visible line range"
+
+ super redrawFromVisibleLine:startVisLine to:endVisLine.
+ self redrawCursorIfBetweenVisibleLine:startVisLine and:endVisLine
+!
+
+redrawVisibleLine:visLine col:colNr
+ "redraw the single character in visibleline at colNr"
+
+ cursorShown ifTrue:[
+ (visLine == cursorVisibleLine) ifTrue:[
+ (colNr == cursorCol) ifTrue:[
+ self drawCursorCharacter.
+ ^ self
+ ]
+ ]
+ ].
+ super redrawVisibleLine:visLine col:colNr
+!
+
+redrawVisibleLine:visLine
+ "redraw a visible line"
+
+ super redrawVisibleLine:visLine.
+ self redrawCursorIfInVisibleLine:visLine
+!
+
+redrawVisibleLine:visLine from:startCol
+ "redraw a visible line from startCol to the end of line"
+
+ super redrawVisibleLine:visLine from:startCol.
+ self redrawCursorIfInVisibleLine:visLine
+!
+
+redrawVisibleLine:visLine from:startCol to:endCol
+ "redraw a visible line from startCol to endCol"
+
+ super redrawVisibleLine:visLine from:startCol to:endCol.
+ self redrawCursorIfInVisibleLine:visLine
+! !
+
+!EditTextView methodsFor:'event processing'!
+
+sizeChanged:how
+ "make certain, cursor is visible after the sizechange"
+
+ |cv|
+
+ cv := cursorVisibleLine.
+ super sizeChanged:how.
+ cv notNil ifTrue:[
+ self makeLineVisible:cursorLine
+ ]
+!
+
+keyPress:key x:x y:y
+ "handle keyboard input"
+
+ (key isMemberOf:Character) ifTrue:[
+ (wordSelectStyle == #left) ifTrue:[
+ self replaceSelectionBy:(' ' copyWith:key)
+ ] ifFalse:[
+ (wordSelectStyle == #right) ifTrue:[
+ self replaceSelectionBy:(key asString , ' ').
+ self cursorLeft
+ ] ifFalse:[
+ self replaceSelectionBy:key
+ ]
+ ].
+ wordSelectStyle := nil.
+ ^ self
+ ].
+
+ ((key == #Paste) or:[key == #Insert]) ifTrue:[self paste. ^self].
+ (key == #Cut) ifTrue:[self cut. ^self].
+
+ (key == #Replace) ifTrue:[self replace. ^self].
+ (key == #Cmdw) ifTrue:[
+ self makeCursorVisible.
+ self selectWordUnderCursor.
+ ^self
+ ].
+
+ (key == #Ctrlm) ifTrue:[
+ self searchForMatchingParentesis.
+ ^self
+ ].
+
+ (key == #Ctrlb) ifTrue:[self unselect. self cursorLeft. ^self].
+ (key == #Ctrlf) ifTrue:[self unselect. self cursorRight. ^self].
+ (key == #Ctrln) ifTrue:[self unselect. self cursorDown. ^self].
+ (key == #Ctrlp) ifTrue:[self unselect. self cursorUp. ^self].
+
+ (key == #Ctrla) ifTrue:[self cursorToBeginOfLine. ^self].
+ (key == #Ctrle) ifTrue:[self cursorToEndOfLine. ^self].
+
+ (key == #CursorRight) ifTrue:[
+ self unselect. self cursorRight. ^self
+ ].
+ (key == #CursorLeft) ifTrue:[
+ self unselect. self cursorLeft. ^self
+ ].
+ (key == #CursorUp) ifTrue:[
+ self unselect. self cursorUp. ^self
+ ].
+ (key == #CursorDown) ifTrue:[
+ self unselect. self cursorDown. ^self
+ ].
+
+ (key == #Return) ifTrue:[
+ device shiftDown ifTrue:[
+ self unselect. self cursorReturn. ^self
+ ].
+ self unselect.
+ self makeCursorVisible.
+ self insertCharAtCursor:(Character cr).
+ ^self
+ ].
+ (key == #BackSpace) ifTrue:[
+ self unselect.
+ self makeCursorVisible.
+ self deleteCharBeforeCursor.
+ ^self
+ ].
+ (key == #Tab) ifTrue:[
+ device shiftDown ifTrue:[
+ self unselect. self cursorBacktab. ^self
+ ].
+ self unselect. self cursorTab. ^self
+ ].
+ (key == #Delete) ifTrue:[
+ selectionStartLine notNil ifTrue:[
+ Smalltalk at:#CopyBuffer put:(self selection).
+ self deleteSelection. ^ self
+ ].
+ self makeCursorVisible.
+ self deleteCharBeforeCursor. ^self
+ ].
+ (key == #Home) ifTrue:[
+ self unselect. self cursorHome. ^self
+ ].
+ (key == #End) ifTrue:[
+ self unselect. self cursorToBottom. ^self
+ ].
+ (key == #Escape) ifTrue:[
+ self makeCursorVisible.
+ self unselect. self selectCursorLine. ^ self
+ ].
+ (key == #DeleteLine) ifTrue:[
+ self makeCursorVisible.
+ self unselect. self deleteCursorLine. ^self
+ ].
+ super keyPress:key x:x y:y
+!
+
+buttonPress:button x:x y:y
+ "hide the cursor when button is activated"
+
+ (button == 1) ifTrue:[
+ self hideCursor
+ ].
+ super buttonPress:button x:x y:y
+!
+
+buttonRelease:button x:x y:y
+ "move the cursor to the click-position of previous button press"
+
+ (button == 1) ifTrue:[
+ selectionStartLine isNil ifTrue:[
+ clickCol notNil ifTrue:[
+ self cursorLine:clickLine col:clickCol
+ ]
+ ].
+ self showCursor
+ ].
+ super buttonRelease:button x:x y:y
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/EditField.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,270 @@
+"
+ COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+EditTextView subclass:#EditField
+ instanceVariableNames:'leaveAction enabled enableAction'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Text'
+!
+
+EditField comment:'
+
+COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+an editable text-field. Realized by using an EditTextView,
+and forcing its size to 1 line - disabling cursor movement
+in the vertical direction.
+
+%W% %E%
+written jan-90 by claus
+'!
+
+!EditField class methodsFor:'defaults'!
+
+defaultNumberOfLines
+ "the number of lines in the field"
+
+ ^ 1
+! !
+
+!EditField methodsFor:'initialization'!
+
+initialize
+ super initialize.
+ self height:(font height + font descent + (topMargin * 2)).
+ enabled := true.
+ fixedSize := true.
+ nFullLinesShown := 1.
+ nLinesShown := 1.
+!
+
+initStyle
+ |myBgColor myFont|
+
+ super initStyle.
+
+ myBgColor := Resource name:'EDITFIELD_BACKGROUND'
+ default:nil
+ fromFile:'Smalltalk.rs'.
+
+ myBgColor notNil ifTrue:[
+ bgColor := myBgColor on:device.
+ self viewBackground:bgColor.
+ selectionFgColor := fgColor on:device.
+ selectionBgColor := White on:device
+ ].
+
+ myFont := Resource name:'EDITFIELD_FONT'
+ default:nil
+ fromFile:'Smalltalk.rs'.
+
+ myFont notNil ifTrue:[
+ font := myFont
+ ]
+!
+
+initializeMiddleButtonMenu
+ |labels|
+
+ labels := resources array:#(
+ 'copy'
+ 'cut'
+ 'paste'
+ 'replace').
+
+ self middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(
+ copySelection
+ cut
+ paste
+ replace)
+ receiver:self
+ for:self)
+! !
+
+!EditField methodsFor:'realization'!
+
+realize
+ "scroll back to beginning when realized"
+ leftOffset := 0.
+ super realize
+! !
+
+!EditField methodsFor:'private'!
+
+startScrollUp:y
+ "no scrolling in editfields"
+
+ ^ self
+!
+
+startScrollDown:y
+ "no scrolling in editfields"
+
+ ^ self
+! !
+
+!EditField methodsFor:'accessing'!
+
+contents
+ "return contents as a string
+ - redefined since EditFields hold only one line of text"
+
+ list isNil ifTrue:[^ ''].
+ (list size == 0) ifTrue:[^ ''].
+ ^ list at:1
+!
+
+enable
+ "enable the field; show cursor and allow input"
+
+ enabled ifFalse:[
+ enableAction notNil ifTrue:[
+ enableAction value
+ ].
+ enabled := true.
+ super showCursor
+ ]
+!
+
+disable
+ "disable the field; hide cursor and ignore input"
+
+ enabled ifTrue:[
+ enabled := false.
+ self hideCursor
+ ]
+!
+
+enableAction:aBlock
+ "define an action to be evaluated when enabled by clicking upon"
+
+ enableAction := aBlock
+!
+
+leaveAction:aBlock
+ "define an action to be evaluated when field is left by return key"
+
+ leaveAction := aBlock
+!
+
+initialText:aString
+ "set the initialText"
+
+ leftOffset := 0.
+ self contents:aString.
+ self selectFromLine:1 col:1 toLine:1 col:(aString size)
+! !
+
+!EditField methodsFor:'cursor drawing'!
+
+showCursor
+ "make cursor visible if currently invisible - but only if this
+ EditField is enabled"
+
+ enabled ifTrue:[super showCursor]
+! !
+
+!EditField methodsFor:'cursor movement'!
+
+cursorLine:line col:col
+ ((line >= 1) and:[line <= nLinesShown]) ifTrue:[
+ super cursorLine:line col:col
+ ]
+ "ignore"
+!
+
+cursorDown
+ "catch cursor movement"
+
+ (cursorVisibleLine == nLinesShown) ifFalse:[
+ super cursorDown
+ ]
+! !
+
+!EditField methodsFor:'event processing'!
+
+buttonPress:button x:x y:y
+ "enable myself on mouse click"
+
+ enabled ifFalse:[
+ enabled := true.
+ super buttonPress:button x:x y:y.
+ enableAction notNil ifTrue:[
+ enableAction value
+ ]
+ ] ifTrue:[
+ super buttonPress:button x:x y:y
+ ]
+!
+
+canHandle:aKey
+ "return true, if the receiver would like to handle aKey
+ (usually from another view, when the receiver is part of
+ a more complex dialog box).
+ We do return true here, since the editfield will handle
+ all keys."
+
+ ^ true
+!
+
+keyPress:key x:x y:y
+ "if keyHandler is defined, pass input; otherwise check for leave
+ keys"
+
+ |leave x|
+
+ enabled ifFalse:[
+ (keyboardHandler notNil
+ and:[keyboardHandler canHandle:key]) ifTrue:[
+ (keyboardHandler == self) ifTrue:[
+ self error:'invalid keyhandler'.
+ ^ self
+ ].
+ keyboardHandler keyPress:key x:x y:y
+ ].
+ ^ self
+ ].
+
+ (key == #DeleteLine) ifTrue:[
+ Smalltalk at:#CopyBuffer put:(self contents).
+ self contents:''. ^ self
+ ].
+
+ leave := false.
+ (key == #Return) ifTrue:[leave := true].
+ ((key == #CursorDown) or:[key == #Next]) ifTrue:[leave := true].
+ ((key == #CursorUp) or:[key == #Prior]) ifTrue:[leave := true].
+
+ leave ifTrue:[
+ leaveAction notNil ifTrue:[
+ leaveAction value:key
+ ].
+ ^ self
+ ].
+ super keyPress:key x:x y:y.
+ x := (self xOfCol:cursorCol inLine:cursorLine) - leftOffset.
+ (x > (width * (5/6))) ifTrue:[
+ leftOffset := leftOffset + (width // 2).
+ self clear.
+ self redraw
+ ] ifFalse:[
+ (x < (width * (1/6))) ifTrue:[
+ leftOffset := 0 max: leftOffset - (width // 2).
+ self clear.
+ self redraw
+ ]
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/EditTextView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,1899 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+TextView subclass:#EditTextView
+ instanceVariableNames:'cursorLine cursorVisibleLine
+ cursorCol cursorShown prevCursorState
+ readOnly modified fixedSize
+ exceptionBlock
+ errorMessage
+ cursorFgColor cursorBgColor
+ undoAction redoAction'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Text'
+!
+
+EditTextView comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+
+written jun-89 by claus
+'!
+
+!EditTextView class methodsFor:'documentation'!
+
+documentation
+"
+ a view for editable text - adds editing functionality to TextView
+
+ Instance variables:
+
+ cursorLine <Number> line where cursor sits (1..)
+ cursorVisibleLine <Number> visible line where cursor sits (1..nLinesShown)
+ cursorCol <Number> col where cursor sits (1..)
+ cursorShown <Boolean> true, if cursor is currently shown
+ prevCursorState <Boolean> temporary
+ readOnly <Boolean> true, if text may not be edited
+ modified <Boolean> true, if text has been modified
+ fixedSize <Boolean> true, if no lines may be added/removed
+ exceptionBlock <Block> block to be evaluated when readonly text is about to be modified
+ errorMessage <String> message text
+ cursorFgColor <Color> color used for cursor drawing
+ cursorBgColor <Color> color used for cursor drawing
+"
+! !
+
+!EditTextView methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ self level:-1.
+ errorMessage := 'Text may not me changed'.
+ readOnly := false.
+ fixedSize := false.
+ exceptionBlock := [:errorText | ].
+ cursorShown := true.
+ cursorLine := 1.
+ cursorVisibleLine := 1.
+ cursorCol := 1.
+ modified := false
+!
+
+initStyle
+ super initStyle.
+ cursorFgColor := bgColor.
+ device hasColors ifTrue:[
+ cursorBgColor := Color red
+ ] ifFalse:[
+ cursorBgColor := fgColor
+ ]
+!
+
+initializeMiddleButtonMenu
+ |labels|
+
+ labels := resources array:#("
+ 'undo'
+ '-'
+ "
+ 'copy'
+ 'cut'
+ 'paste'
+ 'replace'
+ '-'
+ 'font'
+ '-'
+ 'search'
+ 'goto'
+ '-'
+ 'indent'
+ '-'
+ 'save'
+ 'print').
+
+ self middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#("undo
+ nil"
+ copySelection
+ cut
+ paste
+ replace
+ nil
+ changeFont
+ nil
+ search
+ gotoLine
+ nil
+ indent
+ nil
+ save
+ print)
+ receiver:self
+ for:self).
+
+ self enableOrDisableSelectionMenuEntries
+!
+
+realize
+ super realize.
+ cursorFgColor := cursorFgColor on:device.
+ cursorBgColor := cursorBgColor on:device.
+! !
+
+!EditTextView methodsFor:'accessing'!
+
+cursorForegroundColor:color1 backgroundColor:color2
+ "set both cursor foreground and cursor background colors"
+
+ self hideCursor.
+ cursorFgColor := color1 on:device.
+ cursorBgColor := color2 on:device.
+ self showCursor
+!
+
+contents
+ "answer the contents as a String"
+
+ list isNil ifTrue:[^ ''].
+ self removeTrailingBlankLines.
+ ^ list asString
+!
+
+list:something
+ "position cursor home when setting contents"
+
+ super list:something.
+ self cursorHome
+!
+
+readOnly
+ "make the text readonly"
+
+ readOnly := true
+!
+
+fixedSize
+ "make the texts size fixed (no lines may be added)"
+
+ readOnly ifFalse:[
+ readOnly := true.
+ middleButtonMenu disable:#cut.
+ middleButtonMenu disable:#paste.
+ middleButtonMenu disable:#replace.
+ middleButtonMenu disable:#indent
+ ]
+!
+
+exceptionBlock:aBlock
+ "define the action to be triggered when user tries to modify
+ readonly text"
+
+ exceptionBlock := aBlock
+!
+
+fromFile:aFileName
+ "take contents from a named file"
+
+ self contents:(FileText ofFile:aFileName)
+!
+
+modified:aBoolean
+ "set the modified flag"
+
+ modified := aBoolean
+!
+
+modified
+ "return true if text was modified"
+
+ ^ modified
+! !
+
+!EditTextView methodsFor:'private'!
+
+contentsChanged
+ "triggered whenever text is changed"
+
+ super contentsChanged.
+ modified := true.
+ contentsWasSaved := false
+! !
+
+!EditTextView methodsFor:'editing'!
+
+mergeLine:lineNr
+ "merge line lineNr with line lineNr+1"
+
+ |leftPart rightPart bothParts nextLineNr|
+
+ list isNil ifFalse:[
+ nextLineNr := lineNr + 1.
+ (nextLineNr > list size) ifFalse:[
+ (list at:lineNr) isNil ifTrue:[
+ leftPart := ''
+ ] ifFalse:[
+ leftPart := list at:lineNr
+ ].
+ (list at:nextLineNr) isNil ifTrue:[
+ rightPart := ''
+ ] ifFalse:[
+ rightPart := list at:nextLineNr
+ ].
+ bothParts := leftPart , rightPart.
+ bothParts isBlank ifTrue:[bothParts := nil].
+ list at:lineNr put:bothParts.
+ self redrawLine:lineNr.
+ self deleteLine:nextLineNr
+ ]
+ ]
+!
+
+splitLine:lineNr before:colNr
+ "split the line linNr before colNr; the right part (from colNr)
+ is cut off and inserted after lineNr; the view is redrawn"
+
+ |line lineSize leftRest rightRest visLine w
+ srcY "{ Class: SmallInteger }" |
+
+ list isNil ifFalse:[
+ lineNr > (list size) ifFalse:[
+ (colNr == 1) ifTrue:[
+ self insertLine:nil before:lineNr.
+ ^ self
+ ].
+ line := list at:lineNr.
+ line isNil ifFalse:[
+ lineSize := line size.
+ (colNr <= lineSize) ifTrue:[
+ rightRest := line copyFrom:colNr to:lineSize.
+ (colNr > 1) ifTrue:[
+ leftRest := line copyFrom:1 to:(colNr - 1)
+ ]
+ ] ifFalse:[
+ leftRest := line
+ ]
+ ].
+ leftRest notNil ifTrue:[
+ leftRest isBlank ifTrue:[leftRest := nil]
+ ].
+ list at:lineNr put:leftRest.
+ modified := true.
+ contentsWasSaved := false.
+ self withoutRedrawInsertLine:rightRest before:(lineNr + 1).
+
+ visLine := self listLineToVisibleLine:(lineNr).
+ visLine notNil ifTrue:[
+ w := self widthForScrollBetween:lineNr
+ and:(firstLineShown + nLinesShown).
+ srcY := topMargin + (visLine * fontHeight).
+ self copyFrom:self x:textStartLeft y:srcY
+ toX:textStartLeft y:(srcY + fontHeight)
+ width:w
+ height:((nLinesShown - visLine - 1) * fontHeight).
+ self redrawLine:lineNr.
+ self redrawLine:(lineNr + 1).
+ exposePending := true.
+ self waitForExpose
+ ]
+ ]
+ ]
+!
+
+withoutRedrawInsertLine:aString before:lineNr
+ "insert the argument, aString before line lineNr; the string
+ becomes line nileNr; everything else is moved down; the view
+ is not redrawn"
+
+ |line|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ line := aString.
+ line notNil ifTrue:[
+ line isBlank ifTrue:[
+ line := nil
+ ] ifFalse:[
+ (line occurrencesOf:(Character tab)) == 0 ifFalse:[
+ line := self withTabsExpanded:line
+ ]
+ ]
+ ].
+ list isNil ifTrue: [
+ list := Text new:lineNr
+ ] ifFalse: [
+ list grow:((list size + 1) max:lineNr)
+ ].
+
+ "I have changed 'replaceFrom:to:with:startingAt:' to correctly handle
+ overlapping copy - if it didn't, we had to use:"
+"
+ index := list size.
+ [index > lineNr] whileTrue: [
+ pIndex := index - 1.
+ list at:index put:(list at:pIndex).
+ index := pIndex
+ ].
+"
+ list replaceFrom:(lineNr + 1) to:(list size) with:list startingAt:lineNr.
+ list at:lineNr put:line.
+ self contentsChanged
+!
+
+insertLine:aString before:lineNr
+ "insert the line aString before line lineNr"
+
+ |visLine w
+ dstY "{ Class: SmallInteger }" |
+
+ self withoutRedrawInsertLine:aString before:lineNr.
+ visLine := self listLineToVisibleLine:lineNr.
+ visLine notNil ifTrue:[
+ w := self widthForScrollBetween:lineNr
+ and:(firstLineShown + nLinesShown).
+ dstY := topMargin + ((visLine ) * fontHeight).
+ self copyFrom:self x:textStartLeft y:(dstY - fontHeight)
+ toX:textStartLeft y:dstY
+ width:w
+ height:((nLinesShown - visLine "- 1") * fontHeight).
+ self redrawVisibleLine:visLine.
+ exposePending := true.
+ self waitForExpose
+ ]
+!
+
+insertLines:someText from:start to:end before:lineNr
+ "insert a bunch of lines before line lineNr"
+
+ |visLine w nLines "{ Class: SmallInteger }"
+ srcY "{ Class: SmallInteger }"
+ dstY "{ Class: SmallInteger }" |
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ self withoutRedrawInsertLines:someText
+ from:start to:end
+ before:lineNr.
+ visLine := self listLineToVisibleLine:lineNr.
+ visLine notNil ifTrue:[
+ nLines := end - start + 1.
+ ((visLine + nLines) >= nLinesShown) ifTrue:[
+ self redrawFromVisibleLine:visLine to:nLinesShown
+ ] ifFalse:[
+ w := self widthForScrollBetween:(lineNr + nLines)
+ and:(firstLineShown + nLines + nLinesShown).
+ srcY := topMargin + ((visLine - 1) * fontHeight).
+ dstY := srcY + (nLines * fontHeight).
+ self copyFrom:self x:textStartLeft y:srcY
+ toX:textStartLeft y:dstY
+ width:w
+ height:(height - dstY).
+ self redrawFromVisibleLine:visLine to:(visLine + nLines - 1).
+ exposePending := true.
+ self waitForExpose
+ ]
+ ]
+!
+
+insert:aCharacter atLine:lineNr col:colNr
+ "insert a single character at lineNr/colNr"
+
+ |line lineSize newLine drawCharacterOnly|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ aCharacter == (Character cr) ifTrue:[
+ self splitLine:lineNr before:colNr.
+ ^ self
+ ].
+ drawCharacterOnly := false.
+ self checkForExistingLine:lineNr.
+ line := list at:lineNr.
+ lineSize := line size.
+ (aCharacter == Character space) ifTrue:[
+ (colNr > lineSize) ifTrue:[
+ ^ self
+ ]
+ ].
+ (lineSize == 0) ifTrue: [
+ newLine := String new:colNr.
+ drawCharacterOnly := true
+ ] ifFalse: [
+ (colNr > lineSize) ifTrue: [
+ newLine := String new:colNr.
+ newLine replaceFrom:1 to:lineSize
+ with:line startingAt:1.
+ drawCharacterOnly := true
+ ] ifFalse: [
+ newLine := String new:(lineSize + 1).
+ newLine replaceFrom:1 to:(colNr - 1)
+ with:line startingAt:1.
+ newLine replaceFrom:(colNr + 1) to:(lineSize + 1)
+ with:line startingAt:colNr
+ ]
+ ].
+ newLine at:colNr put:aCharacter.
+ aCharacter == (Character tab) ifTrue:[
+ newLine := self withTabsExpanded:newLine.
+ drawCharacterOnly := false
+ ].
+ list at:lineNr put:newLine.
+ modified := true.
+ contentsWasSaved := false.
+ drawCharacterOnly ifTrue:[
+ self redrawLine:lineNr col:colNr
+ ] ifFalse:[
+ self redrawLine:lineNr from:colNr
+ ]
+!
+
+withoutRedrawInsertLines:lines from:start to:end before:lineNr
+ "insert a bunch of lines before line lineNr; the view
+ is not redrawn"
+
+ |newLine newLines nLines|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+
+ nLines := end - start + 1.
+ newLines := Array new:(lines size).
+ start to:end do:[:index |
+ newLine := lines at:index.
+ newLine notNil ifTrue:[
+ newLine isBlank ifTrue:[
+ newLine := nil
+ ] ifFalse:[
+ (newLine occurrencesOf:(Character tab)) == 0 ifFalse:[
+ newLine := self withTabsExpanded:newLine
+ ]
+ ]
+ ].
+ newLines at:index put:newLine
+ ].
+ list isNil ifTrue: [
+ list := Text new:(lineNr + nLines + 1)
+ ] ifFalse: [
+ list grow:((list size + nLines) max:(lineNr + nLines - 1))
+ ].
+
+ "I have changed 'replaceFrom:to:with:startingAt:' to correctly handle
+ overlapping copy - if it didn't, we had to use:"
+"
+ index := list size.
+ [index > lineNr] whileTrue: [
+ pIndex := index - 1.
+ list at:index put:(list at:pIndex).
+ index := pIndex
+ ].
+"
+ list replaceFrom:(lineNr + nLines) to:(list size) with:list startingAt:lineNr.
+ list replaceFrom:lineNr to:(lineNr + nLines - 1) with:newLines startingAt:start.
+ self contentsChanged
+!
+
+withoutRedrawInsertStringWithoutCRs:aString atLine:lineNr col:colNr
+ "insert aString (which has no crs) at lineNr/colNr"
+
+ |strLen line lineSize newLine|
+
+ aString isNil ifTrue:[^ self].
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ strLen := aString size.
+ self checkForExistingLine:lineNr.
+ line := list at:lineNr.
+ line notNil ifTrue:[
+ lineSize := line size
+ ] ifFalse:[
+ lineSize := 0
+ ].
+ ((colNr == 1) and:[lineSize == 0]) ifTrue: [
+ newLine := aString
+ ] ifFalse:[
+ (lineSize == 0) ifTrue: [
+ newLine := String new:(colNr + strLen - 1)
+ ] ifFalse: [
+ (colNr > lineSize) ifTrue: [
+ newLine := String new:(colNr + strLen - 1).
+ newLine replaceFrom:1 to:lineSize
+ with:line startingAt:1
+ ] ifFalse: [
+ newLine := String new:(lineSize + strLen).
+ newLine replaceFrom:1 to:(colNr - 1)
+ with:line startingAt:1.
+ newLine replaceFrom:(colNr + strLen) to:(lineSize + strLen)
+ with:line startingAt:colNr
+ ]
+ ].
+ newLine replaceFrom:colNr to:(colNr + strLen - 1)
+ with:aString startingAt:1
+ ].
+
+ (aString occurrencesOf:(Character tab)) == 0 ifFalse:[
+ newLine := self withTabsExpanded:newLine
+ ].
+
+ list at:lineNr put:newLine.
+ modified := true.
+ contentsWasSaved := false.
+!
+
+insertStringWithoutCRs:aString atLine:lineNr col:colNr
+ "insert aString (which has no crs) at lineNr/colNr"
+
+ self withoutRedrawInsertStringWithoutCRs:aString atLine:lineNr col:colNr.
+ self redrawLine:lineNr from:colNr
+!
+
+insertStringWithoutCRsAtCursor:aString
+ "insert a string (which has no crs) at cursor position
+ - advance cursor"
+
+ aString notNil ifTrue:[
+ self withCursorOffDo:[
+ self insertString:aString atLine:cursorLine col:cursorCol.
+ cursorCol := cursorCol + aString size
+ ]
+ ]
+!
+
+insertCharAtCursor:aCharacter
+ "insert a single character at cursor-position - advance cursor"
+
+ self withCursorOffDo:[
+ self insert:aCharacter atLine:cursorLine col:cursorCol.
+ aCharacter == (Character cr) ifTrue:[
+ self cursorReturn
+ ] ifFalse:[
+ cursorCol := cursorCol + 1
+ ]
+ ]
+!
+
+insertString:aString atLine:lineNr col:colNr
+ "insert the string, aString at line/col;
+ handle cr's correctly"
+
+ |start "{ Class: SmallInteger }"
+ stop "{ Class: SmallInteger }"
+ end "{ Class: SmallInteger }"
+ subString c
+ l "{ Class: SmallInteger }" |
+
+
+ aString isNil ifTrue:[^ self].
+ ((aString occurrencesOf:(Character cr)) == 0) ifTrue:[
+ ^ self insertStringWithoutCRs:aString atLine:lineNr col:colNr
+ ].
+ l := lineNr.
+ c := colNr.
+ start := 1.
+ end := aString size.
+ [start <= end] whileTrue:[
+ stop := aString indexOf:(Character cr)
+ startingAt:start
+ ifAbsent:[end + 1].
+ subString := aString copyFrom:start to:(stop - 1).
+ self insertStringWithoutCRs:subString atLine:l col:c.
+ (stop < end) ifTrue:[
+ c := c + subString size.
+ self insert:(Character cr) atLine:l col:c.
+ l := l + 1.
+ c := 1
+ ].
+ start := stop + 1
+ ]
+!
+
+insertStringAtCursor:aString
+ "insert the argument, aString at cursor position
+ handle cr's correctly"
+
+ |start " { Class: SmallInteger }"
+ stop " { Class: SmallInteger }"
+ end " { Class: SmallInteger }"
+ subString|
+
+ aString isNil ifTrue:[^ self].
+ ((aString occurrencesOf:(Character cr)) == 0) ifTrue:[
+ ^ self insertStringWithoutCRsAtCursor:aString
+ ].
+ start := 1.
+ end := aString size.
+
+ "insert the 1st line"
+ (cursorCol ~~ 1) ifTrue:[
+ stop := aString indexOf:(Character cr)
+ startingAt:start
+ ifAbsent:[end + 1].
+ subString := aString copyFrom:start to:(stop - 1).
+ self insertStringWithoutCRsAtCursor:subString.
+ self insertCharAtCursor:(Character cr).
+ start := stop + 1
+ ].
+ "insert the block of full lines"
+
+ [start <= end] whileTrue:[
+ stop := aString indexOf:(Character cr)
+ startingAt:start
+ ifAbsent:[end + 1].
+ subString := aString copyFrom:start to:(stop - 1).
+ self insertStringWithoutCRsAtCursor:subString.
+ (stop < end) ifTrue:[
+ self insertCharAtCursor:(Character cr)
+ ].
+ start := stop + 1
+ ]
+!
+
+insertSelectedStringAtCursor:aString
+ "insert the argument, aString at cursor position and select it"
+
+ |startLine startCol|
+
+ startLine := cursorLine.
+ startCol := cursorCol.
+ self insertStringAtCursor:aString.
+ self selectFromLine:startLine col:startCol
+ toLine:cursorLine col:(cursorCol - 1)
+!
+
+insertLines:lines withCr:withCr
+ "insert a bunch of lines at cursor position. Cursor
+ is moved behind insertion.
+ If withCr is true, append cr after last line"
+
+ |start end nLines|
+
+ lines notNil ifTrue:[
+ nLines := lines size.
+ (nLines == 1) ifTrue:[
+ self insertStringAtCursor:(lines at:1).
+ withCr ifTrue:[
+ self insertCharAtCursor:(Character cr)
+ ]
+ ] ifFalse:[
+ (cursorCol ~~ 1) ifTrue:[
+ self insertStringAtCursor:(lines at:1).
+ self insertCharAtCursor:(Character cr).
+ start := 2
+ ] ifFalse:[
+ start := 1
+ ].
+ withCr ifTrue:[
+ end := nLines
+ ] ifFalse:[
+ end := nLines - 1
+ ].
+ (start < nLines) ifTrue:[
+ (end >= start) ifTrue:[
+ self withCursorOffDo:[
+ self insertLines:lines
+ from:start to:end
+ before:cursorLine.
+ cursorLine := cursorLine + (end - start + 1).
+ cursorVisibleLine := self absoluteLineToVisibleLine:
+ cursorLine
+ ]
+ ]
+ ].
+ withCr ifFalse:[
+ "last line without cr"
+ self insertStringAtCursor:(lines at:nLines)
+ ]
+ ]
+ ]
+!
+
+deleteFromLine:startLine col:startCol toLine:endLine col:endCol
+ "delete all text from startLine/startCol to endLine/endCol -
+ joining lines if nescessary"
+
+ |line lineSize|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ list isNil ifTrue:[^ self].
+
+ (startLine == endLine) ifTrue:[
+ "delete chars within a line"
+ self deleteCharsAtLine:startLine fromCol:startCol toCol:endCol.
+ ^ self
+ ].
+
+ ((startCol == 1) and:[endCol == 0]) ifTrue:[
+ "delete full lines only"
+ endLine > startLine ifTrue:[
+ self deleteFromLine:startLine toLine:(endLine - 1)
+ ].
+ ^ self
+ ].
+
+ "delete right rest of 1st line"
+ self deleteCharsAtLine:startLine fromCol:startCol.
+
+ "delete the inner lines ..."
+ endLine > (startLine + 1) ifTrue:[
+ self deleteFromLine:(startLine + 1) toLine:(endLine - 1)
+ ].
+
+ (endCol ~~ 0) ifTrue:[
+ "delete the left rest of the last line"
+ self deleteCharsAtLine:(startLine + 1) toCol:endCol.
+
+ "must add blanks, if startCal lies behond end of startLine"
+ line := list at:startLine.
+ lineSize := line size.
+ (startCol > lineSize) ifTrue:[
+ line isNil ifTrue:[
+ line := String new:(startCol - 1)
+ ] ifFalse:[
+ line := line , (String new:(startCol - 1 - lineSize))
+ ].
+ list at:startLine put:line.
+ modified := true.
+ contentsWasSaved := false.
+ ]
+ ].
+
+ "merge the left rest of 1st line with right rest of last line into one"
+ self mergeLine:startLine
+!
+
+deleteFromLine:startLineNr toLine:endLineNr
+ "delete some lines"
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ list isNil ifTrue:[^ self].
+ list removeFromIndex:startLineNr toIndex:endLineNr.
+ self contentsChanged.
+ self redrawFromLine:startLineNr.
+ (firstLineShown >= list size) ifTrue:[
+ self makeLineVisible:(list size)
+ ]
+!
+
+deleteLineWithoutRedraw:lineNr
+ "delete line - no redraw;
+ answer true, if something was really deleted"
+
+ readOnly ifTrue:[
+ exceptionBlock value:errorMessage.
+ ^ false
+ ].
+ (list isNil or:[lineNr > list size]) ifTrue:[^ false].
+ list removeIndex:lineNr.
+ self contentsChanged.
+ ^ true
+!
+
+deleteLinesWithoutRedrawFrom:startLine to:endLine
+ "delete lines - no redraw;
+ answer true, if something was really deleted"
+
+ |lastLine|
+
+ readOnly ifTrue:[
+ exceptionBlock value:errorMessage.
+ ^ false
+ ].
+ (list isNil or:[startLine > list size]) ifTrue:[^ false].
+ (endLine > list size) ifTrue:[
+ lastLine := list size
+ ] ifFalse:[
+ lastLine := endLine
+ ].
+ list removeFromIndex:startLine toIndex:lastLine.
+ self contentsChanged.
+ ^ true
+!
+
+deleteLine:lineNr
+ "delete line"
+
+ |visLine w
+ srcY "{ Class: SmallInteger }" |
+
+ w := self widthForScrollBetween:lineNr
+ and:(firstLineShown + nLinesShown).
+ (self deleteLineWithoutRedraw:lineNr) ifFalse:[^ self].
+ visLine := self listLineToVisibleLine:lineNr.
+ visLine notNil ifTrue:[
+ srcY := margin + topMargin + (visLine * fontHeight).
+ self copyFrom:self x:textStartLeft y:srcY
+ toX:textStartLeft y:(srcY - fontHeight)
+ width:w height:((nLinesShown - visLine) * fontHeight).
+ self redrawVisibleLine:nFullLinesShown.
+ (nFullLinesShown ~~ nLinesShown) ifTrue:[
+ self redrawVisibleLine:nLinesShown
+ ].
+ exposePending := true.
+ self waitForExpose
+ ]
+!
+
+deleteCursorLine
+ "delete the line where the cursor sits"
+
+ self withCursorOffDo:[
+ self deleteLine:cursorLine
+ ]
+!
+
+removeTrailingBlankLines
+ "remove all blank lines at end of text"
+
+ |lastLine "{ Class: SmallInteger }"
+ line finished|
+
+ lastLine := list size.
+ finished := false.
+ [finished] whileFalse:[
+ (lastLine <= 1) ifTrue:[
+ finished := true
+ ] ifFalse:[
+ line := list at:lastLine.
+ line notNil ifTrue:[
+ line isBlank ifTrue:[
+ list at:lastLine put:nil.
+ line := nil
+ ]
+ ].
+ line notNil ifTrue:[
+ finished := true
+ ] ifFalse:[
+ lastLine := lastLine - 1
+ ]
+ ]
+ ].
+ (lastLine ~~ list size) ifTrue:[
+ list grow:lastLine.
+ self contentsChanged
+ ]
+!
+
+deleteCharsAtLine:lineNr toCol:colNr
+ "delete characters from start up to colNr in line lineNr"
+
+ |line lineSize newLine|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ list isNil ifTrue: [^self].
+ (list size < lineNr) ifTrue: [^ self].
+ line := list at:lineNr.
+ line isNil ifTrue: [^self].
+ lineSize := line size.
+ (colNr >= lineSize) ifTrue:[
+ newLine := nil
+ ] ifFalse:[
+ newLine := line copyFrom:(colNr + 1) to:lineSize.
+ newLine isBlank ifTrue:[
+ newLine := nil
+ ]
+ ].
+ list at:lineNr put:newLine.
+ modified := true.
+ contentsWasSaved := false.
+ self redrawLine:lineNr
+!
+
+deleteCharsAtLine:lineNr fromCol:colNr
+ "delete characters from colNr up to the end in line lineNr"
+
+ |line newLine|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ list isNil ifTrue: [^self].
+ (list size < lineNr) ifTrue: [^ self].
+ line := list at:lineNr.
+ line isNil ifTrue: [^self].
+ (colNr > line size) ifTrue: [^ self].
+ newLine := line copyFrom:1 to:(colNr - 1).
+ newLine isBlank ifTrue:[
+ newLine := nil
+ ].
+ list at:lineNr put:newLine.
+ modified := true.
+ contentsWasSaved := false.
+ self redrawLine:lineNr
+!
+
+deleteCharsAtLine:lineNr fromCol:startCol toCol:endCol
+ "delete characters from startCol to endCol in line lineNr"
+
+ |line lineSize newLine|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ list isNil ifTrue: [^self].
+ (list size < lineNr) ifTrue: [^ self].
+
+ line := list at:lineNr.
+ line isNil ifTrue: [^self].
+ lineSize := line size.
+ (startCol > lineSize) ifTrue: [^ self].
+ (endCol == 0) ifTrue:[^ self].
+ (endCol < startCol) ifTrue:[^ self].
+ (startCol == endCol) ifTrue:[
+ self deleteCharAtLine:lineNr col:startCol.
+ ^ self
+ ].
+ (endCol >= lineSize) ifTrue:[
+ self deleteCharsAtLine:lineNr fromCol:startCol.
+ ^ self
+ ].
+ (startCol <= 1) ifTrue:[
+ self deleteCharsAtLine:lineNr toCol:endCol.
+ ^ self
+ ].
+ newLine := (line copyFrom:1 to:(startCol - 1))
+ , (line copyFrom:(endCol + 1) to:lineSize).
+
+ newLine isBlank ifTrue:[
+ newLine := nil
+ ].
+ list at:lineNr put:newLine.
+ modified := true.
+ contentsWasSaved := false.
+ self redrawLine:lineNr
+!
+
+deleteCharAtLine:lineNr col:colNr
+ "delete single character at colNr in line lineNr"
+
+ |line lineSize newLine drawCharacterOnly|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ list isNil ifTrue: [^self].
+ (list size < lineNr) ifTrue: [^ self].
+
+ line := list at:lineNr.
+ line isNil ifTrue: [^self].
+ lineSize := line size.
+ (colNr > lineSize) ifTrue: [^ self].
+
+ drawCharacterOnly := false.
+ (colNr == lineSize) ifTrue:[
+ newLine := line copyFrom:1 to:(lineSize - 1).
+ fontIsFixedWidth ifTrue:[
+ drawCharacterOnly := true
+ ]
+ ] ifFalse:[
+ newLine := String new:(lineSize - 1).
+ newLine replaceFrom:1 to:(colNr - 1)
+ with:line startingAt:1.
+ newLine replaceFrom:colNr to:(lineSize - 1)
+ with:line startingAt:(colNr + 1)
+ ].
+
+ newLine isBlank ifTrue:[
+ newLine := nil
+ ].
+ list at:lineNr put:newLine.
+ modified := true.
+ contentsWasSaved := false.
+ drawCharacterOnly ifTrue:[
+ self redrawLine:lineNr col:colNr
+ ] ifFalse:[
+ self redrawLine:lineNr from:colNr
+ ]
+!
+
+deleteCharBeforeCursor
+ "delete single character to the left of cursor and move cursor to left"
+
+ |oldSize lineNrAboveCursor|
+
+ (cursorCol == 1) ifFalse:[
+ self withCursorOffDo:[
+ cursorCol := cursorCol - 1.
+ self deleteCharAtLine:cursorLine col:cursorCol
+ ]
+ ] ifTrue:[
+ (cursorLine == 1) ifFalse:[
+ oldSize := 0.
+ lineNrAboveCursor := cursorLine - 1.
+ list notNil ifTrue:[
+ (list size >= lineNrAboveCursor) ifTrue:[
+ (list at:lineNrAboveCursor) notNil ifTrue:[
+ oldSize := (list at:lineNrAboveCursor) size
+ ]
+ ]
+ ].
+ self mergeLine:lineNrAboveCursor.
+ self withCursorOffDo:[
+ cursorLine := lineNrAboveCursor.
+ cursorCol := oldSize + 1.
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine
+ ]
+ ]
+ ]
+!
+
+deleteCharAtCursor
+ "delete single character under cursor"
+
+ self withCursorOffDo:[
+ self deleteCharAtLine:cursorLine col:cursorCol
+ ]
+!
+
+deleteSelection
+ "delete the selection"
+
+ |startLine startCol endLine endCol|
+
+ readOnly ifTrue: [
+ exceptionBlock value:errorMessage.
+ ^ self
+ ].
+ selectionStartLine notNil ifTrue:[
+ startLine := selectionStartLine.
+ startCol := selectionStartCol.
+ endLine := selectionEndLine.
+ endCol := selectionEndCol.
+ self withCursorOffDo:[
+ self unselectWithoutRedraw.
+ self deleteFromLine:startLine col:startCol
+ toLine:endLine col:endCol.
+ cursorCol := startCol.
+ cursorLine := startLine.
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine.
+ self makeLineVisible:cursorLine
+ ]
+ ]
+!
+
+replaceSelectionBy:something
+ "delete the selection (if any) and insert something, a character or string;
+ leave cursor after insertion"
+
+ self deleteSelection.
+ (something isMemberOf:Character) ifTrue:[
+ self insertCharAtCursor:something
+ ] ifFalse:[
+ self insertStringAtCursor:something
+ ]
+! !
+
+!EditTextView methodsFor:'formatting'!
+
+indent
+ "indent selected line-range"
+
+ |start end|
+
+ start := selectionStartLine.
+ end := selectionEndLine.
+ (selectionEndCol == 0) ifTrue:[
+ end := end - 1
+ ].
+ self unselect.
+ self indentFromLine:start toLine:end
+!
+
+indentFromLine:start toLine:end
+ "indent a line-range"
+
+ |leftStart s delta line spaces|
+
+ "find a line to base indent on..."
+ leftStart := 0.
+ s := start.
+ [(leftStart == 0) and:[s ~~ 1]] whileTrue:[
+ s := s - 1.
+ leftStart := self leftIndentOfLine:s
+ ].
+
+ (leftStart == 0) ifTrue:[^ self].
+
+ delta := leftStart - (self leftIndentOfLine:start).
+ (delta == 0) ifTrue:[^ self].
+ (delta > 0) ifTrue:[
+ spaces := String new:delta
+ ].
+ start to:end do:[:lineNr |
+ line := self listAt:lineNr.
+ line notNil ifTrue:[
+ line isBlank ifTrue:[
+ list at:lineNr put:nil
+ ] ifFalse:[
+ (delta > 0) ifTrue:[
+ line := spaces , line
+ ] ifFalse:[
+ line := line copyFrom:(delta negated + 1)
+ ].
+ list at:lineNr put:line.
+ modified := true.
+ contentsWasSaved := false.
+ ]
+ ]
+ ].
+ self redrawFromLine:start to:end
+! !
+
+!EditTextView methodsFor:'cursor handling'!
+
+makeCursorVisible
+ "scroll to make cursor visible"
+
+ cursorLine notNil ifTrue:[
+ self makeLineVisible:cursorLine
+ ]
+!
+
+drawCursorCharacter
+ "draw the cursor - helper for many below"
+
+ |oldFg oldBg|
+
+ oldFg := fgColor.
+ oldBg := bgColor.
+ fgColor := cursorFgColor.
+ bgColor := cursorBgColor.
+ super redrawVisibleLine:cursorVisibleLine col:cursorCol.
+ fgColor := oldFg.
+ bgColor := oldBg
+!
+
+drawCursor
+ "draw the cursor if shown and cursor is visible"
+
+ shown ifTrue:[
+ cursorVisibleLine notNil ifTrue:[
+ self drawCursorCharacter
+ ]
+ ]
+!
+
+undrawCursor
+ "undraw the cursor"
+
+ cursorVisibleLine notNil ifTrue:[
+ super redrawVisibleLine:cursorVisibleLine col:cursorCol
+ ]
+!
+
+hideCursor
+ "make cursor invisible if currently visible; return true if cursor
+ was visible"
+
+ cursorShown ifTrue: [
+ self undrawCursor.
+ cursorShown := false.
+ ^ true
+ ].
+ ^ false
+!
+
+showCursor
+ "make cursor visible if currently invisible"
+
+ cursorShown ifFalse: [
+ self drawCursor.
+ cursorShown := true
+ ]
+!
+
+withCursorOffDo:aBlock
+ "evaluate aBlock with cursor off"
+
+ |cShown|
+
+ shown ifFalse:[
+ aBlock value
+ ] ifTrue:[
+ cShown := self hideCursor.
+ aBlock value.
+ cShown ifTrue:[self showCursor]
+ ]
+!
+
+cursorHome
+ "scroll to top AND move cursor to first line of text"
+
+ self withCursorOffDo:[
+ self scrollToTop.
+ cursorCol := 1.
+ cursorVisibleLine := 1.
+ cursorLine := self visibleLineToAbsoluteLine:1.
+ self makeCursorVisible.
+ ]
+!
+
+cursorToBottom
+ "move cursor to last line of text"
+
+ |newTop|
+
+ self withCursorOffDo:[
+ newTop := list size - nFullLinesShown.
+ (newTop < 1) ifTrue:[
+ newTop := 1
+ ].
+ self scrollToLine:newTop.
+ cursorCol := 1.
+ cursorLine := list size.
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine.
+ self makeCursorVisible.
+ ]
+!
+
+cursorUp
+ "move cursor up; scroll if at start of visible text"
+
+ (cursorLine == 1) ifFalse: [
+ self withCursorOffDo:[
+ (cursorVisibleLine == 1) ifTrue:[self scrollUp].
+ cursorLine := cursorLine - 1.
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine.
+ ].
+ self makeCursorVisible.
+ ]
+!
+
+cursorDown
+ "move cursor down; scroll if at end of visible text"
+
+ cursorVisibleLine notNil ifTrue:[
+ self withCursorOffDo:[
+ (cursorVisibleLine >= nFullLinesShown) ifTrue:[self scrollDown].
+ cursorLine := cursorLine + 1.
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine
+ ]
+ ] ifFalse:[
+ cursorLine := cursorLine + 1.
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine
+ ].
+ self makeCursorVisible.
+!
+
+cursorLeft
+ "move cursor to left"
+
+ (cursorCol == 1) ifFalse: [
+ self withCursorOffDo:[cursorCol := cursorCol - 1]
+ ].
+ self makeCursorVisible.
+!
+
+cursorRight
+ "move cursor to right"
+
+ self withCursorOffDo:[cursorCol := cursorCol + 1].
+ self makeCursorVisible.
+!
+
+cursorToBeginOfLine
+ "move cursor to start of current line"
+
+ self withCursorOffDo:[
+ cursorCol := 1
+ ].
+ self makeCursorVisible.
+!
+
+cursorToEndOfLine
+ "move cursor to end of current line"
+
+ |line|
+
+ self withCursorOffDo:[
+ line := list at:cursorLine.
+ cursorCol := line size + 1
+ ].
+ self makeCursorVisible.
+!
+
+cursorTab
+ "move cursor to next tabstop"
+
+ self withCursorOffDo:[
+ cursorCol := self nextTabAfter:cursorCol
+ ].
+ self makeCursorVisible.
+!
+
+cursorBacktab
+ "move cursor to prev tabstop"
+
+ self withCursorOffDo:[
+ cursorCol := self prevTabBefore:cursorCol
+ ].
+ self makeCursorVisible.
+!
+
+cursorReturn
+ "move cursor to start of next line; scroll if at end of visible text"
+
+ self checkForExistingLine:(cursorLine + 1).
+ cursorVisibleLine notNil ifTrue:[
+ nFullLinesShown notNil ifTrue:[
+ (cursorVisibleLine >= nFullLinesShown) ifTrue:[self scrollDown]
+ ]
+ ].
+ self withCursorOffDo:[
+ cursorCol := 1.
+ cursorLine := cursorLine + 1.
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine
+ ].
+ self makeCursorVisible.
+!
+
+cursorVisibleLine:visibleLineNr col:colNr
+ "put cursor to visibleline/col"
+
+ self withCursorOffDo:[
+ cursorLine := self visibleLineToAbsoluteLine:visibleLineNr.
+ cursorVisibleLine := visibleLineNr.
+ cursorCol := colNr.
+ (cursorCol < 1) ifTrue:[
+ cursorCol := 1
+ ]
+ ].
+ self makeCursorVisible.
+!
+
+cursorX:x y:y
+ "put cursor to position next to x/y coordinate in view"
+
+ |line col|
+
+ line := self visibleLineOfY:y.
+ col := self colOfX:x inVisibleLine:line.
+ self cursorVisibleLine:line col:col.
+!
+
+cursorLine:line col:col
+ "this positions onto physical - not visible - line"
+
+ self withCursorOffDo:[
+ cursorLine := line.
+ cursorVisibleLine := self listLineToVisibleLine:line.
+ cursorCol := col.
+ (cursorCol < 1) ifTrue:[
+ cursorCol := 1
+ ]
+ ].
+ self makeCursorVisible.
+!
+
+cursorToTop
+ "move cursor to absolute home"
+
+ self cursorLine:1 col:1
+!
+
+gotoLine:aLineNumber
+ self makeLineVisible:aLineNumber.
+ self cursorLine:aLineNumber col:1
+! !
+
+!EditTextView methodsFor:'undo'!
+
+undo
+ "currently not implemented"
+
+ ^ self
+! !
+
+!EditTextView methodsFor:'cut & paste'!
+
+cut
+ "cut selection into copybuffer"
+
+ Smalltalk at:#CopyBuffer put:(self selection).
+ self deleteSelection
+!
+
+paste
+ "paste copybuffer at cursor"
+
+ |text|
+
+ text := Smalltalk at:#CopyBuffer.
+ text notNil ifTrue:[
+ self insertLines:text asText withCr:false
+ ]
+!
+
+replace
+ "replace selection by copybuffer"
+
+ self deleteSelection.
+ self paste
+! !
+
+!EditTextView methodsFor:'selections'!
+
+disableSelectionMenuEntries
+ "disable relevant menu entries for a selection"
+
+ middleButtonMenu notNil ifTrue:[
+ super disableSelectionMenuEntries.
+ middleButtonMenu disable:#cut.
+ middleButtonMenu disable:#replace.
+ middleButtonMenu disable:#indent
+ ]
+!
+
+enableSelectionMenuEntries
+ "enable relevant menu entries for a selection"
+
+ middleButtonMenu notNil ifTrue:[
+ readOnly ifTrue:[
+ super disableSelectionMenuEntries.
+ middleButtonMenu disable:#cut.
+ middleButtonMenu disable:#replace.
+ middleButtonMenu disable:#indent.
+ middleButtonMenu disable:#paste.
+ ] ifFalse:[
+ super enableSelectionMenuEntries.
+ middleButtonMenu enable:#cut.
+ middleButtonMenu enable:#replace.
+ middleButtonMenu enable:#indent.
+ ]
+ ]
+!
+
+unselect
+ "forget and unhilight selection - must take care of cursor here"
+
+ self withCursorOffDo:[
+ super unselect
+ ]
+!
+
+selectCursorLine
+ "select cursorline up to cursor position"
+
+ self selectFromLine:cursorLine col:1
+ toLine:cursorLine col:cursorCol
+!
+
+selectWordUnderCursor
+ "select the word under the cursor"
+
+ self selectWordAtLine:cursorLine col:cursorCol
+!
+
+selectFromLine:startLine col:startCol toLine:endLine col:endCol
+ "when a range is selected, position the cursor behind the selection
+ for easier editing"
+
+ super selectFromLine:startLine col:startCol toLine:endLine col:endCol.
+ self cursorLine:selectionEndLine col:(selectionEndCol + 1)
+! !
+
+!EditTextView methodsFor:'scrolling'!
+
+originWillChange
+ "sent before scrolling - have to hide the cursor"
+
+ prevCursorState := cursorShown.
+ cursorShown ifTrue:[
+ self hideCursor
+ ]
+!
+
+originChanged:delta
+ "sent after scrolling - have to show the cursor if it was on before"
+
+ super originChanged:delta.
+ "
+ should we move the cursor with the scroll - or leave it ?
+ "
+ cursorVisibleLine := self listLineToVisibleLine:cursorLine.
+ prevCursorState ifTrue:[
+ self showCursor
+ ]
+!
+
+pageUp
+ "page up - to keep cursor on same visible line, it has to be moved
+ within the real text "
+
+ |prevCursorLine|
+
+ prevCursorLine := cursorVisibleLine.
+ super pageUp.
+ self cursorVisibleLine:prevCursorLine col:cursorCol
+!
+
+pageDown
+ "page down - to keep cursor on same visible line, it has to be moved
+ within the real text "
+
+ |prevCursorLine|
+
+ prevCursorLine := cursorVisibleLine.
+ super pageDown.
+ self cursorVisibleLine:prevCursorLine col:cursorCol
+! !
+
+!EditTextView methodsFor:'searching'!
+
+setSearchPattern
+ "set the searchpattern from the selection if there is one, and position
+ corsor to start of pattern"
+
+ |sel|
+
+ sel := self selection.
+ sel notNil ifTrue:[
+ self cursorLine:selectionStartLine col:selectionStartCol.
+ searchPattern := sel asString withoutSeparators
+ ]
+!
+
+searchFwd:pattern
+ "do the forward search"
+
+ self searchForwardFor:pattern startingAtLine:cursorLine col:cursorCol
+ ifFound:[:line :col |
+ self cursorLine:line col:col.
+ self selectFromLine:line col:col
+ toLine:line col:(col + pattern size - 1).
+ self makeLineVisible:cursorLine
+ ] else:[
+ self showNotFound
+ ]
+!
+
+searchBwd:pattern
+ "do the backward search"
+
+ self searchBackwardFor:pattern startingAtLine:cursorLine col:cursorCol
+ ifFound:[:line :col |
+ self cursorLine:line col:col.
+ self selectFromLine:line col:col
+ toLine:line col:(col + pattern size - 1).
+ self makeLineVisible:cursorLine
+ ] else:[
+ self showNotFound
+ ]
+!
+
+searchForMatchingParentesis:parChar
+ "search for a matching parenthesis, parChar is one of '$( $[ ${ $) $] $}'. Search
+ for the corresponding character is done forward if its an opening, backwards if
+ its a closing parenthesis.
+ Positions the cursor if found, peeps if not"
+
+ |i direction lineString line col charSet ignoreSet closingChar
+ ignoring delta endCol cc incSet decSet nesting|
+
+ charSet := #( $( $) $[ $] ${ $} ).
+ ignoreSet := #( $' $" ).
+
+ i := charSet indexOf:parChar.
+ i == 0 ifTrue:[
+ device beep.
+ ^ self
+ ].
+ direction := #( fwd bwd fwd bwd fwd bwd) at:i.
+ closingChar := #( $) $( $] $[ $} ${ ) at:i.
+
+ col := cursorCol.
+ line := cursorLine.
+ direction == #fwd ifTrue:[
+ delta := 1.
+ incSet := #( $( $[ ${ ).
+ decSet := #( $) $] $} ).
+ ] ifFalse:[
+ delta := -1.
+ incSet := #( $) $] $} ).
+ decSet := #( $( $[ ${ ).
+ ].
+
+ nesting := 1.
+ ignoring := false.
+ lineString := list at:line.
+
+ col := col + delta.
+ [nesting ~~ 0] whileTrue:[
+ lineString notNil ifTrue:[
+ direction == #fwd ifTrue:[
+ endCol := lineString size.
+ ] ifFalse:[
+ endCol := 1
+ ].
+ col to:endCol by:delta do:[:runCol |
+ cc := lineString at:runCol.
+
+ (ignoreSet includes:cc) ifTrue:[
+ ignoring := ignoring not
+ ].
+ ignoring ifFalse:[
+ (incSet includes:cc) ifTrue:[
+ nesting := nesting + 1
+ ] ifFalse:[
+ (decSet includes:cc) ifTrue:[
+ nesting := nesting - 1
+ ]
+ ]
+ ].
+ nesting == 0 ifTrue:[
+ "check if legal"
+
+ cc == closingChar ifFalse:[
+ device beep.
+ ] ifTrue:[
+ self cursorLine:line col:runCol.
+ ].
+ ^ self
+ ]
+ ].
+ ].
+ line := line + delta.
+ lineString := list at:line.
+ direction == #fwd ifTrue:[
+ col := 1
+ ] ifFalse:[
+ col := lineString size
+ ]
+ ].
+
+ self showNotFound
+!
+
+searchForMatchingParentesis
+ "search for a matching parenthesis if one is under cusor"
+
+ |line col lineString|
+
+ col := cursorCol.
+ line := cursorLine.
+ lineString := list at:line.
+ lineString notNil ifTrue:[
+ col <= lineString size ifTrue:[
+ self searchForMatchingParentesis:(lineString at:col).
+ ^ self
+ ]
+ ].
+ device beep
+! !
+
+!EditTextView methodsFor:'redrawing'!
+
+redrawCursorIfBetweenVisibleLine:startVisLine and:endVisLine
+ "redraw the cursor, if it sits in a line range"
+
+ cursorShown ifTrue:[
+ cursorVisibleLine notNil ifTrue:[
+ (cursorVisibleLine between:startVisLine and:endVisLine) ifTrue:[
+ self drawCursorCharacter
+ ]
+ ]
+ ]
+!
+
+redrawCursorIfInVisibleLine:visLine
+ "redraw the cursor, if it sits in visible line"
+
+ cursorShown ifTrue:[
+ (visLine == cursorVisibleLine) ifTrue:[
+ self drawCursorCharacter
+ ]
+ ]
+!
+
+redrawFromVisibleLine:startVisLine to:endVisLine
+ "redraw a visible line range"
+
+ super redrawFromVisibleLine:startVisLine to:endVisLine.
+ self redrawCursorIfBetweenVisibleLine:startVisLine and:endVisLine
+!
+
+redrawVisibleLine:visLine col:colNr
+ "redraw the single character in visibleline at colNr"
+
+ cursorShown ifTrue:[
+ (visLine == cursorVisibleLine) ifTrue:[
+ (colNr == cursorCol) ifTrue:[
+ self drawCursorCharacter.
+ ^ self
+ ]
+ ]
+ ].
+ super redrawVisibleLine:visLine col:colNr
+!
+
+redrawVisibleLine:visLine
+ "redraw a visible line"
+
+ super redrawVisibleLine:visLine.
+ self redrawCursorIfInVisibleLine:visLine
+!
+
+redrawVisibleLine:visLine from:startCol
+ "redraw a visible line from startCol to the end of line"
+
+ super redrawVisibleLine:visLine from:startCol.
+ self redrawCursorIfInVisibleLine:visLine
+!
+
+redrawVisibleLine:visLine from:startCol to:endCol
+ "redraw a visible line from startCol to endCol"
+
+ super redrawVisibleLine:visLine from:startCol to:endCol.
+ self redrawCursorIfInVisibleLine:visLine
+! !
+
+!EditTextView methodsFor:'event processing'!
+
+sizeChanged:how
+ "make certain, cursor is visible after the sizechange"
+
+ |cv|
+
+ cv := cursorVisibleLine.
+ super sizeChanged:how.
+ cv notNil ifTrue:[
+ self makeLineVisible:cursorLine
+ ]
+!
+
+keyPress:key x:x y:y
+ "handle keyboard input"
+
+ (key isMemberOf:Character) ifTrue:[
+ (wordSelectStyle == #left) ifTrue:[
+ self replaceSelectionBy:(' ' copyWith:key)
+ ] ifFalse:[
+ (wordSelectStyle == #right) ifTrue:[
+ self replaceSelectionBy:(key asString , ' ').
+ self cursorLeft
+ ] ifFalse:[
+ self replaceSelectionBy:key
+ ]
+ ].
+ wordSelectStyle := nil.
+ ^ self
+ ].
+
+ ((key == #Paste) or:[key == #Insert]) ifTrue:[self paste. ^self].
+ (key == #Cut) ifTrue:[self cut. ^self].
+
+ (key == #Replace) ifTrue:[self replace. ^self].
+ (key == #Cmdw) ifTrue:[
+ self makeCursorVisible.
+ self selectWordUnderCursor.
+ ^self
+ ].
+
+ (key == #Ctrlm) ifTrue:[
+ self searchForMatchingParentesis.
+ ^self
+ ].
+
+ (key == #Ctrlb) ifTrue:[self unselect. self cursorLeft. ^self].
+ (key == #Ctrlf) ifTrue:[self unselect. self cursorRight. ^self].
+ (key == #Ctrln) ifTrue:[self unselect. self cursorDown. ^self].
+ (key == #Ctrlp) ifTrue:[self unselect. self cursorUp. ^self].
+
+ (key == #Ctrla) ifTrue:[self cursorToBeginOfLine. ^self].
+ (key == #Ctrle) ifTrue:[self cursorToEndOfLine. ^self].
+
+ (key == #CursorRight) ifTrue:[
+ self unselect. self cursorRight. ^self
+ ].
+ (key == #CursorLeft) ifTrue:[
+ self unselect. self cursorLeft. ^self
+ ].
+ (key == #CursorUp) ifTrue:[
+ self unselect. self cursorUp. ^self
+ ].
+ (key == #CursorDown) ifTrue:[
+ self unselect. self cursorDown. ^self
+ ].
+
+ (key == #Return) ifTrue:[
+ device shiftDown ifTrue:[
+ self unselect. self cursorReturn. ^self
+ ].
+ self unselect.
+ self makeCursorVisible.
+ self insertCharAtCursor:(Character cr).
+ ^self
+ ].
+ (key == #BackSpace) ifTrue:[
+ self unselect.
+ self makeCursorVisible.
+ self deleteCharBeforeCursor.
+ ^self
+ ].
+ (key == #Tab) ifTrue:[
+ device shiftDown ifTrue:[
+ self unselect. self cursorBacktab. ^self
+ ].
+ self unselect. self cursorTab. ^self
+ ].
+ (key == #Delete) ifTrue:[
+ selectionStartLine notNil ifTrue:[
+ Smalltalk at:#CopyBuffer put:(self selection).
+ self deleteSelection. ^ self
+ ].
+ self makeCursorVisible.
+ self deleteCharBeforeCursor. ^self
+ ].
+ (key == #Home) ifTrue:[
+ self unselect. self cursorHome. ^self
+ ].
+ (key == #End) ifTrue:[
+ self unselect. self cursorToBottom. ^self
+ ].
+ (key == #Escape) ifTrue:[
+ self makeCursorVisible.
+ self unselect. self selectCursorLine. ^ self
+ ].
+ (key == #DeleteLine) ifTrue:[
+ self makeCursorVisible.
+ self unselect. self deleteCursorLine. ^self
+ ].
+ super keyPress:key x:x y:y
+!
+
+buttonPress:button x:x y:y
+ "hide the cursor when button is activated"
+
+ (button == 1) ifTrue:[
+ self hideCursor
+ ].
+ super buttonPress:button x:x y:y
+!
+
+buttonRelease:button x:x y:y
+ "move the cursor to the click-position of previous button press"
+
+ (button == 1) ifTrue:[
+ selectionStartLine isNil ifTrue:[
+ clickCol notNil ifTrue:[
+ self cursorLine:clickLine col:clickCol
+ ]
+ ].
+ self showCursor
+ ].
+ super buttonRelease:button x:x y:y
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/EnterBox.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,280 @@
+"
+ COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ModalBox subclass:#EnterBox
+ instanceVariableNames:'labelField enterField buttonPanel
+ okButton abortButton
+ okAction abortAction'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+EnterBox comment:'
+
+COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+this class implements a pop-up box to enter some string
+with 2 buttons; one to cancel, another to start some action
+
+%W% %E%
+
+written Feb 90 by claus
+'!
+
+!EnterBox class methodsFor:'defaults'!
+
+defaultExtent
+ ^ (Display pixelPerMillimeter * (60 @ 30)) rounded
+! !
+
+!EnterBox class methodsFor:'instance creation'!
+
+action:aBlock
+ "create and return a new EnterBox
+ which will evaluate aBlock when 'ok' is pressed"
+
+ ^ (self new) action:aBlock
+
+ "(EnterBox action:[:string | Transcript showCr:string]) showAtPointer"
+!
+
+title:titleString action:aBlock
+ "create and return a new EnterBox with title aString,
+ which will evaluate aBlock when 'ok' is pressed"
+
+ ^ ((self new) title:titleString) action:aBlock
+!
+
+title:titleString okText:okText abortText:abortText action:aBlock
+ "create and return a new EnterBox with title aString, and buttons showing
+ okText and abortText; it will evaluate aBlock when 'ok' is pressed"
+
+ ^ ((self new) title:titleString
+ okText:okText
+ abortText:abortText) action:aBlock
+! !
+
+!EnterBox methodsFor:'initialization'!
+
+initialize
+ |space2 innerWidth|
+
+ super initialize.
+
+ space2 := 2 * ViewSpacing.
+
+ labelField := Label in:self.
+ labelField label:''.
+ labelField borderWidth:0.
+ labelField adjust:#center.
+
+ "kludge: preset extent to something useful since other subviews
+ depend on it (extent blocks are not evaluated until view is realized)
+ - avoid visible resizing when realized the first time"
+
+ innerWidth := width - space2.
+
+ labelField origin:(ViewSpacing @ ViewSpacing)
+ extent:(innerWidth @ labelField height).
+
+ enterField := EditField in:self.
+ enterField origin:(ViewSpacing @ (space2 + labelField height))
+ extent:((width - space2 - (enterField borderWidth * 2)) @ enterField height).
+ enterField origin:[ViewSpacing @ (space2 + labelField height)]
+ extent:[(width - space2 - (enterField borderWidth * 2)) @ enterField height].
+ enterField leaveAction:[:key | self okPressed].
+
+ buttonPanel := HorizontalPanelView in:self.
+ buttonPanel origin:(ViewSpacing @ (height - (font height * 2) - ViewSpacing - (borderWidth * 2)))
+ extent:((width - space2 - (buttonPanel borderWidth * 2))
+ @ ((font height * 2) + (borderWidth * 2))).
+ buttonPanel origin:[ViewSpacing @ (height - (font height * 2) - ViewSpacing - (borderWidth * 2))]
+ extent:[(width - space2 - (buttonPanel borderWidth * 2))
+ @ ((font height * 2) + (borderWidth * 2))].
+
+ buttonPanel layout:"#spread2" #right.
+ buttonPanel borderWidth:0.
+
+ abortButton := Button label:(Resources at:'abort')
+ action:[
+ abortButton turnOffWithoutRedraw.
+ self abortPressed
+ ]
+ in:buttonPanel.
+
+ okButton := Button label:(Resources at:'ok')
+ action:[
+ okButton turnOffWithoutRedraw.
+ self okPressed
+ ]
+ in:buttonPanel.
+ okButton isReturnButton:true.
+
+ self keyboardHandler:enterField
+
+!
+
+initEvents
+ super initEvents.
+ self enableKeyEvents
+!
+
+reAdjustGeometry
+ "sent late in snapin processing - gives me a chance
+ to resize for new font dimensions"
+
+ super reAdjustGeometry.
+ labelField resize.
+ okButton resize.
+ abortButton resize.
+ self resize
+! !
+
+!EnterBox methodsFor:'private'!
+
+resize
+ "resize myself to make everything visible"
+
+ |wWanted hWanted wPanel|
+
+ wWanted := labelField widthIncludingBorder + ViewSpacing + ViewSpacing.
+ (wWanted > width) ifFalse:[
+ wWanted := width
+ ].
+ wPanel := buttonPanel preferedExtent x + ViewSpacing + ViewSpacing.
+ wPanel > wWanted ifTrue:[
+ wWanted := wPanel
+ ].
+ hWanted := ViewSpacing + labelField height +
+ ViewSpacing + enterField height +
+ (ViewSpacing * 6) + buttonPanel height +
+ ViewSpacing.
+ self extent:(wWanted @ hWanted)
+! !
+
+!EnterBox methodsFor:'accessing'!
+
+title:aString
+ "set the title to be displayed at top of enterBox"
+
+ labelField label:aString.
+ labelField resize.
+ self resize
+!
+
+title:titleString okText:okString abortText:abortString
+ "set title and texts in the buttons"
+
+ self title:titleString.
+ okButton label:okString.
+ abortButton label:abortString
+!
+
+title:titleString okText:okString
+ "set title and text in okbutton"
+
+ self title:titleString.
+ okButton label:okString
+!
+
+okText:aString
+ "set the text to be displayed in the ok-button"
+
+ okButton label:aString.
+ okButton resize.
+ self resize
+!
+
+abortText:aString
+ "set the text to be displayed in the abort-button"
+
+ abortButton label:aString.
+ abortButton resize.
+ self resize
+!
+
+okText:okString abortText:abortString
+ "set both texts displayed in the buttons"
+
+ okButton label:okString.
+ abortButton label:abortString.
+ okButton resize.
+ abortButton resize.
+ self resize
+!
+
+contents
+ "return my contents"
+
+ ^ enterField contents
+!
+
+initialText:aString
+ "define the initial text in the enterfield. all will be selected initially"
+
+ enterField initialText:aString
+!
+
+initialText:aString selectFrom:start to:stop
+ "define the initial text in the enterfield, and the part to be selected"
+
+ enterField initialText:aString.
+ enterField selectFromLine:1 col:start toLine:1 col:stop
+!
+
+action:aBlock
+ "set the action to be performed when user presses ok-button;
+ aBlock must be nil or a block with one argument "
+
+ okAction := aBlock
+!
+
+abortAction:aBlock
+ "set the action to be performed when user presses abort-button;
+ aBlock must be nil or a block with no arguments"
+
+ abortAction := aBlock
+! !
+
+!EnterBox methodsFor:'user interaction'!
+
+hideAndEvaluate:aBlock
+ "common processing for all ok-actions (see subclasses);
+ shut down box, fetch entered string and evaluate the action with it"
+
+ |string|
+
+ self hide.
+ aBlock notNil ifTrue:[
+ string := self contents.
+ string isNil ifTrue:[
+ string := ''
+ ] ifFalse:[
+ string := string withoutSeparators
+ ].
+ aBlock value:string
+ ]
+!
+
+okPressed
+ "user pressed ok button - hide myself and evaluate okAction"
+
+ self hideAndEvaluate:okAction
+!
+
+abortPressed
+ "user pressed abort button - hide myself and evaluate okAction"
+
+ self hideAndEvaluate:abortAction
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/EnterBox2.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,93 @@
+"
+ COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+EnterBox subclass:#EnterBox2
+ instanceVariableNames:'okButton2 okAction2'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+EnterBox2 comment:'
+
+COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+like an EnterBox but with 2 action buttons.
+
+%W% %E%
+
+written Sep 91 by claus
+'!
+
+!EnterBox2 class methodsFor:'instance creation'!
+
+title:titleString okText1:text1 okText2:text2 abortText:abortText
+ action1:block1 action2:block2
+ "create and return a new EnterBox-with-2 buttons
+ and define its text, button-labels and actions"
+
+ ^ (super title:titleString
+ okText:text1
+ abortText:abortText
+ action:block1) okText2:text2 action2:block2
+! !
+
+!EnterBox2 methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ okButton2 := Button label:''
+ action:[
+ okButton2 turnOffWithoutRedraw.
+ self ok2Pressed
+ ]
+ in:buttonPanel.
+ okButton isReturnButton:false.
+ okButton2 isReturnButton:true.
+ self resize.
+ enterField leaveAction:[:key | self ok2Pressed]
+! !
+
+!EnterBox2 methodsFor:'accessing'!
+
+okText2:aString action2:aBlock
+ "set the text to be displayed in the 2nd ok-button,
+ and its action"
+
+ self okText2:aString.
+ okAction2 := aBlock
+!
+
+okText2:aString
+ "set the text to be displayed in the 2nd ok-button"
+
+ okButton2 label:aString.
+ okButton2 resize.
+ self resize
+!
+
+action2:aBlock
+ "set the action to be performed when user presses the 2nd ok-button;
+ aBlock must be nil or a block with one argument "
+
+ okAction2 := aBlock
+! !
+
+!EnterBox2 methodsFor:'user interaction'!
+
+ok2Pressed
+ "user pressed 2nd ok button - evaluate action"
+
+ self hideAndEvaluate:okAction2
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/EnterFieldGroup.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,144 @@
+"
+ COPYRIGHT (c) 1992-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Controller subclass:#EnterFieldGroup
+ instanceVariableNames:'fields currentField leaveAction'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Support'
+!
+
+EnterFieldGroup comment:'
+
+COPYRIGHT (c) 1992-93 by Claus Gittinger
+ All Rights Reserved
+
+EnterFieldGroup controlls the interaction between EnterFields
+enabling next/prev field when a field is left. Instances of
+this class keep track of which field of the group is the currentField
+(i.e. the one getting keyboard input).
+The block accessable as leaveAction is evaluated when the last
+field of the group is left (by cursor-down or cr). Usually this block
+triggers some action on the fields.
+
+%W% %E%
+written nov 91 by claus
+'!
+
+!EnterFieldGroup methodsFor:'adding / removing'!
+
+add:aField
+ |thisIndex next|
+
+ fields isNil ifTrue:[
+ fields := OrderedCollection new
+ ].
+ fields add:aField.
+ thisIndex := fields size.
+ aField controller:self.
+ aField disable.
+
+ "set the fields enableAction to disable active field"
+
+ aField enableAction:[
+ currentField notNil ifTrue:[
+ currentField disable
+ ].
+ currentField := aField
+ ].
+
+ "set the fields leaveAction to enable next field"
+
+ aField leaveAction:[:key |
+ currentField notNil ifTrue:[
+ currentField disable
+ ].
+ (key == #Up) ifTrue:[
+ (thisIndex == 1) ifTrue:[
+ next := fields size
+ ] ifFalse:[
+ next := thisIndex - 1
+ ]
+ ].
+ (key == #Down) ifTrue:[
+ (thisIndex == (fields size)) ifTrue:[
+ next := 1
+ ] ifFalse:[
+ next := thisIndex + 1
+ ]
+ ].
+ (key == #Return) ifTrue:[
+ (thisIndex == (fields size)) ifTrue:[
+ leaveAction notNil ifTrue:[
+ leaveAction value.
+ currentField := nil
+ ] ifFalse:[
+ next := 1
+ ]
+ ] ifFalse:[
+ next := thisIndex + 1
+ ]
+ ].
+ next notNil ifTrue:[
+ (fields at:next) enable.
+ currentField := fields at:next
+ ]
+ ]
+! !
+
+!EnterFieldGroup methodsFor:'accessing'!
+
+leaveAction:aBlock
+ leaveAction := aBlock
+! !
+
+!EnterFieldGroup methodsFor:'controlling'!
+
+canHandle:aKey
+ ^ true
+!
+
+keyPress:key x:x y:y in:aView
+ "key-press in a field"
+
+ currentField notNil ifTrue:[
+ currentField keyPress:key x:0 y:0
+ ]
+!
+
+keyPress:key x:x y:y
+ "key-press in an outer view when keyHandler has been set"
+
+ currentField notNil ifTrue:[
+ currentField keyPress:key x:0 y:0
+ ]
+!
+
+buttonMotion:state x:x y:y in:aView
+ aView buttonMotion:state x:x y:y
+!
+
+buttonShiftPress:button x:x y:y in:aView
+ aView buttonShiftPress:button x:x y:y
+!
+
+buttonMultiPress:button x:x y:y in:aView
+ aView buttonMultiPress:button x:x y:y
+!
+
+buttonPress:button x:x y:y in:aView
+ aView buttonPress:button x:x y:y
+!
+
+buttonRelease:button x:x y:y in:aView
+ aView buttonRelease:button x:x y:y
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/FSelBox.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,128 @@
+"
+ COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ListSelectionBox subclass:#FileSelectionBox
+ instanceVariableNames:'patternField directory timeStamp directoryId'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+FileSelectionBox comment:'
+
+COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+this class implements file selection boxes. They show a list of
+files, and perform an action block with the selected pathname as
+argument when ok is clicked.
+
+%W% %E%
+written Jan 90 by claus
+'!
+
+!FileSelectionBox methodsFor:'initialization'!
+
+initialize
+ directory := FileDirectory currentDirectory.
+ super initialize.
+
+ "selections in list get forwarded to enterfield if not a directory;
+ otherwise directory is changed"
+
+ selectionList action:[:lineNr |
+ |entry|
+
+ entry := selectionList selectionValue.
+ ((directory typeOf:entry) == #directory) ifTrue:[
+ self directory:(directory pathName , '/' , entry)
+ ] ifFalse:[
+ enterField contents:entry
+ ]
+ ]
+
+ "FileSelectionBox new show"
+!
+
+reinitialize
+ directory := FileDirectory currentDirectory.
+ super reinitialize
+! !
+
+!FileSelectionBox methodsFor:'accessing'!
+
+directory:nameOrDirectory
+ "set the lists contents to the filenames in the directory name"
+
+ |oldPath name|
+
+ (nameOrDirectory isKindOf:String) ifTrue:[
+ name := nameOrDirectory
+ ] ifFalse:[
+ name := nameOrDirectory pathName
+ ].
+ oldPath := directory pathName.
+ directory pathName:name.
+ (directory pathName = oldPath) ifFalse:[
+ self updateList
+ ]
+! !
+
+!FileSelectionBox methodsFor:'private'!
+
+updateList
+ "set the lists contents to the filenames in the directory"
+
+ |oldCursor oldListCursor files|
+
+ oldCursor := cursor.
+ oldListCursor := selectionList cursor.
+ self cursor:(Cursor read).
+ selectionList cursor:(Cursor read).
+ timeStamp := directory timeOfLastChange.
+ directoryId := directory id.
+ files := directory asText sort.
+ ((files at:1) = '.') ifTrue:[
+ files removeIndex:1
+ ].
+ self list:files.
+ self cursor:oldCursor.
+ selectionList cursor:oldListCursor
+! !
+
+!FileSelectionBox methodsFor:'events'!
+
+show
+ "make the box visible; redefined to check if directory is still
+ valid (using timestamp and inode numbers) - reread if not"
+
+ (timeStamp isNil
+ or:[(directory timeOfLastChange > timeStamp)
+ or:[(directoryId isNil)
+ or:[directoryId ~~ directory id]]]) ifTrue:[
+ self updateList
+ ].
+ super show
+! !
+
+!FileSelectionBox methodsFor:'user interaction'!
+
+okPressed
+ "redefined, since action will be evaluated with full path as argument
+ (instead of enterfields contents only as inherited by EnterBox"
+
+ self hideAndEvaluate:[:string |
+ okAction notNil ifTrue:[
+ okAction value:(directory pathName , '/' , string)
+ ]
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/FileSelectionBox.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,128 @@
+"
+ COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ListSelectionBox subclass:#FileSelectionBox
+ instanceVariableNames:'patternField directory timeStamp directoryId'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+FileSelectionBox comment:'
+
+COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+this class implements file selection boxes. They show a list of
+files, and perform an action block with the selected pathname as
+argument when ok is clicked.
+
+%W% %E%
+written Jan 90 by claus
+'!
+
+!FileSelectionBox methodsFor:'initialization'!
+
+initialize
+ directory := FileDirectory currentDirectory.
+ super initialize.
+
+ "selections in list get forwarded to enterfield if not a directory;
+ otherwise directory is changed"
+
+ selectionList action:[:lineNr |
+ |entry|
+
+ entry := selectionList selectionValue.
+ ((directory typeOf:entry) == #directory) ifTrue:[
+ self directory:(directory pathName , '/' , entry)
+ ] ifFalse:[
+ enterField contents:entry
+ ]
+ ]
+
+ "FileSelectionBox new show"
+!
+
+reinitialize
+ directory := FileDirectory currentDirectory.
+ super reinitialize
+! !
+
+!FileSelectionBox methodsFor:'accessing'!
+
+directory:nameOrDirectory
+ "set the lists contents to the filenames in the directory name"
+
+ |oldPath name|
+
+ (nameOrDirectory isKindOf:String) ifTrue:[
+ name := nameOrDirectory
+ ] ifFalse:[
+ name := nameOrDirectory pathName
+ ].
+ oldPath := directory pathName.
+ directory pathName:name.
+ (directory pathName = oldPath) ifFalse:[
+ self updateList
+ ]
+! !
+
+!FileSelectionBox methodsFor:'private'!
+
+updateList
+ "set the lists contents to the filenames in the directory"
+
+ |oldCursor oldListCursor files|
+
+ oldCursor := cursor.
+ oldListCursor := selectionList cursor.
+ self cursor:(Cursor read).
+ selectionList cursor:(Cursor read).
+ timeStamp := directory timeOfLastChange.
+ directoryId := directory id.
+ files := directory asText sort.
+ ((files at:1) = '.') ifTrue:[
+ files removeIndex:1
+ ].
+ self list:files.
+ self cursor:oldCursor.
+ selectionList cursor:oldListCursor
+! !
+
+!FileSelectionBox methodsFor:'events'!
+
+show
+ "make the box visible; redefined to check if directory is still
+ valid (using timestamp and inode numbers) - reread if not"
+
+ (timeStamp isNil
+ or:[(directory timeOfLastChange > timeStamp)
+ or:[(directoryId isNil)
+ or:[directoryId ~~ directory id]]]) ifTrue:[
+ self updateList
+ ].
+ super show
+! !
+
+!FileSelectionBox methodsFor:'user interaction'!
+
+okPressed
+ "redefined, since action will be evaluated with full path as argument
+ (instead of enterfields contents only as inherited by EnterBox"
+
+ self hideAndEvaluate:[:string |
+ okAction notNil ifTrue:[
+ okAction value:(directory pathName , '/' , string)
+ ]
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/FontPanel.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,335 @@
+"
+ COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ModalBox subclass:#FontPanel
+ instanceVariableNames:'previewField familyList faceList sizeList
+ applyButton abortButton
+ revertButton okAction abortAction
+ currentFamily currentFace
+ currentStyle currentFaceAndStyle currentSize'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+FontPanel comment:'
+
+COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+this class implements a font chooser
+
+%W% %E%
+written fall 91 by claus
+'!
+
+!FontPanel class methodsFor:'defaults'!
+
+defaultExtent
+ ^ (Display pixelPerMillimeter * (120 @ 100)) rounded
+! !
+
+!FontPanel class methodsFor:'startup'!
+
+fontFromUser
+ |fontPanel|
+ fontPanel := FontPanel new.
+ fontPanel action:[:family :face :style :size |
+ ^ (Font family:family
+ face:face
+ style:style
+ size:size)
+ ].
+ fontPanel showAtPointer.
+ ^ nil
+
+ "FontPanel fontFromUser"
+! !
+
+!FontPanel methodsFor:'initializing'!
+
+initialize
+ |buttonWidth buttonHeight space2 space3 space4 innerWidth
+ familyLabel faceLabel sizeLabel bw|
+
+ super initialize.
+
+ space2 := ViewSpacing * 2.
+ space3 := ViewSpacing * 3.
+ space4 := ViewSpacing * 4.
+
+ previewField := EditField in:self.
+ previewField contents:'The quick brown fox\jumps over the lazy dog\1234567890\!@#$%^&*(){}[]:"~;,./<>?' withCRs.
+ bw := previewField borderWidth.
+
+ innerWidth := width - space2.
+
+ previewField origin:(ViewSpacing @ ViewSpacing)
+ extent:((innerWidth - (2 * bw)) @ (height // 4)).
+ previewField origin:(ViewSpacing @ ViewSpacing)
+ extent:[(width - space2 - (2 * bw)) @ (height // 4)].
+
+ familyLabel := Label in:self.
+ familyLabel origin:(ViewSpacing
+ @
+ (previewField origin y +
+ previewField height +
+ ViewSpacing))
+ extent:(((width - space4) // 5 * 2)
+ @
+ (familyLabel height)).
+ familyLabel origin:[ViewSpacing
+ @
+ (previewField origin y +
+ previewField height +
+ ViewSpacing)]
+ extent:[((width - space4) // 5 * 2)
+ @
+ (familyLabel height)].
+ familyLabel label:'Family'.
+
+ familyList := ScrollableView for:SelectionInListView in:self.
+ familyList origin:(ViewSpacing
+ @
+ (familyLabel origin y + familyLabel height + ViewSpacing))
+ extent:(((width - space4) // 5 * 2)
+ @
+ (height // 2)).
+ familyList origin:[ViewSpacing
+ @
+ (familyLabel origin y + familyLabel height + ViewSpacing)]
+ extent:[((width - space4) // 5 * 2)
+ @
+ (height // 2)].
+
+ faceLabel := Label in:self.
+ faceLabel origin:((familyList origin x +
+ familyList width +
+ ViewSpacing)
+ @
+ (previewField origin y +
+ previewField height +
+ ViewSpacing))
+ extent:(((width - space4) // 5 * 2) @
+ (faceLabel height)).
+ faceLabel origin:[(familyList origin x +
+ familyList width +
+ ViewSpacing)
+ @
+ (previewField origin y +
+ previewField height +
+ ViewSpacing)]
+ extent:[((width - space4) // 5 * 2) @
+ (faceLabel height)].
+ faceLabel label:'Typeface'.
+
+ faceList := ScrollableView for:SelectionInListView in:self.
+ faceList origin:((faceLabel origin x)
+ @
+ (faceLabel origin y + faceLabel height + ViewSpacing))
+ extent:(((width - space4) // 5 * 2) @
+ (height // 2)).
+ faceList origin:[(faceLabel origin x)
+ @
+ (faceLabel origin y + faceLabel height + ViewSpacing)]
+ extent:[((width - space4) // 5 * 2) @
+ (height // 2)].
+
+ sizeLabel := Label in:self.
+ sizeLabel origin:((faceList origin x +
+ faceList width +
+ ViewSpacing)
+ @
+ (previewField origin y +
+ previewField height +
+ ViewSpacing))
+ extent:(((width - space4) // 5 - sizeLabel borderWidth) @
+ (sizeLabel height)).
+ sizeLabel origin:[(faceList origin x +
+ faceList width +
+ ViewSpacing)
+ @
+ (previewField origin y +
+ previewField height +
+ ViewSpacing)]
+ extent:[((width - space4) // 5 - sizeLabel borderWidth) @
+ (sizeLabel height)].
+ sizeLabel label:'Size'.
+
+ sizeList := ScrollableView for:SelectionInListView in:self.
+ sizeList origin:((sizeLabel origin x)
+ @
+ (sizeLabel origin y + sizeLabel height + ViewSpacing))
+ extent:(((width - space4) // 5 - sizeList borderWidth) @
+ (height // 2)).
+ sizeList origin:[(sizeLabel origin x)
+ @
+ (sizeLabel origin y + sizeLabel height + ViewSpacing)]
+ extent:[((width - space4) // 5 - sizeList borderWidth) @
+ (height // 2)].
+
+ applyButton := Button label:(resources at:'ok')
+ action:[
+ applyButton turnOffWithoutRedraw.
+ self okPressed
+ ]
+ in:self.
+ applyButton isReturnButton:true.
+
+ abortButton := Button label:(resources at:'abort')
+ action:[
+ abortButton turnOffWithoutRedraw.
+ self abortPressed
+ ]
+ in:self.
+
+ buttonHeight := abortButton height.
+ buttonWidth := (width - space3) // 2.
+ abortButton extent:(buttonWidth @ buttonHeight).
+ abortButton origin:[ViewSpacing @ (height - buttonHeight - space2)]
+ extent:[((width - space3) // 2) @ buttonHeight].
+
+ applyButton extent:(buttonWidth @ buttonHeight).
+ applyButton origin:[((width + ViewSpacing) // 2) @ (height - buttonHeight - space2)]
+ extent:[((width - space3) // 2) @ buttonHeight].
+
+ familyList action:[:lineNr | self familySelected:(familyList selectionValue)].
+ faceList action:[:lineNr | self faceSelected:(faceList selectionValue)].
+ sizeList action:[:lineNr | self sizeSelected:(sizeList selectionValue)].
+
+ familyList list:(device fontFamilies asOrderedCollection)
+
+ "FontPanel new showAtPointer"
+!
+
+realize
+ "kludge for sco - xlsfont fails sometimes - try again here"
+ familyList list isNil ifTrue:[familyList list:(device fontFamilies)].
+ super realize
+
+
+! !
+
+!FontPanel methodsFor:'user interaction'!
+
+okPressed
+ self hide.
+ okAction notNil ifTrue:[
+ okAction value:currentFamily
+ value:currentFace
+ value:currentStyle
+ value:currentSize
+ ]
+!
+
+abortPressed
+ self hide
+
+!
+
+familySelected:aFamilyName
+ |faces styles list|
+
+ familyList selectElement:aFamilyName.
+
+ list := Text new.
+ currentFamily := aFamilyName.
+ faces := device facesInFamily:aFamilyName.
+ faces do:[:aFace |
+ styles := device stylesInFamily:aFamilyName face:aFace.
+ styles do:[:aStyle |
+ list add:(aFace , '-' , aStyle)
+ ]
+ ].
+ faceList list:list.
+ currentFaceAndStyle notNil ifTrue:[
+ (list includes:currentFaceAndStyle) ifTrue:[
+ faceList selectElement:currentFaceAndStyle.
+ self faceSelected:currentFaceAndStyle.
+ ^ self
+ ]
+ ].
+ sizeList list:nil
+!
+
+faceSelected:aFaceAndStyleName
+ |sizes|
+
+ sizes := Text new.
+ self extractFaceAndStyleFrom:aFaceAndStyleName.
+ sizes := device sizesInFamily:currentFamily face:currentFace style:currentStyle.
+ sizes := sizes asOrderedCollection.
+ sizes sort.
+ sizeList list:sizes.
+ currentSize notNil ifTrue:[
+ (sizes includes:(currentSize printString)) ifTrue:[
+ sizeList selectElement:currentSize.
+ self showPreview
+ ]
+ ]
+!
+
+sizeSelected:aNumberOrString
+ (aNumberOrString isKindOf:Number) ifTrue:[
+ currentSize := aNumberOrString
+ ] ifFalse:[
+ currentSize := Number readFromString:aNumberOrString
+ ].
+ self showPreview
+! !
+
+!FontPanel methodsFor:'accessing'!
+
+initialFont:aFont
+ |family face style size|
+
+ family := aFont family.
+ face := aFont face.
+ style := aFont style.
+ size := aFont size.
+ family notNil ifTrue:[
+ self familySelected:family.
+ face notNil ifTrue:[
+ style notNil ifTrue:[
+ self faceSelected:(face , '-' , style).
+ size notNil ifTrue:[
+ self sizeSelected:size
+ ]
+ ]
+ ]
+ ]
+!
+
+action:aBlock
+ okAction := aBlock
+! !
+
+!FontPanel methodsFor:'private'!
+
+showPreview
+ previewField font:(Font family:currentFamily
+ face:currentFace
+ style:currentStyle
+ size:currentSize)
+!
+
+extractFaceAndStyleFrom:aString
+ |index|
+
+ index := aString indexOf:$-.
+ (index ~~ 0) ifTrue:[
+ currentFaceAndStyle := aString.
+ currentFace := aString copyFrom:1 to:(index - 1).
+ currentStyle := aString copyFrom:(index + 1)
+ ]
+
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/FramedBox.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,179 @@
+"
+ COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+View subclass:#FramedBox
+ instanceVariableNames:'label layout'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Layout'
+!
+
+FramedBox comment:'
+
+COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+a frame around something. The frame may have a label, whose position
+is controlled by the layout variable, aSymbol which may be one of:
+[#topCenter #topLeft #topRight #bottomLeft #bottomCenter #bottomRight]
+
+%W% %E%
+written spring 91 by claus
+'!
+
+!FramedBox methodsFor:'accessing'!
+
+label
+ ^ label
+!
+
+label:aString
+ (label ~= aString) ifTrue:[
+ label := aString.
+ shown ifTrue:[
+ self clear.
+ self redraw
+ ]
+ ]
+!
+
+font:aFont
+ (font ~= aFont) ifTrue:[
+ super font:aFont.
+ shown ifTrue:[
+ self clear.
+ self redraw
+ ]
+ ]
+!
+
+viewRectangle
+ "return the inside area - redefined to save frame from
+ relative computations"
+
+ |m2 sep|
+
+ sep := font height.
+ m2 := sep + sep + sep.
+
+ ^ (sep @ sep) extent:((width - m2) @ (height - m2))
+!
+
+layout
+ ^ layout
+!
+
+layout:aSymbol
+ "define the position of the label;
+ aSymbol may be: topLeft, topCenter, topRight;
+ bottomLeft, bottomCenter or bottomRight"
+
+ layout := aSymbol.
+ self clear.
+ self redraw
+! !
+
+!FramedBox methodsFor:'events'!
+
+sizeChanged:how
+ shown ifTrue:[
+ self clear.
+ self redraw
+ ].
+ super sizeChanged:how
+! !
+
+!FramedBox methodsFor:'drawing'!
+
+drawFrame
+ "redraw the frame"
+
+ |sep halfSep right bot left top bm1 rm3|
+
+ sep := font height.
+ halfSep := sep // 2.
+ self is3D ifFalse:[
+ self drawRectangleX:halfSep y:halfSep
+ width:(width - sep) height:(height - sep).
+ ^ self
+ ].
+ self paint:lightColor.
+ right := width - halfSep.
+ bot := height - halfSep.
+ self drawRectangleX:halfSep y:halfSep
+ width:(width - sep) height:(height - sep + 1).
+ self paint:shadowColor.
+
+ left := halfSep - 1.
+ top := halfSep - 1.
+ bm1 := bot - 1.
+ self displayLineFromX:left y:top
+ toX:(right - 1) y:top.
+ self displayLineFromX:left y:top
+ toX:left y:bm1.
+
+ rm3 := right - 3.
+ self displayLineFromX:rm3 y:(halfSep + 1)
+ toX:rm3 y:bm1.
+ self displayLineFromX:(halfSep + 2) y:(bot - 2)
+ toX:(right - 2) y:(bot - 2)
+!
+
+redraw
+ "redraw the frame and name if present"
+
+ |labelLen l x y|
+
+ label isNil ifTrue:[
+ l := ' '.
+ labelLen := 0
+ ] ifFalse:[
+ l := ' ' , label , ' '.
+ labelLen := font widthOf:l
+ ].
+
+ self drawFrame.
+ labelLen > 0 ifTrue:[
+ labelLen < width ifTrue:[
+ (#(topLeft topCenter topRight) includes:layout) ifTrue:[
+ y := font ascent.
+ ] ifFalse:[
+ y := height - font descent.
+ ].
+ (#(topLeft bottomLeft) includes:layout) ifTrue:[
+ x := font height
+ ] ifFalse:[
+ (#(topRight bottomRight) includes:layout) ifTrue:[
+ x := width - labelLen - font height
+ ] ifFalse:[
+ x := (width - labelLen) // 2
+ ]
+ ].
+ self background:viewBackground.
+ self displayOpaqueString:l x:x y:y
+ ]
+ ]
+! !
+
+!FramedBox methodsFor:'initialization'!
+
+initStyle
+ "default position is top-center, except for ms-windows, where
+ the text is positioned at top-left"
+
+ super initStyle.
+ style == #mswindows ifTrue:[
+ layout := #topLeft
+ ] ifFalse:[
+ layout := #topCenter
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HPanelV.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,129 @@
+"
+ COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+PanelView subclass:#HorizontalPanelView
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Layout'
+!
+
+HorizontalPanelView comment:'
+
+COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+a View for childViews oriented horizontal
+all real work is done in PanelView - just redefine layout
+
+%W% %E%
+
+written spring/summer 89 by claus
+'!
+
+!HorizontalPanelView methodsFor:'queries'!
+
+preferedExtent
+ "return a good extent, one that makes subviews fit"
+
+ |sumOfWidths maxHeight|
+
+ subViews isNil ifTrue:[^ horizontalSpace @ verticalSpace].
+
+ "compute net height needed"
+
+ sumOfWidths := 0.
+ maxHeight := 0.
+
+ subViews do:[:child |
+ sumOfWidths := sumOfWidths + child widthIncludingBorder.
+ maxHeight := maxHeight max:(child heightIncludingBorder)
+ ].
+ borderWidth ~~ 0 ifTrue:[
+ sumOfWidths := sumOfWidths + (horizontalSpace * 2).
+ maxHeight := maxHeight + (verticalSpace * 2).
+ ].
+ sumOfWidths := sumOfWidths + ((subViews size - 1) * horizontalSpace).
+
+ ^ sumOfWidths @ maxHeight
+! !
+
+!HorizontalPanelView methodsFor:'layout'!
+
+setChildPositions
+ "(re)compute position of every child whenever childs are added or
+ my size has changed"
+
+ |xpos ypos space sumOfChildWidths numChilds l|
+
+ subViews isNil ifTrue:[^ self].
+
+ space := horizontalSpace.
+
+ "compute net width needed"
+
+ sumOfChildWidths := 0.
+ numChilds := subViews size.
+ subViews do:[:child |
+ sumOfChildWidths := sumOfChildWidths + child widthIncludingBorder.
+ ].
+
+ l := layout.
+ ((l == #center) and:[numChilds == 1]) ifTrue:[
+ l := #spread
+ ].
+
+ "compute position of leftmost subview and space between them;
+ if they do hardly fit, leave no space between them "
+
+ (sumOfChildWidths >= width) ifTrue:[
+ xpos := 0.
+ space := 0
+ ] ifFalse: [
+ (l == #right) ifTrue:[
+ xpos := width - (horizontalSpace * numChilds)
+ - sumOfChildWidths.
+ borderWidth == 0 ifTrue:[
+ xpos := xpos + horizontalSpace
+ ].
+ ] ifFalse:[
+ (l == #spread) ifTrue:[
+ space := (width - sumOfChildWidths) // (numChilds + 1).
+ xpos := space.
+ (space == 0) ifTrue:[
+ xpos := (width - sumOfChildWidths) // 2
+ ]
+ ] ifFalse:[
+ (l == #center) ifTrue:[
+ xpos := (width - (sumOfChildWidths
+ + ((numChilds - 1) * space))) // 2
+ ] ifFalse:[
+ borderWidth == 0 ifTrue:[
+ xpos := 0
+ ] ifFalse:[
+ xpos := horizontalSpace
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ "now set positions"
+
+ subViews do:[:child |
+ ypos := (height - child heightIncludingBorder) // 2.
+ (ypos < 0) ifTrue:[ypos := 0].
+
+ child origin:(xpos @ ypos).
+ xpos := xpos + (child widthIncludingBorder) + space
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HScrBar.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,268 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ScrollBar subclass:#HorizontalScrollBar
+ instanceVariableNames:''
+ classVariableNames:'defaultScrollRightForm
+ defaultScrollLeftForm'
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+HorizontalScrollBar comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+this class implements horizontal scrollbars with scroller and
+2 step-scroll buttons. when moved or stepped, it perform a
+predefined action.
+
+%W% %E%
+
+written spring/summer 89 by claus
+'!
+
+!HorizontalScrollBar class methodsFor:'defaults'!
+
+scrollLeftButtonForm:style
+ defaultScrollLeftForm isNil ifTrue:[
+ defaultScrollLeftForm := Form fromFile:(Resources at:'LEFT_BUTTON_FORM_FILE'
+ default:(style == #mswindows
+ ifTrue:['ScrollLt_win.xbm']
+ ifFalse:['ScrollLt.xbm']))
+ resolution:100
+ ].
+ defaultScrollLeftForm isNil ifTrue:[
+ defaultScrollLeftForm :=
+ Form width:16 height:16 fromArray:#(2r00000000 2r00000000
+ 2r00000001 2r10000000
+ 2r00000010 2r10000000
+ 2r00000100 2r10000000
+ 2r00001000 2r11111110
+ 2r00010000 2r00000010
+ 2r00100000 2r00000010
+ 2r01000000 2r00000010
+ 2r01000000 2r00000010
+ 2r00100000 2r00000010
+ 2r00010000 2r00000010
+ 2r00001000 2r11111110
+ 2r00000100 2r10000000
+ 2r00000010 2r10000000
+ 2r00000001 2r10000000
+ 2r00000000 2r00000000)
+ ].
+ ^ defaultScrollLeftForm
+!
+
+scrollRightButtonForm:style
+ defaultScrollRightForm isNil ifTrue:[
+ defaultScrollRightForm := Form fromFile:(Resources at:'RIGHT_BUTTON_FORM_FILE'
+ default:(style == #mswindows
+ ifTrue:['ScrollRt_win.xbm']
+ ifFalse:['ScrollRt.xbm']))
+ resolution:100
+ ].
+ defaultScrollRightForm isNil ifTrue:[
+ defaultScrollRightForm :=
+ Form width:16 height:16 fromArray:#(2r00000000 2r00000000
+ 2r00000001 2r10000000
+ 2r00000001 2r01000000
+ 2r00000001 2r00100000
+ 2r01111111 2r00010000
+ 2r01000000 2r00001000
+ 2r01000000 2r00000100
+ 2r01000000 2r00000010
+ 2r01000000 2r00000010
+ 2r01000000 2r00000100
+ 2r01000000 2r00001000
+ 2r01111111 2r00010000
+ 2r00000001 2r00100000
+ 2r00000001 2r01000000
+ 2r00000001 2r10000000
+ 2r00000000 2r00000000)
+ ].
+ ^ defaultScrollRightForm
+! !
+
+!HorizontalScrollBar methodsFor:'initialization'!
+
+initialize
+ |bwn sep h w leftForm rightForm|
+
+ super initialize.
+
+ "compute my extent from sub-components"
+ leftForm := self class scrollLeftButtonForm:style.
+ rightForm := self class scrollRightButtonForm:style.
+ w := leftForm width + rightForm width
+ + (1 "self defaultBorderWidth" * 2)
+ + (HorizontalScroller defaultExtent x).
+ h := (leftForm height) max:(rightForm height).
+ self is3D ifTrue:[
+ h := h + 4.
+ w := w + 4
+ ].
+ self extent:w @ h.
+
+ style == #mswindows ifTrue:[
+ layout := #around
+ ] ifFalse:[
+ layout := defaultLayout
+ ].
+
+ bwn := borderWidth negated.
+ self is3D ifTrue:[
+ sep := 1
+ ] ifFalse:[
+ sep := 0
+ ].
+
+ button1 form:(self class scrollLeftButtonForm:style).
+ button1 name:'LeftButton'.
+ button1 borderWidth:borderWidth.
+ button1 autoRepeat.
+
+ button2 form:(self class scrollRightButtonForm:style).
+ button2 name:'RightButton'.
+ button2 borderWidth:borderWidth.
+ button2 autoRepeat.
+
+ "poor design - destroy thumb and re-create a HScroller for it"
+
+ thumb destroy.
+ thumb := HorizontalScroller in:self.
+ thumb borderWidth:borderWidth.
+
+ (layout == #bottom) ifTrue:[
+ "buttons at left"
+ button1 origin:(bwn @ bwn).
+ button1 viewGravity:#West.
+ button2 origin:(button1 width @ bwn).
+ button2 viewGravity:#West.
+ thumb origin:((button1 width + borderWidth + button2 width + sep + sep) @ bwn).
+ thumb viewGravity:#West
+ ] ifFalse:[
+ (layout == #top) ifTrue:[
+ "buttons at right"
+ button1 viewGravity:#West.
+ button2 viewGravity:#West.
+ thumb origin:(bwn @ bwn).
+ thumb viewGravity:#West
+ ] ifFalse:[
+ button1 origin:(bwn @ bwn).
+ button1 viewGravity:#West.
+ button2 viewGravity:#West.
+ thumb origin:((button1 width + sep) @ bwn).
+ thumb viewGravity:#West
+ ]
+ ]
+! !
+
+!HorizontalScrollBar methodsFor:'accessing'!
+
+scrollLeftAction:aBlock
+ button1 action:aBlock
+!
+
+scrollRightAction:aBlock
+ button2 action:aBlock
+! !
+
+!HorizontalScrollBar methodsFor:'events'!
+
+sizeChanged:how
+ |leftWidth rightWidth thumbWidth leftAndRightWidth bwn sep sep2|
+
+ button1 isNil ifTrue:[^ self].
+ button2 isNil ifTrue:[^ self].
+ thumb isNil ifTrue:[^ self].
+
+ leftWidth := button1 width + borderWidth.
+ rightWidth := button2 width + borderWidth.
+ leftAndRightWidth := leftWidth + rightWidth.
+ bwn := borderWidth negated.
+ self is3D ifTrue:[
+ sep := 1
+ ] ifFalse:[
+ sep := 0
+ ].
+
+ thumbWidth := width - leftAndRightWidth - borderWidth - (sep * 3).
+ ((layout ~~ #top) and:[layout ~~ #bottom]) ifTrue:[
+ thumbWidth := thumbWidth - borderWidth
+ ].
+
+ "if I become too small, hide buttons"
+
+ (width < leftAndRightWidth) ifTrue:[
+ button1 shown ifTrue:[
+ button1 hidden.
+ button2 hidden.
+ thumb hidden
+ ]
+ ] ifFalse:[
+ shown ifTrue:[
+ button1 shown ifFalse:[
+ button1 show.
+ button2 show.
+ thumb show
+ ]
+ ]
+ ].
+
+ (thumbWidth < 10) ifTrue:[
+ thumb shown ifTrue:[
+ thumb hidden
+ ]
+ ] ifFalse:[
+ thumb shown ifFalse:[
+ button1 shown ifTrue:[
+ thumb show
+ ]
+ ]
+ ].
+
+ "height of buttons is always my width"
+
+ (height ~~ button1 height) ifTrue:[
+ button1 height:height.
+ button2 height:height
+ ].
+
+ "thumb height:height. "
+
+ (layout == #bottom) ifTrue:[
+ "buttons at left"
+ thumb extent:(thumbWidth @ height).
+ ^ self
+ ].
+ sep2 := sep * 2.
+ (layout == #top) ifTrue:[
+ "buttons at right"
+ (how == #smaller) ifTrue:[
+ thumb extent:(thumbWidth @ height).
+ button1 origin:((thumbWidth + sep2) @ bwn).
+ button2 origin:((thumbWidth + sep2 + leftWidth) @ bwn)
+ ] ifFalse:[
+ button1 origin:((thumbWidth + sep2) @ bwn).
+ button2 origin:((thumbWidth + sep2 + leftWidth) @ bwn).
+ thumb extent:(thumbWidth @ height)
+ ].
+ ^ self
+ ].
+ "button around thumb"
+
+ button2 origin:((leftWidth + thumbWidth + sep2) @ bwn).
+ thumb extent:(thumbWidth @ height).
+ thumb origin:((leftWidth - borderWidth + sep) @ bwn)
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HScroller.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,169 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Scroller subclass:#HorizontalScroller
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+HorizontalScroller comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+the scroller part of a horizontal scrollbar
+
+%W% %E%
+written spring/summer 89 by claus
+'!
+
+!HorizontalScroller methodsFor:'initialization'!
+
+initialize
+ super initialize.
+ moveDirection := #x
+! !
+
+!HorizontalScroller methodsFor:'accessing'!
+
+thumbOrigin:newOrigin
+ "set the thumbs origin (in percent)"
+
+ |realNewOrigin oldFrame oldLeft oldRight thumbLeft thumbRight
+ tH tW delta top|
+
+ ((newOrigin + thumbHeight) > 100) ifTrue:[
+ realNewOrigin := 100 - thumbHeight
+ ] ifFalse: [
+ realNewOrigin := newOrigin
+ ].
+ (realNewOrigin > 100) ifTrue:[
+ realNewOrigin := 100
+ ] ifFalse: [
+ (realNewOrigin < 0) ifTrue:[
+ realNewOrigin := 0
+ ]
+ ].
+ (realNewOrigin = thumbOrigin) ifFalse:[
+ oldFrame := thumbFrame.
+ thumbOrigin := realNewOrigin.
+ self computeThumbFrame.
+ (thumbHeight = 100) ifTrue:[^ self].
+
+ shown ifTrue:[
+ (thumbFrame ~~ oldFrame) ifTrue:[
+ tH := thumbFrame height.
+ tW := thumbFrame width.
+ oldLeft := oldFrame left.
+ oldRight := oldLeft + tW.
+
+ thumbLeft := thumbFrame left.
+ thumbRight := thumbLeft + tW.
+
+ top := thumbFrame top.
+
+ (oldRight >= width) ifTrue:[
+ "cannot copy - thumb was behind end"
+ self drawThumbBackgroundInX:oldLeft y:top
+ width:(width - oldLeft" - 1") height:tH.
+ self drawThumb.
+ ^ self
+ ].
+
+ self copyFrom:self x:oldLeft y:top
+ toX:thumbLeft y:top
+ width:tW height:tH.
+
+ oldLeft > thumbLeft ifTrue:[
+ delta := oldLeft - thumbLeft.
+ oldLeft > thumbRight ifTrue:[
+ self drawThumbBackgroundInX:oldLeft y:top
+ width:(tW + 1) height:tH
+ ] ifFalse:[
+ self drawThumbBackgroundInX:thumbRight y:top
+ width:delta height:tH
+ ]
+ ] ifFalse:[
+ delta := thumbLeft - oldLeft.
+ oldRight < thumbLeft ifTrue:[
+ self drawThumbBackgroundInX:oldLeft y:top
+ width:tW + 1 height:tH
+ ] ifFalse:[
+ self drawThumbBackgroundInX:oldLeft y:top
+ width:delta height:tH
+ ]
+ ].
+ "View3D ifTrue:[ "
+ self waitForExpose
+ "] "
+ ]
+ ]
+ ]
+!
+
+setThumbFor:aView
+ "get contents and size info from aView and adjust thumb"
+
+ |percentHeight percentOrigin totalWidth|
+
+ aView isNil ifTrue:[
+ totalWidth := 0
+ ] ifFalse:[
+ totalWidth := aView widthOfContents
+ ].
+ (totalWidth = 0) ifTrue:[
+ percentHeight := 100.
+ percentOrigin := 100
+ ] ifFalse:[
+ percentHeight := (aView innerWidth) * 100 // totalWidth.
+ percentOrigin := (aView xOriginOfContents) * 100 // totalWidth
+ ].
+ (percentHeight = thumbHeight) ifTrue:[
+ self thumbOrigin:percentOrigin
+ ] ifFalse:[
+ (percentOrigin = thumbOrigin) ifTrue:[
+ self thumbHeight:percentHeight
+ ] ifFalse:[
+ self thumbOrigin:percentOrigin thumbHeight:percentHeight
+ ]
+ ]
+!
+
+setThumbHeightFor:aView
+ "get contents and size info from aView and adjust thumb height"
+
+ |percent totalWidth|
+
+ totalWidth := aView widthOfContents.
+ (totalWidth = 0) ifTrue:[
+ percent := 100
+ ] ifFalse:[
+ percent := (aView innerWidth) * 100 // totalWidth
+ ].
+ self thumbHeight:percent
+!
+
+setThumbOriginFor:aView
+ "get contents and size info from aView and adjust thumb origin"
+
+ |percent totalWidth|
+
+ totalWidth := aView widthOfContents.
+ (totalWidth = 0) ifTrue:[
+ percent := 100
+ ] ifFalse:[
+ percent := (aView xOriginOfContents) * 100 // totalWidth
+ ].
+ self thumbOrigin:percent
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HVScrView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,161 @@
+"
+ COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ScrollableView subclass:#HVScrollableView
+ instanceVariableNames:'hScrollBar'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Basic'
+!
+
+HVScrollableView comment:'
+
+COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+a view containing both horizontal and vertical scrollbars
+and some other (slave-)view
+
+%W% %E%
+written jan 91 by claus
+'!
+
+!HVScrollableView methodsFor:'initialization'!
+
+initializeFor:aViewClass
+ |negativeOffset halfMargin|
+
+ super initializeFor:aViewClass.
+
+ negativeOffset := borderWidth negated.
+ halfMargin := innerMargin // 2.
+
+ "create the horizontal scrollbar and change vertical scrollbars size"
+
+ hScrollBar := HorizontalScrollBar in:self.
+
+ self is3D ifTrue:[
+ scrollBar extent:[scrollBar width
+ @
+ (height - hScrollBar height - innerMargin)
+ ]
+ ] ifFalse:[
+ aViewClass isNil ifTrue:[
+ scrollBar extent:[scrollBar width
+ @
+ (height - hScrollBar height
+ - (1 * hScrollBar borderWidth))
+ ]
+ ] ifFalse:[
+ scrollBar extent:[scrollBar width
+ @
+ (height - hScrollBar height
+ - hScrollBar borderWidth
+ - scrolledView borderWidth)
+ ]
+ ]
+ ].
+
+ hScrollBar thumbOrigin:0 thumbHeight:100.
+ hScrollBar scrollAction:[:position |
+ scrolledView scrollHorizontalToPercent:position].
+ hScrollBar scrollLeftAction:[scrolledView scrollLeft].
+ hScrollBar scrollRightAction:[scrolledView scrollRight].
+ self is3D ifTrue:[
+ hScrollBar origin:[(scrollBar origin x + scrollBar width + innerMargin)
+ @
+ (height - hScrollBar height - halfMargin)
+ ]
+ extent:[(width - scrollBar width - (innerMargin * 2))
+ @
+ hScrollBar height
+ ]
+ ] ifFalse:[
+ hScrollBar origin:[(scrollBar origin x + scrollBar width + scrollBar borderWidth)
+ @
+ (height - hScrollBar height - (hScrollBar borderWidth "* 2"))
+ ]
+ extent:[(width - scrollBar width) @ hScrollBar height
+ ]
+ ].
+
+ "redefine subviews size"
+ self is3D ifTrue:[
+ helpView extent:[(width - scrollBar width - (innerMargin * 2))
+ @
+ (height - hScrollBar height - (innerMargin * 2))
+ ]
+ ] ifFalse:[
+ scrolledView notNil ifTrue:[
+ scrolledView
+ extent:[(width
+ - scrollBar width
+ - scrollBar borderWidth
+ - scrolledView borderWidth)
+ @
+ (height
+ - hScrollBar height
+ - hScrollBar borderWidth
+ - scrolledView borderWidth)
+ ]
+ ].
+ ].
+
+ scrolledView notNil ifTrue:[
+ scrolledView
+ originChangeAction:[:aView | scrollBar setThumbOriginFor:aView.
+ hScrollBar setThumbOriginFor:aView].
+ scrolledView
+ contentsChangeAction:[:aView | scrollBar setThumbFor:aView.
+ hScrollBar setThumbFor:aView]
+ ]
+!
+
+realize
+ super realize.
+ hScrollBar setThumbFor:scrolledView
+! !
+
+!HVScrollableView methodsFor:'accessing'!
+
+scrolledView:aView
+ super scrolledView:aView.
+
+ "redefine subviews size"
+ self is3D ifFalse:[
+ scrolledView
+ extent:[(width
+ - scrollBar width
+ - scrollBar borderWidth
+ "- scrolledView borderWidth")
+ @
+ (height
+ - hScrollBar height
+ - hScrollBar borderWidth
+ "- scrolledView borderWidth")
+ ]
+ ].
+
+ scrolledView
+ originChangeAction:[:aView | scrollBar setThumbOriginFor:aView.
+ hScrollBar setThumbOriginFor:aView].
+ scrolledView
+ contentsChangeAction:[:aView | scrollBar setThumbFor:aView.
+ hScrollBar setThumbFor:aView]
+! !
+
+!HVScrollableView methodsFor:'event processing'!
+
+sizeChanged:how
+ super sizeChanged:how.
+ hScrollBar setThumbFor:scrolledView
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HVScrollableView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,161 @@
+"
+ COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ScrollableView subclass:#HVScrollableView
+ instanceVariableNames:'hScrollBar'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Basic'
+!
+
+HVScrollableView comment:'
+
+COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+a view containing both horizontal and vertical scrollbars
+and some other (slave-)view
+
+%W% %E%
+written jan 91 by claus
+'!
+
+!HVScrollableView methodsFor:'initialization'!
+
+initializeFor:aViewClass
+ |negativeOffset halfMargin|
+
+ super initializeFor:aViewClass.
+
+ negativeOffset := borderWidth negated.
+ halfMargin := innerMargin // 2.
+
+ "create the horizontal scrollbar and change vertical scrollbars size"
+
+ hScrollBar := HorizontalScrollBar in:self.
+
+ self is3D ifTrue:[
+ scrollBar extent:[scrollBar width
+ @
+ (height - hScrollBar height - innerMargin)
+ ]
+ ] ifFalse:[
+ aViewClass isNil ifTrue:[
+ scrollBar extent:[scrollBar width
+ @
+ (height - hScrollBar height
+ - (1 * hScrollBar borderWidth))
+ ]
+ ] ifFalse:[
+ scrollBar extent:[scrollBar width
+ @
+ (height - hScrollBar height
+ - hScrollBar borderWidth
+ - scrolledView borderWidth)
+ ]
+ ]
+ ].
+
+ hScrollBar thumbOrigin:0 thumbHeight:100.
+ hScrollBar scrollAction:[:position |
+ scrolledView scrollHorizontalToPercent:position].
+ hScrollBar scrollLeftAction:[scrolledView scrollLeft].
+ hScrollBar scrollRightAction:[scrolledView scrollRight].
+ self is3D ifTrue:[
+ hScrollBar origin:[(scrollBar origin x + scrollBar width + innerMargin)
+ @
+ (height - hScrollBar height - halfMargin)
+ ]
+ extent:[(width - scrollBar width - (innerMargin * 2))
+ @
+ hScrollBar height
+ ]
+ ] ifFalse:[
+ hScrollBar origin:[(scrollBar origin x + scrollBar width + scrollBar borderWidth)
+ @
+ (height - hScrollBar height - (hScrollBar borderWidth "* 2"))
+ ]
+ extent:[(width - scrollBar width) @ hScrollBar height
+ ]
+ ].
+
+ "redefine subviews size"
+ self is3D ifTrue:[
+ helpView extent:[(width - scrollBar width - (innerMargin * 2))
+ @
+ (height - hScrollBar height - (innerMargin * 2))
+ ]
+ ] ifFalse:[
+ scrolledView notNil ifTrue:[
+ scrolledView
+ extent:[(width
+ - scrollBar width
+ - scrollBar borderWidth
+ - scrolledView borderWidth)
+ @
+ (height
+ - hScrollBar height
+ - hScrollBar borderWidth
+ - scrolledView borderWidth)
+ ]
+ ].
+ ].
+
+ scrolledView notNil ifTrue:[
+ scrolledView
+ originChangeAction:[:aView | scrollBar setThumbOriginFor:aView.
+ hScrollBar setThumbOriginFor:aView].
+ scrolledView
+ contentsChangeAction:[:aView | scrollBar setThumbFor:aView.
+ hScrollBar setThumbFor:aView]
+ ]
+!
+
+realize
+ super realize.
+ hScrollBar setThumbFor:scrolledView
+! !
+
+!HVScrollableView methodsFor:'accessing'!
+
+scrolledView:aView
+ super scrolledView:aView.
+
+ "redefine subviews size"
+ self is3D ifFalse:[
+ scrolledView
+ extent:[(width
+ - scrollBar width
+ - scrollBar borderWidth
+ "- scrolledView borderWidth")
+ @
+ (height
+ - hScrollBar height
+ - hScrollBar borderWidth
+ "- scrolledView borderWidth")
+ ]
+ ].
+
+ scrolledView
+ originChangeAction:[:aView | scrollBar setThumbOriginFor:aView.
+ hScrollBar setThumbOriginFor:aView].
+ scrolledView
+ contentsChangeAction:[:aView | scrollBar setThumbFor:aView.
+ hScrollBar setThumbFor:aView]
+! !
+
+!HVScrollableView methodsFor:'event processing'!
+
+sizeChanged:how
+ super sizeChanged:how.
+ hScrollBar setThumbFor:scrolledView
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HorizontalPanelView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,129 @@
+"
+ COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+PanelView subclass:#HorizontalPanelView
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Layout'
+!
+
+HorizontalPanelView comment:'
+
+COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+a View for childViews oriented horizontal
+all real work is done in PanelView - just redefine layout
+
+%W% %E%
+
+written spring/summer 89 by claus
+'!
+
+!HorizontalPanelView methodsFor:'queries'!
+
+preferedExtent
+ "return a good extent, one that makes subviews fit"
+
+ |sumOfWidths maxHeight|
+
+ subViews isNil ifTrue:[^ horizontalSpace @ verticalSpace].
+
+ "compute net height needed"
+
+ sumOfWidths := 0.
+ maxHeight := 0.
+
+ subViews do:[:child |
+ sumOfWidths := sumOfWidths + child widthIncludingBorder.
+ maxHeight := maxHeight max:(child heightIncludingBorder)
+ ].
+ borderWidth ~~ 0 ifTrue:[
+ sumOfWidths := sumOfWidths + (horizontalSpace * 2).
+ maxHeight := maxHeight + (verticalSpace * 2).
+ ].
+ sumOfWidths := sumOfWidths + ((subViews size - 1) * horizontalSpace).
+
+ ^ sumOfWidths @ maxHeight
+! !
+
+!HorizontalPanelView methodsFor:'layout'!
+
+setChildPositions
+ "(re)compute position of every child whenever childs are added or
+ my size has changed"
+
+ |xpos ypos space sumOfChildWidths numChilds l|
+
+ subViews isNil ifTrue:[^ self].
+
+ space := horizontalSpace.
+
+ "compute net width needed"
+
+ sumOfChildWidths := 0.
+ numChilds := subViews size.
+ subViews do:[:child |
+ sumOfChildWidths := sumOfChildWidths + child widthIncludingBorder.
+ ].
+
+ l := layout.
+ ((l == #center) and:[numChilds == 1]) ifTrue:[
+ l := #spread
+ ].
+
+ "compute position of leftmost subview and space between them;
+ if they do hardly fit, leave no space between them "
+
+ (sumOfChildWidths >= width) ifTrue:[
+ xpos := 0.
+ space := 0
+ ] ifFalse: [
+ (l == #right) ifTrue:[
+ xpos := width - (horizontalSpace * numChilds)
+ - sumOfChildWidths.
+ borderWidth == 0 ifTrue:[
+ xpos := xpos + horizontalSpace
+ ].
+ ] ifFalse:[
+ (l == #spread) ifTrue:[
+ space := (width - sumOfChildWidths) // (numChilds + 1).
+ xpos := space.
+ (space == 0) ifTrue:[
+ xpos := (width - sumOfChildWidths) // 2
+ ]
+ ] ifFalse:[
+ (l == #center) ifTrue:[
+ xpos := (width - (sumOfChildWidths
+ + ((numChilds - 1) * space))) // 2
+ ] ifFalse:[
+ borderWidth == 0 ifTrue:[
+ xpos := 0
+ ] ifFalse:[
+ xpos := horizontalSpace
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ "now set positions"
+
+ subViews do:[:child |
+ ypos := (height - child heightIncludingBorder) // 2.
+ (ypos < 0) ifTrue:[ypos := 0].
+
+ child origin:(xpos @ ypos).
+ xpos := xpos + (child widthIncludingBorder) + space
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HorizontalScrollBar.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,268 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ScrollBar subclass:#HorizontalScrollBar
+ instanceVariableNames:''
+ classVariableNames:'defaultScrollRightForm
+ defaultScrollLeftForm'
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+HorizontalScrollBar comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+this class implements horizontal scrollbars with scroller and
+2 step-scroll buttons. when moved or stepped, it perform a
+predefined action.
+
+%W% %E%
+
+written spring/summer 89 by claus
+'!
+
+!HorizontalScrollBar class methodsFor:'defaults'!
+
+scrollLeftButtonForm:style
+ defaultScrollLeftForm isNil ifTrue:[
+ defaultScrollLeftForm := Form fromFile:(Resources at:'LEFT_BUTTON_FORM_FILE'
+ default:(style == #mswindows
+ ifTrue:['ScrollLt_win.xbm']
+ ifFalse:['ScrollLt.xbm']))
+ resolution:100
+ ].
+ defaultScrollLeftForm isNil ifTrue:[
+ defaultScrollLeftForm :=
+ Form width:16 height:16 fromArray:#(2r00000000 2r00000000
+ 2r00000001 2r10000000
+ 2r00000010 2r10000000
+ 2r00000100 2r10000000
+ 2r00001000 2r11111110
+ 2r00010000 2r00000010
+ 2r00100000 2r00000010
+ 2r01000000 2r00000010
+ 2r01000000 2r00000010
+ 2r00100000 2r00000010
+ 2r00010000 2r00000010
+ 2r00001000 2r11111110
+ 2r00000100 2r10000000
+ 2r00000010 2r10000000
+ 2r00000001 2r10000000
+ 2r00000000 2r00000000)
+ ].
+ ^ defaultScrollLeftForm
+!
+
+scrollRightButtonForm:style
+ defaultScrollRightForm isNil ifTrue:[
+ defaultScrollRightForm := Form fromFile:(Resources at:'RIGHT_BUTTON_FORM_FILE'
+ default:(style == #mswindows
+ ifTrue:['ScrollRt_win.xbm']
+ ifFalse:['ScrollRt.xbm']))
+ resolution:100
+ ].
+ defaultScrollRightForm isNil ifTrue:[
+ defaultScrollRightForm :=
+ Form width:16 height:16 fromArray:#(2r00000000 2r00000000
+ 2r00000001 2r10000000
+ 2r00000001 2r01000000
+ 2r00000001 2r00100000
+ 2r01111111 2r00010000
+ 2r01000000 2r00001000
+ 2r01000000 2r00000100
+ 2r01000000 2r00000010
+ 2r01000000 2r00000010
+ 2r01000000 2r00000100
+ 2r01000000 2r00001000
+ 2r01111111 2r00010000
+ 2r00000001 2r00100000
+ 2r00000001 2r01000000
+ 2r00000001 2r10000000
+ 2r00000000 2r00000000)
+ ].
+ ^ defaultScrollRightForm
+! !
+
+!HorizontalScrollBar methodsFor:'initialization'!
+
+initialize
+ |bwn sep h w leftForm rightForm|
+
+ super initialize.
+
+ "compute my extent from sub-components"
+ leftForm := self class scrollLeftButtonForm:style.
+ rightForm := self class scrollRightButtonForm:style.
+ w := leftForm width + rightForm width
+ + (1 "self defaultBorderWidth" * 2)
+ + (HorizontalScroller defaultExtent x).
+ h := (leftForm height) max:(rightForm height).
+ self is3D ifTrue:[
+ h := h + 4.
+ w := w + 4
+ ].
+ self extent:w @ h.
+
+ style == #mswindows ifTrue:[
+ layout := #around
+ ] ifFalse:[
+ layout := defaultLayout
+ ].
+
+ bwn := borderWidth negated.
+ self is3D ifTrue:[
+ sep := 1
+ ] ifFalse:[
+ sep := 0
+ ].
+
+ button1 form:(self class scrollLeftButtonForm:style).
+ button1 name:'LeftButton'.
+ button1 borderWidth:borderWidth.
+ button1 autoRepeat.
+
+ button2 form:(self class scrollRightButtonForm:style).
+ button2 name:'RightButton'.
+ button2 borderWidth:borderWidth.
+ button2 autoRepeat.
+
+ "poor design - destroy thumb and re-create a HScroller for it"
+
+ thumb destroy.
+ thumb := HorizontalScroller in:self.
+ thumb borderWidth:borderWidth.
+
+ (layout == #bottom) ifTrue:[
+ "buttons at left"
+ button1 origin:(bwn @ bwn).
+ button1 viewGravity:#West.
+ button2 origin:(button1 width @ bwn).
+ button2 viewGravity:#West.
+ thumb origin:((button1 width + borderWidth + button2 width + sep + sep) @ bwn).
+ thumb viewGravity:#West
+ ] ifFalse:[
+ (layout == #top) ifTrue:[
+ "buttons at right"
+ button1 viewGravity:#West.
+ button2 viewGravity:#West.
+ thumb origin:(bwn @ bwn).
+ thumb viewGravity:#West
+ ] ifFalse:[
+ button1 origin:(bwn @ bwn).
+ button1 viewGravity:#West.
+ button2 viewGravity:#West.
+ thumb origin:((button1 width + sep) @ bwn).
+ thumb viewGravity:#West
+ ]
+ ]
+! !
+
+!HorizontalScrollBar methodsFor:'accessing'!
+
+scrollLeftAction:aBlock
+ button1 action:aBlock
+!
+
+scrollRightAction:aBlock
+ button2 action:aBlock
+! !
+
+!HorizontalScrollBar methodsFor:'events'!
+
+sizeChanged:how
+ |leftWidth rightWidth thumbWidth leftAndRightWidth bwn sep sep2|
+
+ button1 isNil ifTrue:[^ self].
+ button2 isNil ifTrue:[^ self].
+ thumb isNil ifTrue:[^ self].
+
+ leftWidth := button1 width + borderWidth.
+ rightWidth := button2 width + borderWidth.
+ leftAndRightWidth := leftWidth + rightWidth.
+ bwn := borderWidth negated.
+ self is3D ifTrue:[
+ sep := 1
+ ] ifFalse:[
+ sep := 0
+ ].
+
+ thumbWidth := width - leftAndRightWidth - borderWidth - (sep * 3).
+ ((layout ~~ #top) and:[layout ~~ #bottom]) ifTrue:[
+ thumbWidth := thumbWidth - borderWidth
+ ].
+
+ "if I become too small, hide buttons"
+
+ (width < leftAndRightWidth) ifTrue:[
+ button1 shown ifTrue:[
+ button1 hidden.
+ button2 hidden.
+ thumb hidden
+ ]
+ ] ifFalse:[
+ shown ifTrue:[
+ button1 shown ifFalse:[
+ button1 show.
+ button2 show.
+ thumb show
+ ]
+ ]
+ ].
+
+ (thumbWidth < 10) ifTrue:[
+ thumb shown ifTrue:[
+ thumb hidden
+ ]
+ ] ifFalse:[
+ thumb shown ifFalse:[
+ button1 shown ifTrue:[
+ thumb show
+ ]
+ ]
+ ].
+
+ "height of buttons is always my width"
+
+ (height ~~ button1 height) ifTrue:[
+ button1 height:height.
+ button2 height:height
+ ].
+
+ "thumb height:height. "
+
+ (layout == #bottom) ifTrue:[
+ "buttons at left"
+ thumb extent:(thumbWidth @ height).
+ ^ self
+ ].
+ sep2 := sep * 2.
+ (layout == #top) ifTrue:[
+ "buttons at right"
+ (how == #smaller) ifTrue:[
+ thumb extent:(thumbWidth @ height).
+ button1 origin:((thumbWidth + sep2) @ bwn).
+ button2 origin:((thumbWidth + sep2 + leftWidth) @ bwn)
+ ] ifFalse:[
+ button1 origin:((thumbWidth + sep2) @ bwn).
+ button2 origin:((thumbWidth + sep2 + leftWidth) @ bwn).
+ thumb extent:(thumbWidth @ height)
+ ].
+ ^ self
+ ].
+ "button around thumb"
+
+ button2 origin:((leftWidth + thumbWidth + sep2) @ bwn).
+ thumb extent:(thumbWidth @ height).
+ thumb origin:((leftWidth - borderWidth + sep) @ bwn)
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HorizontalScroller.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,169 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Scroller subclass:#HorizontalScroller
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+HorizontalScroller comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+the scroller part of a horizontal scrollbar
+
+%W% %E%
+written spring/summer 89 by claus
+'!
+
+!HorizontalScroller methodsFor:'initialization'!
+
+initialize
+ super initialize.
+ moveDirection := #x
+! !
+
+!HorizontalScroller methodsFor:'accessing'!
+
+thumbOrigin:newOrigin
+ "set the thumbs origin (in percent)"
+
+ |realNewOrigin oldFrame oldLeft oldRight thumbLeft thumbRight
+ tH tW delta top|
+
+ ((newOrigin + thumbHeight) > 100) ifTrue:[
+ realNewOrigin := 100 - thumbHeight
+ ] ifFalse: [
+ realNewOrigin := newOrigin
+ ].
+ (realNewOrigin > 100) ifTrue:[
+ realNewOrigin := 100
+ ] ifFalse: [
+ (realNewOrigin < 0) ifTrue:[
+ realNewOrigin := 0
+ ]
+ ].
+ (realNewOrigin = thumbOrigin) ifFalse:[
+ oldFrame := thumbFrame.
+ thumbOrigin := realNewOrigin.
+ self computeThumbFrame.
+ (thumbHeight = 100) ifTrue:[^ self].
+
+ shown ifTrue:[
+ (thumbFrame ~~ oldFrame) ifTrue:[
+ tH := thumbFrame height.
+ tW := thumbFrame width.
+ oldLeft := oldFrame left.
+ oldRight := oldLeft + tW.
+
+ thumbLeft := thumbFrame left.
+ thumbRight := thumbLeft + tW.
+
+ top := thumbFrame top.
+
+ (oldRight >= width) ifTrue:[
+ "cannot copy - thumb was behind end"
+ self drawThumbBackgroundInX:oldLeft y:top
+ width:(width - oldLeft" - 1") height:tH.
+ self drawThumb.
+ ^ self
+ ].
+
+ self copyFrom:self x:oldLeft y:top
+ toX:thumbLeft y:top
+ width:tW height:tH.
+
+ oldLeft > thumbLeft ifTrue:[
+ delta := oldLeft - thumbLeft.
+ oldLeft > thumbRight ifTrue:[
+ self drawThumbBackgroundInX:oldLeft y:top
+ width:(tW + 1) height:tH
+ ] ifFalse:[
+ self drawThumbBackgroundInX:thumbRight y:top
+ width:delta height:tH
+ ]
+ ] ifFalse:[
+ delta := thumbLeft - oldLeft.
+ oldRight < thumbLeft ifTrue:[
+ self drawThumbBackgroundInX:oldLeft y:top
+ width:tW + 1 height:tH
+ ] ifFalse:[
+ self drawThumbBackgroundInX:oldLeft y:top
+ width:delta height:tH
+ ]
+ ].
+ "View3D ifTrue:[ "
+ self waitForExpose
+ "] "
+ ]
+ ]
+ ]
+!
+
+setThumbFor:aView
+ "get contents and size info from aView and adjust thumb"
+
+ |percentHeight percentOrigin totalWidth|
+
+ aView isNil ifTrue:[
+ totalWidth := 0
+ ] ifFalse:[
+ totalWidth := aView widthOfContents
+ ].
+ (totalWidth = 0) ifTrue:[
+ percentHeight := 100.
+ percentOrigin := 100
+ ] ifFalse:[
+ percentHeight := (aView innerWidth) * 100 // totalWidth.
+ percentOrigin := (aView xOriginOfContents) * 100 // totalWidth
+ ].
+ (percentHeight = thumbHeight) ifTrue:[
+ self thumbOrigin:percentOrigin
+ ] ifFalse:[
+ (percentOrigin = thumbOrigin) ifTrue:[
+ self thumbHeight:percentHeight
+ ] ifFalse:[
+ self thumbOrigin:percentOrigin thumbHeight:percentHeight
+ ]
+ ]
+!
+
+setThumbHeightFor:aView
+ "get contents and size info from aView and adjust thumb height"
+
+ |percent totalWidth|
+
+ totalWidth := aView widthOfContents.
+ (totalWidth = 0) ifTrue:[
+ percent := 100
+ ] ifFalse:[
+ percent := (aView innerWidth) * 100 // totalWidth
+ ].
+ self thumbHeight:percent
+!
+
+setThumbOriginFor:aView
+ "get contents and size info from aView and adjust thumb origin"
+
+ |percent totalWidth|
+
+ totalWidth := aView widthOfContents.
+ (totalWidth = 0) ifTrue:[
+ percent := 100
+ ] ifFalse:[
+ percent := (aView xOriginOfContents) * 100 // totalWidth
+ ].
+ self thumbOrigin:percent
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/InfoBox.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,168 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ModalBox subclass:#InfoBox
+ instanceVariableNames:'formLabel textLabel okButton okAction'
+ classVariableNames:'InfoBitmap'
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+InfoBox comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+this class implements a pop-up box to show an information message
+
+%W% %E%
+written Spring/Summer 89 by claus
+'!
+
+!InfoBox class methodsFor:'instance creation'!
+
+title:titleString
+ "create a new infoBox with title, aTitleString"
+
+ ^ (self new) title:titleString
+! !
+
+!InfoBox methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ InfoBitmap isNil ifTrue:[
+ InfoBitmap := Form fromFile:'Information.xbm' resolution:100 on:device
+ ].
+
+ formLabel := Label in:self.
+ self initFormBitmap.
+ formLabel borderWidth:0.
+ formLabel origin:(ViewSpacing @ ViewSpacing).
+
+ textLabel := Label label:'Information' in:self.
+ textLabel borderWidth:0.
+ textLabel origin:((ViewSpacing + formLabel width + ViewSpacing) @ ViewSpacing).
+
+ okButton := Button label:(Resources at:'ok')
+ action:[
+ okButton turnOffWithoutRedraw.
+ self okPressed
+ ]
+ in:self.
+
+ "okButton isReturnButton:true."
+ okButton origin:[(width // 4) @ (height - ViewSpacing - okButton height)]
+ extent:[(width // 2) @ okButton height]
+!
+
+initFormBitmap
+ formLabel form:InfoBitmap
+! !
+
+!InfoBox methodsFor:'realization'!
+
+show
+ "added bell to wake up user"
+
+ device beep.
+ super show
+!
+
+showAtPointer
+ "redefined to show the box with the cursor in the ok-box"
+
+ self fixSize.
+ self showAt:(device pointerPosition
+ - (okButton originRelativeTo:self)
+ - ((okButton width // 2) @ (okButton height // 2)) )
+
+! !
+
+!InfoBox methodsFor:'accessing'!
+
+form:aForm
+ "define a form to be displayed left of the title
+ - usually an exclamation-mark"
+
+ formLabel form:aForm.
+ formLabel resize.
+ self resize
+!
+
+title:aString
+ "set the title"
+
+ textLabel label:aString.
+ textLabel resize.
+ self resize
+!
+
+title
+ "return the title"
+
+ ^ textLabel label
+!
+
+okAction:aBlock
+ "define the action to be performed when ok is pressed"
+
+ okAction := aBlock
+!
+
+okText:aString
+ "define the text in the ok-button"
+
+ okButton label:aString.
+ self resize
+! !
+
+!InfoBox methodsFor:'private'!
+
+resize
+ "resize myself to make everything fit into myself"
+
+ |w h extra|
+
+ w := ViewSpacing + formLabel width + ViewSpacing + textLabel width + ViewSpacing.
+ h := ViewSpacing
+ + ((formLabel height) max:(textLabel height))
+ + ViewSpacing + ViewSpacing
+ + okButton height
+ + ViewSpacing.
+
+ extra := margin * 2.
+ super extent:(w + extra) @ (h + extra)
+! !
+
+!InfoBox methodsFor:'user interaction'!
+
+hideAndEvaluate:aBlock
+ "make myself invisible and evaluate aBlock"
+
+ self hide.
+ aBlock notNil ifTrue:[aBlock value]
+!
+
+okPressed
+ "user pressed ok-button; make myself invisible and if an action was
+ specified do it"
+
+ self hideAndEvaluate:okAction
+!
+
+keyPress:aKey x:x y:y
+ "return-key dublicates ok-function"
+
+ (aKey == #Return) ifTrue:[self okPressed]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/LSelBox.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,139 @@
+"
+ COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+EnterBox subclass:#ListSelectionBox
+ instanceVariableNames:'selectionList'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+ListSelectionBox comment:'
+
+COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+this class implements boxes for selection from a list
+
+%W% %E%
+
+written Jan 90 by claus
+'!
+
+!ListSelectionBox class methodsFor:'defaults'!
+
+defaultExtent
+ ^ (Display pixelPerMillimeter * (80 @ 100)) rounded
+! !
+
+!ListSelectionBox class methodsFor:'instance creation'!
+
+title:titleString okText:okText abortText:abortText list:aList action:aBlock
+ "create and return a new listSelectionBox with list already defined"
+
+ |newBox|
+
+ newBox := super title:titleString okText:okText abortText:abortText
+ action:aBlock.
+ ^ newBox list:aList
+! !
+
+!ListSelectionBox methodsFor:'initialization'!
+
+initialize
+ |space2 v|
+
+ super initialize.
+
+ "need more space than an enterBox"
+
+ "self height:(height + (font height * 5)). "
+
+ space2 := 2 * ViewSpacing.
+
+ v := ScrollableView for:SelectionInListView in:self.
+
+ "kludge: see note in EnterBox"
+ v origin:(ViewSpacing
+ @
+ (enterField origin y + enterField height + ViewSpacing)).
+ v extent:((width - space2 - (v borderWidth * 2))
+ @
+ (height
+ - ViewSpacing - labelField heightIncludingBorder
+ - ViewSpacing - enterField heightIncludingBorder
+ - buttonPanel heightIncludingBorder - ViewSpacing
+ - space2)
+ ).
+ v origin:[ViewSpacing
+ @
+ (enterField origin y + enterField height + ViewSpacing)]
+ extent:[(width - space2 - (v borderWidth * 2))
+ @
+ (height
+ - ViewSpacing - labelField heightIncludingBorder
+ - ViewSpacing - enterField heightIncludingBorder
+ - buttonPanel heightIncludingBorder - ViewSpacing
+ - space2)
+ ].
+ selectionList := v scrolledView.
+
+ "self updateList."
+
+ "selections in list get forwarded to enterfield"
+ selectionList action:[:lineNr |
+ enterField contents:(selectionList selectionValue)
+ ].
+ selectionList keyboardHandler:enterField
+!
+
+updateList
+ "setup contents of list; nothing done here but redefined in subclasses"
+
+ ^ self
+!
+
+realize
+ self updateList.
+ super realize
+! !
+
+!ListSelectionBox methodsFor:'private'!
+
+resize
+ "resize myself to make everything visible"
+
+ |wWanted hWanted|
+
+ wWanted := labelField width + ViewSpacing + ViewSpacing.
+ (wWanted > width) ifFalse:[
+ wWanted := width
+ ].
+ hWanted := ViewSpacing + labelField height +
+ ViewSpacing + enterField height +
+ ViewSpacing + selectionList height +
+ ViewSpacing + buttonPanel height +
+ ViewSpacing.
+
+ (hWanted < height) ifTrue:[
+ hWanted := height
+ ].
+ self extent:(wWanted @ hWanted)
+! !
+
+!ListSelectionBox methodsFor:'accessing'!
+
+list:aList
+ "set the list to be displayed in selection list"
+
+ selectionList list:aList
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Label.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,347 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+View subclass:#Label
+ instanceVariableNames:'logo
+ labelWidth labelHeight
+ labelOriginX labelOriginY
+ adjust hSpace vSpace
+ bgColor fgColor fixSize'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Layout'
+!
+
+Label comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+this class implements labels - a view holding a string or form
+
+%W% %E%
+
+written spring/summer 89 by claus
+'!
+
+!Label class methodsFor:'defaults'!
+
+defaultExtent
+ "answer default extent"
+
+ ^ 16 @ 16
+! !
+
+!Label class methodsFor:'instance creation'!
+
+form:aForm
+ "answer a new Label showing a form"
+
+ ^ (self on:Display) form:aForm
+!
+
+form:aForm in:aView
+ "answer a new Label showing a form"
+
+ ^ (self in:aView) form:aForm
+! !
+
+!Label methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ font := font on:device.
+ self height:(font height + font descent).
+ adjust := #center.
+ labelOriginX := 0.
+ labelOriginY := 0.
+ labelWidth := 0.
+ labelHeight := 0.
+ logo := nil.
+ fixSize := false.
+ hSpace := (self horizontalPixelPerMillimeter:0.5) rounded.
+ vSpace := (self verticalPixelPerMillimeter:0.5) rounded
+!
+
+initStyle
+ super initStyle.
+
+ fgColor := Black.
+ bgColor := viewBackground.
+!
+
+realize
+ super realize.
+ fgColor := fgColor on:device.
+ bgColor := bgColor on:device.
+!
+
+recreate
+ "after snapin, labels dimensions may have changed due to
+ different font parameters"
+
+ super recreate.
+ self computeLabelSize.
+ self computeLabelOrigin
+! !
+
+!Label methodsFor:'accessing'!
+
+foregroundColor
+ "return the foreground color"
+
+ ^ fgColor
+!
+
+foregroundColor:aColor
+ "set the foreground color"
+
+ fgColor := aColor on:device.
+ self redraw
+!
+
+backgroundColor
+ "return the background color"
+
+ ^ bgColor
+!
+
+backgroundColor:aColor
+ "set the background color"
+
+ bgColor := aColor on:device.
+ self redraw
+!
+
+foregroundColor:fg backgroundColor:bg
+ "set the colors to be used for drawing"
+
+ fgColor := fg on:device.
+ bgColor := bg on:device.
+ self redraw
+!
+
+sizeFixed:aBoolean
+ "set/clear the fix-size attribute (will not change size on label-change)"
+
+ fixSize := aBoolean
+!
+
+label:aString
+ "set the label-string; adjust extent if not already realized"
+
+ (logo = aString) ifFalse:[
+ logo := aString.
+ self newLayout
+ ]
+!
+
+label
+ "answer the labels string"
+
+ ^ logo
+!
+
+labelWidth
+ "answer the logos width in pixels"
+
+ ^ labelWidth
+!
+
+font:aFont
+ "set the font - if I'm not realized, adjust my size"
+
+ (aFont ~~ font) ifTrue:[
+ super font:(aFont on:device).
+ self newLayout
+ ]
+!
+
+adjust:how
+ "set the adjust, how which must be one of
+
+ #left -> left adjust logo
+ #right -> right adjust logo
+ #center -> center logo
+ #centerLeft -> center logo; if it does not fit, left adjust it
+ #centerRight -> center logo; if no fit, right adjust
+ "
+ (adjust ~~ how) ifTrue:[
+ adjust := how.
+ self newLayout
+ ]
+!
+
+form:aForm
+ "set the labels form; adjust extent if not already realized"
+
+ aForm isNil ifFalse:[
+ logo := aForm.
+ self newLayout
+ ]
+! !
+
+!Label methodsFor:'private'!
+
+newLayout
+ "recompute position/size after a change
+ - helper for form:/font: etc."
+
+ self computeLabelSize.
+ fixSize ifFalse:[
+ self resize
+ ] ifTrue:[
+ self computeLabelOrigin
+ ].
+ self redraw
+!
+
+resize
+ "resize myself to make text fit into myself"
+
+ |extra|
+
+ logo isNil ifFalse:[
+ (relativeExtent isNil and:[extentRule isNil]) ifTrue:[
+ extra := margin * 2.
+ self extent:(labelWidth + extra) @ (labelHeight + extra)
+ ].
+ self computeLabelOrigin
+ ]
+!
+
+computeLabelSize
+ "compute the extent needed to hold the label; aForm or aString"
+
+ |numberOfLines textHeight textWidth|
+
+ (logo isKindOf:String) ifFalse:[
+ (logo isKindOf:Text) ifFalse:[
+ logo isNil ifFalse:[
+ labelWidth := logo width.
+ labelHeight := logo height
+ ].
+ ^ self
+ ]
+ ].
+
+ "must be a String or Text"
+ (logo isKindOf:String) ifTrue:[
+ numberOfLines := 1 + (logo occurrencesOf:(Character cr)).
+ (numberOfLines ~~ 1) ifTrue:[
+ logo := logo asText
+ ]
+ ] ifFalse:[
+ numberOfLines := logo size.
+ (numberOfLines == 1) ifTrue:[
+ logo := logo asString
+ ]
+ ].
+
+ textHeight := font height * numberOfLines + font descent.
+ textWidth := font widthOf:logo.
+ labelWidth := textWidth + (hSpace "+ margin" * 2) .
+ labelHeight := textHeight + (vSpace "+ margin" * 2)
+
+!
+
+computeLabelOrigin
+ "(re)compute the origin of the label whenever label or font changes"
+
+ |x y|
+
+ labelHeight isNil ifTrue:[^ self].
+
+ " always center vertically "
+ (labelHeight < height) ifTrue:[
+ y := (height - labelHeight) // 2
+ ] ifFalse:[
+ y := 0
+ ].
+ labelOriginY := y.
+
+ (((adjust == #center)
+ or:[adjust == #centerRight])
+ or:[adjust == #centerLeft]) ifTrue:[
+ " center text/form in button "
+ x := (width - labelWidth) // 2.
+ (width < labelWidth) ifTrue:[
+ "no fit"
+ (adjust == #centerLeft) ifTrue:[
+ x := margin
+ ] ifFalse:[
+ (adjust == #centerRight) ifTrue:[
+ x := width - labelWidth - margin
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ (adjust == #left) ifTrue:[
+ x := margin
+ ] ifFalse:[
+ x := width - labelWidth - margin
+ ]
+ ].
+ labelOriginX := x
+! !
+
+!Label methodsFor:'events'!
+
+sizeChanged:how
+ "sent whenever size is changed by someone else"
+
+ self computeLabelOrigin
+! !
+
+!Label methodsFor:'redrawing'!
+
+drawWith:fg and:bg
+ "redraw my label with fg/bg"
+
+ |x y cutOff|
+
+ cutOff := margin * 2.
+
+ self paint:bg.
+ self fillRectangleX:margin y:margin
+ width:(width - cutOff)
+ height:(height - cutOff).
+
+ logo notNil ifTrue:[
+ self paint:fg on:bg.
+ (logo isKindOf:Form) ifTrue:[
+ self background:bg.
+ self drawOpaqueForm:logo x:labelOriginX y:labelOriginY
+ ] ifFalse:[
+ x := labelOriginX + hSpace.
+ y := labelOriginY + (font ascent) + vSpace.
+
+ (logo isKindOf:String) ifTrue:[
+ self displayString:logo x:x y:y
+ ] ifFalse:[
+ logo do:[ :line |
+ self displayString:(line printString) x:x y:y.
+ y := y + (font height)
+ ]
+ ]
+ ]
+ ]
+!
+
+redraw
+ "redraw my label"
+
+ shown ifTrue:[
+ self drawWith:fgColor and:bgColor
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ListSelectionBox.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,139 @@
+"
+ COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+EnterBox subclass:#ListSelectionBox
+ instanceVariableNames:'selectionList'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+ListSelectionBox comment:'
+
+COPYRIGHT (c) 1990-93 by Claus Gittinger
+ All Rights Reserved
+
+this class implements boxes for selection from a list
+
+%W% %E%
+
+written Jan 90 by claus
+'!
+
+!ListSelectionBox class methodsFor:'defaults'!
+
+defaultExtent
+ ^ (Display pixelPerMillimeter * (80 @ 100)) rounded
+! !
+
+!ListSelectionBox class methodsFor:'instance creation'!
+
+title:titleString okText:okText abortText:abortText list:aList action:aBlock
+ "create and return a new listSelectionBox with list already defined"
+
+ |newBox|
+
+ newBox := super title:titleString okText:okText abortText:abortText
+ action:aBlock.
+ ^ newBox list:aList
+! !
+
+!ListSelectionBox methodsFor:'initialization'!
+
+initialize
+ |space2 v|
+
+ super initialize.
+
+ "need more space than an enterBox"
+
+ "self height:(height + (font height * 5)). "
+
+ space2 := 2 * ViewSpacing.
+
+ v := ScrollableView for:SelectionInListView in:self.
+
+ "kludge: see note in EnterBox"
+ v origin:(ViewSpacing
+ @
+ (enterField origin y + enterField height + ViewSpacing)).
+ v extent:((width - space2 - (v borderWidth * 2))
+ @
+ (height
+ - ViewSpacing - labelField heightIncludingBorder
+ - ViewSpacing - enterField heightIncludingBorder
+ - buttonPanel heightIncludingBorder - ViewSpacing
+ - space2)
+ ).
+ v origin:[ViewSpacing
+ @
+ (enterField origin y + enterField height + ViewSpacing)]
+ extent:[(width - space2 - (v borderWidth * 2))
+ @
+ (height
+ - ViewSpacing - labelField heightIncludingBorder
+ - ViewSpacing - enterField heightIncludingBorder
+ - buttonPanel heightIncludingBorder - ViewSpacing
+ - space2)
+ ].
+ selectionList := v scrolledView.
+
+ "self updateList."
+
+ "selections in list get forwarded to enterfield"
+ selectionList action:[:lineNr |
+ enterField contents:(selectionList selectionValue)
+ ].
+ selectionList keyboardHandler:enterField
+!
+
+updateList
+ "setup contents of list; nothing done here but redefined in subclasses"
+
+ ^ self
+!
+
+realize
+ self updateList.
+ super realize
+! !
+
+!ListSelectionBox methodsFor:'private'!
+
+resize
+ "resize myself to make everything visible"
+
+ |wWanted hWanted|
+
+ wWanted := labelField width + ViewSpacing + ViewSpacing.
+ (wWanted > width) ifFalse:[
+ wWanted := width
+ ].
+ hWanted := ViewSpacing + labelField height +
+ ViewSpacing + enterField height +
+ ViewSpacing + selectionList height +
+ ViewSpacing + buttonPanel height +
+ ViewSpacing.
+
+ (hWanted < height) ifTrue:[
+ hWanted := height
+ ].
+ self extent:(wWanted @ hWanted)
+! !
+
+!ListSelectionBox methodsFor:'accessing'!
+
+list:aList
+ "set the list to be displayed in selection list"
+
+ selectionList list:aList
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ListView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,1722 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+View subclass:#ListView
+ instanceVariableNames:'list
+ attributes
+ firstLineShown leftOffset
+ nFullLinesShown nLinesShown
+ fgColor bgColor
+ partialLines
+ leftMargin topMargin
+ textStartLeft textStartTop innerWidth
+ tabPositions lineSpacing
+ fontHeight fontAscent
+ fontIsFixedWidth fontWidth
+ normalFont boldFont italicFont
+ autoScrollBlock autoScrollDeltaT
+ searchPattern'
+ classVariableNames:'spaces'
+ poolDictionaries:''
+ category:'Views-Text'
+!
+
+ListView comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+
+written spring 89 by claus
+'!
+
+!ListView class methodsFor:'documentation'!
+
+documentation
+"
+a simple View for lists - the elements must understand printString
+the list is changed - the elements are replaced by their printStrings
+(if this leads to problems - I will change it later)
+
+This class can only passively display -
+selections, editing, cursors etc. must be done in subclasses.
+see SelectionInListView, TextView etc.
+
+This code currently handles only fixed-height fonts correctly -
+should be rewritten in some places ...
+
+Instance variables:
+
+list <aCollection> the text strings
+attributes <aCollection> corresponding attributes
+firstLineShown <Number> the index of the 1st visible line (1 ..)
+leftOffset <Number> left offset for horizontal scroll
+nFullLinesShown <Number> the number of unclipped lines in visible
+nLinesShown <Number> the number of lines in visible
+fgColor <Color> color to draw characters
+bgColor <Color> the background
+partialLines <Boolean> allow last line to be partial displayed
+leftMargin <Number> margin at left in pixels
+topMargin <Number> margin at top in pixels
+textStartLeft <Number> margin + leftMargin
+textStartTop <Number> margin + topMargin
+innerWidth <Number> width - margins
+tabPositions <aCollection> tab stops (cols)
+fontHeight <Number> font height in pixels
+fontAscent <Number> font ascent in pixels
+fontIsFixed <Boolean> true if its a fixed font
+fontWidth <Number> width of space
+lineSpacing <Number> pixels between lines
+normalFont <Font> font for normal characters
+boldFont <Font> font for bold characters
+italicFont <Font> font for italic characters
+searchPattern <String> last pattern for searching
+"
+! !
+
+!ListView class methodsFor:'defaults'!
+
+defaultTabPositions
+ ^ #(1 9 17 25 33 41 49 57 65 73 81 89 97 105 113 121 129 137 145)
+! !
+
+!ListView methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ spaces isNil ifTrue:[
+ spaces := String new:100
+ ].
+ bitGravity := #NorthWest.
+ list := nil.
+ firstLineShown := 1.
+ leftOffset := 0.
+ partialLines := true.
+ tabPositions := self class defaultTabPositions.
+ leftMargin := (self horizontalPixelPerMillimeter:0.5) rounded.
+ topMargin := (self verticalPixelPerMillimeter:0.5) rounded.
+ textStartLeft := leftMargin + margin.
+ textStartTop := topMargin + margin.
+ innerWidth := width - textStartLeft - margin.
+ self getFontParameters
+!
+
+initStyle
+ super initStyle.
+ fgColor := Black.
+ bgColor := White.
+ lineSpacing := 0.
+!
+
+initEvents
+ self enableKeyEvents
+!
+
+create
+ super create.
+
+ "I cache font parameters here - they are used so often ..."
+ self getFontParameters.
+ self computeNumberOfLinesShown.
+ fgColor := fgColor on:device.
+ bgColor := bgColor on:device
+!
+
+recreate
+ "recreate after a snapin"
+
+ super recreate.
+
+ "recompute margins and font parameters
+ - display may have different resolution."
+
+ leftMargin := (self horizontalPixelPerMillimeter:0.5) rounded.
+ topMargin := (self verticalPixelPerMillimeter:0.5) rounded.
+ textStartLeft := leftMargin + margin.
+ textStartTop := topMargin + margin.
+ innerWidth := width - textStartLeft - margin.
+ self getFontParameters
+! !
+
+!ListView methodsFor:'accessing'!
+
+backgroundColor:aColor
+ "set the background color"
+
+ bgColor := aColor.
+ shown ifTrue:[
+ self redraw
+ ]
+!
+
+foregroundColor:aColor
+ "set the foreground color"
+
+ fgColor := aColor.
+ shown ifTrue:[
+ self redraw
+ ]
+!
+
+foregroundColor:color1 backgroundColor:color2
+ "set both foreground and background colors"
+
+ fgColor := color1.
+ bgColor := color2.
+ shown ifTrue:[
+ self redraw
+ ]
+!
+
+partialLines:aBoolean
+ "allow/disallow display of a last partial line"
+
+ partialLines := aBoolean.
+ self computeNumberOfLinesShown
+!
+
+leftMargin:aNumber
+ "set the margin to left of 1st col"
+
+ leftMargin := aNumber.
+ textStartLeft := leftMargin + margin.
+ innerWidth := width - textStartLeft - margin
+!
+
+leftMargin
+ "return the margin to left of 1st col"
+
+ ^ leftMargin
+!
+
+setList:aCollection
+ "set the contents (a collection of strings) keep position unchanged"
+
+ (aCollection isNil and:[list isNil]) ifTrue:[
+ "no change"
+ ^ self
+ ].
+ list := aCollection.
+
+ list notNil ifTrue:[
+ self expandTabs
+ ].
+ self contentsChanged.
+ shown ifTrue:[
+ self redrawFromVisibleLine:1 to:nLinesShown
+ ]
+!
+
+list:aCollection
+ "set the contents (a collection of strings) and scroll to top"
+
+ |oldFirst|
+
+ (aCollection isNil and:[list isNil]) ifTrue:[
+ "no change"
+ self scrollToTop.
+ ^ self
+ ].
+ list := aCollection.
+
+ list notNil ifTrue:[
+ self expandTabs
+ ].
+ self contentsChanged.
+ "dont use scroll here to avoid the redraw"
+ oldFirst := firstLineShown.
+ firstLineShown := 1.
+ self originChanged:(oldFirst - 1) negated.
+ shown ifTrue:[
+ self redrawFromVisibleLine:1 to:nLinesShown
+ ]
+!
+
+list
+ "return the contents as a collection of strings"
+
+ ^ list
+!
+
+setContents:something
+ "set the contents (either a string or a Collection of strings)
+ dont change position"
+
+ something isNil ifTrue:[
+ self setList:nil
+ ] ifFalse:[
+ self setList:(something asText)
+ ]
+!
+
+contents:something
+ "set the contents (either a string or a Collection of strings)
+ also scroll to top"
+
+ something isNil ifTrue:[
+ self list:nil
+ ] ifFalse:[
+ self list:(something asText)
+ ]
+!
+
+contents
+ "return the contents as a string"
+
+ list isNil ifTrue:[^ ''].
+ ^ list asString
+!
+
+at:index put:aString
+ "change a line and redisplay"
+
+ self checkForExistingLine:index.
+ list at:index put:aString.
+ shown ifTrue:[
+ self redrawLine:index
+ ]
+!
+
+at:index
+ "retrieve a line; return nil if behond end-of-text"
+
+ ^ self listAt:index
+!
+
+removeIndexWithoutRedraw:lineNr
+ "delete line - no redraw;
+ answer true, if something was really deleted"
+
+ (list isNil or:[lineNr > list size]) ifTrue:[^ false].
+ list removeIndex:lineNr.
+ lineNr <= firstLineShown ifTrue:[
+ firstLineShown := firstLineShown - 1
+ ].
+ self contentsChanged.
+ ^ true
+!
+
+removeIndex:lineNr
+ "delete line"
+
+ |visLine w
+ srcY "{ Class: SmallInteger }" |
+
+ w := self widthForScrollBetween:lineNr
+ and:(firstLineShown + nLinesShown).
+ (self removeIndexWithoutRedraw:lineNr) ifFalse:[^ self].
+ visLine := self listLineToVisibleLine:lineNr.
+ visLine notNil ifTrue:[
+ srcY := topMargin + (visLine * fontHeight).
+ self copyFrom:self x:textStartLeft y:srcY
+ toX:textStartLeft y:(srcY - fontHeight)
+ width:w height:((nLinesShown - visLine) * fontHeight).
+ self redrawVisibleLine:nFullLinesShown.
+ (nFullLinesShown ~~ nLinesShown) ifTrue:[
+ self redrawVisibleLine:nLinesShown
+ ].
+ exposePending := true.
+ self waitForExpose
+ ]
+!
+
+font:aFont
+ "set the font"
+
+ aFont isNil ifTrue:[
+ ^ self error:'nil font'
+ ].
+ super font:aFont.
+ (font device == device) ifTrue:[
+ self getFontParameters.
+ self computeNumberOfLinesShown.
+ shown ifTrue:[
+ self redrawFromVisibleLine:1 to:nLinesShown
+ ]
+ ].
+ self contentsChanged
+!
+
+level:aNumber
+ "set the level - cought here to update text-position variables
+ (which avoid many computations later)"
+
+ super level:aNumber.
+
+ textStartLeft := leftMargin + margin.
+ textStartTop := topMargin + margin.
+" textStartLeft := leftMargin. "
+ innerWidth := width - textStartLeft - margin
+!
+
+innerHeight
+ "return the number of pixels visible of the contents
+ - redefined since ListView adds a margin"
+
+ ^ height - (2 * margin) - (2 * topMargin)
+! !
+
+!ListView methodsFor:'queries'!
+
+numberOfLines
+ "answer the number of lines the text has"
+
+ ^ list size
+!
+
+lengthOfLongestLine
+ "answer the length (in characters) of the longest line"
+
+ |max "{ Class: SmallInteger }"
+ thisLen "{ Class: SmallInteger }" |
+
+ max := 0.
+ list notNil ifTrue:[
+ list do:[:lineString |
+ lineString notNil ifTrue:[
+ thisLen := lineString size.
+ (thisLen > max) ifTrue:[
+ max := thisLen
+ ]
+ ]
+ ]
+ ].
+ ^ max
+!
+
+lengthOfLongestLineBetween:firstLine and:lastLine
+ "answer the length (in characters) of the longest line in a line-range"
+
+ |max "{ Class: SmallInteger }"
+ thisLen "{ Class: SmallInteger }"
+ listSize "{ Class: SmallInteger }"
+ first "{ Class: SmallInteger }"
+ last "{ Class: SmallInteger }" |
+
+ listSize := list size.
+ max := 0.
+ first := firstLine.
+ last := lastLine.
+
+ (first > listSize) ifTrue:[^ max].
+ (last > listSize) ifTrue:[
+ last := listSize
+ ].
+ list from:first to:last do:[:lineString |
+ lineString notNil ifTrue:[
+ thisLen := lineString size.
+ (thisLen > max) ifTrue:[
+ max := thisLen
+ ]
+ ]
+ ].
+ ^ max
+!
+
+heightOfContents
+ "return the height of the contents in pixels
+ - used for scrollbar interface"
+
+ | numLines |
+
+ numLines := self numberOfLines.
+ ^ numLines * fontHeight + textStartTop.
+
+ "it used to be that code - which is wrong"
+ (nLinesShown == nFullLinesShown) ifTrue:[
+ ^ numLines * fontHeight
+ ].
+ "add one - otherwise we cannot make last line
+ fully visible since scrolling is done by full lines only"
+
+ ^ (numLines + 1) * fontHeight
+!
+
+widthOfContents
+ "return the width of the contents in pixels"
+
+ |max|
+
+ fontIsFixedWidth ifTrue:[
+ ^ self lengthOfLongestLine * fontWidth
+ ].
+ max := 0.
+ list notNil ifTrue:[
+ max := max max:(font widthOf:list)
+ ].
+ ^ max
+!
+
+yOriginOfContents
+ "return the vertical origin of the contents in pixels
+ - used for scrollbar interface"
+
+ ^ (firstLineShown - 1) * fontHeight
+!
+
+xOriginOfContents
+ "return the horizontal origin of the contents in pixels
+ - used for scrollbar interface"
+
+ ^leftOffset
+!
+
+leftIndentOfLine:lineNr
+ "return the number of spaces at the left in line, lineNr"
+
+ |lineString index end|
+
+ lineString := self listAt:lineNr.
+ lineString isNil ifTrue:[^ 0].
+ index := 1.
+ end := lineString size.
+ [index <= end] whileTrue:[
+ (lineString at:index) isSeparator ifFalse:[^ index - 1].
+ index := index + 1
+ ].
+ ^ 0
+! !
+
+!ListView methodsFor:'private'!
+
+getFontParameters
+ "get some info of the used font. They are cached since we use them often .."
+
+ font := font on:device.
+ normalFont := font.
+ fontHeight := font height + lineSpacing.
+ fontAscent := font ascent.
+ fontWidth := font width.
+ fontIsFixedWidth := font isFixedWidth.
+!
+
+checkForExistingLine:lineNr
+ "check if a line for lineNr exists; if not, expand text"
+
+ list isNil ifTrue: [
+ list := Text new:lineNr.
+ self contentsChanged
+ ] ifFalse: [
+ lineNr > (list size) ifTrue:[
+ list grow:lineNr.
+ self contentsChanged
+ ]
+ ]
+!
+
+getBoldFont
+ "get a bold-font corresponding to font"
+
+ font style notNil ifTrue:[
+ boldFont := Font family:(font family) face:'bold'
+ style:'roman' size:(font size)
+ ].
+ boldFont isNil ifTrue:[
+ boldFont := font
+ ]
+!
+
+getItalicFont
+ "get an italic-font corresponding to font"
+
+ font style notNil ifTrue:[
+ italicFont := Font family:(font family) face:'medium'
+ style:'oblique' size:(font size)
+ ].
+ italicFont isNil ifTrue:[
+ italicFont := font
+ ]
+!
+
+convertRTF:aList
+ "this is a q&d RTF to poor-text converter which removes any rich stuff.
+ - a first shot 'til DocumentView is finished ..."
+
+ |newList newLine charIndex inEscape char special|
+
+ newList := Text new:200.
+ newList grow:0.
+
+ newLine := ''.
+ aList do:[:line |
+ ((line size == 0) or:[line isBlank]) ifTrue:[
+ newList add:newLine.
+ newLine := ''
+ ] ifFalse:[
+ special := ((line at:1) == ${) or:[(line includes:$\)].
+ special := special or:[(line at:1) == $}].
+ special ifFalse:[
+ newList add:(newLine , line)
+ ] ifTrue:[
+ charIndex := 1.
+ [charIndex <= line size] whileTrue:[
+ char := line at:charIndex.
+ ((char == ${ ) or:[char == $} ]) ifTrue:[
+ "left-brace: ignore rest of line"
+ charIndex := line size + 1
+ ] ifFalse:[
+ (char == $\) ifTrue:[
+ inEscape := true
+ ] ifFalse:[
+ inEscape ifTrue:[
+ (char == Character space) ifTrue:[
+ inEscape := false
+ ]
+ ] ifFalse:[
+ newLine := newLine copyWith:char
+ ]
+ ].
+ charIndex := charIndex + 1
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ newList
+!
+
+expandTabs
+ "go through whole text expanding tabs into spaces"
+
+ |line newLine nLines "{ Class: SmallInteger }"|
+
+ list notNil ifTrue:[
+ nLines := list size.
+ 1 to:nLines do:[:index |
+ line := list at:index.
+ line notNil ifTrue:[
+ (line class == String) ifFalse:[
+ newLine := line printString
+ ] ifTrue:[
+ newLine := line
+ ].
+ (newLine occurrencesOf:(Character tab)) == 0 ifFalse:[
+ newLine := self withTabsExpanded:newLine
+ ].
+ (newLine ~~ line) ifTrue:[
+ list at:index put:newLine
+ ]
+ ]
+ ]
+ ]
+!
+
+nextTabAfter:colNr
+ "answer the next tab position after col"
+
+ |col "{ Class: SmallInteger }"
+ tabIndex "{ Class: SmallInteger }"
+ thisTab "{ Class: SmallInteger }"
+ nTabs "{ Class: SmallInteger }" |
+
+ tabIndex := 1.
+ col := colNr.
+ thisTab := tabPositions at:tabIndex.
+ nTabs := tabPositions size.
+ [thisTab <= col] whileTrue:[
+ (tabIndex == nTabs) ifTrue:[^ thisTab].
+ tabIndex := tabIndex + 1.
+ thisTab := tabPositions at:tabIndex
+ ].
+ ^ thisTab
+!
+
+prevTabBefore:colNr
+ "answer the prev tab position before col"
+
+ |col "{ Class: SmallInteger }"
+ tabIndex "{ Class: SmallInteger }"
+ thisTab "{ Class: SmallInteger }"
+ nTabs "{ Class: SmallInteger }" |
+
+ tabIndex := 1.
+ col := colNr.
+ thisTab := tabPositions at:tabIndex.
+ nTabs := tabPositions size.
+ [thisTab < col] whileTrue:[
+ (tabIndex == nTabs) ifTrue:[^ thisTab].
+ tabIndex := tabIndex + 1.
+ thisTab := tabPositions at:tabIndex
+ ].
+ (tabIndex == 1) ifTrue:[
+ ^ 1
+ ].
+ ^ tabPositions at:(tabIndex - 1)
+!
+
+withTabsExpanded:line
+ "good idea, to make this one a primitive"
+
+ |tmpString nString
+ currentMax "{ Class: SmallInteger }"
+ dstIndex "{ Class: SmallInteger }"
+ nextTab "{ Class: SmallInteger }" |
+
+ currentMax := 200.
+ tmpString := String new:currentMax.
+ dstIndex := 1.
+ line do:[:character |
+ (character == (Character tab)) ifTrue:[
+ nextTab := self nextTabAfter:dstIndex.
+ [dstIndex < nextTab] whileTrue:[
+ tmpString at:dstIndex put:(Character space).
+ dstIndex := dstIndex + 1
+ ]
+ ] ifFalse:[
+ tmpString at:dstIndex put:character.
+ dstIndex := dstIndex + 1
+ ].
+ (dstIndex > currentMax) ifTrue:[
+ currentMax := currentMax + currentMax.
+ nString := String new:currentMax.
+ nString replaceFrom:1 to:(dstIndex - 1)
+ with:tmpString startingAt:1.
+ tmpString := nString.
+ nString := nil
+ ].
+
+ "make stc-optimizer happy
+ - no need to return value of ifTrue:/ifFalse above"
+ 0
+ ].
+ ^ tmpString copyFrom:1 to:(dstIndex - 1)
+!
+
+computeNumberOfLinesShown
+ "recompute the number of visible lines"
+
+ nFullLinesShown := self innerHeight // fontHeight.
+ nLinesShown := nFullLinesShown.
+
+ partialLines ifTrue:[
+ ((nLinesShown * fontHeight) == height) ifFalse:[
+ nLinesShown := nLinesShown + 1
+ ]
+ ]
+!
+
+widthOfWidestLineBetween:firstLine and:lastLine
+ "answer the width in pixels of the widest line in a range"
+
+ |max "{ Class: SmallInteger }"
+ first "{ Class: SmallInteger }"
+ last "{ Class: SmallInteger }"
+ thisLen "{ Class: SmallInteger }"
+ listSize "{ Class: SmallInteger }" |
+
+ fontIsFixedWidth ifTrue:[
+ ^ (self lengthOfLongestLineBetween:firstLine and:lastLine) * fontWidth
+ ].
+ listSize := list size.
+ max := 0.
+ first := firstLine.
+ last := lastLine.
+
+ (first > listSize) ifTrue:[^ max].
+ (last > listSize) ifTrue:[
+ last := listSize
+ ].
+
+ list from:first to:last do:[:line |
+ line notNil ifTrue:[
+ thisLen := font widthOf:line.
+ (thisLen > max) ifTrue:[
+ max := thisLen
+ ]
+ ]
+ ].
+ ^ max
+!
+
+widthForScrollBetween:firstLine and:lastLine
+ "answer the width in pixels for a scroll between firstLine and lastLine"
+
+ |w|
+
+ "for small width, its not worth searching for
+ longest line ..."
+
+ (width < 300) ifTrue:[^ innerWidth].
+
+ w := self widthOfWidestLineBetween:firstLine
+ and:lastLine.
+ (w > innerWidth) ifTrue:[^ innerWidth].
+ ^ w
+!
+
+firstLineShown
+ ^ firstLineShown
+!
+
+listAt:lineNr
+ "given a lineNumber, answer the corresponding string"
+
+ list isNil ifTrue:[^ nil].
+ (lineNr between:1 and:list size) ifFalse:[^ nil].
+ ^ list at:lineNr
+!
+
+listAt:lineNr from:startCol to:endCol
+ "answer substring from startCol to endCol of a line"
+
+ |line stop lineLen|
+
+ line := self listAt:lineNr.
+ line isNil ifTrue:[^ nil].
+ lineLen := line size.
+ (startCol > lineLen) ifTrue:[^ nil].
+ stop := endCol.
+ (stop > lineLen) ifTrue:[stop := lineLen].
+ ^ line copyFrom:startCol to:stop
+!
+
+listAt:lineNr from:startCol
+ "answer right substring from startCol to end of a line"
+
+ |line|
+
+ line := self listAt:lineNr.
+ line isNil ifTrue:[^ nil].
+ (startCol > line size) ifTrue:[^ nil].
+ ^ line copyFrom:startCol to:(line size)
+!
+
+listAt:lineNr to:endCol
+ "answer left substring from start to endCol of a line"
+
+ |line stop|
+
+ line := self listAt:lineNr.
+ line isNil ifTrue:[^ nil].
+ stop := endCol.
+ (stop > line size) ifTrue:[stop := line size].
+ ^ line copyFrom:1 to:stop
+!
+
+listLineToVisibleLine:listLineNr
+ "given a list line (1..) return visible linenr or nil"
+
+ |visibleLineNr "{ Class: SmallInteger }"|
+
+ shown ifFalse:[^ nil].
+ listLineNr isNil ifTrue:[^ nil].
+ visibleLineNr := listLineNr + 1 - firstLineShown.
+ (visibleLineNr between:1 and:nLinesShown) ifFalse:[^ nil].
+ ^ visibleLineNr
+!
+
+visibleLineToListLine:visibleLineNr
+ "given a visible line (1..) return linenr in list or nil
+ (this one returns nil if the given visibleLineNr is one of the
+ separators)"
+
+ |listLineNr "{ Class: SmallInteger }"
+ listsize "{ Class: SmallInteger }" |
+
+ visibleLineNr isNil ifTrue:[^ nil].
+ listLineNr := visibleLineNr + firstLineShown - 1.
+ (listLineNr == 0) ifTrue:[^nil].
+ listsize := list size.
+ (listLineNr <= listsize) ifTrue:[^ listLineNr].
+ ^ nil
+!
+
+absoluteLineToVisibleLine:absLineNr
+ "given an absolute line (1..) return visible linenr or nil"
+
+ absLineNr isNil ifTrue:[^ nil].
+ (absLineNr < firstLineShown) ifTrue:[^ nil].
+ (absLineNr >= (firstLineShown + nLinesShown)) ifTrue:[^ nil].
+ ^ absLineNr - firstLineShown + 1
+!
+
+visibleLineToAbsoluteLine:visibleLineNr
+ "given a visible line (1..) return absolut linenr"
+
+ visibleLineNr isNil ifTrue:[^ nil].
+ ^ visibleLineNr + firstLineShown - 1
+!
+
+yOfLine:visLineNr
+ "given a visible lineNr, return y-coordinate in view
+ - works for fix-height fonts only"
+
+ ^ ((visLineNr - 1) * fontHeight) + textStartTop
+!
+
+xOfCol:col inLine:visLineNr
+ "given a visible line- and colNr, return x-coordinate in view"
+
+ |line lineSize tcol|
+
+ tcol := col - 1.
+ fontIsFixedWidth ifTrue:[
+ ^ (tcol * fontWidth) + textStartLeft
+ ].
+ line := self visibleAt:visLineNr.
+ line notNil ifTrue:[
+ lineSize := line size
+ ] ifFalse:[
+ lineSize := 0
+ ].
+ (lineSize == 0) ifTrue:[
+ ^ (tcol * fontWidth) + textStartLeft
+ ].
+ (lineSize < col) ifTrue:[
+ ^ (font widthOf:line)
+ + (fontWidth * (tcol - lineSize))
+ + textStartLeft
+ ].
+ ^ (font widthOf:line from:1 to:tcol) + textStartLeft
+!
+
+colOfX:x inVisibleLine:visLineNr
+ "given a visible lineNr and x-coordinate, return colNr"
+
+ |lineString linePixelWidth xRel runCol posLeft posRight done|
+
+ xRel := x - textStartLeft.
+ fontIsFixedWidth ifTrue:[
+ ^ (xRel // fontWidth) + 1
+ ].
+ lineString := self visibleAt:visLineNr.
+ lineString notNil ifTrue:[
+ linePixelWidth := font widthOf:lineString
+ ] ifFalse:[
+ linePixelWidth := 0
+ ].
+ (xRel <= 0) ifTrue:[^ 1].
+ (linePixelWidth <= xRel) ifTrue:[
+ ^ lineString size + ((xRel - linePixelWidth) // fontWidth) + 1
+ ].
+ runCol := lineString size // 2.
+ (runCol == 0) ifTrue:[runCol := 1].
+ posLeft := font widthOf:lineString from:1 to:(runCol - 1).
+ posRight := font widthOf:lineString from:1 to:runCol.
+ done := (posLeft <= xRel) and:[posRight > xRel].
+ [done] whileFalse:[
+ (posRight <= xRel) ifTrue:[
+ runCol := runCol + 1.
+ posLeft := posRight.
+ posRight := font widthOf:lineString from:1 to:runCol
+ ] ifFalse:[
+ (posLeft > xRel) ifTrue:[
+ runCol := runCol - 1.
+ (runCol == 0) ifTrue:[^ 0].
+ posRight := posLeft.
+ posLeft := font widthOf:lineString from:1 to:(runCol - 1)
+ ]
+ ].
+ done := (posLeft <= xRel) and:[posRight > xRel]
+ ].
+ ^ runCol
+!
+
+visibleLineOfY:y
+ "given a y-coordinate, return lineNr
+ - works for fix-height fonts only"
+
+ ^ ((y - textStartTop) // fontHeight) + 1
+!
+
+vissibleAttributeAt:visibleLineNr
+ "answer the attributes of what is visible at line (numbers start at 1)"
+
+ |listLineNr listsize|
+
+ listLineNr := visibleLineNr + firstLineShown - 1.
+ (listLineNr == 0) ifTrue:[^ nil].
+ (attributes notNil) ifTrue:[
+ listsize := attributes size
+ ] ifFalse:[
+ listsize := 0
+ ].
+ (listLineNr <= listsize) ifTrue:[^ attributes at:listLineNr].
+ ^ nil
+!
+
+visibleAt:visibleLineNr
+ "answer what is visible at line (numbers start at 1)"
+
+ |listLineNr listsize|
+
+ listLineNr := visibleLineNr + firstLineShown - 1.
+ (listLineNr == 0) ifTrue:[^ nil].
+ (list notNil) ifTrue:[
+ listsize := list size
+ ] ifFalse:[
+ listsize := 0
+ ].
+ (listLineNr <= listsize) ifTrue:[^ list at:listLineNr].
+ ^ ''
+!
+
+lineOfCharacterPosition:charPos
+ "given a character index within the contents-string,
+ return the lineNumber where the character is
+ - used to find line to hilight from Compilers error-position"
+
+ |lineNr sum lastLine|
+
+ lineNr := 1.
+ sum := 0.
+ lastLine := list size.
+ [sum < charPos] whileTrue:[
+ (lineNr > lastLine) ifTrue:[^ lineNr - 1].
+ sum := sum + (list at:lineNr) size + 1.
+ lineNr := lineNr + 1
+ ].
+ ^ lineNr - 1
+!
+
+characterPositionOfLine:lineNr col:col
+ "given a line/col position, return the character index within the contents-string,
+ - used with Compilers error-positioning"
+
+ |lineString pos|
+
+ pos := 1.
+ 1 to:(lineNr - 1) do:[:lnr |
+ lineString := list at:lnr.
+ lineString notNil ifTrue:[
+ pos := pos + lineString size
+ ].
+ pos := pos + 1 "the return-character"
+ ].
+ ^ pos + col - 1
+! !
+
+!ListView methodsFor:'searching'!
+
+setSearchPattern:aString
+ "set the searchpattern"
+
+ searchPattern := aString withoutSeparators
+!
+
+searchForwardFor:pattern startingAtLine:startLine col:startCol ifFound:block1 else:block2
+ "search for a pattern, if found evaluate block1 with row/col as arguments, if not
+ found evaluate block2"
+
+ |lineString col cc found firstChar savedCursor patternSize|
+
+ patternSize := pattern size.
+ patternSize ~~ 0 ifTrue:[
+ savedCursor := cursor.
+ self cursor:(Cursor questionMark).
+ searchPattern := pattern.
+ col := startCol + 1.
+ firstChar := pattern at:1.
+ startLine to:(list size) do:[:lnr |
+ lineString := list at:lnr.
+ lineString notNil ifTrue:[
+ col := lineString indexOf:firstChar startingAt:col.
+ [col == 0] whileFalse:[
+ cc := col.
+ found := true.
+ 1 to:patternSize do:[:cnr |
+ cc > lineString size ifTrue:[
+ found := false
+ ] ifFalse:[
+ (pattern at:cnr) ~~ (lineString at:cc) ifTrue:[
+ found := false
+ ]
+ ].
+ cc := cc + 1
+ ].
+ found ifTrue:[
+ self cursor:savedCursor.
+ ^ block1 value:lnr value:col.
+ ].
+ col := col + 1.
+ col := lineString indexOf:firstChar startingAt:col
+ ]
+ ].
+ col := 1
+ ]
+ ].
+ "not found"
+
+ self cursor:savedCursor.
+ ^ block2 value
+!
+
+searchBackwardFor:pattern startingAtLine:startLine col:startCol ifFound:block1 else:block2
+ "search for a pattern, if found evaluate block1 with row/col as arguments, if not
+ found evaluate block2"
+
+ |lineString col cc found firstChar savedCursor patternSize|
+
+ patternSize := pattern size.
+ patternSize ~~ 0 ifTrue:[
+ savedCursor := cursor.
+ self cursor:(Cursor questionMark).
+ searchPattern := pattern.
+ col := startCol - 1.
+ firstChar := pattern at:1.
+ col > (list at:startLine) size ifTrue:[
+ col := nil
+ ].
+ startLine to:1 by:-1 do:[:lnr |
+ lineString := list at:lnr.
+ lineString notNil ifTrue:[
+ col isNil ifTrue:[col := lineString size - patternSize + 1].
+ [(col > 0) and:[(lineString at:col) ~~ firstChar]] whileTrue:[
+ col := col - 1
+ ].
+ [col > 0] whileTrue:[
+ cc := col.
+ found := true.
+ 1 to:patternSize do:[:cnr |
+ cc > lineString size ifTrue:[
+ found := false
+ ] ifFalse:[
+ (pattern at:cnr) ~~ (lineString at:cc) ifTrue:[
+ found := false
+ ]
+ ].
+ cc := cc + 1
+ ].
+ found ifTrue:[
+ self cursor:savedCursor.
+ ^ block1 value:lnr value:col.
+ ].
+ col := col - 1.
+ [(col > 0) and:[(lineString at:col) ~~ firstChar]] whileTrue:[
+ col := col - 1
+ ]
+ ]
+ ].
+ col := nil
+ ]
+ ].
+ "not found"
+
+ self cursor:savedCursor.
+ ^ block2 value
+! !
+
+!ListView methodsFor:'scrolling'!
+
+gotoLine:aLineNumber
+ "position to line aLineNumber; this may be redefined
+ in subclasses (for example to move the cursor also)"
+
+ ^ self scrollToLine:aLineNumber
+!
+
+pageDown
+ "change origin to display next page"
+
+ self originWillChange.
+ firstLineShown := firstLineShown + nFullLinesShown.
+ self originChanged:nFullLinesShown.
+ self redrawFromVisibleLine:1 to:nLinesShown
+!
+
+pageUp
+ "change origin to display previous page"
+
+ |oldOrg|
+
+ (firstLineShown == 1) ifFalse:[
+ self originWillChange.
+ oldOrg := firstLineShown.
+ firstLineShown := firstLineShown - nFullLinesShown.
+ (firstLineShown < 1) ifTrue:[
+ firstLineShown := 1
+ ].
+ self originChanged:(firstLineShown - oldOrg).
+ self redrawFromVisibleLine:1 to:nLinesShown
+ ]
+!
+
+halfPageDown
+ "scroll down half a page"
+
+ self scrollDown:(nFullLinesShown // 2)
+!
+
+halfPageUp
+ "scroll up half a page"
+
+ self scrollUp:(nFullLinesShown // 2)
+!
+
+scrollDown:nLines
+ "change origin to scroll down some lines"
+
+ |w "{ Class:SmallInteger }"
+ h "{ Class:SmallInteger }"
+ m2 "{ Class:SmallInteger }"
+ count "{ Class:SmallInteger }"|
+
+ count := nLines.
+ (firstLineShown + nLines + nFullLinesShown > list size) ifTrue:[
+ count := list size - firstLineShown - nFullLinesShown + 1
+ ].
+ count <= 0 ifTrue:[^ self].
+
+ self originWillChange.
+ (count >= nLinesShown) ifTrue:[
+ firstLineShown := firstLineShown + count.
+ self redrawFromVisibleLine:1 to:nLinesShown.
+ self originChanged:(count negated)
+ ] ifFalse:[
+ m2 := margin * 2.
+ w := self widthForScrollBetween:firstLineShown
+ and:(firstLineShown + nLinesShown).
+ w := w + leftMargin.
+
+ firstLineShown := firstLineShown + count.
+ h := (fontHeight * count) + textStartTop.
+ self copyFrom:self x:margin y:h
+ toX:margin y:textStartTop
+ width:w height:(height - m2 - h).
+
+ self redrawFromVisibleLine:(nFullLinesShown - count + 1)
+ to:nLinesShown.
+ self originChanged:(count negated).
+ exposePending := true.
+ self waitForExpose
+ ]
+!
+
+scrollDown
+ "change origin to scroll down one line"
+
+ self scrollDown:1
+!
+
+scrollUp:nLines
+ "change origin to scroll up some lines"
+
+ |w "{ Class:SmallInteger }"
+ h "{ Class:SmallInteger }"
+ count "{ Class:SmallInteger }"|
+
+ count := nLines.
+ count >= firstLineShown ifTrue:[
+ count := firstLineShown - 1
+ ].
+ (count == 0) ifTrue:[^ self].
+
+ self originWillChange.
+ (count >= nLinesShown) ifTrue:[
+ firstLineShown := firstLineShown - count.
+ self redrawFromVisibleLine:1 to:nLinesShown.
+ self originChanged:(count negated)
+ ] ifFalse:[
+ w := self widthForScrollBetween:firstLineShown
+ and:(firstLineShown + nLinesShown).
+ w := w + leftMargin.
+ firstLineShown := firstLineShown - count.
+ h := (fontHeight * count) + topMargin.
+ self copyFrom:self x:margin y:topMargin
+ toX:margin y:h
+ width:w height:(height - h - margin).
+ self redrawFromVisibleLine:1 to:count.
+ self originChanged:(count negated).
+ exposePending := true.
+ self waitForExpose
+ ]
+!
+
+scrollUp
+ "change origin to scroll up one line"
+
+ self scrollUp:1
+!
+
+scrollToTop
+ "change origin to start of text"
+
+ self scrollToLine:1
+!
+
+scrollToLine:aLineNr
+ "change origin to make aLineNr be the top line"
+
+ aLineNr < firstLineShown ifTrue:[
+ self scrollUp:(firstLineShown - aLineNr)
+ ] ifFalse:[
+ aLineNr > firstLineShown ifTrue:[
+ self scrollDown:(aLineNr - firstLineShown)
+ ]
+ ]
+!
+
+scrollVerticalToPercent:percent
+ "scroll to a position given in percent of total"
+
+ |lineNr|
+
+ lineNr := (((self numberOfLines * percent) asFloat / 100.0) + 0.5) asInteger + 1.
+ self scrollToLine:lineNr
+!
+
+makeLineVisible:aListLineNr
+ "if aListLineNr is not visible, scroll to make it visible"
+
+ |bott|
+
+ (aListLineNr isNil or:[shown not]) ifTrue:[^ self].
+
+ (aListLineNr >= firstLineShown) ifTrue:[
+ (aListLineNr < (firstLineShown + nFullLinesShown)) ifTrue:[
+ ^ self
+ ]
+ ].
+ (aListLineNr < nFullLinesShown) ifTrue:[
+ ^ self scrollToLine:1
+ ].
+ (nFullLinesShown < 3) ifTrue:[
+ ^ self scrollToLine:aListLineNr
+ ].
+ bott := self numberOfLines - (nFullLinesShown - 1).
+ (aListLineNr > bott) ifTrue:[
+ ^ self scrollToLine:bott
+ ].
+ self scrollToLine:(aListLineNr - (nFullLinesShown // 2) + 1)
+!
+
+scrollSelectUp
+ "just a template - I do not know anything about selections"
+
+ ^ self subclassResponsibility
+!
+
+scrollSelectDown
+ "just a template - I do not know anything about selections"
+
+ ^ self subclassResponsibility
+!
+
+startScrollDown:yDistance
+ "setup for auto-scroll down (when button-press-moving below view)
+ - timeDelta for scroll is computed from distance"
+
+ |deltaT mm|
+
+ mm := yDistance // self verticalIntegerPixelPerMillimeter + 1.
+ deltaT := 0.5 / mm.
+
+ (deltaT = autoScrollDeltaT) ifFalse:[
+ autoScrollDeltaT := deltaT.
+ autoScrollBlock isNil ifTrue:[
+ autoScrollBlock := [self scrollSelectDown].
+ device addTimedBlock:autoScrollBlock after:deltaT
+ ]
+ ]
+!
+
+startScrollUp:yDistance
+ "setup for auto-scroll up (when button-press-moving below view)
+ - timeDelta for scroll is computed from distance"
+
+ |deltaT mm|
+
+ mm := yDistance negated // self verticalIntegerPixelPerMillimeter + 1.
+ deltaT := 0.5 / mm.
+
+ (deltaT = autoScrollDeltaT) ifFalse:[
+ autoScrollDeltaT := deltaT.
+ autoScrollBlock isNil ifTrue:[
+ autoScrollBlock := [self scrollSelectUp].
+ device addTimedBlock:autoScrollBlock after:deltaT
+ ]
+ ]
+!
+
+stopAutoScroll
+ "stop any auto-scroll"
+
+ autoScrollBlock notNil ifTrue:[
+ device compressMotionEvents:true.
+ device removeTimedBlock:autoScrollBlock.
+ autoScrollBlock := nil.
+ autoScrollDeltaT := nil
+ ].
+! !
+
+!ListView methodsFor:'drawing'!
+
+drawVisibleLine:visLineNr col:col with:fg and:bg
+ "draw single character at col index of visible line in fg/bg"
+
+ |y x lineString characterString|
+
+ lineString := self visibleAt:visLineNr.
+ x := (self xOfCol:col inLine:visLineNr) - leftOffset.
+ y := self yOfLine:visLineNr.
+
+ self paint:bg.
+
+ (lineString isNil or:[col > lineString size]) ifTrue:[
+ self fillRectangleX:x y:y width:(font widthOf:' ')
+ height:fontHeight.
+ self paint:fg
+ ] ifFalse:[
+ characterString := (lineString at:col) asString.
+ self fillRectangleX:x y:y width:(font widthOf:characterString)
+ height:fontHeight.
+ self paint:fg.
+ self displayString:characterString x:x y:(y + fontAscent)
+ ]
+!
+
+drawVisibleLine:visLineNr from:startCol to:endCol with:fg and:bg
+ "draw part of a visible line in fg/bg"
+
+ |y x lineString len characterString|
+
+ (endCol >= startCol) ifTrue:[
+ lineString := self visibleAt:visLineNr.
+ x := (self xOfCol:startCol inLine:visLineNr) - leftOffset.
+ y := (self yOfLine:visLineNr).
+
+ len := lineString size.
+ (startCol > len) ifTrue:[
+ len := endCol - startCol + 1.
+ self paint:bg.
+ self fillRectangleX:x y:y
+ width:(fontWidth * len)
+ height:fontHeight
+ ] ifFalse:[
+ (endCol > len) ifTrue:[
+ characterString := String new:endCol.
+ characterString replaceFrom:1 to:len with:lineString startingAt:1.
+ lineString := characterString
+ ].
+ self paint:bg.
+ self fillRectangleX:x y:y width:(font widthOf:lineString from:startCol to:endCol)
+ height:fontHeight.
+ self paint:fg.
+ self displayString:lineString from:startCol to:endCol x:x y:(y + fontAscent)
+ ]
+ ]
+!
+
+drawVisibleLine:visLineNr from:startCol with:fg and:bg
+ "draw right part of a visible line from startCol to end of line in fg/bg"
+
+ |y x lineString index1 index2|
+
+ (startCol < 1) ifTrue:[
+ index1 := 1
+ ] ifFalse:[
+ index1 := startCol
+ ].
+ y := self yOfLine:visLineNr.
+ x := (self xOfCol:index1 inLine:visLineNr) - leftOffset.
+ self paint:bg.
+ self fillRectangleX:x y:y
+ width:(width + leftOffset - x)
+ height:fontHeight.
+
+ lineString := self visibleAt:visLineNr.
+ lineString notNil ifTrue:[
+ index2 := lineString size.
+ (index2 < index1) ifTrue:[^ self].
+ (index1 <= index2) ifTrue:[
+ self paint:fg.
+ self displayString:lineString from:index1 to:index2 x:x y:(y + fontAscent)
+ ]
+ ]
+!
+
+drawFromVisibleLine:startVisLineNr to:endVisLineNr with:fg and:bg
+ "draw a visible line range in fg/bg"
+
+ |y "{ Class: SmallInteger }"
+ x "{ Class: SmallInteger }"
+ startLine "{ Class: SmallInteger }"
+ endLine "{ Class: SmallInteger }"
+ listSize e|
+
+ y := self yOfLine:startVisLineNr.
+ self paint:bg.
+ self fillRectangleX:margin y:y
+ width:(width - (margin * 2))
+ height:(endVisLineNr - startVisLineNr + 1) * fontHeight.
+
+ y := y + fontAscent.
+ listSize := list size.
+
+ startLine := startVisLineNr + firstLineShown - 1.
+ endLine := endVisLineNr + firstLineShown - 1.
+ (startLine == 0) ifTrue:[
+ y := y + fontHeight.
+ startLine := startLine + 1
+ ].
+
+ (endLine > listSize) ifTrue:[
+ e := listSize
+ ] ifFalse:[
+ e := endLine
+ ].
+
+ (startLine <= e) ifTrue:[
+ x := textStartLeft - leftOffset.
+ self paint:fg.
+ list from:startLine to:e do:[:line |
+ line notNil ifTrue:[
+ self displayString:line x:x y:y
+ ].
+ y := y + fontHeight
+ ]
+ ]
+!
+
+drawVisibleLine:visLineNr with:fg and:bg
+ "draw a visible line in fg/bg"
+
+ |y line|
+
+ y := self yOfLine:visLineNr.
+ line := self visibleAt:visLineNr.
+ self paint:bg.
+ self fillRectangleX:margin y:y
+ width:(width - (margin * 2))
+ height:fontHeight.
+ line notNil ifTrue:[
+ self paint:fg.
+ self displayString:line x:(textStartLeft - leftOffset) y:(y + fontAscent)
+ ]
+! !
+
+!ListView methodsFor:'redrawing'!
+
+redrawVisibleLine:visLineNr col:col
+ "redraw single character at col index of visible line"
+
+ shown ifTrue:[
+ self drawVisibleLine:visLineNr col:col with:fgColor and:bgColor
+ ]
+!
+
+redrawVisibleLine:visLineNr from:startCol to:endCol
+ "redraw part of a visible line"
+
+ shown ifTrue:[
+ self drawVisibleLine:visLineNr from:startCol to:endCol with:fgColor and:bgColor
+ ]
+!
+
+redrawVisibleLine:visLineNr from:startCol
+ "redraw right part of a visible line from startCol to end of line"
+
+ shown ifTrue:[
+ self drawVisibleLine:visLineNr from:startCol with:fgColor and:bgColor
+ ]
+!
+
+redrawFromVisibleLine:startVisLineNr to:endVisLineNr
+ "redraw a visible line range"
+
+ shown ifTrue:[
+ self drawFromVisibleLine:startVisLineNr to:endVisLineNr with:fgColor and:bgColor
+ ]
+!
+
+redrawVisibleLine:visLineNr
+ "redraw a visible line"
+
+ shown ifTrue:[
+ self drawVisibleLine:visLineNr with:fgColor and:bgColor
+ ]
+!
+
+redrawLine:lineNr col:col
+ "redraw a single character"
+
+ |visibleLine|
+
+ visibleLine := self listLineToVisibleLine:lineNr.
+ visibleLine notNil ifTrue:[
+ self redrawVisibleLine:visibleLine col:col
+ ]
+!
+
+redrawLine:lineNr
+ "redraw a list line"
+
+ |visibleLine|
+
+ visibleLine := self listLineToVisibleLine:lineNr.
+ visibleLine notNil ifTrue:[
+ self redrawVisibleLine:visibleLine
+ ]
+!
+
+redrawLine:lineNr from:startCol
+ "redraw a list line from startCol to end of line"
+
+ |visibleLine|
+
+ visibleLine := self listLineToVisibleLine:lineNr.
+ visibleLine notNil ifTrue:[
+ self redrawVisibleLine:visibleLine from:startCol
+ ]
+!
+
+redrawLine:lineNr from:startCol to:endCol
+ "redraw a list line from startCol to endCol"
+
+ |visibleLine|
+
+ visibleLine := self listLineToVisibleLine:lineNr.
+ visibleLine notNil ifTrue:[
+ self redrawVisibleLine:visibleLine from:startCol to:endCol
+ ]
+!
+
+redrawFromLine:lineNr
+ "redraw starting at linrNr"
+
+ |visibleLine first|
+
+ shown ifTrue:[
+ "if first line to redraw is above 1st visible line,
+ start redraw at 1st visible line"
+ (lineNr < firstLineShown) ifTrue:[
+ first := firstLineShown
+ ] ifFalse:[
+ first := lineNr
+ ].
+ visibleLine := self listLineToVisibleLine:first.
+ visibleLine notNil ifTrue:[
+ self redrawFromVisibleLine:visibleLine to:nLinesShown
+ ]
+ ]
+!
+
+redrawFromLine:start to:end
+ "redraw lines from start to end"
+
+ |visibleFirst visibleLast first last lastLineShown|
+
+ shown ifTrue:[
+ lastLineShown := firstLineShown + nLinesShown - 1.
+ (start <= lastLineShown) ifTrue:[
+ (end >= firstLineShown) ifTrue:[
+
+ "if first line to redraw is above 1st visible line,
+ start redraw at 1st visible line"
+
+ (start < firstLineShown) ifTrue:[
+ first := firstLineShown
+ ] ifFalse:[
+ first := start
+ ].
+ (end > lastLineShown) ifTrue:[
+ last := lastLineShown
+ ] ifFalse:[
+ last := end
+ ].
+ visibleFirst := self listLineToVisibleLine:first.
+ visibleLast := self listLineToVisibleLine:last.
+ self redrawFromVisibleLine:visibleFirst to:visibleLast
+ ]
+ ]
+ ]
+!
+
+redraw
+ "redraw complete view"
+
+ shown ifTrue:[
+ self redrawFromVisibleLine:1 to:nLinesShown
+ ]
+! !
+
+!ListView methodsFor:'event processing'!
+
+sizeChanged:how
+ "size changed - move origin up if possible"
+
+ |listSize newOrigin|
+
+ self computeNumberOfLinesShown.
+ innerWidth := width - textStartLeft - margin.
+ shown ifTrue:[
+ list notNil ifTrue:[
+ listSize := self numberOfLines.
+ ((firstLineShown + nFullLinesShown) > listSize) ifTrue:[
+ newOrigin := listSize - nFullLinesShown + 1.
+ newOrigin < 1 ifTrue:[
+ newOrigin := 1
+ ].
+ self scrollToLine: newOrigin
+ ]
+ ]
+ ]
+!
+
+redrawX:x y:y width:w height:h
+ "a region must be redrawn"
+
+ |startLine stopLine startCol endCol|
+
+ startLine := self visibleLineOfY:y.
+ stopLine := self visibleLineOfY:(y + h).
+
+ "if text-margin is affected"
+ x < textStartLeft ifTrue:[
+ self paint:bgColor.
+ self fillRectangleX:margin y:margin width:(textStartLeft - margin)
+ height:(height - margin - margin)
+ ].
+ y < textStartTop ifTrue:[
+ self paint:bgColor.
+ self fillRectangleX:margin y:margin width:(width - margin - margin)
+ height:(textStartTop - margin)
+ ].
+ (w > (width // 4 * 3)) ifTrue:[
+ "if area is big enough redraw whole lines"
+ self redrawFromVisibleLine:startLine to:stopLine
+ ] ifFalse:[
+ fontIsFixedWidth ifFalse:[
+ "start/end col has to be computed for each line"
+
+ startLine to:stopLine do:[:i |
+ startCol := self colOfX:x inVisibleLine:i.
+ endCol := self colOfX:(x + w) inVisibleLine:i.
+ self redrawVisibleLine:i from:startCol to:endCol
+ ]
+ ] ifTrue:[
+ "start/end col is the same for all lines"
+
+ startCol := self colOfX:x inVisibleLine:startLine.
+ endCol := self colOfX:(x + w) inVisibleLine:startLine.
+ startLine to:stopLine do:[:i |
+ self redrawVisibleLine:i from:startCol to:endCol
+ ]
+ ]
+ ]
+!
+
+keyPress:key x:x y:y
+ "a key was pressed - handle page-keys here"
+
+ (key == #Prior) ifTrue: [^ self pageUp].
+ (key == #Next) ifTrue: [^ self pageDown].
+
+ (key == #Ctrlb) ifTrue:[^ self pageUp].
+ (key == #Ctrlf) ifTrue:[^ self pageDown].
+ (key == #Ctrld) ifTrue:[^ self halfPageDown].
+ (key == #Ctrlu) ifTrue:[^ self halfPageUp].
+
+ super keyPress:key x:x y:y
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Make.proto Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,251 @@
+# %W% %E%
+
+# -------------- no need to change anything below ----------
+
+LIBNAME=libwidg
+LIB=$(LIBNAME).$(A)
+SUBDIRS=
+
+TOP=..
+
+OBJS= \
+ ListView.$(O) PanelView.$(O) ScrView.$(O) Label.$(O) \
+ Scroller.$(O) ScrollBar.$(O) ObjView.$(O) \
+ InspView.$(O) ConInspV.$(O) SBrowser.$(O) CBrowser.$(O) \
+ DebugView.$(O) Launcher.$(O) PopUpMenu.$(O) \
+ InfoBox.$(O) WarnBox.$(O) Notifier.$(O) \
+ TextView.$(O) HVScrView.$(O) \
+ SelListV.$(O) HPanelV.$(O) VPanelV.$(O) \
+ VarVPanel.$(O) \
+ Button.$(O) HScroller.$(O) HScrBar.$(O) EnterBox.$(O) \
+ YesNoBox.$(O) MenuView.$(O) ETxtView.$(O) \
+ Toggle.$(O) ErrNotify.$(O) LSelBox.$(O) \
+ EnterBox2.$(O) ClckMenuV.$(O) EditField.$(O) TextColl.$(O) \
+ Workspace.$(O) CodeView.$(O)
+
+# these can be autoloaded in small-memory systems
+
+AUXOBJS= \
+ FBrowser.$(O) DirBrwsr.$(O) FramedBox.$(O) \
+ RButton.$(O) RButtGrp.$(O) FSelBox.$(O) MenuButt.$(O) \
+ MtnButt.$(O) PullDMenu.$(O) FontPanel.$(O) \
+ DialogBox.$(O) OptBox.$(O) ChckTggle.$(O) \
+ Ruler.$(O) TextRuler.$(O) TextBox.$(O) LEnterFld.$(O) \
+ EFGroup.$(O) VarHPanel.$(O) \
+ Slider.$(O) HSlider.$(O) \
+ DictInspV.$(O) DialogV.$(O) ProjectV.$(O) RetButton.$(O) \
+ RButton.$(O)
+
+NEWOBJS= \
+ TextContr.$(O) ETxtContr.$(O)
+
+all:: $(OBJTARGET)
+
+objs:: level0 \
+ level1 \
+ level2 \
+ level3 \
+ level4 \
+ level5
+
+auxobjs:: $(AUXOBJS)
+
+level0:$(P) \
+ ListView.$(O) \
+ PanelView.$(O) \
+ ScrView.$(O) \
+ Label.$(O) \
+ Scroller.$(O) \
+ ScrollBar.$(O) \
+ ObjView.$(O) \
+ InspView.$(O) \
+ SBrowser.$(O) \
+ CBrowser.$(O) \
+ DebugView.$(O) \
+ Launcher.$(O) \
+ ProjectV.$(O) \
+ PopUpMenu.$(O)
+
+level1:$(P) \
+ InfoBox.$(O) \
+ Notifier.$(O) \
+ TextView.$(O) \
+ HVScrView.$(O) \
+ SelListV.$(O) \
+ HPanelV.$(O) \
+ VPanelV.$(O) \
+ VarVPanel.$(O) \
+ Button.$(O) \
+ HScroller.$(O) \
+ HScrBar.$(O) \
+ DictInspV.$(O) \
+ ConInspV.$(O) \
+ EnterBox.$(O)
+
+level2:$(P) \
+ WarnBox.$(O) \
+ YesNoBox.$(O) \
+ MenuView.$(O) \
+ ETxtView.$(O) \
+ VarHPanel.$(O) \
+ RetButton.$(O) \
+ Toggle.$(O) \
+ ErrNotify.$(O) \
+ LSelBox.$(O) \
+ EnterBox2.$(O)
+
+level3:$(P) \
+ ClckMenuV.$(O) \
+ EditField.$(O) \
+ ChckTggle.$(O) \
+ RButton.$(O) \
+ TextColl.$(O)
+
+level4:$(P) \
+ Workspace.$(O)
+
+level5:$(P) \
+ CodeView.$(O)
+
+install::
+ -mkdir $(DESTLIBDIR)
+ -$(INSTALL) $(LIBNAME)$(OBJNAME) $(DESTLIBDIR)
+
+cleanjunk::
+ -rm -f *.c *.H bitmaps/*~
+
+clean::
+ -rm -f *.c *.H bitmaps/*~
+
+clobber::
+ -rm -f *.c *.H bitmaps/*~
+
+tar:
+ rm -f $(TOP)/DISTRIB/libwidg.tar*
+ (cd $(TOP); tar cvf DISTRIB/libwidg.tar \
+ libwidg/*.st \
+ libwidg/Make.proto \
+ libwidg/*.stc \
+ libwidg/bitmaps)
+ compress $(TOP)/DISTRIB/libwidg.tar
+
+objs:: $(INCLUDE)/stc.h $(INCLUDE)/stcIntern.h
+
+Workspace.o:
+ $(STC) -CC="$(CC)" $(STCFLAGS) +limitSuperInclude $(CFLAGS) -c $*.st
+
+CodeView.o:
+ $(STC) -CC="$(CC)" $(STCFLAGS) +limitSuperInclude $(CFLAGS) -c $*.st
+
+RButton.o:
+ $(STC) -CC="$(CC)" $(STCFLAGS) +limitSuperInclude $(CFLAGS) -c $*.st
+
+I = $(INCLUDE)
+#
+# next thing I'll build into stc is a makedepend feature for this ...
+#
+STCHDR=$(I)/stc.h $(I)/stcIntern.h
+# OBJECT=$(I)/Object.H $(STCHDR)
+
+DEVDRAWABLE=$(I)/DevDraw.H $(I)/DMedium.H $(I)/GC.H $(OBJECT)
+PSEUDOVIEW=$(I)/PseudoV.H $(DEVDRAWABLE)
+VIEW=$(I)/View.H $(PSEUDOVIEW)
+POPUPVIEW=$(I)/PopUpView.H $(VIEW)
+NOTIFIER=$(I)/Notifier.H $(POPUPVIEW)
+STDSYSVIEW=$(I)/StdSysV.H $(VIEW)
+LISTVIEW=$(I)/ListView.H $(VIEW)
+SELLISTVIEW=$(I)/SelListV.H $(LISTVIEW)
+TEXTVIEW=$(I)/TextView.H $(LISTVIEW)
+EDITTEXTVIEW=$(I)/ETxtView.H $(TEXTVIEW)
+TEXTCOLLECTOR=$(I)/TextColl.H $(EDITTEXTVIEW)
+MODALBOX=$(I)/ModalBox.H $(STDSYSVIEW)
+ENTERBOX=$(I)/EnterBox.H $(MODALBOX)
+DIALOGBOX=$(I)/DialogBox.H $(MODALBOX)
+LABEL=$(I)/Label.H $(VIEW)
+BUTTON=$(I)/Button.H $(LABEL)
+
+RButtGrp.$(O): RButtGrp.st $(I)/VarArray.H $(OBJECT)
+EFGroup.$(O): EFGroup.st $(I)/VarArray.H $(OBJECT)
+
+InfoBox.$(O): InfoBox.st $(MODALBOX)
+WarnBox.$(O): WarnBox.st $(I)/InfoBox.H $(MODALBOX)
+OptBox.$(O): OptBox.st $(MODALBOX)
+InfoBox.$(O): InfoBox.st $(MODALBOX)
+YesNoBox.$(O): YesNoBox.st $(I)/WarnBox.H $(I)/InfoBox.H $(MODALBOX)
+Notifier.$(O): Notifier.st $(MODALBOX)
+ErrNotify.$(O): ErrNotify.st $(NOTIFIER)
+PopUpMenu.$(O): PopUpMenu.st $(POPUPVIEW)
+
+ListView.$(O): ListView.st $(VIEW)
+SelListV.$(O): SelListV.st $(LISTVIEW)
+MenuView.$(O): MenuView.st $(SELLISTVIEW)
+TextView.$(O): TextView.st $(LISTVIEW)
+ETxtView.$(O): ETxtView.st $(TEXTVIEW)
+EditField.$(O): EditField.st $(EDITTEXTVIEW)
+TextColl.$(O): TextColl.st $(EDITTEXTVIEW)
+Workspace.$(O): Workspace.st $(TEXTCOLLECTOR)
+CodeView.$(O): CodeView.st $(I)/Workspace.H $(TEXTCOLLECTOR)
+
+ClckMenuV.$(O): ClckMenuV.st $(I)/MenuView.H $(SELLISTVIEW)
+
+PanelView.$(O): PanelView.st $(VIEW)
+HPanelV.$(O): HPanelV.st $(I)/PanelView.H $(VIEW)
+VPanelV.$(O): VPanelV.st $(I)/PanelView.H $(VIEW)
+
+VarVPanel.$(O): VarVPanel.st $(VIEW)
+VarHPanel.$(O): VarHPanel.st $(I)/VarVPanel.H $(VIEW)
+
+ScrView.$(O): ScrView.st $(VIEW)
+HVScrView.$(O): HVScrView.st $(I)/ScrView.H $(VIEW)
+
+PullDMenu.$(O): PullDMenu.st $(VIEW)
+
+Label.$(O): Label.st $(VIEW)
+DigiLed.$(O): DigiLed.st $(VIEW)
+FramedBox.$(O): FramedBox.st $(VIEW)
+Button.$(O): Button.st $(LABEL)
+MenuButt.$(O): MenuButt.st $(BUTTON)
+MtnButt.$(O): MtnButt.st $(BUTTON)
+Toggle.$(O): Toggle.st $(BUTTON)
+RButton.$(O): RButton.st $(I)/Toggle.H $(BUTTON)
+RetButton.$(O): RetButton.st $(BUTTON)
+ChckTggle.$(O): ChckTggle.st $(I)/Toggle.H $(BUTTON)
+Ruler.$(O): Ruler.st $(VIEW)
+TextRuler.$(O): TextRuler.st $(I)/Ruler.H $(VIEW)
+
+EvMonitor.$(O): EvMonitor.st $(STDSYSVIEW)
+EnterBox.$(O): EnterBox.st $(MODALBOX)
+DialogBox.$(O): DialogBox.st $(MODALBOX)
+EnterBox2.$(O): EnterBox2.st $(ENTERBOX)
+TextBox.$(O): TextBox.st $(ENTERBOX)
+LSelBox.$(O): LSelBox.st $(ENTERBOX)
+FSelBox.$(O): FSelBox.st $(I)/LSelBox.H $(ENTERBOX)
+FontPanel.$(O): FontPanel.st $(MODALBOX)
+
+ScrollBar.$(O): ScrollBar.st $(VIEW)
+HScrBar.$(O): HScrBar.st $(I)/ScrollBar.H $(VIEW)
+Slider.$(O): Slider.st $(VIEW)
+Scroller.$(O): Scroller.st $(VIEW)
+HScroller.$(O): HScroller.st $(I)/Scroller.H $(VIEW)
+
+Slider.$(O): Slider.st $(I)/Scroller.H $(VIEW)
+HSlider.$(O): HSlider.st $(I)/Slider.H $(I)/Scroller.H $(VIEW)
+
+ObjView.$(O): ObjView.st $(VIEW)
+InspView.$(O): InspView.st $(VIEW)
+DictInspV.$(O): DictInspV.st $(I)/InspView.H $(VIEW)
+ConInspV.$(O): ConInspV.st $(I)/InspView.H $(VIEW)
+DebugView.$(O): DebugView.st $(STDSYSVIEW)
+Launcher.$(O): Launcher.st $(STDSYSVIEW)
+ProjectV.$(O): ProjectV.st $(STDSYSVIEW)
+SBrowser.$(O): SBrowser.st $(STDSYSVIEW)
+CBrowser.$(O): CBrowser.st $(STDSYSVIEW)
+FBrowser.$(O): FBrowser.st $(STDSYSVIEW)
+DirBrwsr.$(O): DirBrwsr.st $(STDSYSVIEW)
+FormEdtView.$(O): FormEdtView.st $(VIEW)
+LEnterFld.$(O): LEnterFld.st $(VIEW)
+
+DialogV.$(O): DialogV.st $(MODALBOX)
+
+TextContr.$(O): TextContr.st $(CONTROLLER)
+ETxtContr.$(O): ETxtContr.st $(I)/TextContr.H $(CONTROLLER)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/MenuView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,650 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+SelectionInListView subclass:#MenuView
+ instanceVariableNames:'selectors args receiver enableFlags
+ disabledFgColor onOffFlags subMenus
+ subMenuShown'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Menus'
+!
+
+MenuView comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+a menu view used for both pull-down-menus and pop-up-menus
+the action to be performed can be defined either as:
+
+1) action:aBlockWithOneArg
+ which defines a block to be called with the line number (1..n)
+ of the selected line.
+
+2) selectors:selectorArray [args: argarray] receiver:anObject
+ which defines the messages to be sent to receiver for each
+ line.
+
+It is also possible to define both actionBlock and selectorArray.
+
+%W% %E%
+
+written summer 89 by claus
+'!
+
+!MenuView class methodsFor:'initialization'!
+
+initialize
+ "setup some defaults - these are usually redefined during startup."
+
+ super initialize.
+ DefaultFont := Font family:'helvetica' face:'bold' style:'roman' size:12
+! !
+
+!MenuView class methodsFor:'instance creation'!
+
+labels:labels selectors:selArray args:argArray receiver:anObject in:aView
+ "create and return a new MenuView in aView
+ - receiverObject gets message from selectorArray with argument
+ from argArray"
+
+ ^ (self in:aView) labels:labels
+ selectors:selArray
+ args:argArray
+ receiver:anObject
+!
+
+labels:labels selectors:selArray receiver:anObject in:aView
+ "create and return a new MenuView in aView
+ - receiverObject gets message from selectorArray without argument"
+
+ ^ (self in:aView) labels:labels
+ selectors:selArray
+ args:nil
+ receiver:anObject
+!
+
+labels:labels selector:aSelector args:argArray receiver:anObject in:aTopMenu
+ "create and return a new MenuView
+ - receiverObject gets message aSelector with argument from
+ argArray for all entries"
+
+ ^ (self in:aTopMenu) labels:labels
+ selectors:aSelector
+ args:argArray
+ receiver:anObject
+!
+
+labels:labels selector:aSelector args:argArray receiver:anObject for:aTopMenu
+ "create and return a new MenuView
+ - receiverObject gets message aSelector with argument from
+ argArray for all entries"
+
+ ^ (self in:(aTopMenu superView)) labels:labels
+ selectors:aSelector
+ args:argArray
+ receiver:anObject
+!
+
+labels:labels selectors:selArray args:argArray receiver:anObject for:aTopMenu
+ ^ (self in:(aTopMenu superView)) labels:labels
+ selectors:selArray
+ args:argArray
+ receiver:anObject
+!
+
+labels:labels selectors:selArray receiver:anObject for:aTopMenu
+ ^ (self in:(aTopMenu superView)) labels:labels
+ selectors:selArray
+ args:nil
+ receiver:anObject
+! !
+
+!MenuView methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ disabledFgColor := Color darkGrey.
+ self is3D ifTrue:[
+ borderWidth := 1.
+ self level:1
+ ]
+!
+
+reinitialize
+ "this is called right after snapIn;
+ a kind of kludge - reset cursor"
+
+ super reinitialize.
+ selection := nil. "self selection:nil."
+ self cursor:Cursor hand
+!
+
+initEvents
+ super initEvents.
+ self enableLeaveEvents.
+ self enableButtonMotionEvents
+!
+
+create
+ super create.
+ subMenuShown := false.
+ self recomputeSize
+!
+
+recreate
+ super recreate.
+ self recomputeSize
+! !
+
+!MenuView methodsFor:'accessing'!
+
+labels
+ "return the menu-labels"
+
+ ^ list
+!
+
+labels:text
+ "set the labels to the argument, text"
+
+ (text isKindOf:String) ifTrue:[
+ self list:(text asText)
+ ] ifFalse:[
+ self list:text
+ ].
+ enableFlags := Array new:(list size).
+ enableFlags atAllPut:true.
+ self recomputeSize
+!
+
+labelAt:indexOrName put:aString
+ "change the label at index to be aString"
+
+ |i|
+
+ i := self indexOf:indexOrName.
+ list at:i put:aString.
+ "create onOff flags, if this label has a check-mark"
+ (aString startsWith:'\c') ifTrue:[
+ onOffFlags isNil ifTrue:[
+ onOffFlags := Array new:(list size)
+ ] ifFalse:[
+ [onOffFlags size < (list size)] whileTrue:[
+ onOffFlags := onOffFlags copyWith:nil
+ ]
+ ].
+ onOffFlags at:i put:false
+ ].
+ self recomputeSize
+!
+
+font:aFont
+ "adjust size for new font"
+
+ super font:(aFont on:device).
+ self recomputeSize
+!
+
+addLabel:aLabel selector:aSelector
+ "add another label/selector pair"
+
+ list isNil ifTrue:[
+ list := Array with:aLabel
+ ] ifFalse:[
+ list := list copyWith:aLabel
+ ].
+ selectors := selectors copyWith:aSelector.
+ enableFlags := enableFlags copyWith:true.
+ self recomputeSize
+!
+
+addLabel:aLabel selector:aSelector arg:anArg
+ "add another label/selector/argument trio"
+
+ list isNil ifTrue:[
+ list := Array with:aLabel
+ ] ifFalse:[
+ list := list copyWith:aLabel
+ ].
+ selectors := selectors copyWith:aSelector.
+ args := args copyWith:anArg.
+ enableFlags := enableFlags copyWith:true.
+ self recomputeSize
+!
+
+indexOf:indexOrName
+ "return the index of the label named:aName or , if its a symbol
+ the index in the selector list"
+
+ (indexOrName isMemberOf:String) ifTrue:[
+ ^ list indexOf:indexOrName
+ ].
+ (indexOrName isMemberOf:Symbol) ifTrue:[
+ ^ selectors indexOf:indexOrName
+ ].
+ ^ indexOrName
+!
+
+disable:indexOrName
+ "disable an entry"
+
+ |index|
+
+ index := self indexOf:indexOrName.
+ index ~~ 0 ifTrue:[
+ (enableFlags at:index) ifTrue:[
+ enableFlags at:index put:false.
+ shown ifTrue:[
+ self redrawLine:index
+ ]
+ ]
+ ]
+!
+
+enable:indexOrName
+ "enable an entry"
+
+ |index|
+
+ index := self indexOf:indexOrName.
+ index ~~ 0 ifTrue:[
+ (enableFlags at:index) ifFalse:[
+ enableFlags at:index put:true.
+ shown ifTrue:[
+ self redrawLine:index
+ ]
+ ]
+ ]
+!
+
+receiver
+ "return the receiver of the message"
+
+ ^ receiver
+!
+
+selectors
+ "return the selector array"
+
+ ^ selectors
+!
+
+selectors:anArray
+ "set the selector array"
+
+ selectors := anArray
+!
+
+selectorAt:indexOrName
+ "return an individual selector"
+
+ |i|
+
+ i := self indexOf:indexOrName.
+ ^ selectors at:i
+!
+
+selectorAt:indexOrName put:aSelector
+ "set an individual selector"
+
+ |i|
+
+ i := self indexOf:indexOrName.
+ selectors at:i put:aSelector
+!
+
+args
+ "return the argument array"
+
+ ^ args
+!
+
+args:anArray
+ "set the argument array"
+
+ args := anArray
+!
+
+argsAt:indexOrName put:something
+ "set an individual selector"
+
+ args at:(self indexOf:indexOrName) put:something
+!
+
+receiver:anObject
+ "set the receiver of the message"
+
+ receiver := anObject
+!
+
+labels:text selectors:selArray args:argArray receiver:anObject
+ "set all relevant stuff"
+
+ self labels:text.
+ selectors := selArray.
+ args := argArray.
+ receiver := anObject
+!
+
+checkToggleAt:indexOrName
+ "return a check-toggles boolean state"
+
+ |index|
+
+ index := self indexOf:indexOrName.
+ onOffFlags isNil ifTrue:[^ false].
+ ^ onOffFlags at:index
+!
+
+checkToggleAt:indexOrName put:aBoolean
+ "set/clear a check-toggle"
+
+ |index|
+
+ onOffFlags isNil ifTrue:[
+ onOffFlags := Array new:(list size) withAll:false
+ ].
+ index := self indexOf:indexOrName.
+ onOffFlags at:index put:aBoolean.
+ shown ifTrue:[
+ self redrawLine:index
+ ]
+!
+
+subMenuAt:indexOrName
+ "return a submenu, or nil"
+
+ subMenus isNil ifTrue:[^ nil].
+ ^ subMenus at:(self indexOf:indexOrName)
+!
+
+subMenuAt:indexOrName put:aPopUpMenu
+ "define a submenu"
+
+ subMenus isNil ifTrue:[
+ subMenus := Array new:(list size)
+ ].
+ subMenus at:(self indexOf:indexOrName) put:aPopUpMenu
+! !
+
+!MenuView methodsFor:'private'!
+
+recomputeSize
+ |margin2 w h|
+
+ margin2 := margin * 2.
+ w := self widthOfContents + leftMargin + leftMargin + margin2.
+ h := (self numberOfLines) * fontHeight + (2 * topMargin) + margin2.
+ self extent:(w @ h).
+ (font device == device) ifTrue:[
+ self computeNumberOfLinesShown
+ ]
+!
+
+setSelectionForX:x y:y
+ |newSelection org|
+
+ newSelection := self positionToSelectionX:x y:y.
+ newSelection notNil ifTrue:[
+ (enableFlags at:newSelection) ifFalse:[
+ newSelection := nil
+ ] ifTrue:[
+ subMenus notNil ifTrue:[
+ (subMenus at:newSelection) notNil ifTrue:[
+ org := device translatePoint:(x @ y)
+ from:(self id)
+ to:(DisplayRootView new id).
+ subMenuShown := true.
+ (subMenus at:newSelection) showAt:org.
+ "dont select in this case"
+ ^ self
+ ]
+ ] ifFalse:[
+ subMenuShown := false
+ ]
+ ]
+ ].
+ self selection:newSelection
+! !
+
+!MenuView methodsFor:'showing'!
+
+show
+ hidden := false.
+ super realize
+! !
+
+!MenuView methodsFor:'redrawing'!
+
+drawMarkInVisibleLine:visLineNr with:fg and:bg
+ "draw an on-mark"
+
+ |w h y x l check|
+
+ l := self visibleLineToListLine:visLineNr.
+ onOffFlags isNil ifTrue:[
+ check := false
+ ] ifFalse:[
+ check := onOffFlags at:l.
+ ].
+
+ w := font widthOf:' '.
+ h := font ascent.
+
+ x := (self xOfCol:1 inLine:visLineNr) - leftOffset.
+ y := self yOfLine:visLineNr.
+
+ self paint:bg.
+ self fillRectangleX:x y:y width:w
+ height:fontHeight.
+ self paint:fg.
+ check ifTrue:[
+ self displayLineFromX:x
+ y:(y + (h // 2))
+ toX:(x + (w // 3))
+ y:(y + h - 1).
+
+ self displayLineFromX:(x + (w // 3))
+ y:(y + h - 1)
+ toX:(x + w - 1)
+ y:y
+ ]
+!
+
+drawVisibleLine:visLineNr with:fg and:bg
+ |line isSpecial special|
+
+ line := self visibleAt:visLineNr.
+
+ isSpecial := false.
+
+ ((line at:1) == $\) ifTrue:[
+ special := line at:2.
+ (special == $c) ifTrue:[
+ isSpecial := true
+ ]
+ ].
+ isSpecial ifFalse:[
+ super drawVisibleLine:visLineNr with:fg and:bg
+ ] ifTrue:[
+ super drawVisibleLine:visLineNr from:3 with:fg and:bg.
+ self drawMarkInVisibleLine:visLineNr with:fg and:bg
+ ]
+!
+
+redrawVisibleLine:visLine col:col
+ self redrawVisibleLine:visLine
+!
+
+redrawVisibleLine:visLine from:startCol
+ self redrawVisibleLine:visLine
+!
+
+redrawVisibleLine:visLine from:startCol to:endCol
+ self redrawVisibleLine:visLine
+!
+
+redrawVisibleLine:visLineNr
+ |line lineNr y isSpecial isSeparatingLine mm right|
+
+ line := self visibleAt:visLineNr.
+
+ isSpecial := false.
+ (line = '-') ifTrue:[
+ isSeparatingLine := true.
+ isSpecial := true
+ ] ifFalse:[
+ (line = '') ifTrue:[
+ isSeparatingLine := false.
+ isSpecial := true
+ ]
+ ].
+ isSpecial ifFalse:[
+ lineNr := self visibleLineToListLine:visLineNr.
+ (enableFlags at:lineNr) ifFalse:[
+ self drawVisibleLine:visLineNr with:disabledFgColor and:bgColor
+ ] ifTrue:[
+ super redrawVisibleLine:visLineNr
+ ].
+ ^ self
+ ].
+
+ "handle separating lines"
+
+ y := self yOfLine:visLineNr.
+ self is3D ifFalse:[
+ self paint:bgColor.
+ self fillRectangleX:0 y:y
+ width:width height:fontHeight
+ ].
+ isSeparatingLine ifTrue:[
+ y := y + (fontHeight // 2).
+ self is3D ifFalse:[
+ self paint:fgColor.
+ self displayLineFromX:0 y:y toX:width y:y
+ ] ifTrue:[
+ "the inset on each side"
+ mm := (device horizontalPixelPerMillimeter * 0.8) rounded.
+ right := width - 1 - mm.
+ self paint:shadowColor.
+ self displayLineFromX:mm y:y toX:right y:y.
+ self paint:lightColor.
+ y := y + 1.
+ self displayLineFromX:mm y:y toX:right y:y
+ ]
+ ]
+!
+
+redrawFromVisibleLine:start to:stop
+ "redraw a line range"
+
+ "the natural way to do it is:
+
+ start to:stop do:[:visLine |
+ self redrawVisibleLine:visLine
+ ]
+
+ but I want to draw the stuff in big chunks for slow machines ..."
+
+ |first current line special index|
+
+ first := start.
+ current := start.
+ index := self visibleLineToListLine:start.
+ index notNil ifTrue:[
+ [current <= stop] whileTrue:[
+ line := self visibleAt:current.
+
+ special := (line = '-') or:[(line = '') or:[(line at:1) == $\]].
+ (special or:[(enableFlags at:index) not]) ifTrue:[
+ "a special case"
+ (first < current) ifTrue:[
+ super redrawFromVisibleLine:first to:(current - 1)
+ ].
+ self redrawVisibleLine:current.
+ first := current + 1
+ ].
+ current := current + 1.
+ index := index + 1
+ ].
+ (first < current) ifTrue:[
+ super redrawFromVisibleLine:first to:(current - 1)
+ ]
+ ]
+! !
+
+!MenuView methodsFor:'event handling'!
+
+buttonPress:button x:x y:y
+ self setSelectionForX:x y:y
+!
+
+buttonMotion:state x:x y:y
+ self setSelectionForX:x y:y
+!
+
+pointerLeave:state
+ self setSelectionForX:-1 y:-1. "force deselect"
+ subMenuShown ifFalse:[
+ self selection:nil
+ ]
+!
+
+buttonRelease:button x:x y:y
+ |theSelector isCheck|
+
+ (x >= 0 and:[x < width]) ifTrue:[
+ (y >= 0 and:[y < height]) ifTrue:[
+ selection notNil ifTrue:[
+ self cursor:Cursor wait.
+ actionBlock notNil ifTrue:[
+ actionBlock value:(self selection)
+ ].
+ selectors notNil ifTrue: [
+ (selectors isKindOf:Symbol) ifFalse:[
+ selection <= (selectors size) ifTrue:[
+ theSelector := selectors at:selection
+ ]
+ ] ifTrue:[
+ theSelector := selectors
+ ].
+ theSelector notNil ifTrue:[
+ isCheck := false.
+ onOffFlags notNil ifTrue:[
+ onOffFlags size >= selection ifTrue:[
+ isCheck := (onOffFlags at:selection) notNil
+ ]
+ ].
+ isCheck ifTrue:[
+ onOffFlags at:selection
+ put:(onOffFlags at:selection) not.
+ self redrawLine:selection.
+ receiver perform:theSelector
+ with:(onOffFlags at:selection)
+ ] ifFalse:[
+ args isNil ifTrue:[
+ receiver perform:theSelector
+ ] ifFalse:[
+ receiver perform:theSelector
+ with:(args at:selection)
+ ]
+ ]
+ ]
+ ].
+ self cursor:Cursor hand
+ ]
+ ]
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ObjView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,1880 @@
+"
+ COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+View subclass:#ObjectView
+ instanceVariableNames:'contents
+ sorted
+ lastButt lastPointer lastButtonTime
+ pressAction releaseAction
+ shiftPressAction doublePressAction
+ motionAction keyPressAction
+ selection
+ gridShown gridPixmap
+ scaleShown scaleMetric
+ groupRectangleFrame
+ leftHandCursor readCursor oldCursor
+ movedObject moveStartPoint
+ moveDelta
+ buffer
+ documentFormat
+ leftMarginForScale topMarginForScale
+ canDragOutOfView rootMotion rootView aligning'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Basic'
+!
+
+ObjectView comment:'
+
+COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+a View which can hold DisplayObjects, can make selections, move them around etc.
+this is an abstract class providing common mechanisms - actual instances are
+DrawView, DirectoryView, LogicView or DocumentView.
+
+%W% %E%
+written spring/summer 89 by claus
+'!
+
+!ObjectView class methodsFor:'defaults'!
+
+hitDelta
+ "when clicking an object, allow for hitDelta pixels around object;
+ 0 is exact; 1*pixelPerMillimeter is good for draw programs"
+ ^ 0
+! !
+
+!ObjectView methodsFor:'initialization'!
+
+initialize
+ |pixPerMM|
+
+ super initialize.
+
+ viewBackground := White.
+
+ bitGravity := #NorthWest.
+ contents := OrderedCollection new.
+ gridShown := false.
+ scaleShown := false.
+ canDragOutOfView := false.
+ rootView := DisplayRootView new.
+ rootView noClipByChildren.
+ rootMotion := false.
+ (Language == #english) ifTrue:[
+ documentFormat := 'letter'.
+ scaleMetric := #inch
+ ] ifFalse:[
+ documentFormat := 'a4'.
+ scaleMetric := #mm
+ ].
+ pixPerMM := self verticalPixelPerMillimeter:1.
+ topMarginForScale := ((pixPerMM * 2.0) + 0.5) asInteger.
+ pixPerMM := self horizontalPixelPerMillimeter:1.
+ leftMarginForScale := ((pixPerMM * 2.0) + 0.5) asInteger.
+ readCursor := Cursor read.
+ leftHandCursor := Cursor leftHand.
+ sorted := false.
+ aligning := false
+!
+
+initEvents
+ self backingStore:true.
+ self enableButtonEvents.
+ self enableButtonMotionEvents
+! !
+
+!ObjectView methodsFor:'queries'!
+
+heightOfContentsInMM
+ "answer the height of the document in millimeters"
+
+ (documentFormat = 'a3') ifTrue:[
+ ^ 420
+ ].
+ (documentFormat = 'a4') ifTrue:[
+ ^ 296
+ ].
+ (documentFormat = 'a5') ifTrue:[
+ ^ 210
+ ].
+ (documentFormat = 'letter') ifTrue:[
+ ^ 11 * 25.4
+ ].
+ "assuming window size is document size"
+ ^ (height / self verticalPixelPerMillimeter:1) asInteger
+!
+
+widthOfContentsInMM
+ "answer the width of the document in millimeters"
+
+ (documentFormat = 'a3') ifTrue:[
+ ^ 296
+ ].
+ (documentFormat = 'a4') ifTrue:[
+ ^ 210
+ ].
+ (documentFormat = 'a5') ifTrue:[
+ ^ 148
+ ].
+ (documentFormat = 'letter') ifTrue:[
+ ^ 8.5 * 25.4
+ ].
+ "assuming window size is document size"
+ ^ (width / self horizontalPixelPerMillimeter:1) asInteger
+!
+
+heightOfContents
+ "answer the height of the document in pixels"
+
+ ^ ((self heightOfContentsInMM
+ * (self verticalPixelPerMillimeter:1)) + 0.5) asInteger
+!
+
+widthOfContents
+ "answer the width of the document in pixels"
+
+ ^ ((self widthOfContentsInMM
+ * (self horizontalPixelPerMillimeter:1)) + 0.5) asInteger
+! !
+
+!ObjectView methodsFor:'drawing'!
+
+redraw
+ "redraw complete View"
+
+ realized ifTrue:[
+ gridShown ifTrue:[
+ self redrawGrid
+ ] ifFalse:[
+ self fill:viewBackground
+ ].
+ scaleShown ifTrue:[
+ self redrawScale
+ ].
+ self redrawObjects
+ ]
+!
+
+redrawGrid
+ "redraw the grid"
+
+ gridPixmap notNil ifTrue:[
+ self drawOpaqueForm:gridPixmap x:0 y:0
+ ]
+!
+
+redrawHorizontalScale
+ "redraw the horizontal scale"
+
+ |x mmH short step xRounded shortLen longLen len|
+
+ self clearRectangle:((0 @ 0) corner:(width @ topMarginForScale)).
+ scaleShown ifFalse:[^ self].
+ (scaleMetric == #mm) ifTrue:[
+ "long blibs every centimeter; short ones every half"
+
+ mmH := self horizontalPixelPerMillimeter.
+ step := mmH * 5.0.
+ x := step.
+ short := true.
+ shortLen := (topMarginForScale / 2) asInteger.
+ longLen := topMarginForScale.
+ [x < width] whileTrue:[
+ xRounded := (x + 0.5) asInteger.
+ short ifTrue:[
+ len := shortLen
+ ] ifFalse:[
+ len := longLen
+ ].
+ self displayLineFromX:xRounded y:0 toX:xRounded y:len.
+ short := short not.
+ x := x + step
+ ]
+ ]
+!
+
+redrawVerticalScale
+ "redraw the vertical scale"
+
+ |y mmV short step yRounded shortLen longLen len|
+
+ self clearRectangle:((0 @ 0) corner:(leftMarginForScale @ height)).
+ scaleShown ifFalse:[^ self].
+ (scaleMetric == #mm) ifTrue:[
+ "long blibs every centimeter; short ones every half"
+
+ mmV := self verticalPixelPerMillimeter.
+ step := mmV * 5.0.
+ y := step.
+ short := true.
+ shortLen := (leftMarginForScale / 2) asInteger.
+ longLen := leftMarginForScale.
+ [y < height] whileTrue:[
+ yRounded := (y + 0.5) asInteger.
+ short ifTrue:[
+ len := shortLen
+ ] ifFalse:[
+ len := longLen
+ ].
+ self displayLineFromX:0 y:yRounded toX:len y:yRounded.
+ short := short not.
+ y := y + step
+ ]
+ ]
+!
+
+redrawScale
+ "redraw the scales"
+
+ self redrawHorizontalScale.
+ self redrawVerticalScale
+!
+
+redrawObjectsOn:aGC
+ "redraw all objects on a graphic context"
+
+ |vFrame org|
+
+ (aGC == self) ifTrue:[
+ realized ifFalse:[^ self].
+ org := viewOrigin + (leftMarginForScale @ topMarginForScale).
+ vFrame := Rectangle origin:org
+ corner:(viewOrigin + (width @ height)).
+
+ self redrawObjectsIntersecting:vFrame
+ ] ifFalse:[
+ "loop over pages"
+
+ org := 0 @ 0.
+ vFrame := Rectangle origin:org
+ corner:(org + (width @ height)).
+
+ self redrawObjectsIntersecting:vFrame
+ ]
+!
+
+redrawObjects
+ "redraw all objects"
+
+ self redrawObjectsOn:self
+!
+
+redrawObjectsIntersecting:aRectangle
+ "redraw all objects which have part of themself in aRectangle"
+
+ self objectsIntersecting:aRectangle do:[:theObject |
+ self show:theObject
+ ]
+!
+
+redrawObjectsIntersectingVisible:aRectangle
+ "redraw all objects which have part of themself in a vis rectangle"
+
+ self objectsIntersectingVisible:aRectangle do:[:theObject |
+ self show:theObject
+ ]
+
+!
+
+redrawObjectsAbove:anObject intersecting:aRectangle
+ "redraw all objects which have part of themself in aRectangle
+ and are above (in front of) anObject"
+
+ self objectsAbove:anObject intersecting:aRectangle do:[:theObject |
+ self show:theObject
+ ]
+!
+
+redrawObjectsAbove:anObject intersectingVisible:aRectangle
+ "redraw all objects which have part of themself in a vis rectangle
+ and are above (in front of) anObject"
+
+ self objectsAbove:anObject intersectingVisible:aRectangle do:[:theObject |
+ self show:theObject
+ ]
+!
+
+redrawObjectsIn:aRectangle
+ "redraw all objects which have part of themselfes in aRectangle
+ draw only in (i.e. clip output to) aRectangle"
+
+ |visRect|
+
+ realized ifTrue:[
+ visRect := Rectangle origin:(aRectangle origin - viewOrigin)
+ extent:(aRectangle extent).
+ self clippedTo:visRect do:[
+ gridShown ifTrue:[
+ self redrawGrid
+ ] ifFalse:[
+ self paint:viewBackground.
+ self fillRectangle:visRect
+ ].
+ self redrawObjectsIntersecting:aRectangle
+ ]
+ ]
+!
+
+redrawObjectsInVisible:visRect
+ "redraw all objects which have part of themselfes in a vis rectangle
+ draw only in (i.e. clip output to) aRectangle"
+
+ realized ifTrue:[
+ self clippedTo:visRect do:[
+ gridShown ifTrue:[
+ self redrawGrid
+ ] ifFalse:[
+ self paint:viewBackground.
+ self fillRectangle:visRect
+ ].
+ self redrawObjectsIntersectingVisible:visRect
+ ]
+ ]
+!
+
+redrawObjectsAbove:anObject in:aRectangle
+ "redraw all objects which have part of themselfes in aRectangle
+ and are above (in front of) anObject.
+ draw only in (i.e. clip output to) aRectangle"
+
+ realized ifTrue:[
+ self clippedTo:aRectangle do:[
+ self redrawObjectsAbove:anObject intersecting:aRectangle
+ ]
+ ]
+!
+
+redrawObjectsAbove:anObject inVisible:aRectangle
+ "redraw all objects which have part of themselfes in a vis rectangle
+ and are above (in front of) anObject.
+ draw only in (i.e. clip output to) aRectangle"
+
+ realized ifTrue:[
+ self clippedTo:aRectangle do:[
+ self redrawObjectsAbove:anObject intersectingVisible:aRectangle
+ ]
+ ]
+!
+
+show:anObject
+ "show the object, either selected or not"
+
+ (self isSelected:anObject) ifTrue:[
+ self showSelected:anObject
+ ] ifFalse:[
+ self showUnselected:anObject
+ ]
+!
+
+showDragging:something offset:anOffset
+ "show an object while dragging"
+
+ |drawOffset top drawer|
+
+ canDragOutOfView ifTrue:[
+ "drag in root-window"
+
+ top := self topView.
+ drawOffset := device translatePoint:anOffset
+ from:(self id) to:(rootView id).
+ drawer := rootView
+ ] ifFalse:[
+ drawOffset := anOffset.
+ drawer := self
+ ].
+ self forEach:something do:[:anObject |
+ anObject drawDragIn:drawer offset:drawOffset
+ ]
+!
+
+showSelected:anObject
+ "show an object as selected"
+
+ shown ifTrue:[anObject drawSelectedIn:self]
+!
+
+showUnselected:anObject
+ "show an object as unselected"
+
+ shown ifTrue:[anObject drawIn:self]
+! !
+
+!ObjectView methodsFor:'selections'!
+
+selectionDo:aBlock
+ "apply block to every object in selection"
+
+ self forEach:selection do:aBlock
+!
+
+showSelection
+ "show the selection - draw hilights - whatever that is"
+
+ self selectionDo:[:object |
+ self showSelected:object
+ ]
+!
+
+hideSelection
+ "hide the selection - undraw hilights - whatever that is"
+
+ self selectionDo:[:object |
+ self showUnselected:object
+ ]
+!
+
+unselect
+ "unselect - hide selection; clear selection buffer"
+
+ self hideSelection.
+ selection := nil
+!
+
+select:something
+ "select something - hide previouse selection, set to something and hilight"
+
+ (selection == something) ifFalse:[
+ self hideSelection.
+ selection := something.
+ self showSelection
+ ]
+!
+
+selectAll
+ "select all objects"
+
+ self hideSelection.
+ selection := contents.
+ self showSelection
+!
+
+addToSelection:anObject
+ "add anObject to the selection"
+
+ (selection isKindOf:Collection) ifFalse:[
+ selection := OrderedCollection with:selection
+ ].
+ selection add:anObject.
+ self showSelected:anObject
+!
+
+removeFromSelection:anObject
+ "remove anObject from the selection"
+
+ (selection isKindOf:Collection) ifTrue:[
+ selection remove:anObject ifAbsent:[nil].
+ (selection size == 1) ifTrue:[
+ selection := selection first
+ ]
+ ] ifFalse:[
+ (selection == anObject) ifTrue:[
+ selection := nil
+ ]
+ ].
+ self showUnselected:anObject
+!
+
+selectAllIntersecting:aRectangle
+ "select all objects touched by aRectangle"
+
+ self hideSelection.
+ selection := OrderedCollection new.
+
+ self objectsIntersecting:aRectangle do:[:theObject |
+ selection add:theObject
+ ].
+ (selection size == 0) ifTrue:[
+ selection := nil
+ ] ifFalse:[
+ (selection size == 1) ifTrue:[selection := selection first]
+ ].
+ self showSelection
+!
+
+selectAllIn:aRectangle
+ "select all objects fully in aRectangle"
+
+ self hideSelection.
+ selection := OrderedCollection new.
+ self objectsIn:aRectangle do:[:theObject |
+ selection add:theObject
+ ].
+ (selection size == 0) ifTrue:[
+ selection := nil
+ ] ifFalse:[
+ (selection size == 1) ifTrue:[selection := selection first]
+ ].
+ self showSelection
+!
+
+withSelectionHiddenDo:aBlock
+ "evaluate aBlock while selection is hidden"
+
+ |sel|
+
+ sel := selection.
+ self unselect.
+ aBlock value.
+ self select:sel
+! !
+
+!ObjectView methodsFor:'testing objects'!
+
+findObjectAt:aPoint
+ "find the last object (by looking from back to front) which is hit by
+ the argument, aPoint - this is the topmost object hit"
+
+ |hdelta|
+
+ hdelta := self class hitDelta.
+ contents reverseDo:[:object |
+ (object isHitBy:aPoint withDelta:hdelta) ifTrue:[^ object]
+ ].
+ ^ nil
+!
+
+findObjectAtVisible:aPoint
+ "find the last object (by looking from back to front) which is hit by
+ a visible point - this is the topmost object hit"
+
+ ^ self findObjectAt:(aPoint + viewOrigin)
+!
+
+findObjectAt:aPoint suchThat:aBlock
+ "find the last object (back to front ) which is hit by
+ the argument, aPoint and for which the testBlock, aBlock evaluates to
+ true"
+
+ |hdelta|
+
+ hdelta := self class hitDelta.
+ contents reverseDo:[:object |
+ (object isHitBy:aPoint withDelta:hdelta) ifTrue:[
+ (aBlock value:object) ifTrue:[^ object]
+ ]
+ ].
+ ^ nil
+!
+
+findObjectAtVisible:aPoint suchThat:aBlock
+ "find the last object (back to front ) which is hit by
+ the argument, aPoint and for which the testBlock, aBlock evaluates to
+ true"
+
+ ^ self findObjectAt:(aPoint + viewOrigin) suchThat:aBlock
+!
+
+frameOf:anObjectOrCollection
+ "answer the maximum extent defined by the argument, anObject or a
+ collection of objects"
+
+ |first frameAll|
+
+ anObjectOrCollection isNil ifTrue:[^ nil ].
+ first := true.
+ self forEach:anObjectOrCollection do:[:theObject |
+ first ifTrue:[
+ frameAll := theObject frame.
+ first := false
+ ] ifFalse:[
+ frameAll := frameAll merge:(theObject frame)
+ ]
+ ].
+ ^ frameAll
+!
+
+canMove:something
+ "return true, if the argument, anObject or a collection can be moved"
+
+ (something isKindOf:Collection) ifTrue:[
+ self forEach:something do:[:theObject |
+ (theObject canBeMoved) ifFalse:[^ false]
+ ].
+ ^ true
+ ].
+ ^ something canBeMoved
+!
+
+isSelected:anObject
+ "return true, if the argument, anObject is in the selection"
+
+ selection isNil ifTrue:[^ false].
+ (selection == anObject) ifTrue:[^ true].
+ (selection isKindOf:Collection) ifTrue:[
+ ^ (selection identityIndexOf:anObject startingAt:1) ~~ 0
+ ].
+ ^ false
+!
+
+objectIsObscured:objectToBeTested
+ "return true, if the argument, anObject is obscured (partially or whole)
+ by any other object"
+
+ |frameToBeTested frameleft frameright frametop framebot
+ objectsFrame startIndex|
+
+ (objectToBeTested == (contents last)) ifTrue:[
+ "quick return if object is on top"
+ ^ false
+ ].
+
+ frameToBeTested := self frameOf:objectToBeTested.
+ frameleft := frameToBeTested left.
+ frameright := frameToBeTested right.
+ frametop := frameToBeTested top.
+ framebot := frameToBeTested bottom.
+
+ "check objects after the one to check"
+
+ startIndex := contents identityIndexOf:objectToBeTested ifAbsent:[self error].
+ contents from:(startIndex + 1) to:(contents size) do:[:object |
+ objectsFrame := self frameOf:object.
+ (objectsFrame right < frameleft) ifFalse:[
+ (objectsFrame left > frameright) ifFalse:[
+ (objectsFrame bottom < frametop) ifFalse:[
+ (objectsFrame top > framebot) ifFalse:[
+ ^ true
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ false
+!
+
+isObscured:something
+ "return true, if the argument something, anObject or a collection of
+ objects is obscured (partially or whole) by any other object"
+
+ self forEach:something do:[:anObject |
+ (self objectIsObscured:anObject) ifTrue:[
+ ^ true
+ ]
+ ].
+ ^ false
+! !
+
+!ObjectView methodsFor:'layout manipulation'!
+
+move:something to:aPoint in:aView
+ "can only happen when dragOutOfView is true
+ - should be redefined in subclasses"
+
+ self notify:'cannot move object(s) out of view'
+!
+
+move:something to:aPoint inAlienViewId:aViewId
+ "can only happen when dragOutOfView is true
+ - should be redefined in subclasses"
+
+ self notify:'cannot move object(s) to alien views'
+!
+
+move:something by:delta
+ "change the position of something, an Object or Collection
+ by delta, aPoint"
+
+ (delta x == 0) ifTrue:[
+ (delta y == 0) ifTrue:[^ self]
+ ].
+
+ self forEach:something do:[:anObject |
+ self moveObject:anObject by:delta
+ ]
+!
+
+moveObject:anObject by:delta
+ "change the position of anObject by delta, aPoint"
+
+ self moveObject:anObject to:(anObject origin + delta)
+!
+
+moveObject:anObject to:newOrigin
+ "move anObject to newOrigin, aPoint"
+
+ |oldOrigin oldFrame newFrame
+ objectsIntersectingOldFrame objectsIntersectingNewFrame
+ wasObscured isObscured intersects
+ vx vy oldLeft oldTop w h newLeft newTop|
+
+ anObject isNil ifTrue:[^ self].
+ anObject canBeMoved ifFalse:[^ self].
+
+ oldOrigin := anObject origin.
+ (oldOrigin = newOrigin) ifTrue:[^ self].
+
+ oldFrame := self frameOf:anObject.
+ objectsIntersectingOldFrame := self objectsIntersecting:oldFrame.
+ wasObscured := self isObscured:anObject.
+
+ anObject moveTo:newOrigin.
+
+ newFrame := self frameOf:anObject.
+ objectsIntersectingNewFrame := self objectsIntersecting:newFrame.
+
+ "try to redraw the minimum possible"
+
+ "if no other object intersects both frames we can do a copy:"
+
+ intersects := oldFrame intersects:newFrame.
+ intersects ifFalse:[
+ gridShown ifFalse:[
+ (objectsIntersectingOldFrame size == 1) ifTrue:[
+ (objectsIntersectingNewFrame size == 1) ifTrue:[
+ vx := viewOrigin x.
+ vy := viewOrigin y.
+ oldLeft := oldFrame left - vx.
+ oldTop := oldFrame top - vy.
+ newLeft := newFrame left - vx.
+ newTop := newFrame top - vy.
+ w := oldFrame width.
+ h := oldFrame height.
+ ((newLeft < width) and:[newTop < height]) ifTrue:[
+ ((newLeft >= 0) and:[newTop >= 0]) ifTrue:[
+ self copyFrom:self x:oldLeft y:oldTop
+ toX:newLeft y:newTop
+ width:w height:h.
+ self waitForExpose
+ ]
+ ].
+ ((oldLeft < width) and:[oldTop < height]) ifTrue:[
+ ((oldLeft >= 0) and:[oldTop >= 0]) ifTrue:[
+ self fillRectangleX:oldLeft y:oldTop width:w height:h
+ with:viewBackground
+ ]
+ ].
+ ^ self
+ ]
+ ]
+ ]
+ ].
+ isObscured := self isObscured:anObject.
+ (oldFrame intersects:newFrame) ifTrue:[
+ isObscured ifFalse:[
+ self redrawObjectsIn:oldFrame.
+ self show: anObject
+ ] ifTrue:[
+ self redrawObjectsIn:(oldFrame merge:newFrame)
+ ]
+ ] ifFalse:[
+ self redrawObjectsIn:oldFrame.
+ isObscured ifFalse:[
+ self show: anObject
+ ] ifTrue:[
+ self redrawObjectsIn:newFrame
+ ]
+ ]
+!
+
+objectToFront:anObject
+ "bring the argument, anObject to front"
+
+ |wasObscured|
+
+ anObject notNil ifTrue:[
+ wasObscured := self isObscured:anObject.
+ contents remove:anObject.
+ contents addLast:anObject.
+ wasObscured ifTrue:[
+ self redrawObjectsIn:(anObject frame)
+ ]
+ ]
+!
+
+toFront:something
+ "bring the argument, anObject or a collection of objects to front"
+
+ self forEach:something do:[:anObject |
+ self objectToFront:anObject
+ ]
+!
+
+selectionToFront
+ "bring the selection to front"
+
+ self toFront:selection
+!
+
+objectToBack:anObject
+ "bring the argument, anObject to back"
+
+ anObject notNil ifTrue:[
+ contents remove:anObject.
+ contents addFirst:anObject.
+ (self isObscured:anObject) ifTrue:[
+ self redrawObjectsIn:(anObject frame)
+ ]
+ ]
+!
+
+toBack:something
+ "bring the argument, anObject or a collection of objects to back"
+
+ self forEach:something do:[:anObject |
+ self objectToBack:anObject
+ ]
+!
+
+selectionToBack
+ "bring the selection to back"
+
+ self toBack:selection
+!
+
+alignLeft:something
+ |leftMost|
+
+ leftMost := 999999.
+ self forEach:something do:[:anObject |
+ leftMost := leftMost min:(anObject frame left)
+ ].
+ self withSelectionHiddenDo:[
+ self forEach:something do:[:anObject |
+ self moveObject:anObject to:(leftMost @ (anObject frame top))
+ ]
+ ]
+!
+
+alignRight:something
+ |rightMost|
+
+ rightMost := -999999.
+ self forEach:something do:[:anObject |
+ rightMost := rightMost max:(anObject frame right)
+ ].
+ self withSelectionHiddenDo:[
+ self forEach:something do:[:anObject |
+ self moveObject:anObject to:(rightMost - (anObject frame width))
+ @ (anObject frame top)
+ ]
+ ]
+!
+
+alignTop:something
+ |topMost|
+
+ topMost := 999999.
+ self forEach:something do:[:anObject |
+ topMost := topMost min:(anObject frame top)
+ ].
+ self withSelectionHiddenDo:[
+ self forEach:something do:[:anObject |
+ self moveObject:anObject to:((anObject frame left) @ topMost)
+ ]
+ ]
+!
+
+alignBottom:something
+ |botMost|
+
+ botMost := -999999.
+ self forEach:something do:[:anObject |
+ botMost := botMost max:(anObject frame bottom)
+ ].
+ self withSelectionHiddenDo:[
+ self forEach:something do:[:anObject |
+ self moveObject:anObject to:(anObject frame left)
+ @
+ (botMost - (anObject frame height))
+ ]
+ ]
+!
+
+selectionAlignLeft
+ "align selected objects left"
+
+ self alignLeft:selection
+!
+
+selectionAlignRight
+ "align selected objects right"
+
+ self alignRight:selection
+!
+
+selectionAlignTop
+ "align selected objects at top"
+
+ self alignTop:selection
+!
+
+selectionAlignBottom
+ "align selected objects at bottom"
+
+ self alignBottom:selection
+! !
+
+!ObjectView methodsFor:'adding / removing'!
+
+deleteSelection
+ "delete the selection"
+
+ buffer := selection.
+ self unselect.
+ self remove:buffer.
+ selection := nil
+!
+
+pasteBuffer
+ "add the objects in the paste-buffer"
+
+ self unselect.
+ self addSelected:buffer
+!
+
+copySelection
+ "copy the selection into the paste-buffer"
+
+ buffer := OrderedCollection new.
+ self selectionDo:[:object |
+ buffer add:(object copy)
+ ].
+ self forEach:buffer do:[:anObject |
+ anObject moveTo:(anObject origin + (8 @ 8))
+ ]
+!
+
+addSelected:something
+ "add something, anObject or a collection of objects to the contents
+ and select it"
+
+ self add:something.
+ self select:something
+!
+
+addWithoutRedraw:something
+ "add something, anObject or a collection of objects to the contents
+ do not redraw"
+
+ self forEach:something do:[:anObject |
+ self addObjectWithoutRedraw:anObject
+ ]
+!
+
+addObjectWithoutRedraw:anObject
+ "add the argument, anObject to the contents - no redraw"
+
+ anObject notNil ifTrue:[
+ contents addLast:anObject
+ ]
+!
+
+add:something
+ "add something, anObject or a collection of objects to the contents
+ with redraw"
+
+ self forEach:something do:[:anObject |
+ self addObject:anObject
+ ]
+!
+
+addObject:anObject
+ "add the argument, anObject to the contents - with redraw"
+
+ anObject notNil ifTrue:[
+ contents addLast:anObject.
+ "its on top - only draw this one"
+ realized ifTrue:[
+ self showUnselected:anObject
+ ]
+ ]
+!
+
+remove:something
+ "remove something, anObject or a collection of objects from the contents
+ do redraw"
+
+ self forEach:something do:[:anObject |
+ self removeObject:anObject
+ ]
+!
+
+removeObject:anObject
+ "remove the argument, anObject from the contents - no redraw"
+
+ anObject notNil ifTrue:[
+ self removeFromSelection:anObject.
+ contents remove:anObject.
+ realized ifTrue:[
+ self redrawObjectsIn:(anObject frame)
+ ]
+ ]
+!
+
+removeWithoutRedraw:something
+ "remove something, anObject or a collection of objects from the contents
+ do not redraw"
+
+ self forEach:something do:[:anObject |
+ self removeObjectWithoutRedraw:anObject
+ ]
+!
+
+removeObjectWithoutRedraw:anObject
+ "remove the argument, anObject from the contents - no redraw"
+
+ anObject notNil ifTrue:[
+ self removeFromSelection:anObject.
+ contents remove:anObject
+ ]
+!
+
+removeAllWithoutRedraw
+ "remove all - no redraw"
+
+ selection := nil.
+ contents := OrderedCollection new
+!
+
+removeAll
+ "remove all - redraw"
+
+ self removeAllWithoutRedraw.
+ self redraw
+! !
+
+!ObjectView methodsFor:'misc'!
+
+setDefaultActions
+ motionAction := [:movePoint | nil].
+ releaseAction := [nil]
+!
+
+setRectangleDragActions
+ motionAction := [:movePoint | self doRectangleDrag:movePoint].
+ releaseAction := [self endRectangleDrag]
+!
+
+setMoveActions
+ motionAction := [:movePoint | self doObjectMove:movePoint].
+ releaseAction := [self endObjectMove]
+!
+
+forEach:aCollection do:aBlock
+ "apply block to every object in a collectioni;
+ (adds a check for non-collection)"
+
+ aCollection isNil ifTrue:[^self].
+ (aCollection isKindOf:Collection) ifTrue:[
+ aCollection do:[:object |
+ object notNil ifTrue:[
+ aBlock value:object
+ ]
+ ]
+ ] ifFalse: [
+ aBlock value:aCollection
+ ]
+!
+
+objectsInVisible:aRectangle do:aBlock
+ "do something to every object which is completely in a
+ visible rectangle"
+
+ |absRect|
+
+ absRect := Rectangle left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+ self objectsIn:absRect do:aBlock
+!
+
+objectsIn:aRectangle do:aBlock
+ "do something to every object which is completely in a rectangle"
+
+ |bot|
+
+ sorted ifTrue:[
+ bot := aRectangle bottom.
+ contents do:[:theObject |
+ (theObject isContainedIn:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ] ifFalse:[
+ theObject frame top > bot ifTrue:[^ self]
+ ]
+ ].
+ ^ self
+ ].
+
+ contents do:[:theObject |
+ (theObject isContainedIn:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ]
+ ]
+!
+
+visibleObjectsDo:aBlock
+ "do something to every visible object"
+
+ |absRect|
+
+ absRect := Rectangle left:viewOrigin x
+ top:viewOrigin y
+ width:width
+ height:height.
+ self objectsIntersecting:absRect do:aBlock
+!
+
+numberOfObjectsIntersectingVisible:aRectangle
+ "answer the number of objects intersecting the argument, aRectangle"
+
+ |absRect|
+
+ absRect := Rectangle
+ left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+
+ ^ self numberOfObjectsIntersecting:aRectangle
+!
+
+numberOfObjectsIntersecting:aRectangle
+ "answer the number of objects intersecting the argument, aRectangle"
+
+ |tally|
+
+ tally := 0.
+ contents do:[:theObject |
+ (theObject frame intersects:aRectangle) ifTrue:[
+ tally := tally + 1
+ ]
+ ].
+ ^ tally
+!
+
+objectsIntersecting:aRectangle
+ "answer a Collection of objects intersecting the argument, aRectangle"
+
+ |newCollection|
+
+ newCollection := OrderedCollection new.
+ self objectsIntersecting:aRectangle do:[:theObject |
+ newCollection add:theObject
+ ].
+ (newCollection size == 0) ifTrue:[^ nil].
+ ^ newCollection
+!
+
+objectsIntersectingVisible:aRectangle
+ "answer a Collection of objects intersecting a visible aRectangle"
+
+ |absRect|
+
+ absRect := Rectangle left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+ ^ self objectsIntersecting:absRect
+!
+
+objectsIntersecting:aRectangle do:aBlock
+ "do something to every object which intersects a rectangle"
+
+ |f top bot
+ firstIndex "{ Class: SmallInteger }"
+ delta "{ Class: SmallInteger }"
+ theObject
+ nObjects "{ Class: SmallInteger }"|
+
+ sorted ifFalse:[
+ "have to check every object"
+ contents do:[:theObject |
+ (theObject frame intersects:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ]
+ ].
+ ^ self
+ ].
+ nObjects := contents size.
+ (nObjects == 0) ifTrue:[^ self].
+
+ "can break, when 1st object below aRectangle is reached"
+ bot := aRectangle bottom.
+ top := aRectangle top.
+
+ "binary search an object in aRectangle ..."
+ delta := nObjects // 2.
+ firstIndex := delta.
+ (firstIndex == 0) ifTrue:[
+ firstIndex := 1
+ ].
+ theObject := contents at:firstIndex.
+ (theObject frame bottom < top) ifTrue:[
+ [theObject frame bottom < top and:[delta > 1]] whileTrue:[
+ delta := delta // 2.
+ firstIndex := firstIndex + delta.
+ theObject := contents at:firstIndex
+ ]
+ ] ifFalse:[
+ [theObject frame top > bot and:[delta > 1]] whileTrue:[
+ delta := delta // 2.
+ firstIndex := firstIndex - delta.
+ theObject := contents at:firstIndex
+ ]
+ ].
+ "now, theObject at:firstIndex is in aRectangle; go backward to the object
+ following first non-visible"
+
+ [theObject frame bottom > top and:[firstIndex > 1]] whileTrue:[
+ firstIndex := firstIndex - 1.
+ theObject := contents at:firstIndex
+ ].
+
+ firstIndex to:nObjects do:[:index |
+ theObject := contents at:index.
+ f := theObject frame.
+ (f intersects:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ] ifFalse:[
+ (f top > bot) ifTrue:[^ self]
+ ]
+ ]
+!
+
+objectsIntersectingVisible:aRectangle do:aBlock
+ "do something to every object which intersects a visible rectangle"
+
+ |absRect|
+
+ absRect := Rectangle left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+ self objectsIntersecting:absRect do:aBlock
+!
+
+objectsBelow:objectToBeTested do:aBlock
+ "do something to every object below objectToBeTested
+ (does not mean obscured by - simply below in hierarchy)"
+
+ |endIndex|
+
+ endIndex := contents identityIndexOf:objectToBeTested ifAbsent:[self error].
+ contents from:1 to:(endIndex - 1) do:aBlock
+!
+
+objectsAbove:objectToBeTested do:aBlock
+ "do something to every object above objectToBeTested
+ (does not mean obscured - simply above in hierarchy)"
+
+ |startIndex|
+
+ startIndex := contents identityIndexOf:objectToBeTested
+ ifAbsent:[self error].
+ contents from:startIndex to:(contents size) do:aBlock
+!
+
+objectsAbove:anObject intersecting:aRectangle do:aBlock
+ "do something to every object above objectToBeTested
+ and intersecting aRectangle"
+
+ self objectsAbove:anObject do:[:theObject |
+ (theObject frame intersects:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ]
+ ]
+!
+
+rectangleForScroll
+ "find the area occupied by visible objects"
+
+ |left right top bottom frame oLeft oRight oTop oBottom orgX orgY|
+
+ orgX := viewOrigin x.
+ orgY := viewOrigin y.
+ left := 9999.
+ right := 0.
+ top := 9999.
+ bottom := 0.
+ self visibleObjectsDo:[:anObject |
+ frame := anObject frame.
+ oLeft := frame left - orgX.
+ oRight := frame right - orgX.
+ oTop := frame top - orgY.
+ oBottom := frame bottom - orgY.
+ (oLeft < left) ifTrue:[left := oLeft].
+ (oRight > right) ifTrue:[right := oRight].
+ (oTop < top) ifTrue:[top := oTop].
+ (oBottom > bottom) ifTrue:[bottom := oBottom]
+ ].
+ (left < margin) ifTrue:[left := margin].
+ (top < margin) ifTrue:[top := margin].
+ (right > (width - margin)) ifTrue:[right := width - margin].
+ (bottom > (height - margin)) ifTrue:[bottom := height - margin].
+
+ ((left > right) or:[top > bottom]) ifTrue:[^ nil].
+
+ ^ Rectangle left:left right:right top:top bottom:bottom
+! !
+
+!ObjectView methodsFor:'view manipulation'!
+
+showScale
+ "show the scale"
+
+ scaleShown := true.
+ self redrawScale
+!
+
+hideScale
+ "hide the scale"
+
+ scaleShown := false.
+ self redrawScale
+!
+
+millimeterMetric
+ (scaleMetric == #inch) ifTrue:[
+ scaleMetric := #mm.
+ gridShown ifTrue:[
+ self defineGrid.
+ self redraw
+ ]
+ ]
+!
+
+inchMetric
+ (scaleMetric == #mm) ifTrue:[
+ scaleMetric := #inch.
+ gridShown ifTrue:[
+ self defineGrid.
+ self redraw
+ ]
+ ]
+!
+
+defineGrid
+ "define the grid pattern"
+
+ |mmH mmV gridW gridH xp yp y x
+ bigStepH bigStepV littleStepH littleStepV hires
+ oldCursor|
+
+ mmH := self horizontalPixelPerMillimeter.
+ mmV := self verticalPixelPerMillimeter.
+ hires := self horizontalPixelPerInch > 120.
+
+ (scaleMetric == #mm) ifTrue:[
+ "dots every mm; lines every cm"
+ bigStepH := mmH * 10.0.
+ bigStepV := mmV * 10.0.
+ littleStepH := mmH.
+ littleStepV := mmV
+ ].
+ (scaleMetric == #inch) ifTrue:[
+ "dots every eights inch; lines every half inch"
+ bigStepH := mmH * (25.4 / 2).
+ bigStepV := mmV * (25.4 / 2).
+ littleStepH := mmH * (25.4 / 8).
+ littleStepV := mmV * (25.4 / 8)
+ ].
+ bigStepH isNil ifTrue:[^ self].
+
+ oldCursor := cursor.
+ self cursor:Cursor wait.
+
+ gridW := (self widthOfContentsInMM * mmH + 1) asInteger.
+ gridH := (self heightOfContentsInMM * mmV + 1) asInteger.
+ gridPixmap := Form width:gridW height:gridH depth:(device depth).
+ gridPixmap fill:viewBackground.
+ gridPixmap paint:paint.
+
+ "draw first row point-by-point"
+ yp := 0.0.
+ xp := 0.0.
+ y := yp asInteger.
+ [xp <= gridW] whileTrue:[
+ x := xp rounded.
+ hires ifTrue:[
+ gridPixmap drawPointX:(x + 1) y:y.
+ gridPixmap drawPointX:(x + 2) y:y
+ ].
+ gridPixmap drawPointX:x y:y.
+ xp := xp + littleStepH
+ ].
+
+ "copy rest from what has been drawn already"
+ yp := yp + bigStepV.
+ [yp <= gridH] whileTrue:[
+ y := yp rounded.
+ hires ifTrue:[
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:0 y:(y + 1)
+ width:gridW height:1.
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:0 y:(y + 2)
+ width:gridW height:1
+ ].
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:0 y:y
+ width:gridW height:1.
+ yp := yp + bigStepV
+ ].
+
+ "draw first col point-by-point"
+ xp := 0.0.
+ yp := 0.0.
+ x := xp asInteger.
+ [yp <= gridH] whileTrue:[
+ y := yp rounded.
+ hires ifTrue:[
+ gridPixmap drawPointX:x y:(y + 1).
+ gridPixmap drawPointX:x y:(y + 2)
+ ].
+ gridPixmap drawPointX:x y:y.
+ yp := yp + littleStepV
+ ].
+
+ "copy rest from what has been drawn already"
+ xp := xp + bigStepH.
+ [xp <= gridW] whileTrue:[
+ x := xp rounded.
+ hires ifTrue:[
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:(x + 1) y:0
+ width:1 height:gridH.
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:(x + 2) y:0
+ width:1 height:gridH
+ ].
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:x y:0
+ width:1 height:gridH.
+ xp := xp + bigStepH
+ ].
+ self cursor:oldCursor
+!
+
+showGrid
+ "show the grid"
+
+ gridShown := true.
+ gridPixmap isNil ifTrue:[
+ self defineGrid
+ ].
+ self redraw
+!
+
+hideGrid
+ "hide the grid"
+
+ gridShown := false.
+ self redraw
+!
+
+alignOn
+ "align points to grid"
+
+ aligning := true
+!
+
+alignOff
+ "do no align point to grid"
+
+ aligning := false
+! !
+
+!ObjectView methodsFor:'user interface'!
+
+alignToGrid:aPoint
+ "round aPoint to the next nearest point on the grid"
+
+ |mmH mmV aH aV|
+
+ aligning ifFalse:[
+ ^ aPoint
+ ].
+
+ mmH := self horizontalPixelPerMillimeter.
+ mmV := self verticalPixelPerMillimeter.
+
+ (scaleMetric == #mm) ifTrue:[
+ "align to mm"
+ aH := mmH.
+ aV := mmV
+ ].
+ (scaleMetric == #inch) ifTrue:[
+ "align to eights inch"
+ aH := mmH * (25.4 / 8).
+ aV := mmV * (25.4 / 8)
+ ].
+
+ ^ (aPoint grid:(aH @ aV)) grid:(1 @ 1)
+!
+
+startRectangleDrag:startPoint
+ "start a rectangle drag"
+
+ self setRectangleDragActions.
+ groupRectangleFrame := Rectangle origin:startPoint corner:startPoint.
+ self xoring:[self drawRectangle:groupRectangleFrame].
+ oldCursor := cursor.
+ self cursor:leftHandCursor
+!
+
+doRectangleDrag:aPoint
+ "do drag a rectangle"
+
+ self xoring:[
+ self drawRectangle:groupRectangleFrame.
+ groupRectangleFrame corner:aPoint.
+ self drawRectangle:groupRectangleFrame
+ ]
+!
+
+endRectangleDrag
+ "cleanup after rectangle drag; select them"
+
+ self xoring:[self drawRectangle:groupRectangleFrame].
+ self cursor:oldCursor.
+ self selectAllIn:(groupRectangleFrame + viewOrigin)
+!
+
+selectMore:aPoint
+ "add/remove an object from the selection"
+
+ |anObject|
+
+ anObject := self findObjectAtVisible:aPoint.
+ anObject notNil ifTrue:[
+ (self isSelected:anObject) ifTrue:[
+ "remove from selection"
+ self removeFromSelection:anObject
+ ] ifFalse:[
+ "add to selection"
+ self addToSelection:anObject
+ ]
+ ].
+ ^ self
+!
+
+startSelectOrMove:aPoint
+ "start a rectangleDrag or objectMove - if aPoint hits an object,
+ an object move is started, otherwise a rectangleDrag"
+
+ |anObject|
+
+ anObject := self findObjectAtVisible:aPoint.
+ anObject notNil ifTrue:[
+ (self isSelected:anObject) ifFalse:[self unselect].
+ self startObjectMove:anObject at:aPoint.
+ ^ self
+ ].
+ "nothing was hit by this click - this starts a group select"
+ self unselect.
+ self startRectangleDrag:aPoint
+!
+
+startSelectMoreOrMove:aPoint
+ "add/remove object hit by aPoint, then start a rectangleDrag or move
+ - if aPoint hits an object, a move is started, otherwise a rectangleDrag"
+
+ |anObject|
+
+ anObject := self findObjectAtVisible:aPoint.
+ anObject notNil ifTrue:[
+ (self isSelected:anObject) ifTrue:[
+ "remove from selection"
+ self removeFromSelection:anObject
+ ] ifFalse:[
+ "add to selection"
+ self addToSelection:anObject
+ ].
+ self startObjectMove:selection at:aPoint.
+ ^ self
+ ].
+ self unselect.
+ self startRectangleDrag:aPoint
+!
+
+startObjectMove:something at:aPoint
+ "start an object move"
+
+ something notNil ifTrue:[
+ self select:something.
+ (self canMove:something) ifTrue:[
+ self setMoveActions.
+ moveStartPoint := aPoint.
+ rootMotion := canDragOutOfView "."
+ "self doObjectMove:aPoint "
+ ] ifFalse:[
+ self setDefaultActions
+ ]
+ ]
+!
+
+doObjectMove:aPoint
+ "do an object move"
+
+ |dragger offs2|
+
+ canDragOutOfView ifTrue:[
+ dragger := rootView.
+ offs2 := viewOrigin
+ ] ifFalse:[
+ dragger := self.
+ offs2 := 0@0
+ ].
+ movedObject isNil ifTrue:[
+ movedObject := selection.
+ movedObject notNil ifTrue:[
+ moveDelta := 0@0.
+ dragger xoring:[
+ self showDragging:movedObject
+ offset:(moveDelta - offs2)
+ ]
+ ]
+ ].
+ movedObject notNil ifTrue:[
+ dragger xoring:[
+ self showDragging:movedObject offset:(moveDelta - offs2).
+ moveDelta := aPoint - moveStartPoint.
+ self showDragging:movedObject offset:(moveDelta - offs2)
+ ]
+ ]
+!
+
+endObjectMove
+ "cleanup after object move - physically move the object now"
+
+ |dragger inMySelf offs2 rootPoint destinationPoint
+ viewId destinationView destinationId lastViewId|
+
+ movedObject notNil ifTrue:[
+ canDragOutOfView ifTrue:[
+ dragger := rootView.
+ offs2 := viewOrigin
+ ] ifFalse:[
+ dragger := self.
+ offs2 := 0@0
+ ].
+ dragger xoring:[self showDragging:movedObject
+ offset:(moveDelta - offs2)].
+ dragger device synchronizeOutput.
+
+ "check if object is to be put into another view"
+ rootMotion ifTrue:[
+ rootPoint := device translatePoint:lastButt
+ from:(self id)
+ to:(rootView id).
+ "search view the drop is in"
+ viewId := rootView id.
+ [viewId notNil] whileTrue:[
+ destinationId := device viewIdFromPoint:rootPoint in:viewId.
+ lastViewId := viewId.
+ viewId := destinationId
+ ].
+ destinationView := device viewFromId:lastViewId.
+ destinationId := lastViewId.
+ inMySelf := (destinationView == self).
+ rootMotion := false
+ ] ifFalse:[
+ inMySelf := true
+ ].
+ inMySelf ifTrue:[
+ "simple move"
+ self move:movedObject by:moveDelta
+ ] ifFalse:[
+ destinationPoint := device translatePoint:rootPoint
+ from:(rootView id)
+ to:destinationId.
+ destinationView notNil ifTrue:[
+ "move into another smalltalk view"
+ self move:movedObject to:destinationPoint
+ in:destinationView
+ ] ifFalse:[
+ self move:movedObject to:destinationPoint
+ inAlienViewId:destinationId
+ ]
+ ].
+ self setDefaultActions.
+ movedObject := nil
+ ]
+! !
+
+!ObjectView methodsFor:'events'!
+
+buttonPress:button x:x y:y
+ "user pressed left button"
+
+ (button == 1) ifTrue:[
+ pressAction notNil ifTrue:[
+ lastButt := x @ y.
+ pressAction value:lastButt
+ ]
+ ] ifFalse:[
+ super buttonPress:button x:x y:y
+ ]
+!
+
+buttonShiftPress:button x:x y:y
+ "user pressed left button with shift"
+
+ (button == 1) ifTrue:[
+ shiftPressAction notNil ifTrue:[
+ lastButt := x @ y.
+ shiftPressAction value:lastButt
+ ]
+ ] ifFalse:[
+ super buttonShiftPress:button x:x y:y
+ ]
+!
+
+buttonMultiPress:button x:x y:y
+ "user pressed left button twice (or more)"
+
+ (button == 1) ifTrue:[
+ doublePressAction notNil ifTrue:[
+ doublePressAction value:(x @ y)
+ ]
+ ] ifFalse:[
+ super buttonMultiPress:button x:x y:y
+ ]
+!
+
+buttonMotion:button x:buttX y:buttY
+ "user moved mouse while button pressed"
+
+ |xpos ypos movePoint|
+
+ (lastButt == nil) ifFalse:[
+ xpos := buttX.
+ ypos := buttY.
+
+ "check against view limits if move outside is not allowed"
+ rootMotion ifFalse:[
+ (xpos < 0) ifTrue:[
+ xpos := 0
+ ] ifFalse: [
+ (xpos > width) ifTrue:[xpos := width]
+ ].
+ (ypos < 0) ifTrue:[
+ ypos := 0
+ ] ifFalse: [
+ (ypos > height) ifTrue:[ypos := height]
+ ]
+ ].
+ movePoint := xpos @ ypos.
+
+ (xpos == (lastButt x)) ifTrue:[
+ (ypos == (lastButt y)) ifTrue:[
+ ^ self "no move"
+ ]
+ ].
+
+ motionAction notNil ifTrue:[
+ motionAction value:movePoint
+ ].
+ lastButt := movePoint
+ ]
+!
+
+buttonRelease:button x:x y:y
+ (button == 1) ifTrue: [
+ releaseAction notNil ifTrue:[releaseAction value]
+ ] ifFalse:[
+ super buttonRelease:button x:x y:y
+ ]
+!
+
+keyPress:key x:x y:y
+ keyPressAction notNil ifTrue:[
+ selection notNil ifTrue:[
+ self selectionDo: [:obj |
+ obj keyInput:key
+ ]
+ ]
+ ]
+!
+
+redrawX:x y:y width:w height:h
+ |innerX innerY innerW innerH redrawFrame |
+
+ innerX := x.
+ innerY := y.
+ innerW := w.
+ innerH := h.
+ scaleShown ifTrue:[
+ (x < leftMarginForScale) ifTrue:[
+ self redrawVerticalScale.
+ innerW := w - (leftMarginForScale - x).
+ innerX := leftMarginForScale
+ ].
+ (y < topMarginForScale) ifTrue:[
+ self redrawHorizontalScale.
+ innerH := h - (topMarginForScale - y).
+ innerY := topMarginForScale
+ ]
+ ].
+ (contents size ~~ 0) ifTrue:[
+ redrawFrame := Rectangle left:innerX top:innerY
+ width:innerW height:innerH.
+ self redrawObjectsInVisible:redrawFrame
+ ]
+! !
+
+!ObjectView methodsFor:'saving / restoring'!
+
+storeContentsOn:aStream
+ |excla|
+
+ excla := aStream class chunkSeparator.
+ self forEach:contents do:[:theObject |
+ theObject storeOn:aStream.
+ aStream nextPut:excla.
+ aStream cr
+ ].
+ aStream nextPut:excla
+!
+
+initializeFileInObject:anObject
+ "each object may be processed here after its beeing filed-in
+ - subclasses may do whatever they want here ...
+ (see LogicView for example)"
+
+ ^ self
+!
+
+withoutRedrawFileInContentsFrom:aStream
+ self fileInContentsFrom:aStream redraw:false
+!
+
+fileInContentsFrom:aStream
+ self fileInContentsFrom:aStream redraw:true
+!
+
+fileInContentsFrom:aStream redraw:redraw
+ |newObject chunk savCursor|
+
+ savCursor := self cursor.
+ self cursor:readCursor.
+ self unselect.
+ self removeAll.
+ [aStream atEnd] whileFalse:[
+ chunk := aStream nextChunk.
+ chunk notNil ifTrue:[
+ chunk isEmpty ifFalse:[
+ newObject := Compiler evaluate:chunk.
+ self initializeFileInObject:newObject.
+ redraw ifFalse:[
+ self addObjectWithoutRedraw:newObject
+ ] ifTrue:[
+ self addObject:newObject
+ ]
+ ]
+ ]
+ ].
+ self cursor:savCursor
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ObjectView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,1880 @@
+"
+ COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+View subclass:#ObjectView
+ instanceVariableNames:'contents
+ sorted
+ lastButt lastPointer lastButtonTime
+ pressAction releaseAction
+ shiftPressAction doublePressAction
+ motionAction keyPressAction
+ selection
+ gridShown gridPixmap
+ scaleShown scaleMetric
+ groupRectangleFrame
+ leftHandCursor readCursor oldCursor
+ movedObject moveStartPoint
+ moveDelta
+ buffer
+ documentFormat
+ leftMarginForScale topMarginForScale
+ canDragOutOfView rootMotion rootView aligning'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Basic'
+!
+
+ObjectView comment:'
+
+COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+a View which can hold DisplayObjects, can make selections, move them around etc.
+this is an abstract class providing common mechanisms - actual instances are
+DrawView, DirectoryView, LogicView or DocumentView.
+
+%W% %E%
+written spring/summer 89 by claus
+'!
+
+!ObjectView class methodsFor:'defaults'!
+
+hitDelta
+ "when clicking an object, allow for hitDelta pixels around object;
+ 0 is exact; 1*pixelPerMillimeter is good for draw programs"
+ ^ 0
+! !
+
+!ObjectView methodsFor:'initialization'!
+
+initialize
+ |pixPerMM|
+
+ super initialize.
+
+ viewBackground := White.
+
+ bitGravity := #NorthWest.
+ contents := OrderedCollection new.
+ gridShown := false.
+ scaleShown := false.
+ canDragOutOfView := false.
+ rootView := DisplayRootView new.
+ rootView noClipByChildren.
+ rootMotion := false.
+ (Language == #english) ifTrue:[
+ documentFormat := 'letter'.
+ scaleMetric := #inch
+ ] ifFalse:[
+ documentFormat := 'a4'.
+ scaleMetric := #mm
+ ].
+ pixPerMM := self verticalPixelPerMillimeter:1.
+ topMarginForScale := ((pixPerMM * 2.0) + 0.5) asInteger.
+ pixPerMM := self horizontalPixelPerMillimeter:1.
+ leftMarginForScale := ((pixPerMM * 2.0) + 0.5) asInteger.
+ readCursor := Cursor read.
+ leftHandCursor := Cursor leftHand.
+ sorted := false.
+ aligning := false
+!
+
+initEvents
+ self backingStore:true.
+ self enableButtonEvents.
+ self enableButtonMotionEvents
+! !
+
+!ObjectView methodsFor:'queries'!
+
+heightOfContentsInMM
+ "answer the height of the document in millimeters"
+
+ (documentFormat = 'a3') ifTrue:[
+ ^ 420
+ ].
+ (documentFormat = 'a4') ifTrue:[
+ ^ 296
+ ].
+ (documentFormat = 'a5') ifTrue:[
+ ^ 210
+ ].
+ (documentFormat = 'letter') ifTrue:[
+ ^ 11 * 25.4
+ ].
+ "assuming window size is document size"
+ ^ (height / self verticalPixelPerMillimeter:1) asInteger
+!
+
+widthOfContentsInMM
+ "answer the width of the document in millimeters"
+
+ (documentFormat = 'a3') ifTrue:[
+ ^ 296
+ ].
+ (documentFormat = 'a4') ifTrue:[
+ ^ 210
+ ].
+ (documentFormat = 'a5') ifTrue:[
+ ^ 148
+ ].
+ (documentFormat = 'letter') ifTrue:[
+ ^ 8.5 * 25.4
+ ].
+ "assuming window size is document size"
+ ^ (width / self horizontalPixelPerMillimeter:1) asInteger
+!
+
+heightOfContents
+ "answer the height of the document in pixels"
+
+ ^ ((self heightOfContentsInMM
+ * (self verticalPixelPerMillimeter:1)) + 0.5) asInteger
+!
+
+widthOfContents
+ "answer the width of the document in pixels"
+
+ ^ ((self widthOfContentsInMM
+ * (self horizontalPixelPerMillimeter:1)) + 0.5) asInteger
+! !
+
+!ObjectView methodsFor:'drawing'!
+
+redraw
+ "redraw complete View"
+
+ realized ifTrue:[
+ gridShown ifTrue:[
+ self redrawGrid
+ ] ifFalse:[
+ self fill:viewBackground
+ ].
+ scaleShown ifTrue:[
+ self redrawScale
+ ].
+ self redrawObjects
+ ]
+!
+
+redrawGrid
+ "redraw the grid"
+
+ gridPixmap notNil ifTrue:[
+ self drawOpaqueForm:gridPixmap x:0 y:0
+ ]
+!
+
+redrawHorizontalScale
+ "redraw the horizontal scale"
+
+ |x mmH short step xRounded shortLen longLen len|
+
+ self clearRectangle:((0 @ 0) corner:(width @ topMarginForScale)).
+ scaleShown ifFalse:[^ self].
+ (scaleMetric == #mm) ifTrue:[
+ "long blibs every centimeter; short ones every half"
+
+ mmH := self horizontalPixelPerMillimeter.
+ step := mmH * 5.0.
+ x := step.
+ short := true.
+ shortLen := (topMarginForScale / 2) asInteger.
+ longLen := topMarginForScale.
+ [x < width] whileTrue:[
+ xRounded := (x + 0.5) asInteger.
+ short ifTrue:[
+ len := shortLen
+ ] ifFalse:[
+ len := longLen
+ ].
+ self displayLineFromX:xRounded y:0 toX:xRounded y:len.
+ short := short not.
+ x := x + step
+ ]
+ ]
+!
+
+redrawVerticalScale
+ "redraw the vertical scale"
+
+ |y mmV short step yRounded shortLen longLen len|
+
+ self clearRectangle:((0 @ 0) corner:(leftMarginForScale @ height)).
+ scaleShown ifFalse:[^ self].
+ (scaleMetric == #mm) ifTrue:[
+ "long blibs every centimeter; short ones every half"
+
+ mmV := self verticalPixelPerMillimeter.
+ step := mmV * 5.0.
+ y := step.
+ short := true.
+ shortLen := (leftMarginForScale / 2) asInteger.
+ longLen := leftMarginForScale.
+ [y < height] whileTrue:[
+ yRounded := (y + 0.5) asInteger.
+ short ifTrue:[
+ len := shortLen
+ ] ifFalse:[
+ len := longLen
+ ].
+ self displayLineFromX:0 y:yRounded toX:len y:yRounded.
+ short := short not.
+ y := y + step
+ ]
+ ]
+!
+
+redrawScale
+ "redraw the scales"
+
+ self redrawHorizontalScale.
+ self redrawVerticalScale
+!
+
+redrawObjectsOn:aGC
+ "redraw all objects on a graphic context"
+
+ |vFrame org|
+
+ (aGC == self) ifTrue:[
+ realized ifFalse:[^ self].
+ org := viewOrigin + (leftMarginForScale @ topMarginForScale).
+ vFrame := Rectangle origin:org
+ corner:(viewOrigin + (width @ height)).
+
+ self redrawObjectsIntersecting:vFrame
+ ] ifFalse:[
+ "loop over pages"
+
+ org := 0 @ 0.
+ vFrame := Rectangle origin:org
+ corner:(org + (width @ height)).
+
+ self redrawObjectsIntersecting:vFrame
+ ]
+!
+
+redrawObjects
+ "redraw all objects"
+
+ self redrawObjectsOn:self
+!
+
+redrawObjectsIntersecting:aRectangle
+ "redraw all objects which have part of themself in aRectangle"
+
+ self objectsIntersecting:aRectangle do:[:theObject |
+ self show:theObject
+ ]
+!
+
+redrawObjectsIntersectingVisible:aRectangle
+ "redraw all objects which have part of themself in a vis rectangle"
+
+ self objectsIntersectingVisible:aRectangle do:[:theObject |
+ self show:theObject
+ ]
+
+!
+
+redrawObjectsAbove:anObject intersecting:aRectangle
+ "redraw all objects which have part of themself in aRectangle
+ and are above (in front of) anObject"
+
+ self objectsAbove:anObject intersecting:aRectangle do:[:theObject |
+ self show:theObject
+ ]
+!
+
+redrawObjectsAbove:anObject intersectingVisible:aRectangle
+ "redraw all objects which have part of themself in a vis rectangle
+ and are above (in front of) anObject"
+
+ self objectsAbove:anObject intersectingVisible:aRectangle do:[:theObject |
+ self show:theObject
+ ]
+!
+
+redrawObjectsIn:aRectangle
+ "redraw all objects which have part of themselfes in aRectangle
+ draw only in (i.e. clip output to) aRectangle"
+
+ |visRect|
+
+ realized ifTrue:[
+ visRect := Rectangle origin:(aRectangle origin - viewOrigin)
+ extent:(aRectangle extent).
+ self clippedTo:visRect do:[
+ gridShown ifTrue:[
+ self redrawGrid
+ ] ifFalse:[
+ self paint:viewBackground.
+ self fillRectangle:visRect
+ ].
+ self redrawObjectsIntersecting:aRectangle
+ ]
+ ]
+!
+
+redrawObjectsInVisible:visRect
+ "redraw all objects which have part of themselfes in a vis rectangle
+ draw only in (i.e. clip output to) aRectangle"
+
+ realized ifTrue:[
+ self clippedTo:visRect do:[
+ gridShown ifTrue:[
+ self redrawGrid
+ ] ifFalse:[
+ self paint:viewBackground.
+ self fillRectangle:visRect
+ ].
+ self redrawObjectsIntersectingVisible:visRect
+ ]
+ ]
+!
+
+redrawObjectsAbove:anObject in:aRectangle
+ "redraw all objects which have part of themselfes in aRectangle
+ and are above (in front of) anObject.
+ draw only in (i.e. clip output to) aRectangle"
+
+ realized ifTrue:[
+ self clippedTo:aRectangle do:[
+ self redrawObjectsAbove:anObject intersecting:aRectangle
+ ]
+ ]
+!
+
+redrawObjectsAbove:anObject inVisible:aRectangle
+ "redraw all objects which have part of themselfes in a vis rectangle
+ and are above (in front of) anObject.
+ draw only in (i.e. clip output to) aRectangle"
+
+ realized ifTrue:[
+ self clippedTo:aRectangle do:[
+ self redrawObjectsAbove:anObject intersectingVisible:aRectangle
+ ]
+ ]
+!
+
+show:anObject
+ "show the object, either selected or not"
+
+ (self isSelected:anObject) ifTrue:[
+ self showSelected:anObject
+ ] ifFalse:[
+ self showUnselected:anObject
+ ]
+!
+
+showDragging:something offset:anOffset
+ "show an object while dragging"
+
+ |drawOffset top drawer|
+
+ canDragOutOfView ifTrue:[
+ "drag in root-window"
+
+ top := self topView.
+ drawOffset := device translatePoint:anOffset
+ from:(self id) to:(rootView id).
+ drawer := rootView
+ ] ifFalse:[
+ drawOffset := anOffset.
+ drawer := self
+ ].
+ self forEach:something do:[:anObject |
+ anObject drawDragIn:drawer offset:drawOffset
+ ]
+!
+
+showSelected:anObject
+ "show an object as selected"
+
+ shown ifTrue:[anObject drawSelectedIn:self]
+!
+
+showUnselected:anObject
+ "show an object as unselected"
+
+ shown ifTrue:[anObject drawIn:self]
+! !
+
+!ObjectView methodsFor:'selections'!
+
+selectionDo:aBlock
+ "apply block to every object in selection"
+
+ self forEach:selection do:aBlock
+!
+
+showSelection
+ "show the selection - draw hilights - whatever that is"
+
+ self selectionDo:[:object |
+ self showSelected:object
+ ]
+!
+
+hideSelection
+ "hide the selection - undraw hilights - whatever that is"
+
+ self selectionDo:[:object |
+ self showUnselected:object
+ ]
+!
+
+unselect
+ "unselect - hide selection; clear selection buffer"
+
+ self hideSelection.
+ selection := nil
+!
+
+select:something
+ "select something - hide previouse selection, set to something and hilight"
+
+ (selection == something) ifFalse:[
+ self hideSelection.
+ selection := something.
+ self showSelection
+ ]
+!
+
+selectAll
+ "select all objects"
+
+ self hideSelection.
+ selection := contents.
+ self showSelection
+!
+
+addToSelection:anObject
+ "add anObject to the selection"
+
+ (selection isKindOf:Collection) ifFalse:[
+ selection := OrderedCollection with:selection
+ ].
+ selection add:anObject.
+ self showSelected:anObject
+!
+
+removeFromSelection:anObject
+ "remove anObject from the selection"
+
+ (selection isKindOf:Collection) ifTrue:[
+ selection remove:anObject ifAbsent:[nil].
+ (selection size == 1) ifTrue:[
+ selection := selection first
+ ]
+ ] ifFalse:[
+ (selection == anObject) ifTrue:[
+ selection := nil
+ ]
+ ].
+ self showUnselected:anObject
+!
+
+selectAllIntersecting:aRectangle
+ "select all objects touched by aRectangle"
+
+ self hideSelection.
+ selection := OrderedCollection new.
+
+ self objectsIntersecting:aRectangle do:[:theObject |
+ selection add:theObject
+ ].
+ (selection size == 0) ifTrue:[
+ selection := nil
+ ] ifFalse:[
+ (selection size == 1) ifTrue:[selection := selection first]
+ ].
+ self showSelection
+!
+
+selectAllIn:aRectangle
+ "select all objects fully in aRectangle"
+
+ self hideSelection.
+ selection := OrderedCollection new.
+ self objectsIn:aRectangle do:[:theObject |
+ selection add:theObject
+ ].
+ (selection size == 0) ifTrue:[
+ selection := nil
+ ] ifFalse:[
+ (selection size == 1) ifTrue:[selection := selection first]
+ ].
+ self showSelection
+!
+
+withSelectionHiddenDo:aBlock
+ "evaluate aBlock while selection is hidden"
+
+ |sel|
+
+ sel := selection.
+ self unselect.
+ aBlock value.
+ self select:sel
+! !
+
+!ObjectView methodsFor:'testing objects'!
+
+findObjectAt:aPoint
+ "find the last object (by looking from back to front) which is hit by
+ the argument, aPoint - this is the topmost object hit"
+
+ |hdelta|
+
+ hdelta := self class hitDelta.
+ contents reverseDo:[:object |
+ (object isHitBy:aPoint withDelta:hdelta) ifTrue:[^ object]
+ ].
+ ^ nil
+!
+
+findObjectAtVisible:aPoint
+ "find the last object (by looking from back to front) which is hit by
+ a visible point - this is the topmost object hit"
+
+ ^ self findObjectAt:(aPoint + viewOrigin)
+!
+
+findObjectAt:aPoint suchThat:aBlock
+ "find the last object (back to front ) which is hit by
+ the argument, aPoint and for which the testBlock, aBlock evaluates to
+ true"
+
+ |hdelta|
+
+ hdelta := self class hitDelta.
+ contents reverseDo:[:object |
+ (object isHitBy:aPoint withDelta:hdelta) ifTrue:[
+ (aBlock value:object) ifTrue:[^ object]
+ ]
+ ].
+ ^ nil
+!
+
+findObjectAtVisible:aPoint suchThat:aBlock
+ "find the last object (back to front ) which is hit by
+ the argument, aPoint and for which the testBlock, aBlock evaluates to
+ true"
+
+ ^ self findObjectAt:(aPoint + viewOrigin) suchThat:aBlock
+!
+
+frameOf:anObjectOrCollection
+ "answer the maximum extent defined by the argument, anObject or a
+ collection of objects"
+
+ |first frameAll|
+
+ anObjectOrCollection isNil ifTrue:[^ nil ].
+ first := true.
+ self forEach:anObjectOrCollection do:[:theObject |
+ first ifTrue:[
+ frameAll := theObject frame.
+ first := false
+ ] ifFalse:[
+ frameAll := frameAll merge:(theObject frame)
+ ]
+ ].
+ ^ frameAll
+!
+
+canMove:something
+ "return true, if the argument, anObject or a collection can be moved"
+
+ (something isKindOf:Collection) ifTrue:[
+ self forEach:something do:[:theObject |
+ (theObject canBeMoved) ifFalse:[^ false]
+ ].
+ ^ true
+ ].
+ ^ something canBeMoved
+!
+
+isSelected:anObject
+ "return true, if the argument, anObject is in the selection"
+
+ selection isNil ifTrue:[^ false].
+ (selection == anObject) ifTrue:[^ true].
+ (selection isKindOf:Collection) ifTrue:[
+ ^ (selection identityIndexOf:anObject startingAt:1) ~~ 0
+ ].
+ ^ false
+!
+
+objectIsObscured:objectToBeTested
+ "return true, if the argument, anObject is obscured (partially or whole)
+ by any other object"
+
+ |frameToBeTested frameleft frameright frametop framebot
+ objectsFrame startIndex|
+
+ (objectToBeTested == (contents last)) ifTrue:[
+ "quick return if object is on top"
+ ^ false
+ ].
+
+ frameToBeTested := self frameOf:objectToBeTested.
+ frameleft := frameToBeTested left.
+ frameright := frameToBeTested right.
+ frametop := frameToBeTested top.
+ framebot := frameToBeTested bottom.
+
+ "check objects after the one to check"
+
+ startIndex := contents identityIndexOf:objectToBeTested ifAbsent:[self error].
+ contents from:(startIndex + 1) to:(contents size) do:[:object |
+ objectsFrame := self frameOf:object.
+ (objectsFrame right < frameleft) ifFalse:[
+ (objectsFrame left > frameright) ifFalse:[
+ (objectsFrame bottom < frametop) ifFalse:[
+ (objectsFrame top > framebot) ifFalse:[
+ ^ true
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ false
+!
+
+isObscured:something
+ "return true, if the argument something, anObject or a collection of
+ objects is obscured (partially or whole) by any other object"
+
+ self forEach:something do:[:anObject |
+ (self objectIsObscured:anObject) ifTrue:[
+ ^ true
+ ]
+ ].
+ ^ false
+! !
+
+!ObjectView methodsFor:'layout manipulation'!
+
+move:something to:aPoint in:aView
+ "can only happen when dragOutOfView is true
+ - should be redefined in subclasses"
+
+ self notify:'cannot move object(s) out of view'
+!
+
+move:something to:aPoint inAlienViewId:aViewId
+ "can only happen when dragOutOfView is true
+ - should be redefined in subclasses"
+
+ self notify:'cannot move object(s) to alien views'
+!
+
+move:something by:delta
+ "change the position of something, an Object or Collection
+ by delta, aPoint"
+
+ (delta x == 0) ifTrue:[
+ (delta y == 0) ifTrue:[^ self]
+ ].
+
+ self forEach:something do:[:anObject |
+ self moveObject:anObject by:delta
+ ]
+!
+
+moveObject:anObject by:delta
+ "change the position of anObject by delta, aPoint"
+
+ self moveObject:anObject to:(anObject origin + delta)
+!
+
+moveObject:anObject to:newOrigin
+ "move anObject to newOrigin, aPoint"
+
+ |oldOrigin oldFrame newFrame
+ objectsIntersectingOldFrame objectsIntersectingNewFrame
+ wasObscured isObscured intersects
+ vx vy oldLeft oldTop w h newLeft newTop|
+
+ anObject isNil ifTrue:[^ self].
+ anObject canBeMoved ifFalse:[^ self].
+
+ oldOrigin := anObject origin.
+ (oldOrigin = newOrigin) ifTrue:[^ self].
+
+ oldFrame := self frameOf:anObject.
+ objectsIntersectingOldFrame := self objectsIntersecting:oldFrame.
+ wasObscured := self isObscured:anObject.
+
+ anObject moveTo:newOrigin.
+
+ newFrame := self frameOf:anObject.
+ objectsIntersectingNewFrame := self objectsIntersecting:newFrame.
+
+ "try to redraw the minimum possible"
+
+ "if no other object intersects both frames we can do a copy:"
+
+ intersects := oldFrame intersects:newFrame.
+ intersects ifFalse:[
+ gridShown ifFalse:[
+ (objectsIntersectingOldFrame size == 1) ifTrue:[
+ (objectsIntersectingNewFrame size == 1) ifTrue:[
+ vx := viewOrigin x.
+ vy := viewOrigin y.
+ oldLeft := oldFrame left - vx.
+ oldTop := oldFrame top - vy.
+ newLeft := newFrame left - vx.
+ newTop := newFrame top - vy.
+ w := oldFrame width.
+ h := oldFrame height.
+ ((newLeft < width) and:[newTop < height]) ifTrue:[
+ ((newLeft >= 0) and:[newTop >= 0]) ifTrue:[
+ self copyFrom:self x:oldLeft y:oldTop
+ toX:newLeft y:newTop
+ width:w height:h.
+ self waitForExpose
+ ]
+ ].
+ ((oldLeft < width) and:[oldTop < height]) ifTrue:[
+ ((oldLeft >= 0) and:[oldTop >= 0]) ifTrue:[
+ self fillRectangleX:oldLeft y:oldTop width:w height:h
+ with:viewBackground
+ ]
+ ].
+ ^ self
+ ]
+ ]
+ ]
+ ].
+ isObscured := self isObscured:anObject.
+ (oldFrame intersects:newFrame) ifTrue:[
+ isObscured ifFalse:[
+ self redrawObjectsIn:oldFrame.
+ self show: anObject
+ ] ifTrue:[
+ self redrawObjectsIn:(oldFrame merge:newFrame)
+ ]
+ ] ifFalse:[
+ self redrawObjectsIn:oldFrame.
+ isObscured ifFalse:[
+ self show: anObject
+ ] ifTrue:[
+ self redrawObjectsIn:newFrame
+ ]
+ ]
+!
+
+objectToFront:anObject
+ "bring the argument, anObject to front"
+
+ |wasObscured|
+
+ anObject notNil ifTrue:[
+ wasObscured := self isObscured:anObject.
+ contents remove:anObject.
+ contents addLast:anObject.
+ wasObscured ifTrue:[
+ self redrawObjectsIn:(anObject frame)
+ ]
+ ]
+!
+
+toFront:something
+ "bring the argument, anObject or a collection of objects to front"
+
+ self forEach:something do:[:anObject |
+ self objectToFront:anObject
+ ]
+!
+
+selectionToFront
+ "bring the selection to front"
+
+ self toFront:selection
+!
+
+objectToBack:anObject
+ "bring the argument, anObject to back"
+
+ anObject notNil ifTrue:[
+ contents remove:anObject.
+ contents addFirst:anObject.
+ (self isObscured:anObject) ifTrue:[
+ self redrawObjectsIn:(anObject frame)
+ ]
+ ]
+!
+
+toBack:something
+ "bring the argument, anObject or a collection of objects to back"
+
+ self forEach:something do:[:anObject |
+ self objectToBack:anObject
+ ]
+!
+
+selectionToBack
+ "bring the selection to back"
+
+ self toBack:selection
+!
+
+alignLeft:something
+ |leftMost|
+
+ leftMost := 999999.
+ self forEach:something do:[:anObject |
+ leftMost := leftMost min:(anObject frame left)
+ ].
+ self withSelectionHiddenDo:[
+ self forEach:something do:[:anObject |
+ self moveObject:anObject to:(leftMost @ (anObject frame top))
+ ]
+ ]
+!
+
+alignRight:something
+ |rightMost|
+
+ rightMost := -999999.
+ self forEach:something do:[:anObject |
+ rightMost := rightMost max:(anObject frame right)
+ ].
+ self withSelectionHiddenDo:[
+ self forEach:something do:[:anObject |
+ self moveObject:anObject to:(rightMost - (anObject frame width))
+ @ (anObject frame top)
+ ]
+ ]
+!
+
+alignTop:something
+ |topMost|
+
+ topMost := 999999.
+ self forEach:something do:[:anObject |
+ topMost := topMost min:(anObject frame top)
+ ].
+ self withSelectionHiddenDo:[
+ self forEach:something do:[:anObject |
+ self moveObject:anObject to:((anObject frame left) @ topMost)
+ ]
+ ]
+!
+
+alignBottom:something
+ |botMost|
+
+ botMost := -999999.
+ self forEach:something do:[:anObject |
+ botMost := botMost max:(anObject frame bottom)
+ ].
+ self withSelectionHiddenDo:[
+ self forEach:something do:[:anObject |
+ self moveObject:anObject to:(anObject frame left)
+ @
+ (botMost - (anObject frame height))
+ ]
+ ]
+!
+
+selectionAlignLeft
+ "align selected objects left"
+
+ self alignLeft:selection
+!
+
+selectionAlignRight
+ "align selected objects right"
+
+ self alignRight:selection
+!
+
+selectionAlignTop
+ "align selected objects at top"
+
+ self alignTop:selection
+!
+
+selectionAlignBottom
+ "align selected objects at bottom"
+
+ self alignBottom:selection
+! !
+
+!ObjectView methodsFor:'adding / removing'!
+
+deleteSelection
+ "delete the selection"
+
+ buffer := selection.
+ self unselect.
+ self remove:buffer.
+ selection := nil
+!
+
+pasteBuffer
+ "add the objects in the paste-buffer"
+
+ self unselect.
+ self addSelected:buffer
+!
+
+copySelection
+ "copy the selection into the paste-buffer"
+
+ buffer := OrderedCollection new.
+ self selectionDo:[:object |
+ buffer add:(object copy)
+ ].
+ self forEach:buffer do:[:anObject |
+ anObject moveTo:(anObject origin + (8 @ 8))
+ ]
+!
+
+addSelected:something
+ "add something, anObject or a collection of objects to the contents
+ and select it"
+
+ self add:something.
+ self select:something
+!
+
+addWithoutRedraw:something
+ "add something, anObject or a collection of objects to the contents
+ do not redraw"
+
+ self forEach:something do:[:anObject |
+ self addObjectWithoutRedraw:anObject
+ ]
+!
+
+addObjectWithoutRedraw:anObject
+ "add the argument, anObject to the contents - no redraw"
+
+ anObject notNil ifTrue:[
+ contents addLast:anObject
+ ]
+!
+
+add:something
+ "add something, anObject or a collection of objects to the contents
+ with redraw"
+
+ self forEach:something do:[:anObject |
+ self addObject:anObject
+ ]
+!
+
+addObject:anObject
+ "add the argument, anObject to the contents - with redraw"
+
+ anObject notNil ifTrue:[
+ contents addLast:anObject.
+ "its on top - only draw this one"
+ realized ifTrue:[
+ self showUnselected:anObject
+ ]
+ ]
+!
+
+remove:something
+ "remove something, anObject or a collection of objects from the contents
+ do redraw"
+
+ self forEach:something do:[:anObject |
+ self removeObject:anObject
+ ]
+!
+
+removeObject:anObject
+ "remove the argument, anObject from the contents - no redraw"
+
+ anObject notNil ifTrue:[
+ self removeFromSelection:anObject.
+ contents remove:anObject.
+ realized ifTrue:[
+ self redrawObjectsIn:(anObject frame)
+ ]
+ ]
+!
+
+removeWithoutRedraw:something
+ "remove something, anObject or a collection of objects from the contents
+ do not redraw"
+
+ self forEach:something do:[:anObject |
+ self removeObjectWithoutRedraw:anObject
+ ]
+!
+
+removeObjectWithoutRedraw:anObject
+ "remove the argument, anObject from the contents - no redraw"
+
+ anObject notNil ifTrue:[
+ self removeFromSelection:anObject.
+ contents remove:anObject
+ ]
+!
+
+removeAllWithoutRedraw
+ "remove all - no redraw"
+
+ selection := nil.
+ contents := OrderedCollection new
+!
+
+removeAll
+ "remove all - redraw"
+
+ self removeAllWithoutRedraw.
+ self redraw
+! !
+
+!ObjectView methodsFor:'misc'!
+
+setDefaultActions
+ motionAction := [:movePoint | nil].
+ releaseAction := [nil]
+!
+
+setRectangleDragActions
+ motionAction := [:movePoint | self doRectangleDrag:movePoint].
+ releaseAction := [self endRectangleDrag]
+!
+
+setMoveActions
+ motionAction := [:movePoint | self doObjectMove:movePoint].
+ releaseAction := [self endObjectMove]
+!
+
+forEach:aCollection do:aBlock
+ "apply block to every object in a collectioni;
+ (adds a check for non-collection)"
+
+ aCollection isNil ifTrue:[^self].
+ (aCollection isKindOf:Collection) ifTrue:[
+ aCollection do:[:object |
+ object notNil ifTrue:[
+ aBlock value:object
+ ]
+ ]
+ ] ifFalse: [
+ aBlock value:aCollection
+ ]
+!
+
+objectsInVisible:aRectangle do:aBlock
+ "do something to every object which is completely in a
+ visible rectangle"
+
+ |absRect|
+
+ absRect := Rectangle left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+ self objectsIn:absRect do:aBlock
+!
+
+objectsIn:aRectangle do:aBlock
+ "do something to every object which is completely in a rectangle"
+
+ |bot|
+
+ sorted ifTrue:[
+ bot := aRectangle bottom.
+ contents do:[:theObject |
+ (theObject isContainedIn:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ] ifFalse:[
+ theObject frame top > bot ifTrue:[^ self]
+ ]
+ ].
+ ^ self
+ ].
+
+ contents do:[:theObject |
+ (theObject isContainedIn:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ]
+ ]
+!
+
+visibleObjectsDo:aBlock
+ "do something to every visible object"
+
+ |absRect|
+
+ absRect := Rectangle left:viewOrigin x
+ top:viewOrigin y
+ width:width
+ height:height.
+ self objectsIntersecting:absRect do:aBlock
+!
+
+numberOfObjectsIntersectingVisible:aRectangle
+ "answer the number of objects intersecting the argument, aRectangle"
+
+ |absRect|
+
+ absRect := Rectangle
+ left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+
+ ^ self numberOfObjectsIntersecting:aRectangle
+!
+
+numberOfObjectsIntersecting:aRectangle
+ "answer the number of objects intersecting the argument, aRectangle"
+
+ |tally|
+
+ tally := 0.
+ contents do:[:theObject |
+ (theObject frame intersects:aRectangle) ifTrue:[
+ tally := tally + 1
+ ]
+ ].
+ ^ tally
+!
+
+objectsIntersecting:aRectangle
+ "answer a Collection of objects intersecting the argument, aRectangle"
+
+ |newCollection|
+
+ newCollection := OrderedCollection new.
+ self objectsIntersecting:aRectangle do:[:theObject |
+ newCollection add:theObject
+ ].
+ (newCollection size == 0) ifTrue:[^ nil].
+ ^ newCollection
+!
+
+objectsIntersectingVisible:aRectangle
+ "answer a Collection of objects intersecting a visible aRectangle"
+
+ |absRect|
+
+ absRect := Rectangle left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+ ^ self objectsIntersecting:absRect
+!
+
+objectsIntersecting:aRectangle do:aBlock
+ "do something to every object which intersects a rectangle"
+
+ |f top bot
+ firstIndex "{ Class: SmallInteger }"
+ delta "{ Class: SmallInteger }"
+ theObject
+ nObjects "{ Class: SmallInteger }"|
+
+ sorted ifFalse:[
+ "have to check every object"
+ contents do:[:theObject |
+ (theObject frame intersects:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ]
+ ].
+ ^ self
+ ].
+ nObjects := contents size.
+ (nObjects == 0) ifTrue:[^ self].
+
+ "can break, when 1st object below aRectangle is reached"
+ bot := aRectangle bottom.
+ top := aRectangle top.
+
+ "binary search an object in aRectangle ..."
+ delta := nObjects // 2.
+ firstIndex := delta.
+ (firstIndex == 0) ifTrue:[
+ firstIndex := 1
+ ].
+ theObject := contents at:firstIndex.
+ (theObject frame bottom < top) ifTrue:[
+ [theObject frame bottom < top and:[delta > 1]] whileTrue:[
+ delta := delta // 2.
+ firstIndex := firstIndex + delta.
+ theObject := contents at:firstIndex
+ ]
+ ] ifFalse:[
+ [theObject frame top > bot and:[delta > 1]] whileTrue:[
+ delta := delta // 2.
+ firstIndex := firstIndex - delta.
+ theObject := contents at:firstIndex
+ ]
+ ].
+ "now, theObject at:firstIndex is in aRectangle; go backward to the object
+ following first non-visible"
+
+ [theObject frame bottom > top and:[firstIndex > 1]] whileTrue:[
+ firstIndex := firstIndex - 1.
+ theObject := contents at:firstIndex
+ ].
+
+ firstIndex to:nObjects do:[:index |
+ theObject := contents at:index.
+ f := theObject frame.
+ (f intersects:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ] ifFalse:[
+ (f top > bot) ifTrue:[^ self]
+ ]
+ ]
+!
+
+objectsIntersectingVisible:aRectangle do:aBlock
+ "do something to every object which intersects a visible rectangle"
+
+ |absRect|
+
+ absRect := Rectangle left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+ self objectsIntersecting:absRect do:aBlock
+!
+
+objectsBelow:objectToBeTested do:aBlock
+ "do something to every object below objectToBeTested
+ (does not mean obscured by - simply below in hierarchy)"
+
+ |endIndex|
+
+ endIndex := contents identityIndexOf:objectToBeTested ifAbsent:[self error].
+ contents from:1 to:(endIndex - 1) do:aBlock
+!
+
+objectsAbove:objectToBeTested do:aBlock
+ "do something to every object above objectToBeTested
+ (does not mean obscured - simply above in hierarchy)"
+
+ |startIndex|
+
+ startIndex := contents identityIndexOf:objectToBeTested
+ ifAbsent:[self error].
+ contents from:startIndex to:(contents size) do:aBlock
+!
+
+objectsAbove:anObject intersecting:aRectangle do:aBlock
+ "do something to every object above objectToBeTested
+ and intersecting aRectangle"
+
+ self objectsAbove:anObject do:[:theObject |
+ (theObject frame intersects:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ]
+ ]
+!
+
+rectangleForScroll
+ "find the area occupied by visible objects"
+
+ |left right top bottom frame oLeft oRight oTop oBottom orgX orgY|
+
+ orgX := viewOrigin x.
+ orgY := viewOrigin y.
+ left := 9999.
+ right := 0.
+ top := 9999.
+ bottom := 0.
+ self visibleObjectsDo:[:anObject |
+ frame := anObject frame.
+ oLeft := frame left - orgX.
+ oRight := frame right - orgX.
+ oTop := frame top - orgY.
+ oBottom := frame bottom - orgY.
+ (oLeft < left) ifTrue:[left := oLeft].
+ (oRight > right) ifTrue:[right := oRight].
+ (oTop < top) ifTrue:[top := oTop].
+ (oBottom > bottom) ifTrue:[bottom := oBottom]
+ ].
+ (left < margin) ifTrue:[left := margin].
+ (top < margin) ifTrue:[top := margin].
+ (right > (width - margin)) ifTrue:[right := width - margin].
+ (bottom > (height - margin)) ifTrue:[bottom := height - margin].
+
+ ((left > right) or:[top > bottom]) ifTrue:[^ nil].
+
+ ^ Rectangle left:left right:right top:top bottom:bottom
+! !
+
+!ObjectView methodsFor:'view manipulation'!
+
+showScale
+ "show the scale"
+
+ scaleShown := true.
+ self redrawScale
+!
+
+hideScale
+ "hide the scale"
+
+ scaleShown := false.
+ self redrawScale
+!
+
+millimeterMetric
+ (scaleMetric == #inch) ifTrue:[
+ scaleMetric := #mm.
+ gridShown ifTrue:[
+ self defineGrid.
+ self redraw
+ ]
+ ]
+!
+
+inchMetric
+ (scaleMetric == #mm) ifTrue:[
+ scaleMetric := #inch.
+ gridShown ifTrue:[
+ self defineGrid.
+ self redraw
+ ]
+ ]
+!
+
+defineGrid
+ "define the grid pattern"
+
+ |mmH mmV gridW gridH xp yp y x
+ bigStepH bigStepV littleStepH littleStepV hires
+ oldCursor|
+
+ mmH := self horizontalPixelPerMillimeter.
+ mmV := self verticalPixelPerMillimeter.
+ hires := self horizontalPixelPerInch > 120.
+
+ (scaleMetric == #mm) ifTrue:[
+ "dots every mm; lines every cm"
+ bigStepH := mmH * 10.0.
+ bigStepV := mmV * 10.0.
+ littleStepH := mmH.
+ littleStepV := mmV
+ ].
+ (scaleMetric == #inch) ifTrue:[
+ "dots every eights inch; lines every half inch"
+ bigStepH := mmH * (25.4 / 2).
+ bigStepV := mmV * (25.4 / 2).
+ littleStepH := mmH * (25.4 / 8).
+ littleStepV := mmV * (25.4 / 8)
+ ].
+ bigStepH isNil ifTrue:[^ self].
+
+ oldCursor := cursor.
+ self cursor:Cursor wait.
+
+ gridW := (self widthOfContentsInMM * mmH + 1) asInteger.
+ gridH := (self heightOfContentsInMM * mmV + 1) asInteger.
+ gridPixmap := Form width:gridW height:gridH depth:(device depth).
+ gridPixmap fill:viewBackground.
+ gridPixmap paint:paint.
+
+ "draw first row point-by-point"
+ yp := 0.0.
+ xp := 0.0.
+ y := yp asInteger.
+ [xp <= gridW] whileTrue:[
+ x := xp rounded.
+ hires ifTrue:[
+ gridPixmap drawPointX:(x + 1) y:y.
+ gridPixmap drawPointX:(x + 2) y:y
+ ].
+ gridPixmap drawPointX:x y:y.
+ xp := xp + littleStepH
+ ].
+
+ "copy rest from what has been drawn already"
+ yp := yp + bigStepV.
+ [yp <= gridH] whileTrue:[
+ y := yp rounded.
+ hires ifTrue:[
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:0 y:(y + 1)
+ width:gridW height:1.
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:0 y:(y + 2)
+ width:gridW height:1
+ ].
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:0 y:y
+ width:gridW height:1.
+ yp := yp + bigStepV
+ ].
+
+ "draw first col point-by-point"
+ xp := 0.0.
+ yp := 0.0.
+ x := xp asInteger.
+ [yp <= gridH] whileTrue:[
+ y := yp rounded.
+ hires ifTrue:[
+ gridPixmap drawPointX:x y:(y + 1).
+ gridPixmap drawPointX:x y:(y + 2)
+ ].
+ gridPixmap drawPointX:x y:y.
+ yp := yp + littleStepV
+ ].
+
+ "copy rest from what has been drawn already"
+ xp := xp + bigStepH.
+ [xp <= gridW] whileTrue:[
+ x := xp rounded.
+ hires ifTrue:[
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:(x + 1) y:0
+ width:1 height:gridH.
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:(x + 2) y:0
+ width:1 height:gridH
+ ].
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:x y:0
+ width:1 height:gridH.
+ xp := xp + bigStepH
+ ].
+ self cursor:oldCursor
+!
+
+showGrid
+ "show the grid"
+
+ gridShown := true.
+ gridPixmap isNil ifTrue:[
+ self defineGrid
+ ].
+ self redraw
+!
+
+hideGrid
+ "hide the grid"
+
+ gridShown := false.
+ self redraw
+!
+
+alignOn
+ "align points to grid"
+
+ aligning := true
+!
+
+alignOff
+ "do no align point to grid"
+
+ aligning := false
+! !
+
+!ObjectView methodsFor:'user interface'!
+
+alignToGrid:aPoint
+ "round aPoint to the next nearest point on the grid"
+
+ |mmH mmV aH aV|
+
+ aligning ifFalse:[
+ ^ aPoint
+ ].
+
+ mmH := self horizontalPixelPerMillimeter.
+ mmV := self verticalPixelPerMillimeter.
+
+ (scaleMetric == #mm) ifTrue:[
+ "align to mm"
+ aH := mmH.
+ aV := mmV
+ ].
+ (scaleMetric == #inch) ifTrue:[
+ "align to eights inch"
+ aH := mmH * (25.4 / 8).
+ aV := mmV * (25.4 / 8)
+ ].
+
+ ^ (aPoint grid:(aH @ aV)) grid:(1 @ 1)
+!
+
+startRectangleDrag:startPoint
+ "start a rectangle drag"
+
+ self setRectangleDragActions.
+ groupRectangleFrame := Rectangle origin:startPoint corner:startPoint.
+ self xoring:[self drawRectangle:groupRectangleFrame].
+ oldCursor := cursor.
+ self cursor:leftHandCursor
+!
+
+doRectangleDrag:aPoint
+ "do drag a rectangle"
+
+ self xoring:[
+ self drawRectangle:groupRectangleFrame.
+ groupRectangleFrame corner:aPoint.
+ self drawRectangle:groupRectangleFrame
+ ]
+!
+
+endRectangleDrag
+ "cleanup after rectangle drag; select them"
+
+ self xoring:[self drawRectangle:groupRectangleFrame].
+ self cursor:oldCursor.
+ self selectAllIn:(groupRectangleFrame + viewOrigin)
+!
+
+selectMore:aPoint
+ "add/remove an object from the selection"
+
+ |anObject|
+
+ anObject := self findObjectAtVisible:aPoint.
+ anObject notNil ifTrue:[
+ (self isSelected:anObject) ifTrue:[
+ "remove from selection"
+ self removeFromSelection:anObject
+ ] ifFalse:[
+ "add to selection"
+ self addToSelection:anObject
+ ]
+ ].
+ ^ self
+!
+
+startSelectOrMove:aPoint
+ "start a rectangleDrag or objectMove - if aPoint hits an object,
+ an object move is started, otherwise a rectangleDrag"
+
+ |anObject|
+
+ anObject := self findObjectAtVisible:aPoint.
+ anObject notNil ifTrue:[
+ (self isSelected:anObject) ifFalse:[self unselect].
+ self startObjectMove:anObject at:aPoint.
+ ^ self
+ ].
+ "nothing was hit by this click - this starts a group select"
+ self unselect.
+ self startRectangleDrag:aPoint
+!
+
+startSelectMoreOrMove:aPoint
+ "add/remove object hit by aPoint, then start a rectangleDrag or move
+ - if aPoint hits an object, a move is started, otherwise a rectangleDrag"
+
+ |anObject|
+
+ anObject := self findObjectAtVisible:aPoint.
+ anObject notNil ifTrue:[
+ (self isSelected:anObject) ifTrue:[
+ "remove from selection"
+ self removeFromSelection:anObject
+ ] ifFalse:[
+ "add to selection"
+ self addToSelection:anObject
+ ].
+ self startObjectMove:selection at:aPoint.
+ ^ self
+ ].
+ self unselect.
+ self startRectangleDrag:aPoint
+!
+
+startObjectMove:something at:aPoint
+ "start an object move"
+
+ something notNil ifTrue:[
+ self select:something.
+ (self canMove:something) ifTrue:[
+ self setMoveActions.
+ moveStartPoint := aPoint.
+ rootMotion := canDragOutOfView "."
+ "self doObjectMove:aPoint "
+ ] ifFalse:[
+ self setDefaultActions
+ ]
+ ]
+!
+
+doObjectMove:aPoint
+ "do an object move"
+
+ |dragger offs2|
+
+ canDragOutOfView ifTrue:[
+ dragger := rootView.
+ offs2 := viewOrigin
+ ] ifFalse:[
+ dragger := self.
+ offs2 := 0@0
+ ].
+ movedObject isNil ifTrue:[
+ movedObject := selection.
+ movedObject notNil ifTrue:[
+ moveDelta := 0@0.
+ dragger xoring:[
+ self showDragging:movedObject
+ offset:(moveDelta - offs2)
+ ]
+ ]
+ ].
+ movedObject notNil ifTrue:[
+ dragger xoring:[
+ self showDragging:movedObject offset:(moveDelta - offs2).
+ moveDelta := aPoint - moveStartPoint.
+ self showDragging:movedObject offset:(moveDelta - offs2)
+ ]
+ ]
+!
+
+endObjectMove
+ "cleanup after object move - physically move the object now"
+
+ |dragger inMySelf offs2 rootPoint destinationPoint
+ viewId destinationView destinationId lastViewId|
+
+ movedObject notNil ifTrue:[
+ canDragOutOfView ifTrue:[
+ dragger := rootView.
+ offs2 := viewOrigin
+ ] ifFalse:[
+ dragger := self.
+ offs2 := 0@0
+ ].
+ dragger xoring:[self showDragging:movedObject
+ offset:(moveDelta - offs2)].
+ dragger device synchronizeOutput.
+
+ "check if object is to be put into another view"
+ rootMotion ifTrue:[
+ rootPoint := device translatePoint:lastButt
+ from:(self id)
+ to:(rootView id).
+ "search view the drop is in"
+ viewId := rootView id.
+ [viewId notNil] whileTrue:[
+ destinationId := device viewIdFromPoint:rootPoint in:viewId.
+ lastViewId := viewId.
+ viewId := destinationId
+ ].
+ destinationView := device viewFromId:lastViewId.
+ destinationId := lastViewId.
+ inMySelf := (destinationView == self).
+ rootMotion := false
+ ] ifFalse:[
+ inMySelf := true
+ ].
+ inMySelf ifTrue:[
+ "simple move"
+ self move:movedObject by:moveDelta
+ ] ifFalse:[
+ destinationPoint := device translatePoint:rootPoint
+ from:(rootView id)
+ to:destinationId.
+ destinationView notNil ifTrue:[
+ "move into another smalltalk view"
+ self move:movedObject to:destinationPoint
+ in:destinationView
+ ] ifFalse:[
+ self move:movedObject to:destinationPoint
+ inAlienViewId:destinationId
+ ]
+ ].
+ self setDefaultActions.
+ movedObject := nil
+ ]
+! !
+
+!ObjectView methodsFor:'events'!
+
+buttonPress:button x:x y:y
+ "user pressed left button"
+
+ (button == 1) ifTrue:[
+ pressAction notNil ifTrue:[
+ lastButt := x @ y.
+ pressAction value:lastButt
+ ]
+ ] ifFalse:[
+ super buttonPress:button x:x y:y
+ ]
+!
+
+buttonShiftPress:button x:x y:y
+ "user pressed left button with shift"
+
+ (button == 1) ifTrue:[
+ shiftPressAction notNil ifTrue:[
+ lastButt := x @ y.
+ shiftPressAction value:lastButt
+ ]
+ ] ifFalse:[
+ super buttonShiftPress:button x:x y:y
+ ]
+!
+
+buttonMultiPress:button x:x y:y
+ "user pressed left button twice (or more)"
+
+ (button == 1) ifTrue:[
+ doublePressAction notNil ifTrue:[
+ doublePressAction value:(x @ y)
+ ]
+ ] ifFalse:[
+ super buttonMultiPress:button x:x y:y
+ ]
+!
+
+buttonMotion:button x:buttX y:buttY
+ "user moved mouse while button pressed"
+
+ |xpos ypos movePoint|
+
+ (lastButt == nil) ifFalse:[
+ xpos := buttX.
+ ypos := buttY.
+
+ "check against view limits if move outside is not allowed"
+ rootMotion ifFalse:[
+ (xpos < 0) ifTrue:[
+ xpos := 0
+ ] ifFalse: [
+ (xpos > width) ifTrue:[xpos := width]
+ ].
+ (ypos < 0) ifTrue:[
+ ypos := 0
+ ] ifFalse: [
+ (ypos > height) ifTrue:[ypos := height]
+ ]
+ ].
+ movePoint := xpos @ ypos.
+
+ (xpos == (lastButt x)) ifTrue:[
+ (ypos == (lastButt y)) ifTrue:[
+ ^ self "no move"
+ ]
+ ].
+
+ motionAction notNil ifTrue:[
+ motionAction value:movePoint
+ ].
+ lastButt := movePoint
+ ]
+!
+
+buttonRelease:button x:x y:y
+ (button == 1) ifTrue: [
+ releaseAction notNil ifTrue:[releaseAction value]
+ ] ifFalse:[
+ super buttonRelease:button x:x y:y
+ ]
+!
+
+keyPress:key x:x y:y
+ keyPressAction notNil ifTrue:[
+ selection notNil ifTrue:[
+ self selectionDo: [:obj |
+ obj keyInput:key
+ ]
+ ]
+ ]
+!
+
+redrawX:x y:y width:w height:h
+ |innerX innerY innerW innerH redrawFrame |
+
+ innerX := x.
+ innerY := y.
+ innerW := w.
+ innerH := h.
+ scaleShown ifTrue:[
+ (x < leftMarginForScale) ifTrue:[
+ self redrawVerticalScale.
+ innerW := w - (leftMarginForScale - x).
+ innerX := leftMarginForScale
+ ].
+ (y < topMarginForScale) ifTrue:[
+ self redrawHorizontalScale.
+ innerH := h - (topMarginForScale - y).
+ innerY := topMarginForScale
+ ]
+ ].
+ (contents size ~~ 0) ifTrue:[
+ redrawFrame := Rectangle left:innerX top:innerY
+ width:innerW height:innerH.
+ self redrawObjectsInVisible:redrawFrame
+ ]
+! !
+
+!ObjectView methodsFor:'saving / restoring'!
+
+storeContentsOn:aStream
+ |excla|
+
+ excla := aStream class chunkSeparator.
+ self forEach:contents do:[:theObject |
+ theObject storeOn:aStream.
+ aStream nextPut:excla.
+ aStream cr
+ ].
+ aStream nextPut:excla
+!
+
+initializeFileInObject:anObject
+ "each object may be processed here after its beeing filed-in
+ - subclasses may do whatever they want here ...
+ (see LogicView for example)"
+
+ ^ self
+!
+
+withoutRedrawFileInContentsFrom:aStream
+ self fileInContentsFrom:aStream redraw:false
+!
+
+fileInContentsFrom:aStream
+ self fileInContentsFrom:aStream redraw:true
+!
+
+fileInContentsFrom:aStream redraw:redraw
+ |newObject chunk savCursor|
+
+ savCursor := self cursor.
+ self cursor:readCursor.
+ self unselect.
+ self removeAll.
+ [aStream atEnd] whileFalse:[
+ chunk := aStream nextChunk.
+ chunk notNil ifTrue:[
+ chunk isEmpty ifFalse:[
+ newObject := Compiler evaluate:chunk.
+ self initializeFileInObject:newObject.
+ redraw ifFalse:[
+ self addObjectWithoutRedraw:newObject
+ ] ifTrue:[
+ self addObject:newObject
+ ]
+ ]
+ ]
+ ].
+ self cursor:savCursor
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/OptBox.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,169 @@
+"
+ COPYRIGHT (c) 1991-92 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ModalBox subclass:#OptionBox
+ instanceVariableNames:'formLabel textLabel buttons actions'
+ classVariableNames:'warnBitmap'
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+OptionBox comment:'
+
+COPYRIGHT (c) 1991-92 by Claus Gittinger
+ All Rights Reserved
+
+like a YesNoBox but with as many as you like buttons in it;
+will finally be a superclass of WarnBox and YesNoBox.
+
+%W% %E%
+
+written Nov 91 by claus
+'!
+
+!OptionBox class methodsFor:'instance creation'!
+
+title:titleString numberOfOptions:nOptions
+ "create a new optionBox with title, aTitleString and nOptions options"
+
+ |box|
+
+ box := (self basicNew) numberOfOptions:nOptions.
+ box device:ModalDisplay.
+ box initialize.
+ box title:titleString.
+ ^ box
+! !
+
+!OptionBox methodsFor:'accessing'!
+
+title:aString numberOfOptions:nOptions
+ "set the title and number of options"
+
+ textLabel label:aString.
+ textLabel resize.
+ buttons grow:nOptions.
+ actions grow:nOptions
+!
+
+title:aString
+ "set the title"
+
+ textLabel label:aString.
+ textLabel resize.
+ self resize
+!
+
+numberOfOptions:nOptions
+ "set the number of options"
+
+ buttons := Array new:nOptions.
+ actions := Array new:nOptions
+!
+
+buttonTitles:titles
+ |index|
+
+ index := 1.
+ titles do:[:aString |
+ (buttons at:index) label:aString.
+ index := index + 1
+ ].
+ self resize
+!
+
+actions:actionBlocks
+ actions := actionBlocks
+!
+
+buttonTitles:titles actions:actionBlocks
+ |index|
+
+ index := 1.
+ titles do:[:aString |
+ (buttons at:index) label:aString.
+ index := index + 1
+ ].
+ actions := actionBlocks.
+ self resize
+!
+
+numberOfOptions
+ "return the number of options"
+
+ ^ buttons size
+! !
+
+!OptionBox methodsFor:'initializing'!
+
+initialize
+ |nButt|
+
+ super initialize.
+
+ warnBitmap isNil ifTrue:[
+ warnBitmap := Form fromFile:'Warning.xbm' resolution:100 on:device
+ ].
+
+ formLabel := Label form:warnBitmap in:self.
+ formLabel borderWidth:0.
+ formLabel origin:(ViewSpacing @ ViewSpacing).
+
+ textLabel := Label label:'Warning' in:self.
+ textLabel borderWidth:0.
+ textLabel origin:((ViewSpacing + formLabel width + ViewSpacing) @ ViewSpacing).
+
+ nButt := buttons size.
+
+ 1 to:nButt do:[:b |
+ buttons at:b put:(Button label:'press'
+ action:[(buttons at:b) turnOff.
+ self hide.
+ (actions at:b) notNil ifTrue:[
+ (actions at:b) value
+ ]
+ ]
+ in:self).
+ (buttons at:b) origin:[( (b - 1) * ((width - ViewSpacing) // nButt) + (ViewSpacing // 2) )
+ @
+ (height - ViewSpacing - (buttons at:b) height)].
+ (buttons at:b) extent:[(width // nButt - ViewSpacing) @ (buttons at:b) height]
+ ]
+! !
+
+!OptionBox methodsFor:'private'!
+
+resize
+ "resize myself to make everything fit into myself"
+
+ |w w1 w2 h extra|
+
+ w1 := ViewSpacing + formLabel width + ViewSpacing + textLabel width + ViewSpacing.
+
+ w2 := 0.
+ buttons do:[:butt |
+ w2 := w2 + butt width "labelWidth".
+ w2 := w2 + ViewSpacing
+ ].
+ w2 := w2 + (4 * ViewSpacing).
+ w := w1 max:w2.
+
+ h := ViewSpacing
+ + ((formLabel height) max:(textLabel height))
+ + ViewSpacing + ViewSpacing
+ + (buttons at:1) height
+ + ViewSpacing.
+
+ extra := margin * 2.
+ super extent:(w + extra) @ (h + extra)
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/OptionBox.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,169 @@
+"
+ COPYRIGHT (c) 1991-92 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ModalBox subclass:#OptionBox
+ instanceVariableNames:'formLabel textLabel buttons actions'
+ classVariableNames:'warnBitmap'
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+OptionBox comment:'
+
+COPYRIGHT (c) 1991-92 by Claus Gittinger
+ All Rights Reserved
+
+like a YesNoBox but with as many as you like buttons in it;
+will finally be a superclass of WarnBox and YesNoBox.
+
+%W% %E%
+
+written Nov 91 by claus
+'!
+
+!OptionBox class methodsFor:'instance creation'!
+
+title:titleString numberOfOptions:nOptions
+ "create a new optionBox with title, aTitleString and nOptions options"
+
+ |box|
+
+ box := (self basicNew) numberOfOptions:nOptions.
+ box device:ModalDisplay.
+ box initialize.
+ box title:titleString.
+ ^ box
+! !
+
+!OptionBox methodsFor:'accessing'!
+
+title:aString numberOfOptions:nOptions
+ "set the title and number of options"
+
+ textLabel label:aString.
+ textLabel resize.
+ buttons grow:nOptions.
+ actions grow:nOptions
+!
+
+title:aString
+ "set the title"
+
+ textLabel label:aString.
+ textLabel resize.
+ self resize
+!
+
+numberOfOptions:nOptions
+ "set the number of options"
+
+ buttons := Array new:nOptions.
+ actions := Array new:nOptions
+!
+
+buttonTitles:titles
+ |index|
+
+ index := 1.
+ titles do:[:aString |
+ (buttons at:index) label:aString.
+ index := index + 1
+ ].
+ self resize
+!
+
+actions:actionBlocks
+ actions := actionBlocks
+!
+
+buttonTitles:titles actions:actionBlocks
+ |index|
+
+ index := 1.
+ titles do:[:aString |
+ (buttons at:index) label:aString.
+ index := index + 1
+ ].
+ actions := actionBlocks.
+ self resize
+!
+
+numberOfOptions
+ "return the number of options"
+
+ ^ buttons size
+! !
+
+!OptionBox methodsFor:'initializing'!
+
+initialize
+ |nButt|
+
+ super initialize.
+
+ warnBitmap isNil ifTrue:[
+ warnBitmap := Form fromFile:'Warning.xbm' resolution:100 on:device
+ ].
+
+ formLabel := Label form:warnBitmap in:self.
+ formLabel borderWidth:0.
+ formLabel origin:(ViewSpacing @ ViewSpacing).
+
+ textLabel := Label label:'Warning' in:self.
+ textLabel borderWidth:0.
+ textLabel origin:((ViewSpacing + formLabel width + ViewSpacing) @ ViewSpacing).
+
+ nButt := buttons size.
+
+ 1 to:nButt do:[:b |
+ buttons at:b put:(Button label:'press'
+ action:[(buttons at:b) turnOff.
+ self hide.
+ (actions at:b) notNil ifTrue:[
+ (actions at:b) value
+ ]
+ ]
+ in:self).
+ (buttons at:b) origin:[( (b - 1) * ((width - ViewSpacing) // nButt) + (ViewSpacing // 2) )
+ @
+ (height - ViewSpacing - (buttons at:b) height)].
+ (buttons at:b) extent:[(width // nButt - ViewSpacing) @ (buttons at:b) height]
+ ]
+! !
+
+!OptionBox methodsFor:'private'!
+
+resize
+ "resize myself to make everything fit into myself"
+
+ |w w1 w2 h extra|
+
+ w1 := ViewSpacing + formLabel width + ViewSpacing + textLabel width + ViewSpacing.
+
+ w2 := 0.
+ buttons do:[:butt |
+ w2 := w2 + butt width "labelWidth".
+ w2 := w2 + ViewSpacing
+ ].
+ w2 := w2 + (4 * ViewSpacing).
+ w := w1 max:w2.
+
+ h := ViewSpacing
+ + ((formLabel height) max:(textLabel height))
+ + ViewSpacing + ViewSpacing
+ + (buttons at:1) height
+ + ViewSpacing.
+
+ extra := margin * 2.
+ super extent:(w + extra) @ (h + extra)
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/PanelView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,139 @@
+"
+ COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+View subclass:#PanelView
+ instanceVariableNames:'layout verticalSpace horizontalSpace mustRearrange'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Layout'
+!
+
+PanelView comment:'
+
+COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+this is a view for holding subviews. (layout-widget ?!)
+
+this one just tries to get everything into its space -
+if you dont like its layout, define a subclass ...
+
+HorizontalPanelView and VerticalPanelView are two of them.
+
+%W% %E%
+
+written spring/summer 89 by claus
+'!
+
+!PanelView methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ layout := #center.
+ verticalSpace := ViewSpacing.
+ horizontalSpace := ViewSpacing.
+ mustRearrange := false
+!
+
+realize
+ mustRearrange ifTrue:[
+ self setChildPositions
+ ].
+ super realize
+! !
+
+!PanelView methodsFor:'accessing'!
+
+verticalSpace:numberOfPixels
+ "set the space between elements (default is 1mm)"
+
+ verticalSpace := numberOfPixels
+!
+
+horizontalSpace:numberOfPixels
+ "set the space between elements (default is 1mm)"
+
+ horizontalSpace := numberOfPixels
+!
+
+space:numberOfPixels
+ "set the space between elements (default is 1mm)"
+
+ horizontalSpace := numberOfPixels.
+ verticalSpace := numberOfPixels
+!
+
+layout:aSymbol
+ "change the layout - the argument, aSymbol is interpreted in subclasses
+ HorizontalPanelView and VerticalPanelView;
+ it may be: #left / #top; #spread; #center or #right / #bottom"
+
+ (layout ~~ aSymbol) ifTrue:[
+ layout := aSymbol.
+ self layoutChanged
+ ]
+!
+
+addSubView:aView
+ super addSubView:aView.
+ self layoutChanged
+! !
+
+!PanelView methodsFor:'event processing'!
+
+sizeChanged:how
+ super sizeChanged:how.
+ self setChildPositions
+! !
+
+!PanelView methodsFor:'private'!
+
+layoutChanged
+ (shown and:[realized]) ifTrue:[
+ self setChildPositions
+ ] ifFalse:[
+ mustRearrange := true
+ ]
+!
+
+setChildPositions
+ "(re)compute position of every child"
+
+ |first xpos ypos maxHeightInRow|
+
+ subViews notNil ifTrue:[
+ xpos := horizontalSpace.
+ ypos := verticalSpace.
+
+ maxHeightInRow := 0.
+ first := true.
+ subViews do:[:child |
+ "go to next row, if this subview won't fit"
+ first ifFalse: [
+ (xpos + child widthIncludingBorder + horizontalSpace) > width
+ ifTrue: [
+ ypos := ypos + verticalSpace + maxHeightInRow.
+ xpos := horizontalSpace.
+ maxHeightInRow := 0
+ ]
+ ].
+ child origin:(xpos@ypos).
+ xpos := xpos + (child widthIncludingBorder) + horizontalSpace.
+ (maxHeightInRow < (child heightIncludingBorder)) ifTrue:[
+ maxHeightInRow := child heightIncludingBorder
+ ].
+ first := false
+ ]
+ ].
+ mustRearrange := false
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/PopUpMenu.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,408 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+PopUpView subclass:#PopUpMenu
+ instanceVariableNames:'menuView lastSelection memorize hideOnLeave
+ actionLabels actionLines actionValues'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Menus'
+!
+
+PopUpMenu comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+
+written summer 89 by claus;
+ST-80 compatibility added Dec 92;
+'!
+
+!PopUpMenu class methodsFor:'instance creation'!
+
+labels:labels selectors:selectors receiver:anObject for:aView
+ |newMenu|
+
+ aView isNil ifTrue:[
+ newMenu := self on:Display
+ ] ifFalse:[
+ newMenu := self on:(aView device)
+ ].
+ ^ newMenu menu:(MenuView
+ labels:labels
+ selectors:selectors
+ receiver:anObject
+ in:newMenu)
+!
+
+labels:labels selectors:selectors receiver:anObject
+ ^ self labels:labels selectors:selectors receiver:anObject for:nil
+!
+
+labels:labels selectors:selectors args:args receiver:anObject for:aView
+ |newMenu|
+
+ aView isNil ifTrue:[
+ newMenu := self on:Display
+ ] ifFalse:[
+ newMenu := self on:(aView device)
+ ].
+ ^ newMenu menu:(MenuView
+ labels:labels
+ selectors:selectors
+ args:args
+ receiver:anObject
+ in:newMenu)
+!
+
+labels:labels selectors:selectors args:args receiver:anObject
+ ^ self labels:labels
+ selectors:selectors
+ args:args
+ receiver:anObject
+ for:nil
+! !
+
+!PopUpMenu class methodsFor:'ST-80 instance creation'!
+
+labels:labels
+ ^ self labels:labels lines:nil values:nil
+!
+
+labels:labels values:values
+ ^ self labels:labels lines:nil values:values
+!
+
+labels:labels lines:lines
+ ^ self labels:labels lines:lines values:nil
+!
+
+labels:labels lines:lines values:values
+ ^ (self new) labels:labels lines:lines values:values
+!
+
+labelList:labels values:values
+ ^ self labels:labels lines:nil values:values
+!
+
+labelList:labels lines:lines values:values
+ ^ (self new) labels:labels lines:lines values:values
+! !
+
+!PopUpMenu methodsFor:'initialization'!
+
+initialize
+ super initialize.
+ memorize := true.
+ hideOnLeave := false
+!
+
+initEvents
+ super initEvents.
+ self enableEnterLeaveEvents.
+ self enableButtonMotionEvents.
+ self enableMotionEvents.
+ self enableButtonEvents
+! !
+
+!PopUpMenu methodsFor:'realization'!
+
+fixSize
+ "adjust my size to the size of the actual menu"
+
+ |extra newWidth newHeight|
+
+ extra := margin * 2.
+ newWidth := menuView width + extra.
+ newHeight := menuView height + extra.
+ ((newWidth ~~ width) or:[newHeight ~~ height]) ifTrue:[
+ self extent:(menuView width + extra) @ (menuView height + extra)
+ ].
+ super fixSize
+!
+
+realize
+ menuView deselectWithoutRedraw.
+ super realize.
+
+ menuView disableButtonMotionEvents.
+ menuView disableMotionEvents.
+ menuView disableButtonEvents
+! !
+
+!PopUpMenu methodsFor:'private accessing'!
+
+menu:aMenu
+ "set the actual menu"
+
+ menuView := aMenu.
+ menuView origin:(margin @ margin).
+ menuView borderWidth:0
+!
+
+menuView
+ "return the actual menu"
+
+ ^ menuView
+! !
+
+!PopUpMenu methodsFor:'accessing'!
+
+viewBackground:aColor
+ "this is a kludge and will vanish ..."
+
+ super viewBackground:aColor.
+ menuView viewBackground:aColor
+!
+
+hideOnLeave:aBoolean
+ "set/clear the hideOnLeave attribute, which controls
+ if the menu should be hidden when the pointer leaves
+ the view (used with multiple-menus)"
+
+ hideOnLeave := aBoolean
+!
+
+enable:anEntry
+ "enable a menu entry"
+
+ menuView enable:anEntry
+!
+
+disable:anEntry
+ "disable a menu entry"
+
+ menuView disable:anEntry
+!
+
+receiver:anObject
+ menuView receiver:anObject
+!
+
+addLabel:aLabel selector:aSelector
+ "add a new menu entry to the end"
+
+ menuView addLabel:aLabel selector:aSelector
+!
+
+addLabel:aLabel selector:aSelector arg:anArg
+ "add a new menu entry to the end"
+
+ menuView addLabel:aLabel selector:aSelector arg:anArg
+!
+
+labelAt:index put:aString
+ "change a menu entry"
+
+ menuView labelAt:index put:aString
+!
+
+selectorAt:index put:aSymbol
+ "change a selector entry"
+
+ menuView selectorAt:index put:aSymbol
+!
+
+subMenuAt:indexOrName put:aMenu
+ "define a submenu to be shown for entry indexOrName"
+
+ aMenu hideOnLeave:true.
+ menuView subMenuAt:indexOrName put:aMenu
+
+ "|v m|
+ v := View new.
+ m := PopUpMenu labels:#('1' '2' '3')
+ selectors:#(one two nil)
+ receiver:v
+ for:nil.
+ m subMenuAt:3 put:(PopUpMenu
+ labels:#('a' 'b' 'c')
+ selectors:#(a b c)
+ receiver:v
+ for:nil).
+ v middleButtonMenu:m.
+ v realize"
+!
+
+checkToggleAt:index
+ "return a checkToggles state"
+
+ ^ menuView checkToggleAt:index
+!
+
+checkToggleAt:index put:aBoolean
+ "set/clear a checkToggle"
+
+ ^ menuView checkToggleAt:index put:aBoolean
+! !
+
+!PopUpMenu methodsFor:'ST-80 accessing'!
+
+numberOfItems
+ ^ actionLabels asText size
+!
+
+labels
+ ^ actionLabels asText
+!
+
+values
+ ^ actionValues
+!
+
+lines
+ ^ actionLines
+!
+
+labels:labelString lines:lineArray values:valueArray
+ "define the menu the ST-80 way (with labels and lines
+ defined separately)"
+
+ |labelArray argArray convertedLabels
+ offs dstOffs linePos|
+
+ actionLabels := labelString.
+ actionLines := lineArray.
+ actionValues := valueArray.
+
+ labelArray := labelString asText.
+
+ convertedLabels := Array new:(labelArray size + lineArray size).
+ argArray := Array new:(labelArray size + lineArray size).
+
+ offs := 1.
+ dstOffs := 1.
+ 1 to:lineArray size do:[:lineIndex |
+ linePos := lineArray at:lineIndex.
+ [offs <= linePos] whileTrue:[
+ convertedLabels at:dstOffs put:(labelArray at:offs).
+ argArray at:dstOffs put:offs.
+ offs := offs + 1.
+ dstOffs := dstOffs + 1
+ ].
+ convertedLabels at:dstOffs put:'-'.
+ argArray at:dstOffs put:nil.
+ dstOffs := dstOffs + 1
+ ].
+ [offs <= labelArray size] whileTrue:[
+ convertedLabels at:dstOffs put:(labelArray at:offs).
+ argArray at:dstOffs put:offs.
+ offs := offs + 1.
+ dstOffs := dstOffs + 1
+ ].
+ self menu:(MenuView
+ labels:convertedLabels
+ selector:nil
+ args:argArray
+ receiver:nil
+ in:self)
+
+! !
+
+!PopUpMenu methodsFor:'activation'!
+
+showAt:aPoint
+ "realize the menu at aPoint - return control"
+
+ self fixSize.
+ self origin:aPoint.
+ ((top + height) > (device height)) ifTrue:[
+ self top:(device height - height)
+ ].
+ ((left + width) > (device width)) ifTrue:[
+ self left:(device width - width)
+ ].
+ self realize
+!
+
+showAtPointer
+ "realize the menu at the current pointer position - return control"
+
+ self showAt:(device pointerPosition)
+!
+
+show
+ "realize the menu at its last position - return control"
+
+ self fixSize.
+ self realize
+!
+
+hide
+ "hide the menu"
+
+ ^ self unrealize
+! !
+
+!PopUpMenu methodsFor:'ST-80 activation'!
+
+startUp
+ "start the menu modal - return the selected selector,
+ or - if no selectors where specified - the index.
+ If nothing was selected, return 0.
+ Modal - i.e. stay in the menu until finished"
+
+ |actionIndex value|
+
+ menuView action:[:selected |
+ menuView args isNil ifTrue:[
+ menuView selectors isNil ifTrue:[
+ ^ 0
+ ].
+ ^ menuView receiver perform:(menuView selectors at:selected)
+ ].
+ actionIndex := menuView args at:selected.
+ actionIndex isNil ifTrue:[^ 0].
+ actionValues isNil ifTrue:[^ actionIndex].
+ value := actionValues at:actionIndex.
+ (value isKindOf:PopUpMenu) ifTrue:[
+ ^ value startUp
+ ].
+ ^ value
+ ].
+ self showAtPointer.
+ self modalLoop.
+ ^ 0
+! !
+
+!PopUpMenu methodsFor:'events'!
+
+buttonMotion:button x:x y:y
+ (x >= 0) ifTrue:[
+ (x < width) ifTrue:[
+ (y >= 0) ifTrue:[
+ (y < height) ifTrue:[
+ menuView buttonMotion:button x:x y:y.
+ ^ self
+ ]
+ ]
+ ]
+ ].
+ menuView pointerLeave:button.
+ hideOnLeave ifTrue:[
+ self hide
+ ]
+!
+
+pointerLeave:state
+ menuView pointerLeave:state.
+ hideOnLeave ifTrue:[
+ self hide
+ ]
+!
+
+buttonRelease:button x:x y:y
+ self hide.
+ menuView buttonRelease:button x:x y:y
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/PullDMenu.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,461 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+View subclass:#PullDownMenu
+ instanceVariableNames:'menus titles activeMenuNumber
+ showSeparatingLines topMargin
+ fgColor bgColor activeFgColor activeBgColor
+ onLevel offLevel'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Menus'
+!
+
+PullDownMenu comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+
+PullDown menu provides the top (always visible) part of these menus. It controls
+display of its menus, which become visible when one of the PullDownMenus entries is pressed.
+
+Instance variables:
+
+menus <aCollection> the sub menus
+titles <aCollection> the strings in the menu
+activeMenuNumber <Number> the index of the currently active menu
+showSeparatingLines <Boolean> show separating lines between my menu-strings
+topMargin <Number> number of pixels at top
+fgColor <Color> color to draw passive menu-titles
+bgColor <Color> color to draw passive menu-titles
+activeFgColor <Color> color to draw activated menu-titles
+activeBgColor <Color> color to draw activated menu-titles
+
+written summer 89 by claus
+'!
+
+!PullDownMenu class methodsFor:'instance creation'!
+
+labels:titleArray
+ "create and return a new PullDownMenu"
+
+ ^ self new labels:titleArray
+! !
+
+!PullDownMenu methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ font := font on:device.
+ self origin:(0.0 @ 0.0)
+ extent:(1.0 @ (font height + (font descent * 2))).
+!
+
+initStyle
+ super initStyle.
+
+ showSeparatingLines := false.
+ fgColor := Black.
+ bgColor := viewBackground.
+ self is3D ifTrue:[
+ device hasColors ifTrue:[
+ activeFgColor := Color name:'yellow'
+ ] ifFalse:[
+ activeFgColor := White
+ ].
+ device hasGreyscales ifTrue:[
+ activeBgColor := bgColor.
+ ] ifFalse:[
+ activeBgColor := fgColor.
+ ].
+ topMargin := 2
+ ] ifFalse:[
+ activeFgColor := bgColor.
+ activeBgColor := fgColor.
+ topMargin := 0
+ ].
+ onLevel := -1.
+ offLevel := 1
+!
+
+initEvents
+ self enableButtonMotionEvents.
+ self enableButtonEvents
+!
+
+recreate
+ super create.
+ self setMenuOrigins
+!
+
+create
+ super create.
+ self setMenuOrigins
+! !
+
+!PullDownMenu methodsFor:'accessing'!
+
+showSeparatingLines:aBoolean
+ "turn on/off drawing of separating lines"
+
+ showSeparatingLines := aBoolean.
+ shown ifTrue:[
+ self redraw
+ ]
+!
+
+numberOfTitles:n
+ "setup blank title-space to be filled in later"
+
+ menus := Array new:n.
+ titles := Array new:n
+!
+
+labels:titleArray
+ "define the menu-titles (group-headers)"
+
+ |numberOfLabels|
+
+ numberOfLabels := titleArray size.
+ menus := Array new:numberOfLabels.
+ titles := Array new:numberOfLabels.
+ 1 to:numberOfLabels do:[:index |
+ titles at:index put:(titleArray at:index) printString
+ ].
+ shown ifTrue:[
+ self clear.
+ self redraw
+ ]
+!
+
+labels
+ "return the menu-titles (group-headers)"
+
+ ^ titles
+!
+
+font:aFont
+ "adjust menu-origins when font changes"
+
+ super font:aFont.
+ self setMenuOrigins
+!
+
+menuAt:string
+ "return the menu with the title; return nil if not found"
+
+ |index|
+
+ index := self indexOf:string.
+ (index == 0) ifTrue:[^ nil].
+ ^ menus at:index
+!
+
+at:aString putMenu:aMenu
+ "set the menu under the title, aString"
+
+ |index|
+
+ index := self indexOf:aString.
+ (index == 0) ifTrue:[^ nil].
+ aMenu origin:((left + (self titleLenUpTo:index))
+ @
+ (height + aMenu borderWidth)).
+ aMenu hidden:true.
+ menus at:index put:aMenu
+!
+
+at:aString putLabels:labels selectors:selectors args:args receiver:anObject
+ "create and set the menu under the title, aString"
+
+ |menuView|
+
+ menuView := MenuView labels:labels
+ selectors:selectors
+ args:args
+ receiver:anObject
+ for:self.
+ self at:aString putMenu:menuView
+!
+
+at:aString putLabels:labels selector:selector args:args receiver:anObject
+ "create and set the menu under the title, aString"
+
+ |menuView|
+
+ menuView := MenuView labels:labels
+ selector:selector
+ args:args
+ receiver:anObject
+ for:self.
+ self at:aString putMenu:menuView
+!
+
+at:aString putLabels:labels selectors:selectors receiver:anObject
+ "create and set the menu under the title, aString"
+
+ |menuView|
+
+ menuView := MenuView labels:labels
+ selectors:selectors
+ receiver:anObject
+ for:self.
+ self at:aString putMenu:menuView
+! !
+
+!PullDownMenu methodsFor:'private'!
+
+titleLenUpTo:index
+ "answer len of all title-strings up-to (but excluding) title-index"
+
+ |len "{ Class: SmallInteger }" |
+
+ (index <= 1) ifTrue:[^ 0].
+ len := 0.
+ titles from:1 to:(index - 1) do:[:string |
+ len := len + (font widthOf:(' ' , string , ' ')).
+ showSeparatingLines ifTrue:[
+ self is3D ifTrue:[
+ len := len + 2
+ ] ifFalse:[
+ len := len + 1
+ ]
+ ]
+ ].
+ ^ len
+!
+
+indexOf:stringOrNumber
+ "return the index of the menu with title; return 0 if not found"
+
+ (stringOrNumber isMemberOf:SmallInteger) ifTrue:[
+ ^ stringOrNumber
+ ].
+ ^ titles indexOf:stringOrNumber
+!
+
+setMenuOrigins
+ "adjust origins of menus when font changes"
+
+ |index|
+
+ (font device == device) ifTrue:[
+ index := 1.
+ menus do:[:aMenu |
+ aMenu notNil ifTrue:[
+ aMenu origin:((left + (self titleLenUpTo:index))
+ @
+ (height + aMenu borderWidth))
+ ].
+ index := index + 1
+ ]
+ ]
+! !
+
+!PullDownMenu methodsFor:'hiding/showing menus'!
+
+drawTitle:string x:x selected:selected
+ |yText w|
+
+ yText := ((height - (font height)) // 2) + (font ascent) + topMargin.
+ w := font widthOf:string.
+ selected ifTrue:[
+ self paint:activeBgColor
+ ] ifFalse:[
+ self paint:bgColor
+ ].
+ self fillRectangleX:x y:0 width:w height:height.
+
+ self is3D ifTrue:[
+ self drawEdgesForX:x y:0
+ width:w
+ height:height
+ level:(selected ifTrue:[onLevel] ifFalse:[offLevel])
+ ].
+ selected ifTrue:[
+ self paint:activeFgColor
+ ] ifFalse:[
+ self paint:fgColor
+ ].
+ self displayString:string x:x y:yText
+!
+
+highlightActiveTitle
+ |x string|
+ activeMenuNumber notNil ifTrue:[
+ x := self titleLenUpTo:activeMenuNumber.
+ string := ' ' , (titles at:activeMenuNumber) , ' '.
+ self drawTitle:string x:x selected:true
+ ]
+!
+
+unHighlightActiveTitle
+ |x string|
+ activeMenuNumber notNil ifTrue:[
+ x := self titleLenUpTo:activeMenuNumber.
+ string := ' ' , (titles at:activeMenuNumber) , ' '.
+ self drawTitle:string x:x selected:false
+ ]
+!
+
+hideActiveMenu
+ activeMenuNumber notNil ifTrue:[
+ (menus at:activeMenuNumber) unrealize.
+ self unHighlightActiveTitle.
+ activeMenuNumber := nil
+ ]
+!
+
+pullMenu:aNumber
+ "activate a menu"
+
+ |subMenu|
+
+ activeMenuNumber notNil ifTrue:[self hideActiveMenu].
+ subMenu := menus at:aNumber.
+ subMenu notNil ifTrue:[
+ activeMenuNumber := aNumber.
+ self highlightActiveTitle.
+ subMenu deselect.
+ subMenu create.
+ subMenu saveUnder:true.
+ subMenu raise show
+ ]
+! !
+
+!PullDownMenu methodsFor:'events'!
+
+redraw
+ |string
+ x "{ Class: SmallInteger }"
+ y "{ Class: SmallInteger }"
+ index "{ Class: SmallInteger }" |
+
+ shown ifFalse: [ ^ self ].
+ titles isNil ifTrue:[^ self].
+ x := 0.
+ y := height "- 1".
+ index := 0.
+ titles do:[:title |
+ string := ' ' , title , ' '.
+ self drawTitle:string x:x selected:(index == activeMenuNumber).
+ x := x + (font widthOf:string).
+ showSeparatingLines ifTrue:[
+ self is3D ifTrue:[
+ self paint:shadowColor.
+ self displayLineFromX:x y:0 toX:x y:y.
+ x := x + 1.
+ self paint:lightColor.
+ self displayLineFromX:x y:0 toX:x y:y
+ ] ifFalse:[
+ self paint:fgColor.
+ self displayLineFromX:x y:0 toX:x y:y
+ ].
+ x := x + 1
+ ].
+ index := index + 1
+ ]
+!
+
+titleIndexForX:x
+ "given a click x-position, return index in title or nil"
+
+ |string
+ xstart "{ Class: SmallInteger }"
+ xend "{ Class: SmallInteger }" |
+
+ xstart := 0.
+ 1 to:(titles size) do:[:index |
+ string := ' ' , (titles at:index) , ' '.
+ xend := xstart + (font widthOf:string).
+ showSeparatingLines ifTrue:[
+ self is3D ifTrue:[
+ xend := xend + 2
+ ] ifFalse:[
+ xend := xend + 1
+ ]
+ ].
+ (x between:xstart and:xend) ifTrue:[^ index].
+ xstart := xend
+ ].
+ ^ nil
+!
+
+buttonPress:button x:x y:y
+ |titleIndex|
+
+ titleIndex := self titleIndexForX:x.
+ titleIndex notNil ifTrue:[
+ self pullMenu:titleIndex
+ ]
+!
+
+buttonMotion:button x:x y:y
+ |titleIndex activeMenu activeLeft activeTop|
+
+ (y < height) ifTrue:[
+ "moving around in title line"
+ activeMenuNumber notNil ifTrue:[
+ (menus at:activeMenuNumber) selection:nil
+ ].
+ titleIndex := self titleIndexForX:x.
+ titleIndex notNil ifTrue:[
+ (titleIndex ~~ activeMenuNumber) ifTrue:[
+ self hideActiveMenu.
+ self pullMenu:titleIndex
+ ]
+ ]
+ ] ifFalse:[
+ "moving around below"
+ activeMenuNumber isNil ifTrue:[^self].
+ activeMenu := menus at:activeMenuNumber.
+ activeLeft := activeMenu left.
+ (x between:activeLeft and:(activeMenu right)) ifTrue:[
+ activeTop := activeMenu top.
+ (y between:activeTop and:(activeMenu bottom)) ifTrue:[
+ "moving around in menu"
+ activeMenu buttonMotion:button
+ x:(x - activeLeft)
+ y:(y - activeTop).
+ ^ self
+ ]
+ ].
+ "moved outside menu"
+ activeMenu selection:nil
+ ]
+!
+
+buttonRelease:button x:x y:y
+ |activeMenu activeLeft activeTop|
+
+ (y >= height) ifTrue:[
+ "release below title-line"
+ activeMenuNumber isNil ifTrue:[^self].
+ activeMenu := menus at:activeMenuNumber.
+ activeLeft := activeMenu left.
+ (x between:activeLeft and:(activeMenu right)) ifTrue:[
+ activeTop := activeMenu top.
+ (y between:activeTop and:(activeMenu bottom)) ifTrue:[
+ "release in menu"
+ self hideActiveMenu.
+ activeMenu buttonRelease:button
+ x:(x - activeLeft)
+ y:(y - activeTop).
+ ^ self
+ ]
+ ]
+ ].
+ self hideActiveMenu
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/PullDownMenu.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,461 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+View subclass:#PullDownMenu
+ instanceVariableNames:'menus titles activeMenuNumber
+ showSeparatingLines topMargin
+ fgColor bgColor activeFgColor activeBgColor
+ onLevel offLevel'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Menus'
+!
+
+PullDownMenu comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+
+PullDown menu provides the top (always visible) part of these menus. It controls
+display of its menus, which become visible when one of the PullDownMenus entries is pressed.
+
+Instance variables:
+
+menus <aCollection> the sub menus
+titles <aCollection> the strings in the menu
+activeMenuNumber <Number> the index of the currently active menu
+showSeparatingLines <Boolean> show separating lines between my menu-strings
+topMargin <Number> number of pixels at top
+fgColor <Color> color to draw passive menu-titles
+bgColor <Color> color to draw passive menu-titles
+activeFgColor <Color> color to draw activated menu-titles
+activeBgColor <Color> color to draw activated menu-titles
+
+written summer 89 by claus
+'!
+
+!PullDownMenu class methodsFor:'instance creation'!
+
+labels:titleArray
+ "create and return a new PullDownMenu"
+
+ ^ self new labels:titleArray
+! !
+
+!PullDownMenu methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ font := font on:device.
+ self origin:(0.0 @ 0.0)
+ extent:(1.0 @ (font height + (font descent * 2))).
+!
+
+initStyle
+ super initStyle.
+
+ showSeparatingLines := false.
+ fgColor := Black.
+ bgColor := viewBackground.
+ self is3D ifTrue:[
+ device hasColors ifTrue:[
+ activeFgColor := Color name:'yellow'
+ ] ifFalse:[
+ activeFgColor := White
+ ].
+ device hasGreyscales ifTrue:[
+ activeBgColor := bgColor.
+ ] ifFalse:[
+ activeBgColor := fgColor.
+ ].
+ topMargin := 2
+ ] ifFalse:[
+ activeFgColor := bgColor.
+ activeBgColor := fgColor.
+ topMargin := 0
+ ].
+ onLevel := -1.
+ offLevel := 1
+!
+
+initEvents
+ self enableButtonMotionEvents.
+ self enableButtonEvents
+!
+
+recreate
+ super create.
+ self setMenuOrigins
+!
+
+create
+ super create.
+ self setMenuOrigins
+! !
+
+!PullDownMenu methodsFor:'accessing'!
+
+showSeparatingLines:aBoolean
+ "turn on/off drawing of separating lines"
+
+ showSeparatingLines := aBoolean.
+ shown ifTrue:[
+ self redraw
+ ]
+!
+
+numberOfTitles:n
+ "setup blank title-space to be filled in later"
+
+ menus := Array new:n.
+ titles := Array new:n
+!
+
+labels:titleArray
+ "define the menu-titles (group-headers)"
+
+ |numberOfLabels|
+
+ numberOfLabels := titleArray size.
+ menus := Array new:numberOfLabels.
+ titles := Array new:numberOfLabels.
+ 1 to:numberOfLabels do:[:index |
+ titles at:index put:(titleArray at:index) printString
+ ].
+ shown ifTrue:[
+ self clear.
+ self redraw
+ ]
+!
+
+labels
+ "return the menu-titles (group-headers)"
+
+ ^ titles
+!
+
+font:aFont
+ "adjust menu-origins when font changes"
+
+ super font:aFont.
+ self setMenuOrigins
+!
+
+menuAt:string
+ "return the menu with the title; return nil if not found"
+
+ |index|
+
+ index := self indexOf:string.
+ (index == 0) ifTrue:[^ nil].
+ ^ menus at:index
+!
+
+at:aString putMenu:aMenu
+ "set the menu under the title, aString"
+
+ |index|
+
+ index := self indexOf:aString.
+ (index == 0) ifTrue:[^ nil].
+ aMenu origin:((left + (self titleLenUpTo:index))
+ @
+ (height + aMenu borderWidth)).
+ aMenu hidden:true.
+ menus at:index put:aMenu
+!
+
+at:aString putLabels:labels selectors:selectors args:args receiver:anObject
+ "create and set the menu under the title, aString"
+
+ |menuView|
+
+ menuView := MenuView labels:labels
+ selectors:selectors
+ args:args
+ receiver:anObject
+ for:self.
+ self at:aString putMenu:menuView
+!
+
+at:aString putLabels:labels selector:selector args:args receiver:anObject
+ "create and set the menu under the title, aString"
+
+ |menuView|
+
+ menuView := MenuView labels:labels
+ selector:selector
+ args:args
+ receiver:anObject
+ for:self.
+ self at:aString putMenu:menuView
+!
+
+at:aString putLabels:labels selectors:selectors receiver:anObject
+ "create and set the menu under the title, aString"
+
+ |menuView|
+
+ menuView := MenuView labels:labels
+ selectors:selectors
+ receiver:anObject
+ for:self.
+ self at:aString putMenu:menuView
+! !
+
+!PullDownMenu methodsFor:'private'!
+
+titleLenUpTo:index
+ "answer len of all title-strings up-to (but excluding) title-index"
+
+ |len "{ Class: SmallInteger }" |
+
+ (index <= 1) ifTrue:[^ 0].
+ len := 0.
+ titles from:1 to:(index - 1) do:[:string |
+ len := len + (font widthOf:(' ' , string , ' ')).
+ showSeparatingLines ifTrue:[
+ self is3D ifTrue:[
+ len := len + 2
+ ] ifFalse:[
+ len := len + 1
+ ]
+ ]
+ ].
+ ^ len
+!
+
+indexOf:stringOrNumber
+ "return the index of the menu with title; return 0 if not found"
+
+ (stringOrNumber isMemberOf:SmallInteger) ifTrue:[
+ ^ stringOrNumber
+ ].
+ ^ titles indexOf:stringOrNumber
+!
+
+setMenuOrigins
+ "adjust origins of menus when font changes"
+
+ |index|
+
+ (font device == device) ifTrue:[
+ index := 1.
+ menus do:[:aMenu |
+ aMenu notNil ifTrue:[
+ aMenu origin:((left + (self titleLenUpTo:index))
+ @
+ (height + aMenu borderWidth))
+ ].
+ index := index + 1
+ ]
+ ]
+! !
+
+!PullDownMenu methodsFor:'hiding/showing menus'!
+
+drawTitle:string x:x selected:selected
+ |yText w|
+
+ yText := ((height - (font height)) // 2) + (font ascent) + topMargin.
+ w := font widthOf:string.
+ selected ifTrue:[
+ self paint:activeBgColor
+ ] ifFalse:[
+ self paint:bgColor
+ ].
+ self fillRectangleX:x y:0 width:w height:height.
+
+ self is3D ifTrue:[
+ self drawEdgesForX:x y:0
+ width:w
+ height:height
+ level:(selected ifTrue:[onLevel] ifFalse:[offLevel])
+ ].
+ selected ifTrue:[
+ self paint:activeFgColor
+ ] ifFalse:[
+ self paint:fgColor
+ ].
+ self displayString:string x:x y:yText
+!
+
+highlightActiveTitle
+ |x string|
+ activeMenuNumber notNil ifTrue:[
+ x := self titleLenUpTo:activeMenuNumber.
+ string := ' ' , (titles at:activeMenuNumber) , ' '.
+ self drawTitle:string x:x selected:true
+ ]
+!
+
+unHighlightActiveTitle
+ |x string|
+ activeMenuNumber notNil ifTrue:[
+ x := self titleLenUpTo:activeMenuNumber.
+ string := ' ' , (titles at:activeMenuNumber) , ' '.
+ self drawTitle:string x:x selected:false
+ ]
+!
+
+hideActiveMenu
+ activeMenuNumber notNil ifTrue:[
+ (menus at:activeMenuNumber) unrealize.
+ self unHighlightActiveTitle.
+ activeMenuNumber := nil
+ ]
+!
+
+pullMenu:aNumber
+ "activate a menu"
+
+ |subMenu|
+
+ activeMenuNumber notNil ifTrue:[self hideActiveMenu].
+ subMenu := menus at:aNumber.
+ subMenu notNil ifTrue:[
+ activeMenuNumber := aNumber.
+ self highlightActiveTitle.
+ subMenu deselect.
+ subMenu create.
+ subMenu saveUnder:true.
+ subMenu raise show
+ ]
+! !
+
+!PullDownMenu methodsFor:'events'!
+
+redraw
+ |string
+ x "{ Class: SmallInteger }"
+ y "{ Class: SmallInteger }"
+ index "{ Class: SmallInteger }" |
+
+ shown ifFalse: [ ^ self ].
+ titles isNil ifTrue:[^ self].
+ x := 0.
+ y := height "- 1".
+ index := 0.
+ titles do:[:title |
+ string := ' ' , title , ' '.
+ self drawTitle:string x:x selected:(index == activeMenuNumber).
+ x := x + (font widthOf:string).
+ showSeparatingLines ifTrue:[
+ self is3D ifTrue:[
+ self paint:shadowColor.
+ self displayLineFromX:x y:0 toX:x y:y.
+ x := x + 1.
+ self paint:lightColor.
+ self displayLineFromX:x y:0 toX:x y:y
+ ] ifFalse:[
+ self paint:fgColor.
+ self displayLineFromX:x y:0 toX:x y:y
+ ].
+ x := x + 1
+ ].
+ index := index + 1
+ ]
+!
+
+titleIndexForX:x
+ "given a click x-position, return index in title or nil"
+
+ |string
+ xstart "{ Class: SmallInteger }"
+ xend "{ Class: SmallInteger }" |
+
+ xstart := 0.
+ 1 to:(titles size) do:[:index |
+ string := ' ' , (titles at:index) , ' '.
+ xend := xstart + (font widthOf:string).
+ showSeparatingLines ifTrue:[
+ self is3D ifTrue:[
+ xend := xend + 2
+ ] ifFalse:[
+ xend := xend + 1
+ ]
+ ].
+ (x between:xstart and:xend) ifTrue:[^ index].
+ xstart := xend
+ ].
+ ^ nil
+!
+
+buttonPress:button x:x y:y
+ |titleIndex|
+
+ titleIndex := self titleIndexForX:x.
+ titleIndex notNil ifTrue:[
+ self pullMenu:titleIndex
+ ]
+!
+
+buttonMotion:button x:x y:y
+ |titleIndex activeMenu activeLeft activeTop|
+
+ (y < height) ifTrue:[
+ "moving around in title line"
+ activeMenuNumber notNil ifTrue:[
+ (menus at:activeMenuNumber) selection:nil
+ ].
+ titleIndex := self titleIndexForX:x.
+ titleIndex notNil ifTrue:[
+ (titleIndex ~~ activeMenuNumber) ifTrue:[
+ self hideActiveMenu.
+ self pullMenu:titleIndex
+ ]
+ ]
+ ] ifFalse:[
+ "moving around below"
+ activeMenuNumber isNil ifTrue:[^self].
+ activeMenu := menus at:activeMenuNumber.
+ activeLeft := activeMenu left.
+ (x between:activeLeft and:(activeMenu right)) ifTrue:[
+ activeTop := activeMenu top.
+ (y between:activeTop and:(activeMenu bottom)) ifTrue:[
+ "moving around in menu"
+ activeMenu buttonMotion:button
+ x:(x - activeLeft)
+ y:(y - activeTop).
+ ^ self
+ ]
+ ].
+ "moved outside menu"
+ activeMenu selection:nil
+ ]
+!
+
+buttonRelease:button x:x y:y
+ |activeMenu activeLeft activeTop|
+
+ (y >= height) ifTrue:[
+ "release below title-line"
+ activeMenuNumber isNil ifTrue:[^self].
+ activeMenu := menus at:activeMenuNumber.
+ activeLeft := activeMenu left.
+ (x between:activeLeft and:(activeMenu right)) ifTrue:[
+ activeTop := activeMenu top.
+ (y between:activeTop and:(activeMenu bottom)) ifTrue:[
+ "release in menu"
+ self hideActiveMenu.
+ activeMenu buttonRelease:button
+ x:(x - activeLeft)
+ y:(y - activeTop).
+ ^ self
+ ]
+ ]
+ ].
+ self hideActiveMenu
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/RButtGrp.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,53 @@
+"
+ COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+VariableArray subclass:#RadioButtonGroup
+ instanceVariableNames:'buttonGroup'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Support'
+!
+
+RadioButtonGroup comment:'
+
+COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+RadioButtonGroups controll the interaction between RadioButtons
+turning off other button(s) when one of the group is pressed.
+
+@(#)RButtGrp.st 3.1 92/08/23
+written nov 91 by claus
+'!
+
+!RadioButtonGroup methodsFor:'adding / removing'!
+
+add:aRadioButton
+ super add:aRadioButton.
+ aRadioButton addDependent:self
+! !
+
+!RadioButtonGroup methodsFor:'update'!
+
+update:changedButton
+ "a RadioButton in this group has changed - notify the others"
+
+ self do:[:aButton |
+ (aButton == changedButton) ifFalse:[
+ aButton isOn ifTrue:[
+ aButton turnOff
+ ]
+ ]
+ ]
+
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/RButton.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,61 @@
+"
+ COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Toggle subclass:#RadioButton
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+RadioButton comment:'
+
+COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+like a Toggle, but do not turn off when pressed again, instead only
+turn off when another RadioButton is pressed (see RadioButtonGroup).
+
+@(#)RButton.st 3.1 92/08/23
+written fall 91 by claus
+'!
+
+!RadioButton methodsFor:'destroying'!
+
+destroy
+ self release.
+ super destroy
+! !
+
+!RadioButton methodsFor:'changing state'!
+
+toggle
+ "in addition to toggling, notify RadioButtonGroup"
+
+ enabled ifTrue:[
+ super toggle.
+ pressed ifTrue:[
+ self changed
+ ]
+ ]
+! !
+
+!RadioButton methodsFor:'events'!
+
+buttonPress:button x:x y:y
+ "radiobuttons change only off-to-on; turning off is done by other
+ buttons"
+
+ pressed ifFalse:[
+ self toggle
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/RadioButton.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,61 @@
+"
+ COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Toggle subclass:#RadioButton
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+RadioButton comment:'
+
+COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+like a Toggle, but do not turn off when pressed again, instead only
+turn off when another RadioButton is pressed (see RadioButtonGroup).
+
+@(#)RButton.st 3.1 92/08/23
+written fall 91 by claus
+'!
+
+!RadioButton methodsFor:'destroying'!
+
+destroy
+ self release.
+ super destroy
+! !
+
+!RadioButton methodsFor:'changing state'!
+
+toggle
+ "in addition to toggling, notify RadioButtonGroup"
+
+ enabled ifTrue:[
+ super toggle.
+ pressed ifTrue:[
+ self changed
+ ]
+ ]
+! !
+
+!RadioButton methodsFor:'events'!
+
+buttonPress:button x:x y:y
+ "radiobuttons change only off-to-on; turning off is done by other
+ buttons"
+
+ pressed ifFalse:[
+ self toggle
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/RadioButtonGroup.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,53 @@
+"
+ COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+VariableArray subclass:#RadioButtonGroup
+ instanceVariableNames:'buttonGroup'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Support'
+!
+
+RadioButtonGroup comment:'
+
+COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+RadioButtonGroups controll the interaction between RadioButtons
+turning off other button(s) when one of the group is pressed.
+
+@(#)RButtGrp.st 3.1 92/08/23
+written nov 91 by claus
+'!
+
+!RadioButtonGroup methodsFor:'adding / removing'!
+
+add:aRadioButton
+ super add:aRadioButton.
+ aRadioButton addDependent:self
+! !
+
+!RadioButtonGroup methodsFor:'update'!
+
+update:changedButton
+ "a RadioButton in this group has changed - notify the others"
+
+ self do:[:aButton |
+ (aButton == changedButton) ifFalse:[
+ aButton isOn ifTrue:[
+ aButton turnOff
+ ]
+ ]
+ ]
+
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ScrView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,259 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+View subclass:#ScrollableView
+ instanceVariableNames:'scrolledView scrollBar helpView innerMargin'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Basic'
+!
+
+ScrollableView comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+a view containing a scrollbar and some other (slave-)view
+
+%W% %E%
+
+written spring 89 by claus
+'!
+
+!ScrollableView class methodsFor:'instance creation'!
+
+in:aView
+ ^ self for:nil in:aView
+!
+
+for:aViewClass
+ ^ self for:aViewClass in:nil
+!
+
+for:aViewClass in:aView
+ |newView|
+
+ newView := self basicNew.
+ aView notNil ifTrue:[
+ newView device:(aView device).
+ aView addSubView:newView
+ ] ifFalse:[
+ newView device:Display
+ ].
+ newView initializeFor:aViewClass.
+ ^ newView
+! !
+
+!ScrollableView methodsFor:'initialization'!
+
+initialize
+ ^ self initializeFor:nil
+!
+
+initializeFor:aViewClass
+ |negativeOffset twoMargins halfMargin|
+
+ super initialize.
+
+ innerMargin := ViewSpacing.
+ negativeOffset := borderWidth negated.
+
+ "create the scrollbar"
+
+ scrollBar := ScrollBar in:self.
+ scrollBar thumbOrigin:0 thumbHeight:100.
+ scrollBar scrollAction:[:position |
+ scrolledView scrollVerticalToPercent:position
+ ].
+ scrollBar scrollUpAction:[scrolledView scrollUp].
+ scrollBar scrollDownAction:[scrolledView scrollDown].
+
+ "create the subview"
+ self is3D ifTrue:[
+ twoMargins := innerMargin * 2.
+ halfMargin := innerMargin // 2.
+
+ scrollBar origin:(halfMargin @ halfMargin)
+ extent:[scrollBar extent x @ (height - innerMargin)].
+
+ helpView := View in:self.
+ helpView origin:((scrollBar origin x + scrollBar width + innerMargin)
+ @
+ halfMargin)
+ extent:[(width - scrollBar width - twoMargins) @ (height - innerMargin)].
+
+ aViewClass notNil ifTrue:[
+ scrolledView := aViewClass in:helpView.
+ scrolledView origin:(helpView level abs @ helpView level abs)
+ extent:[(helpView width - helpView level abs - helpView level abs)
+ @
+ (helpView height - helpView level abs - helpView level abs)].
+ helpView viewBackground:(scrolledView viewBackground).
+ scrolledView level:-1
+ ]
+ ] ifFalse:[
+ (style == #mswindows) ifTrue:[
+ scrollBar origin:[width - scrollBar extent x
+ - scrollBar borderWidth
+ @
+ negativeOffset]
+ ] ifFalse:[
+ scrollBar origin:(negativeOffset @ negativeOffset)
+ ].
+ scrollBar extent:[scrollBar extent x @ (height "+ (scrollBar borderWidth * 1)")].
+
+ aViewClass notNil ifTrue:[
+ scrolledView := aViewClass in:self.
+ (style == #mswindows) ifTrue:[
+ scrolledView origin:scrolledView borderWidth negated
+ @
+ scrolledView borderWidth negated
+ ] ifFalse:[
+ scrolledView origin:((scrollBar width + scrollBar borderWidth
+ - scrolledView borderWidth)
+ @
+ scrolledView borderWidth negated)
+ ].
+ scrolledView extent:[(width - scrollBar width
+ - scrolledView borderWidth)
+ @
+ (height + (scrollBar borderWidth))
+ ]
+ ].
+ ].
+ scrolledView notNil ifTrue:[
+ scrolledView
+ originChangeAction:[:aView | scrollBar setThumbOriginFor:aView].
+ scrolledView
+ contentsChangeAction:[:aView | scrollBar setThumbFor:aView]
+ ]
+!
+
+realize
+ super realize.
+ "since scrolledview may have done something to its contents
+ during init-time we had no chance yet to catch contents-
+ changes; do it now
+ "
+ scrollBar setThumbFor:scrolledView
+! !
+
+!ScrollableView methodsFor:'accessing'!
+
+scrollBar
+ "return the scrollbar"
+
+ ^ scrollBar
+!
+
+scrolledView
+ "return the scrolled view"
+
+ ^ scrolledView
+!
+
+scrolledView:aView
+ |m m2 b|
+
+ scrolledView notNil ifTrue:[
+ self error:'can only scroll one view'
+ ].
+ scrolledView := aView.
+
+ b := scrolledView borderWidth.
+ self is3D ifTrue:[
+ m := helpView margin.
+ m2 := m * 2.
+
+ helpView addSubView:scrolledView.
+ scrolledView origin:(m @ m)
+ extent:[(helpView width - m2) @ (helpView height - m2)].
+ scrolledView superViewChangedSize.
+ helpView viewBackground:(scrolledView viewBackground).
+ scrolledView level:-1
+ ] ifFalse:[
+ self addSubView:scrolledView.
+ scrolledView origin:((scrollBar width + scrollBar borderWidth - b) @ b negated)
+ extent:[(width - scrollBar width - b) @ (height + scrollBar borderWidth)
+ ].
+ scrolledView superViewChangedSize.
+ ].
+ scrolledView
+ originChangeAction:[:aView | scrollBar setThumbOriginFor:aView].
+ scrolledView
+ contentsChangeAction:[:aView | scrollBar setThumbFor:aView].
+
+ realized ifTrue:[scrolledView realize]
+! !
+
+!ScrollableView methodsFor:'slave-view messages'!
+
+cursor
+ scrolledView isNil ifTrue:[
+ ^ super cursor
+ ].
+ ^ scrolledView cursor
+!
+
+cursor:aCursor
+ "I have the same cursor as my scrolledView"
+
+ scrolledView cursor:aCursor.
+ super cursor:aCursor
+!
+
+leftButtonMenu
+ ^ scrolledView leftButtonMenu
+!
+
+leftButtonMenu:aMenu
+ "pass on leftbuttonmenu to scrolledView"
+
+ scrolledView leftButtonMenu:aMenu
+!
+
+middleButtonMenu
+ ^ scrolledView middleButtonMenu
+!
+
+middleButtonMenu:aMenu
+ "pass on middlebuttonmenu to scrolledView"
+
+ scrolledView middleButtonMenu:aMenu
+!
+
+rightButtonMenu
+ ^ scrolledView rightButtonMenu
+!
+
+rightButtonMenu:aMenu
+ "pass on rightbuttonmenu to scrolledView"
+
+ scrolledView rightButtonMenu:aMenu
+!
+
+doesNotUnderstand:aMessage
+ "this is funny: all message we do not understand, are passed
+ on to the scrolledView - so we do not have to care for all
+ possible messages ...(thanks to the Message class)"
+
+ scrolledView isNil ifFalse:[
+ ^ scrolledView perform:(aMessage selector)
+ withArguments:(aMessage arguments)
+ ]
+! !
+
+!ScrollableView methodsFor:'event processing'!
+
+sizeChanged:how
+ super sizeChanged:how.
+ scrollBar setThumbFor:scrolledView
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ScrollBar.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,395 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+View subclass:#ScrollBar
+ instanceVariableNames:'thumb button1 button2 layout'
+ classVariableNames:'defaultScrollUpForm
+ defaultScrollDownForm
+ defaultLayout'
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+ScrollBar comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+this class implements vertical scrollbars with scroller and
+2 step-scroll buttons. when moved or stepped, it performs a
+predefined action.
+
+%W% %E%
+
+written spring/summer 89 by claus
+'!
+
+!ScrollBar class methodsFor:'initialization'!
+
+initialize
+ "read defaults"
+
+ super initialize.
+
+ "layout controls how buttons are positioned:
+ #top puts them at top/left
+ #bottom puts them at bottom/right
+ #around puts them around thumb
+ "
+ defaultLayout := Resources at:'LAYOUT' default:#around
+! !
+
+!ScrollBar class methodsFor:'defaults'!
+
+scrollUpButtonForm:style
+ "answer the form used for the scrollUp Button"
+
+ defaultScrollUpForm isNil ifTrue:[
+ defaultScrollUpForm := Form fromFile:(Resources at:'UP_BUTTON_FORM_FILE'
+ default:(style == #mswindows
+ ifTrue:['ScrollUp_win.xbm']
+ ifFalse:['ScrollUp.xbm'])
+ )
+ resolution:100
+ ].
+ defaultScrollUpForm isNil ifTrue:[
+ defaultScrollUpForm := Form width:16 height:16
+ fromArray:#(2r00000000 2r00000000
+ 2r00000001 2r10000000
+ 2r00000010 2r01000000
+ 2r00000100 2r00100000
+ 2r00001000 2r00010000
+ 2r00010000 2r00001000
+ 2r00100000 2r00000100
+ 2r01000000 2r00000010
+ 2r01111000 2r00011110
+ 2r00001000 2r00010000
+ 2r00001000 2r00010000
+ 2r00001000 2r00010000
+ 2r00001000 2r00010000
+ 2r00001000 2r00010000
+ 2r00001111 2r11110000
+ 2r00000000 2r00000000)
+ ].
+ ^ defaultScrollUpForm
+!
+
+scrollDownButtonForm:style
+ "retun the form used for the scrollDown Button"
+
+ defaultScrollDownForm isNil ifTrue:[
+ defaultScrollDownForm := Form fromFile:(Resources at:'DOWN_BUTTON_FORM_FILE'
+ default:(style == #mswindows
+ ifTrue:['ScrollDn_win.xbm']
+ ifFalse:['ScrollDn.xbm'])
+ )
+ resolution:100
+ ].
+ defaultScrollDownForm isNil ifTrue:[
+ defaultScrollDownForm := Form width:16 height:16
+ fromArray:#(2r00000000 2r00000000
+ 2r00001111 2r11110000
+ 2r00001000 2r00010000
+ 2r00001000 2r00010000
+ 2r00001000 2r00010000
+ 2r00001000 2r00010000
+ 2r00001000 2r00010000
+ 2r01111000 2r00011110
+ 2r01000000 2r00000010
+ 2r00100000 2r00000100
+ 2r00010000 2r00001000
+ 2r00001000 2r00010000
+ 2r00000100 2r00100000
+ 2r00000010 2r01000000
+ 2r00000001 2r10000000
+ 2r00000000 2r00000000)
+ ].
+ ^ defaultScrollDownForm
+! !
+
+!ScrollBar class methodsFor:'style changes'!
+
+styleChange
+ defaultScrollUpForm := nil.
+ defaultScrollDownForm := nil
+
+ "ScrollBar styleChange"
+! !
+
+!ScrollBar methodsFor:'initialization'!
+
+initialize
+ "setup; create the 2 buttons and a scroller"
+
+ |bwn sep w h upForm downForm c|
+
+ super initialize.
+
+ "compute my extent from sub-components"
+ upForm := self class scrollUpButtonForm:style.
+ downForm := self class scrollDownButtonForm:style.
+ h := upForm height + downForm height +
+ (1 "self defaultBorderWidth" * 2) + (Scroller defaultExtent y).
+ w := (upForm width) max:(downForm width).
+ self is3D ifTrue:[
+ h := h + 4.
+ w := w + 4
+ ].
+ self extent:w @ h.
+
+ style == #mswindows ifTrue:[
+ layout := #around
+ ] ifFalse:[
+ layout := defaultLayout
+ ].
+
+ bwn := borderWidth negated.
+ self is3D ifTrue:[
+ sep := 1
+ ] ifFalse:[
+ sep := 0
+ ].
+
+ button1 := Button form:(self class scrollUpButtonForm:style) in:self.
+ button1 name:'UpButton'.
+ button1 borderWidth:borderWidth.
+ button1 autoRepeat.
+
+ thumb := Scroller in:self.
+ style ~~ #next ifTrue:[
+ thumb borderWidth:borderWidth.
+ ].
+
+ button2 := Button form:(self class scrollDownButtonForm:style) in:self.
+ button2 name:'DownButton'.
+ button2 borderWidth:borderWidth.
+ button2 autoRepeat.
+
+ ((style == #iris) and:[Display hasGreyscales])ifTrue:[
+ "have to change some of Buttons defaults"
+ c := (Color grey:25) on:device.
+ button1 offLevel:2.
+ button2 offLevel:2.
+ button1 foregroundColor:c.
+ button1 activeForegroundColor:c.
+ button1 enteredForegroundColor:c.
+ button2 foregroundColor:c.
+ button2 activeForegroundColor:c.
+ button2 enteredForegroundColor:c.
+ ].
+
+ (layout == #top) ifTrue:[
+ button1 origin:(bwn @ bwn).
+ button1 viewGravity:#North.
+ button2 origin:(bwn @ (button1 height)).
+ button2 viewGravity:#North.
+ thumb origin:(bwn @ (button1 height + borderWidth + button2 height + sep + sep)).
+ thumb viewGravity:#North
+ ] ifFalse:[
+ (layout == #bottom) ifTrue:[
+ button1 viewGravity:#North.
+ button2 viewGravity:#North.
+ thumb origin:(bwn @ bwn).
+ thumb viewGravity:#North
+ ] ifFalse:[
+ button1 origin:(bwn @ bwn).
+ button1 viewGravity:#North.
+ button2 viewGravity:#North.
+ thumb origin:(bwn @ (button1 height + sep)).
+ thumb viewGravity:#North
+ ]
+ ]
+! !
+
+!ScrollBar methodsFor:'accessing'!
+
+scrollAction:aBlock
+ "set the action, aBlock to be performed when the scroller is moved"
+
+ thumb scrollAction:aBlock
+!
+
+scrollUpAction:aBlock
+ "set the action, aBlock to be performed when the up-button is pressed"
+
+ button1 action:aBlock
+!
+
+scrollDownAction:aBlock
+ "set the action, aBlock to be performed when the down-button is pressed"
+
+ button2 action:aBlock
+!
+
+thumbColor:aColor
+ thumb thumbColor:aColor
+!
+
+thumbOrigin
+ "answer position of (top of) thumb in percent"
+
+ ^ thumb thumbOrigin
+!
+
+thumbOrigin:newOrigin
+ "set position of (top of) thumb in percent"
+
+ ^ thumb thumbOrigin:newOrigin
+!
+
+thumbHeight
+ "answer height of thumb in percent"
+
+ ^ thumb thumbHeight
+!
+
+thumbHeight:newHeight
+ "set height of thumb in percent"
+
+ ^ thumb thumbHeight:newHeight
+!
+
+thumbOrigin:newOrigin thumbHeight:newHeight
+ "set origin and height of thumb in percent"
+
+ ^ thumb thumbOrigin:newOrigin thumbHeight:newHeight
+!
+
+setThumbFor:aView
+ "adjust thumb for aView"
+
+ thumb setThumbFor:aView
+!
+
+setThumbHeightFor:aView
+ "adjust thumbs height for aView"
+
+ thumb setThumbHeightFor:aView
+!
+
+setThumbOriginFor:aView
+ "adjust thumbs origin for aView"
+
+ thumb setThumbOriginFor:aView
+!
+
+asynchronousOperation
+ "set asynchronous-mode - scroll action is performed after movement
+ of scroller (i.e. when mouse-button is finally released)"
+
+ thumb asynchronousOperation
+!
+
+synchronousOperation
+ "set synchronous-mode - scroll action is performed for every movement
+ of scroller"
+
+ thumb synchronousOperation
+! !
+
+!ScrollBar methodsFor:'events'!
+
+sizeChanged:how
+ "when my size changes, I have to resize/reposition the subviews"
+
+ |upHeight downHeight thumbHeight upAndDownHeight bwn sep sep2
+ thumbWidth|
+
+ button1 isNil ifTrue:[^ self].
+ thumb isNil ifTrue:[^ self].
+ button2 isNil ifTrue:[^ self].
+
+ upHeight := button1 height + borderWidth.
+ downHeight := button2 height + borderWidth.
+ upAndDownHeight := upHeight + downHeight.
+ bwn := borderWidth negated.
+ self is3D ifTrue:[
+ sep := 1
+ ] ifFalse:[
+ sep := 0
+ ].
+
+ thumbHeight := height - upAndDownHeight - borderWidth - (sep * 3).
+ ((layout ~~ #top) and:[layout ~~ #bottom]) ifTrue:[
+ thumbHeight := thumbHeight - borderWidth
+ ].
+
+ "if I become too small, hide buttons and thumb"
+
+ height < (upHeight + downHeight) ifTrue:[
+ button1 shown ifTrue:[
+ button1 hidden.
+ button2 hidden.
+ thumb hidden
+ ]
+ ] ifFalse:[
+ shown ifTrue:[
+ button1 shown ifFalse:[
+ button1 show.
+ button2 show.
+ thumb show
+ ]
+ ]
+ ].
+
+ (thumbHeight < 10) ifTrue:[
+ thumb shown ifTrue:[
+ thumb hidden
+ ]
+ ] ifFalse:[
+ thumb shown ifFalse:[
+ button1 shown ifTrue:[
+ thumb show
+ ]
+ ]
+ ].
+
+ "width of buttons is always my width"
+
+ (width ~~ button1 width) ifTrue:[
+ button1 width:width.
+ button2 width:width
+ ].
+
+ thumbWidth := width.
+ style == #next ifTrue:[
+ thumbWidth := thumbWidth - (thumb borderWidth * 2).
+ thumbHeight := thumbHeight - 1
+ ].
+
+ (layout == #top) ifTrue:[
+ "buttons at top"
+ thumb extent:(thumbWidth @ thumbHeight).
+ ^ self
+ ].
+
+ sep2 := sep * 2.
+ (layout == #bottom) ifTrue:[
+ "buttons at bottom"
+ thumbHeight := thumbHeight + borderWidth.
+ (how == #smaller) ifTrue:[
+ thumb extent:(thumbWidth @ thumbHeight).
+ button1 origin:(bwn @ (thumbHeight + sep2)).
+ button2 origin:(bwn @ (thumbHeight + sep2 + upHeight))
+ ] ifFalse:[
+ button1 origin:(bwn @ (thumbHeight + sep2)).
+ button2 origin:(bwn @ (thumbHeight + sep2 + upHeight)).
+ thumb extent:(thumbWidth @ thumbHeight)
+ ].
+ ^ self
+ ].
+ "buttons around thumb"
+
+ button2 origin:(bwn @ (upHeight + thumbHeight + sep2 + borderWidth)).
+ thumb extent:(thumbWidth @ thumbHeight).
+ thumb origin:(bwn @ (upHeight - borderWidth + sep))
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/ScrollableView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,259 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+View subclass:#ScrollableView
+ instanceVariableNames:'scrolledView scrollBar helpView innerMargin'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Basic'
+!
+
+ScrollableView comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+a view containing a scrollbar and some other (slave-)view
+
+%W% %E%
+
+written spring 89 by claus
+'!
+
+!ScrollableView class methodsFor:'instance creation'!
+
+in:aView
+ ^ self for:nil in:aView
+!
+
+for:aViewClass
+ ^ self for:aViewClass in:nil
+!
+
+for:aViewClass in:aView
+ |newView|
+
+ newView := self basicNew.
+ aView notNil ifTrue:[
+ newView device:(aView device).
+ aView addSubView:newView
+ ] ifFalse:[
+ newView device:Display
+ ].
+ newView initializeFor:aViewClass.
+ ^ newView
+! !
+
+!ScrollableView methodsFor:'initialization'!
+
+initialize
+ ^ self initializeFor:nil
+!
+
+initializeFor:aViewClass
+ |negativeOffset twoMargins halfMargin|
+
+ super initialize.
+
+ innerMargin := ViewSpacing.
+ negativeOffset := borderWidth negated.
+
+ "create the scrollbar"
+
+ scrollBar := ScrollBar in:self.
+ scrollBar thumbOrigin:0 thumbHeight:100.
+ scrollBar scrollAction:[:position |
+ scrolledView scrollVerticalToPercent:position
+ ].
+ scrollBar scrollUpAction:[scrolledView scrollUp].
+ scrollBar scrollDownAction:[scrolledView scrollDown].
+
+ "create the subview"
+ self is3D ifTrue:[
+ twoMargins := innerMargin * 2.
+ halfMargin := innerMargin // 2.
+
+ scrollBar origin:(halfMargin @ halfMargin)
+ extent:[scrollBar extent x @ (height - innerMargin)].
+
+ helpView := View in:self.
+ helpView origin:((scrollBar origin x + scrollBar width + innerMargin)
+ @
+ halfMargin)
+ extent:[(width - scrollBar width - twoMargins) @ (height - innerMargin)].
+
+ aViewClass notNil ifTrue:[
+ scrolledView := aViewClass in:helpView.
+ scrolledView origin:(helpView level abs @ helpView level abs)
+ extent:[(helpView width - helpView level abs - helpView level abs)
+ @
+ (helpView height - helpView level abs - helpView level abs)].
+ helpView viewBackground:(scrolledView viewBackground).
+ scrolledView level:-1
+ ]
+ ] ifFalse:[
+ (style == #mswindows) ifTrue:[
+ scrollBar origin:[width - scrollBar extent x
+ - scrollBar borderWidth
+ @
+ negativeOffset]
+ ] ifFalse:[
+ scrollBar origin:(negativeOffset @ negativeOffset)
+ ].
+ scrollBar extent:[scrollBar extent x @ (height "+ (scrollBar borderWidth * 1)")].
+
+ aViewClass notNil ifTrue:[
+ scrolledView := aViewClass in:self.
+ (style == #mswindows) ifTrue:[
+ scrolledView origin:scrolledView borderWidth negated
+ @
+ scrolledView borderWidth negated
+ ] ifFalse:[
+ scrolledView origin:((scrollBar width + scrollBar borderWidth
+ - scrolledView borderWidth)
+ @
+ scrolledView borderWidth negated)
+ ].
+ scrolledView extent:[(width - scrollBar width
+ - scrolledView borderWidth)
+ @
+ (height + (scrollBar borderWidth))
+ ]
+ ].
+ ].
+ scrolledView notNil ifTrue:[
+ scrolledView
+ originChangeAction:[:aView | scrollBar setThumbOriginFor:aView].
+ scrolledView
+ contentsChangeAction:[:aView | scrollBar setThumbFor:aView]
+ ]
+!
+
+realize
+ super realize.
+ "since scrolledview may have done something to its contents
+ during init-time we had no chance yet to catch contents-
+ changes; do it now
+ "
+ scrollBar setThumbFor:scrolledView
+! !
+
+!ScrollableView methodsFor:'accessing'!
+
+scrollBar
+ "return the scrollbar"
+
+ ^ scrollBar
+!
+
+scrolledView
+ "return the scrolled view"
+
+ ^ scrolledView
+!
+
+scrolledView:aView
+ |m m2 b|
+
+ scrolledView notNil ifTrue:[
+ self error:'can only scroll one view'
+ ].
+ scrolledView := aView.
+
+ b := scrolledView borderWidth.
+ self is3D ifTrue:[
+ m := helpView margin.
+ m2 := m * 2.
+
+ helpView addSubView:scrolledView.
+ scrolledView origin:(m @ m)
+ extent:[(helpView width - m2) @ (helpView height - m2)].
+ scrolledView superViewChangedSize.
+ helpView viewBackground:(scrolledView viewBackground).
+ scrolledView level:-1
+ ] ifFalse:[
+ self addSubView:scrolledView.
+ scrolledView origin:((scrollBar width + scrollBar borderWidth - b) @ b negated)
+ extent:[(width - scrollBar width - b) @ (height + scrollBar borderWidth)
+ ].
+ scrolledView superViewChangedSize.
+ ].
+ scrolledView
+ originChangeAction:[:aView | scrollBar setThumbOriginFor:aView].
+ scrolledView
+ contentsChangeAction:[:aView | scrollBar setThumbFor:aView].
+
+ realized ifTrue:[scrolledView realize]
+! !
+
+!ScrollableView methodsFor:'slave-view messages'!
+
+cursor
+ scrolledView isNil ifTrue:[
+ ^ super cursor
+ ].
+ ^ scrolledView cursor
+!
+
+cursor:aCursor
+ "I have the same cursor as my scrolledView"
+
+ scrolledView cursor:aCursor.
+ super cursor:aCursor
+!
+
+leftButtonMenu
+ ^ scrolledView leftButtonMenu
+!
+
+leftButtonMenu:aMenu
+ "pass on leftbuttonmenu to scrolledView"
+
+ scrolledView leftButtonMenu:aMenu
+!
+
+middleButtonMenu
+ ^ scrolledView middleButtonMenu
+!
+
+middleButtonMenu:aMenu
+ "pass on middlebuttonmenu to scrolledView"
+
+ scrolledView middleButtonMenu:aMenu
+!
+
+rightButtonMenu
+ ^ scrolledView rightButtonMenu
+!
+
+rightButtonMenu:aMenu
+ "pass on rightbuttonmenu to scrolledView"
+
+ scrolledView rightButtonMenu:aMenu
+!
+
+doesNotUnderstand:aMessage
+ "this is funny: all message we do not understand, are passed
+ on to the scrolledView - so we do not have to care for all
+ possible messages ...(thanks to the Message class)"
+
+ scrolledView isNil ifFalse:[
+ ^ scrolledView perform:(aMessage selector)
+ withArguments:(aMessage arguments)
+ ]
+! !
+
+!ScrollableView methodsFor:'event processing'!
+
+sizeChanged:how
+ super sizeChanged:how.
+ scrollBar setThumbFor:scrolledView
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Scroller.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,911 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+View subclass:#Scroller
+ instanceVariableNames:'thumbOrigin thumbHeight thumbColor thumbFrameColor
+ realThumbHeight
+ scrollAction moveDirection
+ thumbFrame thumbLevel
+ scrolling pressOffset
+ synchronousOperation
+ shadowForm lightForm inset noColor
+ thumbShadowColor thumbLightColor
+ thumbSoftEdge
+ thumbHalfShadowColor thumbHalfLightColor'
+ classVariableNames: 'handleShadowForm handleLightForm
+ hand'
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+Scroller comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+this class implements the scroller for scrollbars.
+it can also be used by itself for scrollbars without step-buttons.
+when moved, a predefined action is performed.
+
+Instance variables:
+
+thumbOrigin <Number> origin of thumb (in percent)
+thumbHeight <Number> height of thumb (in percent)
+thumbColor <Color> color of thumb
+scrollAction <Block> 1 arg block to be evaluated when scrolled
+ (arg is position in percent)
+moveDirection <Symbol> #x or #y
+thumbFrame <Rectangle> frame of thumb in pixels
+thumbLevel <Number> level of thumb if 3d
+scrolling <Boolean> true during scroll
+pressOffset <Number> temporary
+synchronousOperation <Boolean> true if synchronous
+shadowForm <Form> bitmap of knob (shadow part)
+lightForm <Form> bitmap of knob (light part)
+
+%W% %E%
+
+written spring/summer 89 by claus
+'!
+
+!Scroller class methodsFor:'defaults'!
+
+handleShadowFormOn:aDisplay
+ "answer the form used for the handles shadow area;
+ cache the one for Display for the next round"
+
+ |f|
+
+ ((aDisplay == Display) and:[handleShadowForm notNil]) ifTrue:[
+ ^ handleShadowForm
+ ].
+ f := Form fromFile:'HandleShadow.xbm' resolution:100 on:aDisplay.
+ f isNil ifTrue:[
+ f := Form width:8 height:8 fromArray:#(2r00111100
+ 2r01100000
+ 2r11000000
+ 2r11000000
+ 2r11000000
+ 2r11000000
+ 2r01000000
+ 2r00000000)
+ on:aDisplay
+ ].
+ (aDisplay == Display) ifTrue:[
+ handleShadowForm := f
+ ].
+ ^ f
+!
+
+handleLightFormOn:aDisplay
+ "answer the form used for the handles light area;
+ cache the one for Display for the next round"
+
+ |f|
+
+ ((aDisplay == Display) and:[handleLightForm notNil]) ifTrue:[
+ ^ handleLightForm
+ ].
+ f := Form fromFile:'HandleLight.xbm' resolution:100 on:aDisplay.
+ f isNil ifTrue:[
+ f := Form width:8 height:8 fromArray:#(2r00000000
+ 2r00000010
+ 2r00000011
+ 2r00000011
+ 2r00000011
+ 2r00000011
+ 2r00000110
+ 2r00111100)
+ on:aDisplay
+ ].
+ (aDisplay == Display) ifTrue:[
+ handleLightForm := f
+ ].
+ ^ f
+! !
+
+!Scroller methodsFor:'initialization'!
+
+initialize
+ "initialize - setup instvars from defaults"
+
+ super initialize.
+ moveDirection := #y.
+
+ scrolling := false.
+ synchronousOperation := true.
+
+ noColor := Color noColor.
+ thumbOrigin := 0.
+ thumbHeight := 100.
+
+ inset := 1.
+
+ self initStyle.
+ self computeThumbFrame
+!
+
+initStyle
+ "initialize style dep. stuff"
+
+ super initStyle.
+
+ viewBackground := Color grey.
+ thumbLevel := 0.
+
+ self is3D ifTrue:[
+ thumbSoftEdge := false.
+ inset := 0.
+
+ style == #next ifTrue:[
+ self level:0.
+ self borderWidth:1.
+ inset := 1.
+ thumbSoftEdge := true.
+ thumbLevel := 2.
+ thumbColor := Color lightGrey
+ ] ifFalse:[
+ self level:-1.
+ style == #iris ifTrue:[
+ thumbLevel := 3.
+ thumbSoftEdge := true.
+ thumbColor := viewBackground
+ ] ifFalse:[
+ style == #mswindows ifTrue:[
+ self level:0.
+ self borderWidth:1.
+ thumbLevel := 2.
+ thumbColor := Color lightGrey.
+ thumbSoftEdge := true.
+ viewBackground := Color grey:80.
+ ] ifFalse:[
+ thumbLevel := 2.
+ thumbColor := Color lightGrey
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ thumbColor := White.
+ inset := 1
+ ].
+
+ thumbShadowColor := shadowColor.
+ thumbLightColor := lightColor.
+ thumbSoftEdge ifTrue:[
+ device hasGreyscales ifTrue:[
+ thumbHalfShadowColor := halfShadowColor.
+ thumbHalfLightColor := halfLightColor
+ ] ifFalse:[
+ thumbHalfShadowColor := Color darkGrey "halfShadowColor".
+ thumbHalfLightColor := White
+ ]
+ ].
+ device hasGreyscales ifFalse:[
+ thumbShadowColor := Black.
+ thumbLightColor := White.
+ viewBackground := Color veryLightGrey "White"
+ ].
+
+ thumbFrameColor := Black.
+
+ style == #next ifTrue:[
+ shadowForm := self class handleShadowFormOn:device.
+ lightForm := self class handleLightFormOn:device
+ ].
+
+ drawableId notNil ifTrue:[
+ self computeThumbFrame
+ ]
+!
+
+initCursor
+ "set the cursor - a hand"
+
+ cursor := Cursor hand
+!
+
+initEvents
+ self enableButtonEvents.
+ self enableButtonMotionEvents
+! !
+
+!Scroller methodsFor:'accessing'!
+
+is3D
+ style == #mswindows ifTrue:[^ true].
+ ^ super is3D
+!
+
+asynchronousOperation
+ "set scroll-mode to be asynchronous - scroll action is performed after
+ scrolling, when mouse-button is finally released"
+
+ synchronousOperation := false
+!
+
+synchronousOperation
+ "set scroll-mode to be synchronous - scroll action is performed for
+ every movement of thumb"
+
+ synchronousOperation := true
+!
+
+scrollAction:aBlock
+ "set the scroll action, aBlock which is evaluated when scrolled"
+
+ scrollAction := aBlock
+!
+
+scrollAction
+ "answer the scroll action block"
+
+ ^ scrollAction
+!
+
+thumbOrigin
+ "answer the thumbs origin (in percent)"
+
+ ^ thumbOrigin
+!
+
+thumbOrigin:newOrigin
+ "set the thumbs origin (in percent)"
+
+ |realNewOrigin oldFrame oldTop oldBot thumbTop thumbBot
+ tH "{ Class: SmallInteger }"
+ tW delta left|
+
+ ((newOrigin + thumbHeight) > 100) ifTrue:[
+ realNewOrigin := 100 - thumbHeight
+ ] ifFalse: [
+ realNewOrigin := newOrigin
+ ].
+ (realNewOrigin > 100) ifTrue:[
+ realNewOrigin := 100
+ ] ifFalse: [
+ (realNewOrigin < 0) ifTrue:[
+ realNewOrigin := 0
+ ]
+ ].
+ (realNewOrigin = thumbOrigin) ifFalse:[
+ oldFrame := thumbFrame.
+ thumbOrigin := realNewOrigin.
+ self computeThumbFrame.
+ (thumbHeight = 100) ifTrue:[^ self].
+
+ shown ifTrue:[
+ (thumbFrame ~~ oldFrame) ifTrue:[
+ tH := thumbFrame height.
+ tW := thumbFrame width.
+ oldTop := oldFrame top.
+ oldBot := oldTop + tH.
+
+ thumbTop := thumbFrame top.
+ thumbBot := thumbTop + tH.
+
+ left := thumbFrame left.
+
+ (oldBot >= height) ifTrue:[
+ "cannot copy - thumb was below end"
+ self drawThumbBackgroundInX:left y:oldTop
+ width:tW height:(height - oldTop).
+ self drawThumb.
+ ^ self
+ ].
+
+ self copyFrom:self x:left y:oldTop
+ toX:left y:thumbTop
+ width:tW height:tH.
+
+ oldTop > thumbTop ifTrue:[
+ delta := oldTop - thumbTop.
+ oldTop > thumbBot ifTrue:[
+ self drawThumbBackgroundInX:left y:oldTop
+ width:tW height:(tH + 1)
+ ] ifFalse:[
+ self drawThumbBackgroundInX:left y:thumbBot
+ width:tW height:delta
+ ]
+ ] ifFalse:[
+ delta := thumbTop - oldTop.
+ oldBot < thumbTop ifTrue:[
+ self drawThumbBackgroundInX:left y:oldTop
+ width:tW height:(tH + 1)
+ ] ifFalse:[
+ self drawThumbBackgroundInX:left y:oldTop
+ width:tW height:delta
+ ]
+ ].
+ "self is3D ifTrue:[ "
+ self waitForExpose
+ "] "
+ ]
+ ]
+ ]
+!
+
+thumbHeight
+ "answer the thumbs height (in percent)"
+
+ ^ thumbHeight
+!
+
+thumbHeight:newHeight
+ "set the thumbs height (in percent)"
+
+ |realNewHeight oldFrame|
+
+ (newHeight > 100) ifTrue:[
+ realNewHeight := 100
+ ] ifFalse:[
+ realNewHeight := newHeight
+ ].
+ (realNewHeight = thumbHeight) ifFalse:[
+ oldFrame := thumbFrame.
+ thumbHeight := realNewHeight.
+ self computeThumbFrame.
+ shown ifTrue:[
+ (oldFrame ~~ thumbFrame) ifTrue:[
+ self drawThumbBackgroundInX:(oldFrame left)
+ y:(oldFrame top)
+ width:(oldFrame width)
+ height:(oldFrame height).
+ self drawThumb
+ ]
+ ]
+ ]
+!
+
+thumbOrigin:newOrigin thumbHeight:newHeight
+ "set both thumbs height and origin (in percent)"
+
+ |realNewOrigin realNewHeight old new same|
+
+ (newHeight > 100) ifTrue:[
+ realNewHeight := 100
+ ] ifFalse:[
+ realNewHeight := newHeight
+ ].
+ ((newOrigin + realNewHeight) > 100) ifTrue:[
+ realNewOrigin := 100 - realNewHeight
+ ] ifFalse: [
+ realNewOrigin := newOrigin
+ ].
+ (realNewOrigin < 0) ifTrue: [
+ realNewOrigin := 0
+ ].
+
+ same := (realNewHeight = thumbHeight).
+ same ifTrue:[
+ same := (realNewOrigin = thumbOrigin)
+ ].
+
+ same ifFalse:[
+ old := self absFromPercent:thumbOrigin.
+ new := self absFromPercent:realNewOrigin.
+ (old == new) ifTrue:[
+ old := self absFromPercent:thumbHeight.
+ new := self absFromPercent:realNewHeight.
+ (old == new) ifTrue:[^ self]
+ ].
+
+ shown ifTrue:[
+ self drawThumbBackgroundInX:(thumbFrame left)
+ y:(thumbFrame top)
+ width:(thumbFrame width)
+ height:(thumbFrame height).
+ ].
+ thumbOrigin := realNewOrigin.
+ thumbHeight := realNewHeight.
+ self computeThumbFrame.
+ shown ifTrue:[
+ self drawThumb
+ ]
+ ]
+!
+
+setThumbFor:aView
+ "get contents and size info from aView and adjust thumb"
+
+ |percentSize percentOrigin totalHeight|
+
+ aView isNil ifTrue:[
+ totalHeight := 0
+ ] ifFalse:[
+ totalHeight := aView heightOfContents
+ ].
+ (totalHeight = 0) ifTrue:[
+ percentSize := 100.
+ percentOrigin := 100
+ ] ifFalse:[
+ percentSize := (aView innerHeight) * 100.0 / totalHeight.
+ percentOrigin := (aView yOriginOfContents) * 100.0 / totalHeight
+ ].
+ (percentSize = thumbHeight) ifTrue:[
+ self thumbOrigin:percentOrigin
+ ] ifFalse:[
+ (percentOrigin = thumbOrigin) ifTrue:[
+ self thumbHeight:percentSize
+ ] ifFalse:[
+ self thumbOrigin:percentOrigin thumbHeight:percentSize
+ ]
+ ]
+!
+
+setThumbHeightFor:aView
+ "get contents and size info from aView and adjust thumb height"
+
+ |percent totalHeight|
+
+ totalHeight := aView heightOfContents.
+ (totalHeight = 0) ifTrue:[
+ percent := 100
+ ] ifFalse:[
+ percent := (aView innerHeight) * 100.0 / totalHeight
+ ].
+ self thumbHeight:percent
+!
+
+setThumbOriginFor:aView
+ "get contents and size info from aView and adjust thumb origin"
+
+ |percent totalHeight|
+
+ totalHeight := aView heightOfContents.
+ (totalHeight = 0) ifTrue:[
+ percent := 100
+ ] ifFalse:[
+ percent := (aView yOriginOfContents) * 100.0 / totalHeight
+ ].
+ self thumbOrigin:percent
+!
+
+thumbColor:aColor
+ "change the color of the thumb"
+
+ thumbColor := aColor on:device.
+ self is3D ifTrue:[
+ thumbShadowColor := aColor darkened on:device.
+ thumbLightColor := aColor lightened on:device
+ ].
+ shown ifTrue:[
+ self redraw
+ ]
+!
+
+thumbFrame
+ "return the area used by the thumbFrame (in device coordinates).
+ Allows access toi the thumbs physical screen position, for
+ example to position a label below (see Slider-Examples)"
+
+ ^ thumbFrame
+! !
+
+!Scroller methodsFor:'private'!
+
+absFromPercent:percent
+ "given a percentage, compute number of pixels"
+
+ |fullSize|
+
+ (moveDirection == #y) ifTrue:[
+ fullSize := height
+ ] ifFalse:[
+ fullSize := width
+ ].
+ ^ ((percent * (fullSize - (margin * 2))) / 100) rounded
+!
+
+percentFromAbs:absValue
+ "given a number of pixels, compute percentage"
+
+ |fullSize val|
+
+ (moveDirection == #y) ifTrue:[
+ fullSize := height
+ ] ifFalse:[
+ fullSize := width
+ ].
+
+ val := absValue / (fullSize - (margin * 2)) * 100.
+ val < 0 ifTrue:[^ 0].
+ val > 100 ifTrue:[^ 100].
+ ^ val
+!
+
+computeThumbFrame
+ "compute the thumbs frame (a rectangle) whenever thumb is moved, changed
+ height or the scrollers size has changed"
+
+ |np1 np2 ns1 ns2 nh nw ny nx t diff sz1 sz2|
+
+ np1 := (self absFromPercent:thumbOrigin) + margin.
+ ns1 := self absFromPercent:thumbHeight.
+ diff := 0.
+ (moveDirection == #y) ifTrue:[
+ sz1 := height.
+ sz2 := width
+ ] ifFalse:[
+ sz1 := width.
+ sz2 := height
+ ].
+ self is3D ifTrue:[
+ np2 := margin + inset.
+ ns2 := sz2 - (margin * 2) - (inset * 2).
+ "
+ do not make thumb too small (for handle)
+ "
+ (ns1 < (10 + (2 * thumbLevel))) ifTrue:[
+ t := ns1.
+ ns1 := 10 + (2 * thumbLevel).
+ diff := ns1 - t
+ ]
+ ] ifFalse:[
+ np2 := inset.
+ ns2 := sz2 - (inset * 2).
+
+ "
+ do not make thumb too small (uncatchable)
+ "
+ (ns1 < 4) ifTrue:[
+ t := ns1.
+ ns1 := 4.
+ diff := ns1 - t
+ ]
+ ].
+ "
+ oops - if height has been increased, we have to adjust
+ the origin
+ "
+ (diff == 0) ifFalse:[
+ np1 := ((thumbOrigin * (sz1 - diff - (margin * 2))) / 100) rounded
+ + margin
+ ].
+
+ (moveDirection == #y) ifTrue:[
+ ny := np1.
+ nx := np2.
+ nh := ns1.
+ nw := ns2.
+ ny + nh + margin > height ifTrue:[
+ ny := height - margin - nh
+ ]
+ ] ifFalse:[
+ nx := np1.
+ ny := np2.
+ nw := ns1.
+ nh := ns2.
+ nx + nw + margin > width ifTrue:[
+ nx := width - margin - nw
+ ]
+ ].
+
+ "
+ do not create new Rectangle if its the same anyway
+ "
+ thumbFrame notNil ifTrue:[
+ (ny == thumbFrame top) ifTrue:[
+ (nx == thumbFrame left) ifTrue:[
+ (nh == thumbFrame height) ifTrue:[
+ (nw == thumbFrame width) ifTrue:[ ^ self]
+ ]
+ ]
+ ]
+ ].
+ thumbFrame := Rectangle left:nx top:ny width:nw height:nh
+! !
+
+!Scroller methodsFor:'drawing'!
+
+drawHandleFormAtX:x y:y
+ |oldFg oldBg oldFun|
+
+ oldFg := foreground.
+ oldBg := background.
+ oldFun := function.
+
+ "kludge for now"
+ ((thumbShadowColor colorId notNil)
+ and:[(thumbLightColor colorId notNil)
+ and:[thumbColor colorId notNil]])
+ ifTrue:[
+ self foreground:thumbColor background:noColor function:#xor.
+ self drawOpaqueForm:shadowForm x:x y:y.
+ self foreground:thumbShadowColor function:#or.
+ self drawOpaqueForm:shadowForm x:x y:y.
+ self foreground:thumbColor function:#xor.
+ self drawOpaqueForm:lightForm x:x y:y.
+ self foreground:thumbLightColor function:#or.
+ self drawOpaqueForm:lightForm x:x y:y.
+ self foreground:oldFg background:oldBg function:#copy
+ ] ifFalse:[
+false ifTrue:[
+ "turn off shadow bits"
+ self foreground:noColor background:(Color allColor) function:#and.
+
+ self drawOpaqueForm:shadowForm x:x y:y.
+ "turn off light bits"
+ self drawOpaqueForm:lightForm x:x y:y.
+
+ "draw shadow bits"
+ self paint:shadowColor.
+ self function:#or.
+ self drawOpaqueForm:shadowForm x:x y:y.
+
+ "draw light bits"
+ self paint:lightColor.
+ self drawOpaqueForm:lightForm x:x y:y.
+ self foreground:oldFg background:oldBg function:oldFun
+]
+ ]
+!
+
+drawThumbBackgroundInX:x y:y width:w height:h
+ "draw part of the thumbs background; defined as a separate
+ method, to allow drawing of arbitrary patterns under thumb."
+
+ self clearRectangleX:x y:y width:w height:h.
+!
+
+drawThumb
+ "draw the thumb"
+
+ |handleX handleY l t
+ w "{ Class: SmallInteger }"
+ h "{ Class: SmallInteger }"
+ x "{ Class: SmallInteger }"
+ y "{ Class: SmallInteger }"
+ mm xL xR yT yB|
+
+ ((thumbHeight >= 100) or:[thumbFrame height >= height]) ifTrue:[^ self].
+
+ l := thumbFrame left.
+ t := thumbFrame top.
+ w := thumbFrame width.
+ h := thumbFrame height.
+ self paint:thumbColor.
+ self fillRectangleX:l y:t width:w height:h.
+
+ self is3D ifFalse:[
+ self paint:thumbFrameColor.
+ self drawRectangle:thumbFrame.
+ ^ self
+ ].
+
+ thumbSoftEdge ifTrue:[
+ softEdge := true
+ ].
+ self drawEdgesForX:l y:t width:w height:h level:thumbLevel
+ shadow:thumbShadowColor light:thumbLightColor
+ halfShadow:thumbHalfShadowColor halfLight:thumbHalfLightColor.
+ softEdge := false.
+
+ style == #iris ifFalse:[
+ shadowForm notNil ifTrue:[
+ handleX := l + ((w - 8) // 2).
+ handleY := t + ((h - 8) // 2).
+ self drawHandleFormAtX:handleX y:handleY
+ ].
+ ^ self
+ ].
+
+ (moveDirection == #y) ifTrue:[
+ self paint:shadowColor.
+ y := t + (h // 2) - 1.
+ xL := l + thumbLevel - 1.
+ xR := l + w - thumbLevel + 1.
+ self displayLineFromX:xL y:y toX:xR y:y.
+ y := y + 1.
+ self paint:lightColor.
+ self displayLineFromX:xL y:y toX:xR y:y.
+
+ mm := device verticalPixelPerMillimeter rounded.
+ h > (mm * 6) ifTrue:[
+ y := y - 1 - mm.
+ self paint:shadowColor.
+ self displayLineFromX:xL y:y toX:xR y:y.
+ y := y + 1.
+ self paint:lightColor.
+ self displayLineFromX:xL y:y toX:xR y:y.
+
+ y := y - 1 + mm + mm.
+ self paint:shadowColor.
+ self displayLineFromX:xL y:y toX:xR y:y.
+ y := y + 1.
+ self paint:lightColor.
+ self displayLineFromX:xL y:y toX:xR y:y
+
+ ]
+ ] ifFalse:[
+ x := l + (w // 2) - 1.
+ yT := t + thumbLevel - 1.
+ yB := t + h - thumbLevel + 1.
+ self paint:shadowColor.
+ self displayLineFromX:x y:yT toX:x y:yB.
+ self paint:lightColor.
+ x := x + 1.
+ self displayLineFromX:x y:yT toX:x y:yB.
+
+ mm := device horizontalPixelPerMillimeter rounded.
+ w > (mm * 6) ifTrue:[
+ x := x - 1 - mm.
+ self paint:shadowColor.
+ self displayLineFromX:x y:yT toX:x y:yB.
+ x := x + 1.
+ self paint:lightColor.
+ self displayLineFromX:x y:yT toX:x y:yB.
+
+ x := x - 1 + mm + mm.
+ self paint:shadowColor.
+ self displayLineFromX:x y:yT toX:x y:yB.
+ x := x + 1.
+ self paint:lightColor.
+ self displayLineFromX:x y:yT toX:x y:yB
+ ]
+ ]
+! !
+
+!Scroller methodsFor:'events'!
+
+redrawX:x y:y width:w height:h
+ (y > thumbFrame bottom) ifTrue:[
+ self drawThumbBackgroundInX:x y:y width:w height:h.
+ ^ self
+ ].
+ ((y + h) < thumbFrame top) ifTrue:[
+ self drawThumbBackgroundInX:x y:y width:w height:h.
+ ^ self
+ ].
+ self drawThumbBackgroundInX:0 y:0 width:width height:height.
+ self drawThumb
+!
+
+redraw
+ "redraw"
+
+ shown ifTrue:[
+ self drawThumbBackgroundInX:0 y:0 width:width height:height.
+ self drawThumb
+ ]
+!
+
+sizeChanged:how
+ "size of scroller changed - recompute thumbs frame and redraw it"
+
+ self computeThumbFrame.
+ self redraw
+!
+
+buttonPress:button x:x y:y
+ "button was pressed - if above thumb, page up; if below thumb, page down;
+ otherwise start scrolling"
+
+ |curr limit1 limit2|
+
+ (moveDirection == #y) ifTrue:[
+ curr := y.
+ limit1 := thumbFrame top.
+ limit2 := thumbFrame bottom
+ ] ifFalse:[
+ curr := x.
+ limit1 := thumbFrame left.
+ limit2 := thumbFrame right
+ ].
+
+ (curr < limit1) ifTrue:[
+ "page up/left"
+ self thumbOrigin:(thumbOrigin - thumbHeight).
+ scrollAction notNil ifTrue:[
+ scrollAction value:thumbOrigin
+ ]
+ ] ifFalse:[
+ (curr > limit2) ifTrue:[
+ "page down/right"
+ self thumbOrigin:(thumbOrigin + thumbHeight).
+ scrollAction notNil ifTrue:[
+ scrollAction value:thumbOrigin
+ ]
+ ] ifFalse:[
+ pressOffset := curr - limit1.
+ scrolling := true
+ ]
+ ]
+!
+
+buttonMultiPress:button x:x y:y
+ ^ self buttonPress:button x:x y:y
+!
+
+buttonShiftPress:button x:x y:y
+ "mouse-click with shift - jump to position"
+
+ |pos newThumbOrigin curr limit org|
+
+ (moveDirection == #y) ifTrue:[
+ curr := y.
+ limit := height.
+ org := thumbFrame top
+ ] ifFalse:[
+ curr := x.
+ limit := width.
+ org := thumbFrame left
+ ].
+
+ (curr < 0) ifTrue:[ "check against limits"
+ pos := 0
+ ] ifFalse:[
+ (curr > limit) ifTrue:[
+ pos := limit
+ ] ifFalse:[
+ pos := curr
+ ]
+ ].
+
+ newThumbOrigin := self percentFromAbs:pos.
+ self thumbOrigin:newThumbOrigin.
+ scrollAction notNil ifTrue:[
+ scrollAction value:thumbOrigin
+ ].
+ pressOffset := curr - org.
+ scrolling := true
+!
+
+buttonMotion:button x:x y:y
+ "mouse-button was moved while pressed;
+ redraw thumb at its new position and, if scroll-mode is asynchronous,
+ the scroll action is performed"
+
+ |pos newThumbOrigin curr limit|
+
+ scrolling ifFalse: [ ^ self ]. "should not happen"
+
+ (moveDirection == #y) ifTrue:[
+ curr := y.
+ limit := height
+ ] ifFalse:[
+ curr := x.
+ limit := width
+ ].
+
+ (curr < 0) ifTrue:[ "check against limits"
+ pos := 0
+ ] ifFalse:[
+ (curr > limit) ifTrue:[
+ pos := limit
+ ] ifFalse:[
+ pos := curr
+ ]
+ ].
+
+ newThumbOrigin := self percentFromAbs:(pos - pressOffset).
+
+ self thumbOrigin:newThumbOrigin.
+ synchronousOperation ifTrue: [
+ scrollAction notNil ifTrue:[
+ scrollAction value:thumbOrigin
+ ]
+ ]
+!
+
+buttonRelease:button x:x y:y
+ "mouse-button was released - if scroll-mode is asynchronous, the scroll
+ action is now performed"
+
+ scrolling ifTrue:[
+ scrolling := false.
+ synchronousOperation ifFalse: [
+ scrollAction notNil ifTrue:[
+ scrollAction value:thumbOrigin
+ ]
+ ]
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/SelListV.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,807 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ListView subclass:#SelectionInListView
+ instanceVariableNames:'selection actionBlock enabled
+ hilightFgColor hilightBgColor
+ halfIntensityFgColor
+ doubleClickActionBlock
+ listAttributes multipleSelectOk clickLine
+ listSymbol initialSelectionSymbol printItems oneItem'
+ classVariableNames: 'hand'
+ poolDictionaries:''
+ category:'Views-Text'
+!
+
+SelectionInListView comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+this one is a ListView with a selected line (which is shown highlighted)
+If multipleSelectionsOk is true, it is also allowed to shift-click multiple entries.
+
+%W% %E%
+
+written spring/summer 89 by claus
+3D Jan 90 by claus
+multiselect Jun 92 my claus
+'!
+
+!SelectionInListView class methodsFor:'instance creation'!
+
+on:aModel printItems:print oneItem:one aspect:aspect
+ change:change list:list menu:menu
+ initialSelection:initial
+
+ "for ST-80 compatibility"
+
+ ^ (self new) on:aModel printItems:print oneItem:one aspect:aspect
+ change:change list:list menu:menu
+ initialSelection:initial
+! !
+
+!SelectionInListView methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ fontHeight := font height + lineSpacing.
+ multipleSelectOk := false.
+ enabled := true
+!
+
+initStyle
+ super initStyle.
+
+ bgColor := viewBackground.
+ (style == #openwin) ifTrue:[
+ lineSpacing := 3
+ ] ifFalse:[
+ lineSpacing := 2
+ ].
+
+ (style == #next) ifTrue:[
+ device hasGreyscales ifTrue:[
+ hilightFgColor := fgColor.
+ hilightBgColor := White
+ ] ifFalse:[
+ hilightFgColor := White.
+ hilightBgColor := Black
+ ]
+ ] ifFalse:[
+ (style == #openwin) ifTrue:[
+ device hasGreyscales ifTrue:[
+ hilightFgColor := fgColor.
+ hilightBgColor := Color grey
+ ] ifFalse:[
+ hilightFgColor := White.
+ hilightBgColor := Black
+ ]
+ ] ifFalse:[
+ (style == #iris) ifTrue:[
+ device hasGreyscales ifTrue:[
+ hilightFgColor := bgColor.
+ hilightBgColor := Black
+ ] ifFalse:[
+ hilightFgColor := White.
+ hilightBgColor := Black
+ ]
+ ] ifFalse:[
+ self is3D ifTrue:[
+ device hasColors ifTrue:[
+ hilightFgColor := Color name:'yellow'
+ ] ifFalse:[
+ hilightFgColor := White
+ ].
+ device hasGreyscales ifTrue:[
+ hilightBgColor := viewBackground
+ ] ifFalse:[
+ hilightBgColor := Black
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ hilightFgColor isNil ifTrue:[
+ hilightFgColor := bgColor.
+ hilightBgColor := fgColor
+ ].
+
+ halfIntensityFgColor := Color darkGrey.
+!
+
+initCursor
+ "set the cursor - a hand"
+
+ cursor := Cursor hand
+!
+
+initEvents
+ super initEvents.
+ self enableButtonEvents
+!
+
+realize
+ super realize.
+ selection notNil ifTrue:[
+ self makeLineVisible:selection
+ ]
+! !
+
+!SelectionInListView methodsFor:'accessing'!
+
+multipleSelectOk:aBoolean
+ "allow/disallow multiple selections"
+
+ multipleSelectOk := aBoolean.
+ aBoolean ifTrue:[
+ self enableButtonMotionEvents
+ ] ifFalse:[
+ self disableButtonMotionEvents
+ ]
+!
+
+setList:aCollection
+ "set the list - redefined, since setting the list implies unselecting"
+
+ selection := nil.
+ super setList:aCollection
+!
+
+list:aCollection
+ "set the list - redefined, since setting the list implies unselecting"
+
+ selection := nil.
+ super list:aCollection
+!
+
+attributes:aList
+ "set the attribute list"
+
+ listAttributes := attributes
+!
+
+attributeAt:index
+ "return the line attribute of list line index"
+
+ listAttributes isNil ifFalse:[
+ (index > listAttributes size) ifFalse:[
+ ^ listAttributes at:index
+ ]
+ ].
+ ^ nil
+!
+
+attributeAt:index put:aSymbol
+ "set a line attribute; currently attributes are:
+ #halfIntensity
+ "
+
+ (index > list size) ifFalse:[
+ listAttributes isNil ifTrue:[
+ listAttributes := VariableArray new:index
+ ] ifFalse:[
+ (index > listAttributes size) ifTrue:[
+ listAttributes grow:index
+ ]
+ ].
+ aSymbol == (listAttributes at:index) ifFalse:[
+ listAttributes at:index put:aSymbol.
+ self redrawLine:index
+ ]
+ ]
+!
+
+action:aBlock
+ "set the action block to be performed on select"
+
+ actionBlock := aBlock
+!
+
+doubleClickAction:aBlock
+ "set the double click action block to be performed on select"
+
+ doubleClickActionBlock := aBlock
+!
+
+selectionValue
+ "answer the selection value i.e. the text in the selected line"
+
+ selection isNil ifTrue:[^ nil].
+ ^ list at:selection
+!
+
+selection
+ "answer the selection line nr"
+
+ ^ selection
+!
+
+deselect
+ "deselect"
+
+ self selection:nil
+!
+
+deselectWithoutRedraw
+ "deselect - no redraw"
+
+ selection := nil
+!
+
+enable
+ "enable selections"
+
+ enabled := true
+!
+
+disable
+ "disable selections"
+
+ enabled := false
+!
+
+selectElement:anObject
+ "select the element with same printString as the argument, anObject"
+
+ |lineNo|
+
+ list notNil ifTrue:[
+ lineNo := list indexOf:(anObject printString) ifAbsent:[^ self].
+ self selection:lineNo
+ ]
+!
+
+selectWithoutScroll:aNumberOrNil
+ "select line, aNumber or deselect if argument is nil"
+
+ |prevSelection newSelection|
+
+ newSelection := aNumberOrNil.
+ newSelection notNil ifTrue:[
+ (self isValidSelection:newSelection) ifFalse:[
+ newSelection := nil
+ ]
+ ].
+
+ (newSelection == selection) ifTrue: [^ self].
+
+ selection notNil ifTrue: [
+ prevSelection := selection.
+ selection := nil.
+ (prevSelection isKindOf:Collection) ifTrue:[
+ prevSelection do:[:line |
+ self redrawElement:line
+ ]
+ ] ifFalse:[
+ self redrawElement:prevSelection
+ ]
+ ].
+ selection := newSelection.
+ selection notNil ifTrue:[
+ self redrawElement:selection
+ ]
+!
+
+selection:aNumberOrNil
+ "select line, aNumber or deselect if argument is nil;
+ make the line visible"
+
+ self selectWithoutScroll:aNumberOrNil.
+ selection notNil ifTrue:[
+ shown ifTrue:[
+ self makeLineVisible:selection
+ ]
+ ]
+!
+
+selectNext
+ "select next line or first if there is currrently no selection"
+
+ selection isNil ifTrue:[
+ self selection:1
+ ] ifFalse:[
+ self selection:(selection + 1).
+ selection isNil ifTrue:[
+ self selection:1
+ ]
+ ]
+!
+
+selectPrevious
+ "select previous line or last if there is currently no selection"
+
+ selection isNil ifTrue:[
+ self selection:(list size)
+ ] ifFalse:[
+ self selection:(selection - 1).
+ selection isNil ifTrue:[
+ self selection:(list size)
+ ]
+ ]
+!
+
+on:aModel printItems:print oneItem:one aspect:aspect
+ change:change list:list menu:menu
+ initialSelection:initial
+
+ "ST-80 compatibility"
+
+ aspectSymbol := aspect.
+ changeSymbol := change.
+ listSymbol := list.
+ menuSymbol := menu.
+ initialSelectionSymbol := initial.
+ printItems := print.
+ oneItem := one.
+
+ model := aModel.
+
+ listSymbol notNil ifTrue:[
+ self list:(aModel perform:listSymbol) asText
+ ].
+ model addDependent:self
+! !
+
+!SelectionInListView methodsFor:'private'!
+
+isValidSelection:aNumber
+ "answer true, if aNumber is ok for a selection lineNo"
+
+ aNumber isNil ifTrue:[^ false].
+ ^ (aNumber between:1 and:list size)
+!
+
+isInSelection:aNumber
+ "return true, if line, aNumber is in the selection"
+
+ selection isNil ifTrue:[^ false].
+ (selection isKindOf:Collection) ifTrue:[
+ ^ (selection includes:aNumber)
+ ].
+ ^ (aNumber == selection)
+!
+
+positionToSelectionX:x y:y
+ "given a click position, return the selection lineNo"
+
+ |visibleLine|
+
+ (x between:0 and:width) ifTrue:[
+ (y between:0 and:height) ifTrue:[
+ visibleLine := self visibleLineOfY:y.
+ ^ self visibleLineToListLine:visibleLine
+ ]
+ ].
+ ^ nil
+!
+
+widthForScrollBetween:start and:end
+ "has to be redefined since WHOLE line is inverted/modified sometimes"
+
+ | anySelectionInRange |
+
+ selection notNil ifTrue:[
+ (selection isKindOf:Collection) ifTrue:[
+ anySelectionInRange := false.
+ selection do:[:s |
+ (s between:start and:end) ifTrue:[
+ anySelectionInRange := true
+ ]
+ ]
+ ] ifFalse:[
+ anySelectionInRange := selection between:start and:end
+ ]
+ ] ifFalse:[
+ anySelectionInRange := false
+ ].
+
+ anySelectionInRange ifTrue:[
+ self is3D ifFalse:[
+ ^ width
+ ].
+ ( #(next openwin) includes:style) ifTrue:[
+ ^ width
+ ].
+ viewBackground = background ifFalse:[
+ ^ width
+ ]
+ ].
+ ^ super widthForScrollBetween:start and:end
+!
+
+visibleLineNeedsSpecialCare:visLineNr
+ |listLine|
+
+ listLine := self visibleLineToListLine:visLineNr.
+ listLine isNil ifTrue:[^ false].
+ (self isInSelection:listLine) ifTrue:[^ true].
+ listAttributes notNil ifTrue:[
+ (listLine <= listAttributes size) ifTrue:[
+ ^ (listAttributes at:listLine) notNil
+ ]
+ ].
+ ^ false
+!
+
+removeFromSelection:aNumber
+ "remove line, aNumber from the selection"
+
+ selection isNil ifTrue:[^ self].
+
+ (selection isKindOf:Collection) ifTrue:[
+ (selection includes:aNumber) ifFalse:[^ self].
+ selection remove:aNumber.
+ (selection size == 1) ifTrue:[
+ selection := selection at:1
+ ]
+ ] ifFalse:[
+ (aNumber == selection) ifFalse:[^ self].
+ selection := nil
+ ].
+ self redrawElement:aNumber
+!
+
+addToSelection:aNumber
+ "add line, aNumber to the selection"
+
+ selection isNil ifTrue:[^ self selectWithoutScroll:aNumber].
+
+ (self isValidSelection:aNumber) ifFalse:[^ self].
+ (selection isKindOf:Collection) ifTrue:[
+ (selection includes:aNumber) ifTrue:[^ self].
+ selection add:aNumber
+ ] ifFalse:[
+ (aNumber == selection) ifTrue:[^ self].
+ selection := OrderedCollection with:selection
+ with:aNumber
+ ].
+ self redrawElement:aNumber
+!
+
+scrollSelectDown
+ "auto scroll action; scroll and reinstall timed-block"
+
+ device addTimedBlock:autoScrollBlock after:autoScrollDeltaT.
+ self scrollDown
+!
+
+scrollSelectUp
+ "auto scroll action; scroll and reinstall timed-block"
+
+ device addTimedBlock:autoScrollBlock after:autoScrollDeltaT.
+ self scrollUp
+! !
+
+!SelectionInListView methodsFor:'drawing'!
+
+drawVisibleLine:visLineNr with:fg and:bg
+ "draw a visible line in fg/bg
+ - redefined to clear edge of selection"
+
+ |y "{ Class:SmallInteger }"
+ line|
+
+ y := self yOfLine:visLineNr.
+ line := self visibleAt:visLineNr.
+ self paint:bg.
+ (style == #openwin) ifTrue:[
+ self fillRectangleX:margin y:y - 1
+ width:(width - (margin * 2))
+ height:fontHeight + 1
+ ] ifFalse:[
+ self fillRectangleX:margin y:y
+ width:(width - (margin * 2))
+ height:fontHeight
+ ].
+ line notNil ifTrue:[
+ self paint:fg.
+ self displayString:line x:(textStartLeft - leftOffset) y:(y + fontAscent)
+ ]
+! !
+
+!SelectionInListView methodsFor:'redrawing'!
+
+redrawElement:aNumber
+ "redraw an individual element"
+
+ ^ self redrawLine:aNumber
+!
+
+redrawVisibleLine:visLineNr col:colNr
+ (self visibleLineNeedsSpecialCare:visLineNr) ifTrue:[
+ ^ self redrawVisibleLine:visLineNr
+ ].
+ super redrawVisibleLine:visLineNr col:colNr
+!
+
+redrawVisibleLine:visLineNr from:startCol
+ (self visibleLineNeedsSpecialCare:visLineNr) ifTrue:[
+ ^ self redrawVisibleLine:visLineNr
+ ].
+ super redrawVisibleLine:visLineNr from:startCol
+!
+
+redrawVisibleLine:visLineNr from:startCol to:endCol
+ (self visibleLineNeedsSpecialCare:visLineNr) ifTrue:[
+ ^ self redrawVisibleLine:visLineNr
+ ].
+ super redrawVisibleLine:visLineNr from:startCol to:endCol
+!
+
+redrawFromVisibleLine:startVisLineNr to:endVisLineNr
+ |special sel
+ selNo "{ Class: SmallInteger }" |
+
+ ((selection isKindOf:Collection) or:[listAttributes notNil]) ifTrue:[
+ startVisLineNr to:endVisLineNr do:[:visLine |
+ self redrawVisibleLine:visLine
+ ].
+ ^ self
+ ].
+
+ special := true.
+ selection isNil ifTrue:[
+ special := false
+ ] ifFalse:[
+ sel := self listLineToVisibleLine:selection.
+ sel isNil ifTrue:[
+ special := false
+ ] ifFalse:[
+ special := (sel between:startVisLineNr and:endVisLineNr)
+ ]
+ ].
+ special ifFalse:[
+ ^ super redrawFromVisibleLine:startVisLineNr
+ to:endVisLineNr
+ ].
+
+ selNo := sel.
+ selNo > startVisLineNr ifTrue:[
+ super redrawFromVisibleLine:startVisLineNr to:(selNo - 1)
+ ].
+ self redrawVisibleLine:selNo.
+ selNo < endVisLineNr ifTrue:[
+ super redrawFromVisibleLine:(selNo + 1) to:endVisLineNr
+ ]
+!
+
+redrawVisibleLine:visLineNr
+ |listLine fg bg
+ y "{ Class: SmallInteger }" |
+
+ fg := fgColor.
+ bg := bgColor.
+ listLine := self visibleLineToListLine:visLineNr.
+ listLine notNil ifTrue:[
+ (self attributeAt:listLine) == #halfIntensity ifTrue:[
+ fg := halfIntensityFgColor
+ ].
+ (self isInSelection:listLine) ifTrue:[
+ bg := hilightBgColor.
+ fg := hilightFgColor.
+ (style == #next) ifTrue:[
+ self drawVisibleLine:visLineNr with:fg and:bg.
+ y := self yOfLine:visLineNr.
+ self paint:fg.
+ self displayLineFromX:0 y:y toX:width y:y.
+ y := y + fontHeight - 1.
+ self displayLineFromX:0 y:y toX:width y:y.
+ ^ self
+ ].
+ (style == #openwin) ifTrue:[
+ self drawVisibleLine:visLineNr with:fg and:bg.
+ y := self yOfLine:visLineNr.
+ self paint:fg.
+ self drawEdgesForX:0 y:y - 1
+ width:width height:fontHeight + 1
+ level:-1.
+ ^ self
+ ]
+ ]
+ ].
+ ^ self drawVisibleLine:visLineNr with:fg and:bg
+! !
+
+!SelectionInListView methodsFor:'event handling'!
+
+sizeChanged:how
+ "if there is a selection, make certain, its visible
+ after the sizechange"
+
+ |first|
+
+ super sizeChanged:how.
+ shown ifTrue:[
+ selection notNil ifTrue:[
+ (selection isKindOf:Collection) ifTrue:[
+ first := selection first
+ ] ifFalse:[
+ first := selection
+ ].
+ self makeLineVisible:first
+ ]
+ ]
+!
+
+keyPress:key x:x y:y
+ "handle keyboard input"
+
+ (keyboardHandler notNil
+ and:[keyboardHandler canHandle:key]) ifTrue:[
+ keyboardHandler keyPress:key x:x y:y.
+ ^ self
+ ].
+ (selection isKindOf:Collection) ifFalse:[
+ (key isMemberOf:Character) ifFalse: [
+ (key == #CursorUp) ifTrue:[
+ self selectPrevious.
+ actionBlock notNil ifTrue:[actionBlock value:selection].
+ ^ self
+ ].
+ (key == #CursorDown) ifTrue:[
+ self selectNext.
+ actionBlock notNil ifTrue:[actionBlock value:selection].
+ ^ self
+ ].
+ (key == #Home) ifTrue:[
+ self selection:1.
+ actionBlock notNil ifTrue:[actionBlock value:selection].
+ ^ self
+ ].
+ (key == #End) ifTrue:[
+ self selection:list size.
+ actionBlock notNil ifTrue:[actionBlock value:selection].
+ ^ self
+ ].
+ ]
+ ]
+!
+
+buttonPress:button x:x y:y
+ |oldSelection listLineNr menu menuSelector|
+
+ (button == 1) ifTrue:[
+ enabled ifTrue:[
+ oldSelection := selection.
+ listLineNr := self visibleLineToListLine:(self visibleLineOfY:y).
+ listLineNr notNil ifTrue: [
+ self selectWithoutScroll:listLineNr
+ ].
+ (selection ~= oldSelection) ifTrue:[
+ actionBlock notNil ifTrue:[actionBlock value:selection].
+ "the ST-80 way of doing things"
+ model notNil ifTrue:[
+ model perform:changeSymbol with:(self selectionValue)
+ ]
+ ].
+ clickLine := listLineNr
+ ]
+ ] ifFalse:[
+ super buttonPress:button x:x y:y
+ ]
+!
+
+buttonShiftPress:button x:x y:y
+ |oldSelection listLineNr|
+
+ (button == 1) ifTrue:[
+ enabled ifTrue:[
+ oldSelection := selection copy.
+ listLineNr := self visibleLineToListLine:(self visibleLineOfY:y).
+ listLineNr notNil ifTrue: [
+ multipleSelectOk ifTrue:[
+ (self isInSelection:listLineNr) ifTrue:[
+ self removeFromSelection:listLineNr
+ ] ifFalse:[
+ self addToSelection:listLineNr
+ ]
+ ] ifFalse:[
+ self selectWithoutScroll:listLineNr
+ ]
+ ].
+ (selection ~= oldSelection) ifTrue:[
+ actionBlock notNil ifTrue:[actionBlock value:selection].
+ "the ST-80 way of doing things"
+ model notNil ifTrue:[model perform:changeSymbol with:(self selectionValue)]
+ ].
+ clickLine := listLineNr
+ ]
+ ] ifFalse:[
+ super buttonShiftPress:button x:x y:y
+ ]
+!
+
+buttonMultiPress:button x:x y:y
+ (button == 1) ifTrue:[
+ doubleClickActionBlock isNil ifTrue:[
+ self buttonPress:button x:x y:y
+ ] ifFalse:[
+ doubleClickActionBlock value:selection
+ ]
+ ] ifFalse:[
+ super buttonMultiPress:button x:x y:y
+ ]
+!
+
+buttonRelease:button x:x y:y
+ "stop any autoscroll"
+
+ self stopAutoScroll
+!
+
+buttonMotion:button x:x y:y
+ "mouse-move while button was pressed - handle selection changes"
+
+ |movedVisibleLine movedLine delta oldSelection oldSelCount|
+
+ clickLine isNil ifTrue:[^ self].
+
+ "if moved outside of view, start autoscroll"
+ (y < 0) ifTrue:[
+ device compressMotionEvents:false.
+ self startScrollUp:y.
+ ^ self
+ ].
+ (y > height) ifTrue:[
+ device compressMotionEvents:false.
+ self startScrollDown:(y - height).
+ ^ self
+ ].
+
+ "move inside - stop autoscroll if any"
+ self stopAutoScroll.
+
+ movedVisibleLine := self visibleLineOfY:y.
+ movedLine := self visibleLineToAbsoluteLine:movedVisibleLine.
+ (movedLine == clickLine) ifTrue:[^ self].
+
+ multipleSelectOk ifTrue:[
+ delta := (clickLine < movedLine) ifTrue:[1] ifFalse:[-1].
+
+ oldSelection := selection.
+ oldSelCount := selection size.
+
+ (clickLine+delta) to:movedLine by:delta do:[:line |
+ (self isInSelection:line) ifTrue:[
+ self removeFromSelection:line
+ ] ifFalse:[
+ self addToSelection:line
+ ]
+ ].
+ ((selection ~= oldSelection)
+ or:[selection size ~~ oldSelCount]) ifTrue:[
+ actionBlock notNil ifTrue:[actionBlock value:selection]
+ ]
+ ] ifFalse:[
+ self selectWithoutScroll:movedLine
+ ].
+
+ clickLine := movedLine
+!
+
+update:aParameter
+ |newList|
+
+ (aParameter == initialSelectionSymbol) ifTrue:[
+ self selectElement:(model perform:initialSelectionSymbol).
+ ^ self
+ ].
+ (aParameter == listSymbol) ifTrue:[
+ newList := (model perform:listSymbol) asText.
+ (newList = list) ifFalse:[
+ self list:newList
+ ]
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/SelectionInListView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,807 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ListView subclass:#SelectionInListView
+ instanceVariableNames:'selection actionBlock enabled
+ hilightFgColor hilightBgColor
+ halfIntensityFgColor
+ doubleClickActionBlock
+ listAttributes multipleSelectOk clickLine
+ listSymbol initialSelectionSymbol printItems oneItem'
+ classVariableNames: 'hand'
+ poolDictionaries:''
+ category:'Views-Text'
+!
+
+SelectionInListView comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+this one is a ListView with a selected line (which is shown highlighted)
+If multipleSelectionsOk is true, it is also allowed to shift-click multiple entries.
+
+%W% %E%
+
+written spring/summer 89 by claus
+3D Jan 90 by claus
+multiselect Jun 92 my claus
+'!
+
+!SelectionInListView class methodsFor:'instance creation'!
+
+on:aModel printItems:print oneItem:one aspect:aspect
+ change:change list:list menu:menu
+ initialSelection:initial
+
+ "for ST-80 compatibility"
+
+ ^ (self new) on:aModel printItems:print oneItem:one aspect:aspect
+ change:change list:list menu:menu
+ initialSelection:initial
+! !
+
+!SelectionInListView methodsFor:'initialization'!
+
+initialize
+ super initialize.
+
+ fontHeight := font height + lineSpacing.
+ multipleSelectOk := false.
+ enabled := true
+!
+
+initStyle
+ super initStyle.
+
+ bgColor := viewBackground.
+ (style == #openwin) ifTrue:[
+ lineSpacing := 3
+ ] ifFalse:[
+ lineSpacing := 2
+ ].
+
+ (style == #next) ifTrue:[
+ device hasGreyscales ifTrue:[
+ hilightFgColor := fgColor.
+ hilightBgColor := White
+ ] ifFalse:[
+ hilightFgColor := White.
+ hilightBgColor := Black
+ ]
+ ] ifFalse:[
+ (style == #openwin) ifTrue:[
+ device hasGreyscales ifTrue:[
+ hilightFgColor := fgColor.
+ hilightBgColor := Color grey
+ ] ifFalse:[
+ hilightFgColor := White.
+ hilightBgColor := Black
+ ]
+ ] ifFalse:[
+ (style == #iris) ifTrue:[
+ device hasGreyscales ifTrue:[
+ hilightFgColor := bgColor.
+ hilightBgColor := Black
+ ] ifFalse:[
+ hilightFgColor := White.
+ hilightBgColor := Black
+ ]
+ ] ifFalse:[
+ self is3D ifTrue:[
+ device hasColors ifTrue:[
+ hilightFgColor := Color name:'yellow'
+ ] ifFalse:[
+ hilightFgColor := White
+ ].
+ device hasGreyscales ifTrue:[
+ hilightBgColor := viewBackground
+ ] ifFalse:[
+ hilightBgColor := Black
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ hilightFgColor isNil ifTrue:[
+ hilightFgColor := bgColor.
+ hilightBgColor := fgColor
+ ].
+
+ halfIntensityFgColor := Color darkGrey.
+!
+
+initCursor
+ "set the cursor - a hand"
+
+ cursor := Cursor hand
+!
+
+initEvents
+ super initEvents.
+ self enableButtonEvents
+!
+
+realize
+ super realize.
+ selection notNil ifTrue:[
+ self makeLineVisible:selection
+ ]
+! !
+
+!SelectionInListView methodsFor:'accessing'!
+
+multipleSelectOk:aBoolean
+ "allow/disallow multiple selections"
+
+ multipleSelectOk := aBoolean.
+ aBoolean ifTrue:[
+ self enableButtonMotionEvents
+ ] ifFalse:[
+ self disableButtonMotionEvents
+ ]
+!
+
+setList:aCollection
+ "set the list - redefined, since setting the list implies unselecting"
+
+ selection := nil.
+ super setList:aCollection
+!
+
+list:aCollection
+ "set the list - redefined, since setting the list implies unselecting"
+
+ selection := nil.
+ super list:aCollection
+!
+
+attributes:aList
+ "set the attribute list"
+
+ listAttributes := attributes
+!
+
+attributeAt:index
+ "return the line attribute of list line index"
+
+ listAttributes isNil ifFalse:[
+ (index > listAttributes size) ifFalse:[
+ ^ listAttributes at:index
+ ]
+ ].
+ ^ nil
+!
+
+attributeAt:index put:aSymbol
+ "set a line attribute; currently attributes are:
+ #halfIntensity
+ "
+
+ (index > list size) ifFalse:[
+ listAttributes isNil ifTrue:[
+ listAttributes := VariableArray new:index
+ ] ifFalse:[
+ (index > listAttributes size) ifTrue:[
+ listAttributes grow:index
+ ]
+ ].
+ aSymbol == (listAttributes at:index) ifFalse:[
+ listAttributes at:index put:aSymbol.
+ self redrawLine:index
+ ]
+ ]
+!
+
+action:aBlock
+ "set the action block to be performed on select"
+
+ actionBlock := aBlock
+!
+
+doubleClickAction:aBlock
+ "set the double click action block to be performed on select"
+
+ doubleClickActionBlock := aBlock
+!
+
+selectionValue
+ "answer the selection value i.e. the text in the selected line"
+
+ selection isNil ifTrue:[^ nil].
+ ^ list at:selection
+!
+
+selection
+ "answer the selection line nr"
+
+ ^ selection
+!
+
+deselect
+ "deselect"
+
+ self selection:nil
+!
+
+deselectWithoutRedraw
+ "deselect - no redraw"
+
+ selection := nil
+!
+
+enable
+ "enable selections"
+
+ enabled := true
+!
+
+disable
+ "disable selections"
+
+ enabled := false
+!
+
+selectElement:anObject
+ "select the element with same printString as the argument, anObject"
+
+ |lineNo|
+
+ list notNil ifTrue:[
+ lineNo := list indexOf:(anObject printString) ifAbsent:[^ self].
+ self selection:lineNo
+ ]
+!
+
+selectWithoutScroll:aNumberOrNil
+ "select line, aNumber or deselect if argument is nil"
+
+ |prevSelection newSelection|
+
+ newSelection := aNumberOrNil.
+ newSelection notNil ifTrue:[
+ (self isValidSelection:newSelection) ifFalse:[
+ newSelection := nil
+ ]
+ ].
+
+ (newSelection == selection) ifTrue: [^ self].
+
+ selection notNil ifTrue: [
+ prevSelection := selection.
+ selection := nil.
+ (prevSelection isKindOf:Collection) ifTrue:[
+ prevSelection do:[:line |
+ self redrawElement:line
+ ]
+ ] ifFalse:[
+ self redrawElement:prevSelection
+ ]
+ ].
+ selection := newSelection.
+ selection notNil ifTrue:[
+ self redrawElement:selection
+ ]
+!
+
+selection:aNumberOrNil
+ "select line, aNumber or deselect if argument is nil;
+ make the line visible"
+
+ self selectWithoutScroll:aNumberOrNil.
+ selection notNil ifTrue:[
+ shown ifTrue:[
+ self makeLineVisible:selection
+ ]
+ ]
+!
+
+selectNext
+ "select next line or first if there is currrently no selection"
+
+ selection isNil ifTrue:[
+ self selection:1
+ ] ifFalse:[
+ self selection:(selection + 1).
+ selection isNil ifTrue:[
+ self selection:1
+ ]
+ ]
+!
+
+selectPrevious
+ "select previous line or last if there is currently no selection"
+
+ selection isNil ifTrue:[
+ self selection:(list size)
+ ] ifFalse:[
+ self selection:(selection - 1).
+ selection isNil ifTrue:[
+ self selection:(list size)
+ ]
+ ]
+!
+
+on:aModel printItems:print oneItem:one aspect:aspect
+ change:change list:list menu:menu
+ initialSelection:initial
+
+ "ST-80 compatibility"
+
+ aspectSymbol := aspect.
+ changeSymbol := change.
+ listSymbol := list.
+ menuSymbol := menu.
+ initialSelectionSymbol := initial.
+ printItems := print.
+ oneItem := one.
+
+ model := aModel.
+
+ listSymbol notNil ifTrue:[
+ self list:(aModel perform:listSymbol) asText
+ ].
+ model addDependent:self
+! !
+
+!SelectionInListView methodsFor:'private'!
+
+isValidSelection:aNumber
+ "answer true, if aNumber is ok for a selection lineNo"
+
+ aNumber isNil ifTrue:[^ false].
+ ^ (aNumber between:1 and:list size)
+!
+
+isInSelection:aNumber
+ "return true, if line, aNumber is in the selection"
+
+ selection isNil ifTrue:[^ false].
+ (selection isKindOf:Collection) ifTrue:[
+ ^ (selection includes:aNumber)
+ ].
+ ^ (aNumber == selection)
+!
+
+positionToSelectionX:x y:y
+ "given a click position, return the selection lineNo"
+
+ |visibleLine|
+
+ (x between:0 and:width) ifTrue:[
+ (y between:0 and:height) ifTrue:[
+ visibleLine := self visibleLineOfY:y.
+ ^ self visibleLineToListLine:visibleLine
+ ]
+ ].
+ ^ nil
+!
+
+widthForScrollBetween:start and:end
+ "has to be redefined since WHOLE line is inverted/modified sometimes"
+
+ | anySelectionInRange |
+
+ selection notNil ifTrue:[
+ (selection isKindOf:Collection) ifTrue:[
+ anySelectionInRange := false.
+ selection do:[:s |
+ (s between:start and:end) ifTrue:[
+ anySelectionInRange := true
+ ]
+ ]
+ ] ifFalse:[
+ anySelectionInRange := selection between:start and:end
+ ]
+ ] ifFalse:[
+ anySelectionInRange := false
+ ].
+
+ anySelectionInRange ifTrue:[
+ self is3D ifFalse:[
+ ^ width
+ ].
+ ( #(next openwin) includes:style) ifTrue:[
+ ^ width
+ ].
+ viewBackground = background ifFalse:[
+ ^ width
+ ]
+ ].
+ ^ super widthForScrollBetween:start and:end
+!
+
+visibleLineNeedsSpecialCare:visLineNr
+ |listLine|
+
+ listLine := self visibleLineToListLine:visLineNr.
+ listLine isNil ifTrue:[^ false].
+ (self isInSelection:listLine) ifTrue:[^ true].
+ listAttributes notNil ifTrue:[
+ (listLine <= listAttributes size) ifTrue:[
+ ^ (listAttributes at:listLine) notNil
+ ]
+ ].
+ ^ false
+!
+
+removeFromSelection:aNumber
+ "remove line, aNumber from the selection"
+
+ selection isNil ifTrue:[^ self].
+
+ (selection isKindOf:Collection) ifTrue:[
+ (selection includes:aNumber) ifFalse:[^ self].
+ selection remove:aNumber.
+ (selection size == 1) ifTrue:[
+ selection := selection at:1
+ ]
+ ] ifFalse:[
+ (aNumber == selection) ifFalse:[^ self].
+ selection := nil
+ ].
+ self redrawElement:aNumber
+!
+
+addToSelection:aNumber
+ "add line, aNumber to the selection"
+
+ selection isNil ifTrue:[^ self selectWithoutScroll:aNumber].
+
+ (self isValidSelection:aNumber) ifFalse:[^ self].
+ (selection isKindOf:Collection) ifTrue:[
+ (selection includes:aNumber) ifTrue:[^ self].
+ selection add:aNumber
+ ] ifFalse:[
+ (aNumber == selection) ifTrue:[^ self].
+ selection := OrderedCollection with:selection
+ with:aNumber
+ ].
+ self redrawElement:aNumber
+!
+
+scrollSelectDown
+ "auto scroll action; scroll and reinstall timed-block"
+
+ device addTimedBlock:autoScrollBlock after:autoScrollDeltaT.
+ self scrollDown
+!
+
+scrollSelectUp
+ "auto scroll action; scroll and reinstall timed-block"
+
+ device addTimedBlock:autoScrollBlock after:autoScrollDeltaT.
+ self scrollUp
+! !
+
+!SelectionInListView methodsFor:'drawing'!
+
+drawVisibleLine:visLineNr with:fg and:bg
+ "draw a visible line in fg/bg
+ - redefined to clear edge of selection"
+
+ |y "{ Class:SmallInteger }"
+ line|
+
+ y := self yOfLine:visLineNr.
+ line := self visibleAt:visLineNr.
+ self paint:bg.
+ (style == #openwin) ifTrue:[
+ self fillRectangleX:margin y:y - 1
+ width:(width - (margin * 2))
+ height:fontHeight + 1
+ ] ifFalse:[
+ self fillRectangleX:margin y:y
+ width:(width - (margin * 2))
+ height:fontHeight
+ ].
+ line notNil ifTrue:[
+ self paint:fg.
+ self displayString:line x:(textStartLeft - leftOffset) y:(y + fontAscent)
+ ]
+! !
+
+!SelectionInListView methodsFor:'redrawing'!
+
+redrawElement:aNumber
+ "redraw an individual element"
+
+ ^ self redrawLine:aNumber
+!
+
+redrawVisibleLine:visLineNr col:colNr
+ (self visibleLineNeedsSpecialCare:visLineNr) ifTrue:[
+ ^ self redrawVisibleLine:visLineNr
+ ].
+ super redrawVisibleLine:visLineNr col:colNr
+!
+
+redrawVisibleLine:visLineNr from:startCol
+ (self visibleLineNeedsSpecialCare:visLineNr) ifTrue:[
+ ^ self redrawVisibleLine:visLineNr
+ ].
+ super redrawVisibleLine:visLineNr from:startCol
+!
+
+redrawVisibleLine:visLineNr from:startCol to:endCol
+ (self visibleLineNeedsSpecialCare:visLineNr) ifTrue:[
+ ^ self redrawVisibleLine:visLineNr
+ ].
+ super redrawVisibleLine:visLineNr from:startCol to:endCol
+!
+
+redrawFromVisibleLine:startVisLineNr to:endVisLineNr
+ |special sel
+ selNo "{ Class: SmallInteger }" |
+
+ ((selection isKindOf:Collection) or:[listAttributes notNil]) ifTrue:[
+ startVisLineNr to:endVisLineNr do:[:visLine |
+ self redrawVisibleLine:visLine
+ ].
+ ^ self
+ ].
+
+ special := true.
+ selection isNil ifTrue:[
+ special := false
+ ] ifFalse:[
+ sel := self listLineToVisibleLine:selection.
+ sel isNil ifTrue:[
+ special := false
+ ] ifFalse:[
+ special := (sel between:startVisLineNr and:endVisLineNr)
+ ]
+ ].
+ special ifFalse:[
+ ^ super redrawFromVisibleLine:startVisLineNr
+ to:endVisLineNr
+ ].
+
+ selNo := sel.
+ selNo > startVisLineNr ifTrue:[
+ super redrawFromVisibleLine:startVisLineNr to:(selNo - 1)
+ ].
+ self redrawVisibleLine:selNo.
+ selNo < endVisLineNr ifTrue:[
+ super redrawFromVisibleLine:(selNo + 1) to:endVisLineNr
+ ]
+!
+
+redrawVisibleLine:visLineNr
+ |listLine fg bg
+ y "{ Class: SmallInteger }" |
+
+ fg := fgColor.
+ bg := bgColor.
+ listLine := self visibleLineToListLine:visLineNr.
+ listLine notNil ifTrue:[
+ (self attributeAt:listLine) == #halfIntensity ifTrue:[
+ fg := halfIntensityFgColor
+ ].
+ (self isInSelection:listLine) ifTrue:[
+ bg := hilightBgColor.
+ fg := hilightFgColor.
+ (style == #next) ifTrue:[
+ self drawVisibleLine:visLineNr with:fg and:bg.
+ y := self yOfLine:visLineNr.
+ self paint:fg.
+ self displayLineFromX:0 y:y toX:width y:y.
+ y := y + fontHeight - 1.
+ self displayLineFromX:0 y:y toX:width y:y.
+ ^ self
+ ].
+ (style == #openwin) ifTrue:[
+ self drawVisibleLine:visLineNr with:fg and:bg.
+ y := self yOfLine:visLineNr.
+ self paint:fg.
+ self drawEdgesForX:0 y:y - 1
+ width:width height:fontHeight + 1
+ level:-1.
+ ^ self
+ ]
+ ]
+ ].
+ ^ self drawVisibleLine:visLineNr with:fg and:bg
+! !
+
+!SelectionInListView methodsFor:'event handling'!
+
+sizeChanged:how
+ "if there is a selection, make certain, its visible
+ after the sizechange"
+
+ |first|
+
+ super sizeChanged:how.
+ shown ifTrue:[
+ selection notNil ifTrue:[
+ (selection isKindOf:Collection) ifTrue:[
+ first := selection first
+ ] ifFalse:[
+ first := selection
+ ].
+ self makeLineVisible:first
+ ]
+ ]
+!
+
+keyPress:key x:x y:y
+ "handle keyboard input"
+
+ (keyboardHandler notNil
+ and:[keyboardHandler canHandle:key]) ifTrue:[
+ keyboardHandler keyPress:key x:x y:y.
+ ^ self
+ ].
+ (selection isKindOf:Collection) ifFalse:[
+ (key isMemberOf:Character) ifFalse: [
+ (key == #CursorUp) ifTrue:[
+ self selectPrevious.
+ actionBlock notNil ifTrue:[actionBlock value:selection].
+ ^ self
+ ].
+ (key == #CursorDown) ifTrue:[
+ self selectNext.
+ actionBlock notNil ifTrue:[actionBlock value:selection].
+ ^ self
+ ].
+ (key == #Home) ifTrue:[
+ self selection:1.
+ actionBlock notNil ifTrue:[actionBlock value:selection].
+ ^ self
+ ].
+ (key == #End) ifTrue:[
+ self selection:list size.
+ actionBlock notNil ifTrue:[actionBlock value:selection].
+ ^ self
+ ].
+ ]
+ ]
+!
+
+buttonPress:button x:x y:y
+ |oldSelection listLineNr menu menuSelector|
+
+ (button == 1) ifTrue:[
+ enabled ifTrue:[
+ oldSelection := selection.
+ listLineNr := self visibleLineToListLine:(self visibleLineOfY:y).
+ listLineNr notNil ifTrue: [
+ self selectWithoutScroll:listLineNr
+ ].
+ (selection ~= oldSelection) ifTrue:[
+ actionBlock notNil ifTrue:[actionBlock value:selection].
+ "the ST-80 way of doing things"
+ model notNil ifTrue:[
+ model perform:changeSymbol with:(self selectionValue)
+ ]
+ ].
+ clickLine := listLineNr
+ ]
+ ] ifFalse:[
+ super buttonPress:button x:x y:y
+ ]
+!
+
+buttonShiftPress:button x:x y:y
+ |oldSelection listLineNr|
+
+ (button == 1) ifTrue:[
+ enabled ifTrue:[
+ oldSelection := selection copy.
+ listLineNr := self visibleLineToListLine:(self visibleLineOfY:y).
+ listLineNr notNil ifTrue: [
+ multipleSelectOk ifTrue:[
+ (self isInSelection:listLineNr) ifTrue:[
+ self removeFromSelection:listLineNr
+ ] ifFalse:[
+ self addToSelection:listLineNr
+ ]
+ ] ifFalse:[
+ self selectWithoutScroll:listLineNr
+ ]
+ ].
+ (selection ~= oldSelection) ifTrue:[
+ actionBlock notNil ifTrue:[actionBlock value:selection].
+ "the ST-80 way of doing things"
+ model notNil ifTrue:[model perform:changeSymbol with:(self selectionValue)]
+ ].
+ clickLine := listLineNr
+ ]
+ ] ifFalse:[
+ super buttonShiftPress:button x:x y:y
+ ]
+!
+
+buttonMultiPress:button x:x y:y
+ (button == 1) ifTrue:[
+ doubleClickActionBlock isNil ifTrue:[
+ self buttonPress:button x:x y:y
+ ] ifFalse:[
+ doubleClickActionBlock value:selection
+ ]
+ ] ifFalse:[
+ super buttonMultiPress:button x:x y:y
+ ]
+!
+
+buttonRelease:button x:x y:y
+ "stop any autoscroll"
+
+ self stopAutoScroll
+!
+
+buttonMotion:button x:x y:y
+ "mouse-move while button was pressed - handle selection changes"
+
+ |movedVisibleLine movedLine delta oldSelection oldSelCount|
+
+ clickLine isNil ifTrue:[^ self].
+
+ "if moved outside of view, start autoscroll"
+ (y < 0) ifTrue:[
+ device compressMotionEvents:false.
+ self startScrollUp:y.
+ ^ self
+ ].
+ (y > height) ifTrue:[
+ device compressMotionEvents:false.
+ self startScrollDown:(y - height).
+ ^ self
+ ].
+
+ "move inside - stop autoscroll if any"
+ self stopAutoScroll.
+
+ movedVisibleLine := self visibleLineOfY:y.
+ movedLine := self visibleLineToAbsoluteLine:movedVisibleLine.
+ (movedLine == clickLine) ifTrue:[^ self].
+
+ multipleSelectOk ifTrue:[
+ delta := (clickLine < movedLine) ifTrue:[1] ifFalse:[-1].
+
+ oldSelection := selection.
+ oldSelCount := selection size.
+
+ (clickLine+delta) to:movedLine by:delta do:[:line |
+ (self isInSelection:line) ifTrue:[
+ self removeFromSelection:line
+ ] ifFalse:[
+ self addToSelection:line
+ ]
+ ].
+ ((selection ~= oldSelection)
+ or:[selection size ~~ oldSelCount]) ifTrue:[
+ actionBlock notNil ifTrue:[actionBlock value:selection]
+ ]
+ ] ifFalse:[
+ self selectWithoutScroll:movedLine
+ ].
+
+ clickLine := movedLine
+!
+
+update:aParameter
+ |newList|
+
+ (aParameter == initialSelectionSymbol) ifTrue:[
+ self selectElement:(model perform:initialSelectionSymbol).
+ ^ self
+ ].
+ (aParameter == listSymbol) ifTrue:[
+ newList := (model perform:listSymbol) asText.
+ (newList = list) ifFalse:[
+ self list:newList
+ ]
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/TextColl.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,255 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+EditTextView subclass:#TextCollector
+ instanceVariableNames:'entryStream lineLimit destroyAction
+ outstandingLines outstandingLine
+ flushBlock flushPending collecting'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Text'
+!
+
+TextCollector comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+a view for editable text, which also understands some stream messages.
+Instances of this view can take the place of a stream and display the received
+text; it is used especially for Transcript.
+
+%W% %E%
+written winter-89 by claus
+'!
+
+!TextCollector class methodsFor:'defaults'!
+
+defaultLineLimit
+ ^ nil
+! !
+
+!TextCollector class methodsFor:'instance creation'!
+
+newTranscript
+ |topView transcript f v|
+
+ Display initialize.
+ topView := StandardSystemView label:'Transcript'
+ minExtent:(100 @ 100).
+
+ v := ScrollableView for:self in:topView.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
+ transcript := v scrolledView.
+ transcript lineLimit:600.
+ transcript collect:true.
+ "transcript partialLines:false."
+
+ f := transcript font.
+ topView extent:(((f widthOf:'x') * 70) @ (f height * 10)).
+
+ Smalltalk at:#Transcript put:transcript.
+
+ "fancy feature: whenever Transcript is closed, reset to StdError"
+ transcript destroyAction:[Smalltalk at:#Transcript put:Stderr].
+
+ topView realize.
+ ^ transcript
+! !
+
+!TextCollector methodsFor:'initialize / release'!
+
+initialize
+ super initialize.
+
+ outstandingLines := OrderedCollection new.
+ flushBlock := [self endEntry].
+ flushPending := false.
+ collecting := false.
+
+ lineLimit := self class defaultLineLimit.
+ entryStream := ActorStream new.
+ entryStream nextPutBlock:[:something | self nextPut:something].
+ entryStream nextPutAllBlock:[:something | self nextPutAll:something]
+!
+
+destroy
+ destroyAction notNil ifTrue:[
+ destroyAction value
+ ].
+ flushBlock notNil ifTrue:[
+ device removeTimedBlock:flushBlock
+ ].
+ super destroy
+! !
+
+!TextCollector methodsFor:'accessing'!
+
+collect:aBoolean
+ "turn on collecting - i.e. do not output immediately
+ but collect text and output en-bloque after some time
+ delta"
+
+ collecting := aBoolean
+!
+
+lineLimit:aNumber
+ "define the number of text-lines I am supposed to hold"
+
+ lineLimit := aNumber
+!
+
+destroyAction:aBlock
+ "define the action to be performed when I get destroyed"
+
+ destroyAction := aBlock
+!
+
+endEntry
+ "flush collected output"
+
+ |nLines|
+
+ "insert the bunch of lines - if any"
+ nLines := outstandingLines size.
+ (nLines ~~ 0) ifTrue:[
+ outstandingLines do:[:line |
+ self insertStringAtCursor:line.
+ self insertCharAtCursor:(Character cr)
+ ].
+"
+ self insertLines:outstandingLines withCr:true.
+"
+ self withCursorOffDo:[
+ (cursorLine >= (firstLineShown + nFullLinesShown)) ifTrue:[
+ self scrollDown:nLines
+ ]
+ ].
+ outstandingLines grow:0
+ ].
+ "and the last partial line - if any"
+ outstandingLine notNil ifTrue:[
+ flushPending := false.
+ self nextPut:outstandingLine.
+ outstandingLine := nil
+ ].
+ device removeTimedBlock:flushBlock.
+ flushPending := false
+! !
+
+!TextCollector methodsFor:'private'!
+
+checkLineLimit
+ "this method checks if the text has become too large (> lineLimit)
+ and cuts off some lines at the top if so; it must be called whenever lines
+ have been added to the bottom"
+
+ |nDel|
+
+ lineLimit notNil ifTrue:[
+ (cursorLine > lineLimit) ifTrue:[
+ nDel := list size - lineLimit.
+ list removeFromIndex:1 toIndex:nDel.
+ cursorLine := cursorLine - nDel.
+ firstLineShown := firstLineShown - nDel.
+ (firstLineShown < 1) ifTrue:[
+ cursorLine := cursorLine - firstLineShown + 1.
+ firstLineShown := 1
+ ].
+ self contentsChanged
+ ]
+ ]
+! !
+
+!TextCollector methodsFor:'stream messages'!
+
+lineLength
+ ^ width // (font width)
+!
+
+nextPut:something
+ "this allows TextCollectors to be used Stream-wise"
+
+ flushPending ifTrue:[
+ self endEntry
+ ].
+ (something isMemberOf:Character) ifTrue:[
+ ((something == Character cr) or:[something == Character nl]) ifTrue:[
+ ^ self cr
+ ].
+ self insertCharAtCursor:something
+ ] ifFalse:[
+ self insertStringAtCursor:(something printString).
+ self checkLineLimit
+ ].
+ device synchronizeOutput
+!
+
+nextPutAll:something
+ "this allows TextCollectors to be used Stream-wise"
+
+ ^ self nextPut:something
+!
+
+cr
+ collecting ifTrue:[
+ outstandingLines add:outstandingLine.
+ outstandingLine := nil.
+ flushPending ifFalse:[
+ device addTimedBlock:flushBlock after:0.2.
+ flushPending := true
+ ] ifTrue:[
+ device evaluateTimeOutBlocks
+ ]
+ ] ifFalse:[
+ self cursorReturn.
+ self checkLineLimit
+ ]
+!
+
+show:anObject
+ "insert the argument aString at current cursor position"
+
+ |aString|
+
+ aString := anObject printString.
+ collecting ifTrue:[
+ outstandingLine notNil ifTrue:[
+ outstandingLine := outstandingLine , aString
+ ] ifFalse:[
+ outstandingLine := aString
+ ].
+ flushPending ifFalse:[
+ device addTimedBlock:flushBlock after:0.2.
+ flushPending := true
+ ]
+ ] ifFalse:[
+ self nextPut:aString
+ ]
+!
+
+showCr:aString
+ "insert the argument aString followed by a newline
+ at current cursor position"
+
+ self show:aString.
+ self cr
+!
+
+doesNotUnderstand:aMessage
+ "this is funny: all message we do not understand, are passed
+ on to the stream which will send the characters via nextPut:
+ This way, we understand all Stream messages - great isn't it !!
+ "
+ ^ entryStream perform:(aMessage selector)
+ withArguments:(aMessage arguments)
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/TextCollector.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,255 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+EditTextView subclass:#TextCollector
+ instanceVariableNames:'entryStream lineLimit destroyAction
+ outstandingLines outstandingLine
+ flushBlock flushPending collecting'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Text'
+!
+
+TextCollector comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+a view for editable text, which also understands some stream messages.
+Instances of this view can take the place of a stream and display the received
+text; it is used especially for Transcript.
+
+%W% %E%
+written winter-89 by claus
+'!
+
+!TextCollector class methodsFor:'defaults'!
+
+defaultLineLimit
+ ^ nil
+! !
+
+!TextCollector class methodsFor:'instance creation'!
+
+newTranscript
+ |topView transcript f v|
+
+ Display initialize.
+ topView := StandardSystemView label:'Transcript'
+ minExtent:(100 @ 100).
+
+ v := ScrollableView for:self in:topView.
+ v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
+ transcript := v scrolledView.
+ transcript lineLimit:600.
+ transcript collect:true.
+ "transcript partialLines:false."
+
+ f := transcript font.
+ topView extent:(((f widthOf:'x') * 70) @ (f height * 10)).
+
+ Smalltalk at:#Transcript put:transcript.
+
+ "fancy feature: whenever Transcript is closed, reset to StdError"
+ transcript destroyAction:[Smalltalk at:#Transcript put:Stderr].
+
+ topView realize.
+ ^ transcript
+! !
+
+!TextCollector methodsFor:'initialize / release'!
+
+initialize
+ super initialize.
+
+ outstandingLines := OrderedCollection new.
+ flushBlock := [self endEntry].
+ flushPending := false.
+ collecting := false.
+
+ lineLimit := self class defaultLineLimit.
+ entryStream := ActorStream new.
+ entryStream nextPutBlock:[:something | self nextPut:something].
+ entryStream nextPutAllBlock:[:something | self nextPutAll:something]
+!
+
+destroy
+ destroyAction notNil ifTrue:[
+ destroyAction value
+ ].
+ flushBlock notNil ifTrue:[
+ device removeTimedBlock:flushBlock
+ ].
+ super destroy
+! !
+
+!TextCollector methodsFor:'accessing'!
+
+collect:aBoolean
+ "turn on collecting - i.e. do not output immediately
+ but collect text and output en-bloque after some time
+ delta"
+
+ collecting := aBoolean
+!
+
+lineLimit:aNumber
+ "define the number of text-lines I am supposed to hold"
+
+ lineLimit := aNumber
+!
+
+destroyAction:aBlock
+ "define the action to be performed when I get destroyed"
+
+ destroyAction := aBlock
+!
+
+endEntry
+ "flush collected output"
+
+ |nLines|
+
+ "insert the bunch of lines - if any"
+ nLines := outstandingLines size.
+ (nLines ~~ 0) ifTrue:[
+ outstandingLines do:[:line |
+ self insertStringAtCursor:line.
+ self insertCharAtCursor:(Character cr)
+ ].
+"
+ self insertLines:outstandingLines withCr:true.
+"
+ self withCursorOffDo:[
+ (cursorLine >= (firstLineShown + nFullLinesShown)) ifTrue:[
+ self scrollDown:nLines
+ ]
+ ].
+ outstandingLines grow:0
+ ].
+ "and the last partial line - if any"
+ outstandingLine notNil ifTrue:[
+ flushPending := false.
+ self nextPut:outstandingLine.
+ outstandingLine := nil
+ ].
+ device removeTimedBlock:flushBlock.
+ flushPending := false
+! !
+
+!TextCollector methodsFor:'private'!
+
+checkLineLimit
+ "this method checks if the text has become too large (> lineLimit)
+ and cuts off some lines at the top if so; it must be called whenever lines
+ have been added to the bottom"
+
+ |nDel|
+
+ lineLimit notNil ifTrue:[
+ (cursorLine > lineLimit) ifTrue:[
+ nDel := list size - lineLimit.
+ list removeFromIndex:1 toIndex:nDel.
+ cursorLine := cursorLine - nDel.
+ firstLineShown := firstLineShown - nDel.
+ (firstLineShown < 1) ifTrue:[
+ cursorLine := cursorLine - firstLineShown + 1.
+ firstLineShown := 1
+ ].
+ self contentsChanged
+ ]
+ ]
+! !
+
+!TextCollector methodsFor:'stream messages'!
+
+lineLength
+ ^ width // (font width)
+!
+
+nextPut:something
+ "this allows TextCollectors to be used Stream-wise"
+
+ flushPending ifTrue:[
+ self endEntry
+ ].
+ (something isMemberOf:Character) ifTrue:[
+ ((something == Character cr) or:[something == Character nl]) ifTrue:[
+ ^ self cr
+ ].
+ self insertCharAtCursor:something
+ ] ifFalse:[
+ self insertStringAtCursor:(something printString).
+ self checkLineLimit
+ ].
+ device synchronizeOutput
+!
+
+nextPutAll:something
+ "this allows TextCollectors to be used Stream-wise"
+
+ ^ self nextPut:something
+!
+
+cr
+ collecting ifTrue:[
+ outstandingLines add:outstandingLine.
+ outstandingLine := nil.
+ flushPending ifFalse:[
+ device addTimedBlock:flushBlock after:0.2.
+ flushPending := true
+ ] ifTrue:[
+ device evaluateTimeOutBlocks
+ ]
+ ] ifFalse:[
+ self cursorReturn.
+ self checkLineLimit
+ ]
+!
+
+show:anObject
+ "insert the argument aString at current cursor position"
+
+ |aString|
+
+ aString := anObject printString.
+ collecting ifTrue:[
+ outstandingLine notNil ifTrue:[
+ outstandingLine := outstandingLine , aString
+ ] ifFalse:[
+ outstandingLine := aString
+ ].
+ flushPending ifFalse:[
+ device addTimedBlock:flushBlock after:0.2.
+ flushPending := true
+ ]
+ ] ifFalse:[
+ self nextPut:aString
+ ]
+!
+
+showCr:aString
+ "insert the argument aString followed by a newline
+ at current cursor position"
+
+ self show:aString.
+ self cr
+!
+
+doesNotUnderstand:aMessage
+ "this is funny: all message we do not understand, are passed
+ on to the stream which will send the characters via nextPut:
+ This way, we understand all Stream messages - great isn't it !!
+ "
+ ^ entryStream perform:(aMessage selector)
+ withArguments:(aMessage arguments)
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/TextView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,1271 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+ListView subclass:#TextView
+ instanceVariableNames:'selectionStartLine selectionStartCol
+ selectionEndLine selectionEndCol
+ clickStartLine clickStartCol
+ clickLine clickCol clickCount
+ selectionFgColor selectionBgColor
+ fileBox searchBox lineNumberBox
+ wordSelectStyle
+ directoryForFileDialog
+ contentsWasSaved'
+ classVariableNames:'fontPanel'
+ poolDictionaries:''
+ category:'Views-Text'
+!
+
+TextView comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+
+written jun-89 by claus
+autoscroll added spring 92 by claus
+'!
+
+!TextView class methodsFor:'documentation'!
+
+documantation
+"
+a view for text - this class adds selections to a simple List
+
+Instance variables:
+
+selectionStartLine <Number> the line of the selection start (or nil)
+selectionStartCol <Number> the col of the selection start
+selectionEndLine <Number> the line of the selection end
+selectionEndCol <Number> the col of the selection end
+clickStartLine <Number> temporary
+clickStartCol <Number> temporary
+clickLine <Number> temporary
+clickCol <Number> temporary
+clickCount <Number> temporary
+selectionFgColor <Color> color used to draw selections
+selectionBgColor <Color> color used to draw selections
+fileBox <FileSelectionBox> box for save
+searchBox <EnterBox2> box to enter searchpattern
+lineNumberBox <EnterBox> box to enter linenumber
+wordSelectStyle <Symbol> how words are selected
+"
+! !
+
+!TextView class methodsFor:'startup'!
+
+setupEmpty
+ "create a textview - a helper for startWith: and startOn:"
+
+ |top frame label|
+
+ label := 'unnamed'.
+ top := StandardSystemView label:label
+ icon:(Form fromFile:'Editor.xbm' resolution:100).
+
+ frame := ScrollableView for:self in:top.
+ frame origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
+ ^ frame scrolledView
+!
+
+start
+ "start an empty TextView"
+
+ ^ self startWith:nil
+!
+
+startWith:aString
+ "start a textView with aString as initial contents"
+
+ |top textView|
+
+ textView := self setupEmpty.
+ top := textView topView.
+ aString notNil ifTrue:[
+ textView contents:aString
+ ].
+
+ top realize.
+ ^ textView
+
+ "TextView startWith:'some text'"
+ "EditTextView startWith:'some text'"
+!
+
+startOn:aFileName
+ "start a textView on a file"
+
+ |top textView|
+
+ textView := self setupEmpty.
+ top := textView topView.
+ aFileName notNil ifTrue:[
+ top label:(OperatingSystem baseNameOf:aFileName).
+ textView fromFile:aFileName
+ ].
+
+ top realize.
+ ^ textView
+
+ "TextView startOn:'../doc/info.doc'"
+ "EditTextView startOn:'../doc/info.doc'"
+! !
+
+!TextView methodsFor:'initialize & release'!
+
+initialize
+ super initialize.
+ resources := ResourcePack fromFile:'TextViews.rs'.
+ resources addDependent:self.
+ contentsWasSaved := false
+!
+
+initStyle
+ super initStyle.
+
+ viewBackground := White.
+
+ "if running on a color display, we hilight by drawing black on green
+ (looks like a text-marker) otherwise, we draw reverse"
+ device hasColors ifTrue:[
+ selectionFgColor := fgColor.
+ selectionBgColor := Color red:0 green:100 blue:0
+ ] ifFalse:[
+ device hasGreyscales ifTrue:[
+ selectionFgColor := fgColor.
+ selectionBgColor := Color lightGrey
+ ] ifFalse:[
+ selectionFgColor := bgColor.
+ selectionBgColor := fgColor
+ ]
+ ]
+!
+
+initEvents
+ super initEvents.
+ self enableButtonEvents.
+ self enableButtonMotionEvents
+!
+
+realize
+ super realize.
+ selectionFgColor := selectionFgColor on:device.
+ selectionBgColor := selectionBgColor on:device.
+!
+
+initializeMiddleButtonMenu
+ |labels|
+
+ labels := resources array:#(
+ 'copy'
+ '-'
+ 'font'
+ '-'
+ 'search'
+ 'goto'
+ '-'
+ 'save'
+ 'print').
+
+ self middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(copySelection
+ nil
+ changeFont
+ nil
+ search
+ gotoLine
+ nil
+ save
+ print)
+ receiver:self
+ for:self).
+
+ self enableOrDisableSelectionMenuEntries
+!
+
+destroy
+ fileBox notNil ifTrue:[
+ fileBox destroy.
+ fileBox := nil
+ ].
+ searchBox notNil ifTrue:[
+ searchBox destroy.
+ searchBox := nil
+ ].
+ lineNumberBox notNil ifTrue:[
+ lineNumberBox destroy.
+ lineNumberBox := nil
+ ].
+ resources removeDependent:self.
+ super destroy
+! !
+
+!TextView methodsFor:'accessing'!
+
+selectionForegroundColor:color1 backgroundColor:color2
+ "set both selection-foreground and cursor background colors"
+
+ selectionFgColor := color1 on:device.
+ selectionBgColor := color2 on:device.
+ shown ifTrue:[
+ self redraw
+ ]
+!
+
+setList:something
+ "set the displayed contents (a collection of strings)
+ without redraw.
+ Redefined since changing contents implies deselect"
+
+ self unselect.
+ super setList:something
+!
+
+list:something
+ "set the displayed contents (a collection of strings)
+ with redraw.
+ Redefined since changing contents implies deselect"
+
+ self unselect.
+ super list:something
+!
+
+characterAtLine:lineNr col:colNr
+ "return the character at physical line/col -
+ return space if nothing is there"
+
+ |line|
+
+ list notNil ifTrue:[
+ line := self listAt:lineNr.
+ line notNil ifTrue:[
+ (line size >= colNr) ifTrue:[
+ ^ line at:colNr
+ ]
+ ]
+ ].
+ ^ Character space
+!
+
+characterPositionOfSelection
+ "return the character index of the first character in the selection"
+
+ selectionStartLine isNil ifTrue:[^ 1].
+ ^ self characterPositionOfLine:selectionStartLine
+ col:selectionStartCol
+!
+
+directoryForFileDialog:aDirectory
+ "define the directory to use for save-box"
+
+ directoryForFileDialog := aDirectory
+!
+
+contentsWasSaved
+ "return true, if the contents was saved (by a save action),
+ false if not (or was modified again after the last save)."
+
+ ^ contentsWasSaved
+!
+
+fromFile:aFileName
+ "take contents from a named file"
+
+ self directoryForFileDialog:(OperatingSystem directoryNameOf:aFileName).
+ self contents:(FileStream oldFileNamed:aFileName) contents
+! !
+
+!TextView methodsFor:'private'!
+
+fileOutContentsOn:aStream
+ "save contents on a stream"
+
+ list do:[:aLine |
+ aLine notNil ifTrue:[
+ aStream nextPutAll:aLine
+ ].
+ aStream cr
+ ]
+!
+
+widthForScrollBetween:firstLine and:lastLine
+ "return the width in pixels for a scroll between firstLine and lastLine"
+
+ selectionStartLine notNil ifTrue:[
+ (lastLine < selectionStartLine) ifFalse:[
+ (firstLine > selectionEndLine) ifFalse:[
+ ^ width
+ ]
+ ]
+ ].
+ ^ super widthForScrollBetween:firstLine and:lastLine
+!
+
+scrollSelectUp
+ "auto scroll action; scroll and reinstall timed-block"
+
+ device addTimedBlock:autoScrollBlock after:autoScrollDeltaT.
+ self scrollUp
+!
+
+scrollSelectDown
+ "auto scroll action; scroll and reinstall timed-block"
+
+ device addTimedBlock:autoScrollBlock after:autoScrollDeltaT.
+ self scrollDown
+!
+
+stopScrollSelect
+ "stop auto scroll; deinstall timed-block"
+
+ autoScrollBlock notNil ifTrue:[
+ device compressMotionEvents:true.
+ device removeTimedBlock:autoScrollBlock.
+ autoScrollBlock := nil.
+ autoScrollDeltaT := nil
+ ]
+! !
+
+!TextView methodsFor:'menu actions'!
+
+print
+ "print the contents on the printer"
+
+ |printStream|
+
+ list isNil ifTrue:[^ self].
+ printStream := Printer new.
+ printStream notNil ifTrue:[
+ self fileOutContentsOn:printStream.
+ printStream close
+ ]
+!
+
+saveAs:fileName
+ "save contents into a file named fileName"
+
+ |aStream|
+
+ aStream := FileStream newFileNamed:fileName.
+ aStream notNil ifTrue:[
+ self fileOutContentsOn:aStream.
+ aStream close.
+ contentsWasSaved := true
+ ]
+!
+
+save
+ "save contents into a file
+ - ask user for filename using a fileSelectionBox."
+
+ fileBox isNil ifTrue:[
+ fileBox := FileSelectionBox
+ title:'save contents in:'
+ okText:'save'
+ abortText:'cancel'
+ action:[:fileName | self saveAs:fileName]
+ ].
+ directoryForFileDialog notNil ifTrue:[
+ fileBox directory:directoryForFileDialog
+ ].
+ fileBox showAtPointer
+!
+
+copySelection
+ "copy contents into smalltalk copybuffer"
+
+ |text|
+
+ text := self selection.
+ text notNil ifTrue:[
+ Smalltalk at:#CopyBuffer put:text.
+ self unselect
+ ]
+!
+
+changeFont
+ "pop up a fontPanel to change font"
+
+ fontPanel isNil ifTrue:[
+ fontPanel := FontPanel new
+ ].
+ fontPanel action:[:family :face :style :size |
+ self font:(Font family:family
+ face:face
+ style:style
+ size:size)
+ ].
+ fontPanel initialFont:font.
+ fontPanel showAtPointer
+!
+
+gotoLine
+ "show a box to enter lineNumber for positioning"
+
+ lineNumberBox isNil ifTrue:[
+ lineNumberBox :=
+ EnterBox
+ title:(resources at:'line number:')
+ okText:(resources at:'goto')
+ abortText:(resources at:'cancel')
+ action:[:l | self gotoLine:(Number readFromString:l)]
+ ].
+ lineNumberBox showAtPointer
+! !
+
+!TextView methodsFor:'selections'!
+
+enableOrDisableSelectionMenuEntries
+ "sent internally, whenever selection status changes to
+ update menu entries"
+
+ selectionStartLine isNil ifTrue:[
+ self disableSelectionMenuEntries
+ ] ifFalse:[
+ self enableSelectionMenuEntries
+ ]
+!
+
+disableSelectionMenuEntries
+ "disable relevant menu entries when no selection is
+ available - redefined in subclasses to disable more,
+ but do NOT forget a super disableSelectionMenuEntries there."
+
+ middleButtonMenu notNil ifTrue:[
+ middleButtonMenu disable:#copySelection
+ ]
+!
+
+enableSelectionMenuEntries
+ "disable relevant menu entries when a selection is
+ available - redefined in subclasses to enable more,
+ but do NOT forget a super enableSelectionMenuEntries there."
+
+ middleButtonMenu notNil ifTrue:[
+ middleButtonMenu enable:#copySelection
+ ]
+!
+
+unselectWithoutRedraw
+ "forget selection but do not redraw the selection area
+ - can be done when selected area is redrawn anyway or
+ known to be invisible."
+
+ selectionStartLine := nil.
+ self disableSelectionMenuEntries
+!
+
+unselect
+ "unselect - if there was a selection redraw"
+
+ |startLine endLine startVisLine endVisLine|
+
+ selectionStartLine notNil ifTrue:[
+ startLine := selectionStartLine.
+ endLine := selectionEndLine.
+ selectionStartLine := nil.
+
+ "if selection is not visible, we are done"
+ startLine >= (firstLineShown + nLinesShown) ifTrue:[^ self].
+ endLine < firstLineShown ifTrue:[^ self].
+
+ startLine < firstLineShown ifTrue:[
+ startVisLine := 1
+ ] ifFalse:[
+ startVisLine := self listLineToVisibleLine:startLine
+ ].
+ endLine >= (firstLineShown + nLinesShown) ifTrue:[
+ endVisLine := nLinesShown
+ ] ifFalse:[
+ endVisLine := self listLineToVisibleLine:endLine
+ ].
+ "if its only part of a line, just redraw what has to be"
+ (startVisLine == endVisLine) ifTrue:[
+ super redrawVisibleLine:startVisLine from:selectionStartCol to:selectionEndCol
+ ] ifFalse:[
+ super redrawFromVisibleLine:startVisLine to:endVisLine
+ ].
+ self unselectWithoutRedraw
+ ].
+ wordSelectStyle := nil
+!
+
+selectFromLine:startLine col:startCol toLine:endLine col:endCol
+ "select a piece of text"
+
+ self unselect.
+ startLine notNil ifTrue:[
+ selectionStartLine := startLine.
+ selectionStartCol := startCol.
+ selectionEndLine := endLine.
+ selectionEndCol := endCol.
+ (startLine == endLine) ifTrue:[
+ self redrawLine:startLine from:startCol to:endCol
+ ] ifFalse:[
+ startLine to:endLine do:[:lineNr |
+ self redrawLine:lineNr
+ ]
+ ].
+ wordSelectStyle := nil.
+ self enableSelectionMenuEntries
+ ]
+!
+
+selectLine:selectLine
+ "select one line"
+
+ self selectFromLine:selectLine col:1 toLine:(selectLine + 1) col:0
+!
+
+selectLineWhereCharacterPosition:pos
+ "select the line, where characterPosition pos is living.
+ The argument pos starts at 1 from the start of the text."
+
+ self selectLine:(self lineOfCharacterPosition:pos)
+!
+
+selectFromCharacterPosition:pos1 to:pos2
+ "compute line/col from character positions and select the text"
+
+ |line1 col1 line2 col2|
+
+ line1 := self lineOfCharacterPosition:pos1.
+ col1 := pos1 - (self characterPositionOfLine:line1 col:1) + 1.
+ line2 := self lineOfCharacterPosition:pos2.
+ col2 := pos2 - (self characterPositionOfLine:line2 col:1) + 1.
+ self selectFromLine:line1 col:col1 toLine:line2 col:col2
+!
+
+selectWordAtLine:selectLine col:selectCol
+ "select the word at given line/col"
+
+ |beginCol endCol thisCharacter flag|
+
+ flag := nil.
+ beginCol := selectCol.
+ endCol := selectCol.
+ thisCharacter := self characterAtLine:selectLine col:beginCol.
+ thisCharacter isAlphaNumeric ifTrue:[
+ [thisCharacter isAlphaNumeric] whileTrue:[
+ beginCol := beginCol - 1.
+ beginCol < 1 ifTrue:[
+ thisCharacter := Character space
+ ] ifFalse:[
+ thisCharacter := self characterAtLine:selectLine col:beginCol
+ ]
+ ].
+ beginCol := beginCol + 1.
+ thisCharacter := self characterAtLine:selectLine col:endCol.
+ [thisCharacter isAlphaNumeric] whileTrue:[
+ endCol := endCol + 1.
+ thisCharacter := self characterAtLine:selectLine col:endCol
+ ].
+ endCol := endCol - 1.
+
+ "now, we have the word at beginCol..endCol try to catch a blank ..."
+ ((beginCol == 1)
+ or:[(self characterAtLine:selectLine col:(beginCol - 1))
+ ~~ Character space]) ifTrue:[
+ ((self characterAtLine:selectLine col:(endCol + 1))
+ == Character space) ifTrue:[
+ endCol := endCol + 1.
+ flag := #right
+ ]
+ ] ifFalse:[
+ beginCol := beginCol - 1.
+ flag := #left
+ ]
+ ].
+ self selectFromLine:selectLine col:beginCol toLine:selectLine col:endCol.
+ wordSelectStyle := flag
+!
+
+selectWordAtX:x y:y
+ "select the word at given x/y-(view-)coordinate"
+
+ |selectVisibleLine selectLine selectCol|
+
+ wordSelectStyle := nil.
+ selectVisibleLine := self visibleLineOfY:y.
+ selectLine := self visibleLineToListLine:selectVisibleLine.
+ selectLine notNil ifTrue:[
+ selectCol := self colOfX:x inVisibleLine:selectLine.
+ self selectWordAtLine:selectLine col:selectCol
+ ]
+!
+
+selectLineAtY:y
+ "select the line at given y-(view-)coordinate"
+
+ |selectVisibleLine selectLine|
+
+ selectVisibleLine := self visibleLineOfY:y.
+ selectLine := self visibleLineToListLine:selectVisibleLine.
+ selectLine notNil ifTrue:[
+ self selectLine:selectLine
+ ]
+!
+
+selectAll
+ "select the whole text"
+
+ self selectFromLine:1 col:1 toLine:(list size + 1) col:0
+!
+
+selection
+ "return the selection as a Text-Collection"
+
+ |text sz index|
+
+ selectionStartLine isNil ifTrue:[^ nil].
+ (selectionStartLine == selectionEndLine) ifTrue:[
+ "part of a line"
+ ^ Text with:(self listAt:selectionStartLine
+ from:selectionStartCol
+ to:selectionEndCol)
+ ].
+ sz := selectionEndLine - selectionStartLine + 1.
+ text := Text new:sz.
+
+ "get 1st and last (possibly) partial lines"
+ text at:1 put:(self listAt:selectionStartLine from:selectionStartCol).
+ text at:sz put:(self listAt:selectionEndLine to:selectionEndCol).
+
+ "get bulk of text"
+ index := 2.
+ (selectionStartLine + 1) to:(selectionEndLine - 1) do:[:lineNr |
+ text at:index put:(self listAt:lineNr).
+ index := index + 1
+ ].
+ ^ text
+!
+
+makeSelectionVisible
+ "scroll to make selection visible"
+
+ selectionStartLine notNil ifTrue:[
+ self makeLineVisible:selectionStartLine
+ ]
+! !
+
+!TextView methodsFor:'searching'!
+
+search
+ "show a box to enter searchpattern
+ - currently no regular expressions are handled."
+
+ searchBox isNil ifTrue:[
+ searchBox :=
+ EnterBox2
+ title:(resources at:'searchPattern:')
+ okText1:(resources at:'prev')
+ okText2:(resources at:'next')
+ abortText:(resources at:'cancel')
+ action1:[:pattern | self searchBwd:(pattern withoutSeparators)]
+ action2:[:pattern | self searchFwd:(pattern withoutSeparators)]
+ ].
+ searchPattern notNil ifTrue:[
+ searchBox initialText:searchPattern
+ ].
+ searchBox showAtPointer
+!
+
+setSearchPattern
+ "set the searchpattern from the selection if there is one"
+
+ |sel|
+
+ sel := self selection.
+ sel notNil ifTrue:[
+ searchPattern := sel asString withoutSeparators
+ ]
+!
+
+showNotFound
+ "search not found - tell user by beeping and changing
+ cursor for a while (sometimes I work with a headset :-)
+ (used to be: tell user by changing cursor for a while)"
+
+ |savedCursor|
+
+ device beep.
+"
+ uncomment if you want a CROSS cursor to be shown for a while ..
+"
+
+" "
+ savedCursor := cursor.
+ self cursor:(Cursor cross).
+ OperatingSystem millisecondDelay:300.
+ self cursor:savedCursor
+" "
+!
+
+searchFwd
+ "search forward for pattern or selection"
+
+ self setSearchPattern.
+ searchPattern notNil ifTrue:[
+ self searchFwd:searchPattern
+ ]
+!
+
+searchBwd
+ "search backward and -if found- position cursor"
+
+ self setSearchPattern.
+ searchPattern notNil ifTrue:[
+ self searchBwd:searchPattern
+ ]
+!
+
+searchFwd:pattern
+ "do the forward search"
+
+ |startLine startCol|
+
+ selectionStartLine notNil ifTrue:[
+ startLine := selectionStartLine.
+ startCol := selectionStartCol
+ ] ifFalse:[
+ startLine := 1.
+ startCol := 1
+ ].
+ self searchForwardFor:pattern startingAtLine:startLine col:startCol
+ ifFound:[:line :col |
+ self selectFromLine:line col:col
+ toLine:line col:(col + pattern size - 1).
+ self makeLineVisible:line
+ ] else:[
+ self showNotFound
+ ]
+!
+
+searchBwd:pattern
+ "do the backward search"
+
+ |startLine startCol|
+
+ selectionStartLine notNil ifTrue:[
+ startLine := selectionStartLine.
+ startCol := selectionStartCol
+ ] ifFalse:[
+ startLine := 1.
+ startCol := 1
+ ].
+ self searchBackwardFor:pattern startingAtLine:startLine col:startCol
+ ifFound:[:line :col |
+ self selectFromLine:line col:col
+ toLine:line col:(col + pattern size - 1).
+ self makeLineVisible:line
+ ] else:[
+ self showNotFound
+ ]
+! !
+
+!TextView methodsFor:'redrawing'!
+
+clearMarginOfVisible:visLine with:color
+ "if there is a margin, clear it - a helper for selection drawing"
+
+ (leftMargin ~~ 0) ifTrue:[
+ self paint:color.
+ self fillRectangleX:margin
+ y:(self yOfLine:visLine)
+ width:leftMargin
+ height:fontHeight
+ ]
+!
+
+redrawVisibleLine:visLine col:col
+ "redraw single character at col in visible line lineNr"
+
+ |line|
+
+ line := self visibleLineToAbsoluteLine:visLine.
+ selectionStartLine notNil ifTrue:[
+ (line between:selectionStartLine and:selectionEndLine) ifTrue:[
+ ((line == selectionStartLine)
+ and: [col < selectionStartCol]) ifFalse:[
+ ((line == selectionEndLine)
+ and: [col > selectionEndCol]) ifFalse:[
+ "its in the selection"
+ self drawVisibleLine:visLine col:col with:selectionFgColor
+ and:selectionBgColor.
+ ^ self
+ ]
+ ]
+ ]
+ ].
+ super redrawVisibleLine:visLine col:col
+!
+
+redrawFromVisibleLine:startVisLineNr to:endVisLineNr
+ "redraw a visible line range"
+
+ |startLine endLine specialCare end selVisStart line1 line2|
+
+ shown ifFalse:[^ self].
+
+ end := endVisLineNr.
+ (end > nLinesShown) ifTrue:[
+ end := nLinesShown
+ ].
+
+ selectionStartLine isNil ifTrue:[
+ specialCare := false
+ ] ifFalse:[
+ startLine := self visibleLineToAbsoluteLine:startVisLineNr.
+ (startLine > selectionEndLine) ifTrue:[
+ specialCare := false
+ ] ifFalse:[
+ endLine := self visibleLineToAbsoluteLine:end.
+ (endLine < selectionStartLine) ifTrue:[
+ specialCare := false
+ ] ifFalse:[
+ specialCare := true
+ ]
+ ]
+ ].
+
+ "easy: nothing is selected"
+ specialCare ifFalse:[
+ ^ super redrawFromVisibleLine:startVisLineNr to:end
+ ].
+
+ "easy: all is selected"
+ ((selectionStartLine < startLine) and:[selectionEndLine > endLine]) ifTrue:[
+ ^ self drawFromVisibleLine:startVisLineNr to:end with:selectionFgColor
+ and:selectionBgColor
+ ].
+
+ (selectionStartLine >= firstLineShown) ifTrue:[
+ "draw unselected top part"
+
+ selVisStart := self listLineToVisibleLine:selectionStartLine.
+ super redrawFromVisibleLine:startVisLineNr to:(selVisStart - 1).
+
+ "and first partial selected line"
+ self redrawVisibleLine:selVisStart.
+
+ "rest starts after this one"
+ line1 := selVisStart + 1
+ ] ifFalse:[
+ line1 := 1
+ ].
+
+ (line1 > end) ifTrue:[^ self].
+ (line1 < startVisLineNr) ifTrue:[
+ line1 := startVisLineNr
+ ].
+
+ "draw middle part of selection"
+
+ (selectionEndLine >= (firstLineShown + nLinesShown)) ifTrue:[
+ line2 := nLinesShown
+ ] ifFalse:[
+ line2 := (self listLineToVisibleLine:selectionEndLine) - 1
+ ].
+ (line2 > end) ifTrue:[
+ line2 := end
+ ].
+
+ self drawFromVisibleLine:line1 to:line2 with:selectionFgColor
+ and:selectionBgColor.
+
+ (line2 >= end) ifTrue:[^ self].
+
+ "last line of selection"
+ self redrawVisibleLine:(line2 + 1).
+
+ ((line2 + 2) <= end) ifTrue:[
+ super redrawFromVisibleLine:(line2 + 2) to:end
+ ]
+!
+
+redrawVisibleLine:visLine
+ "redraw visible line lineNr"
+
+ |len line l|
+
+ selectionStartLine notNil ifTrue:[
+ line := self visibleLineToAbsoluteLine:visLine.
+ (line between:selectionStartLine and:selectionEndLine) ifTrue:[
+ (line == selectionStartLine) ifTrue:[
+ (line == selectionEndLine) ifTrue:[
+ "its part-of-single-line selection"
+ self clearMarginOfVisible:visLine with:bgColor.
+ (selectionStartCol > 1) ifTrue:[
+ super redrawVisibleLine:visLine
+ from:1
+ to:(selectionStartCol - 1)
+ ].
+ self drawVisibleLine:visLine from:selectionStartCol
+ to:selectionEndCol
+ with:selectionFgColor
+ and:selectionBgColor.
+ ^ super redrawVisibleLine:visLine
+ from:(selectionEndCol + 1)
+ ].
+
+ "its the first line of a multi-line selection"
+ (selectionStartCol ~~ 1) ifTrue:[
+ self clearMarginOfVisible:visLine with:bgColor.
+ super redrawVisibleLine:visLine
+ from:1
+ to:(selectionStartCol - 1)
+ ].
+ ^ self drawVisibleLine:visLine from:selectionStartCol
+ with:selectionFgColor and:selectionBgColor
+ ].
+
+ (line == selectionEndLine) ifTrue:[
+ "its the last line of a multi-line selection"
+ (selectionEndCol == 0) ifTrue:[
+ ^ super redrawVisibleLine:visLine
+ ].
+ l := self visibleAt:selectionEndLine.
+ l isNil ifTrue:[
+ len := 0
+ ] ifFalse:[
+ len := l size
+ ].
+
+ self clearMarginOfVisible:visLine with:selectionBgColor.
+ self drawVisibleLine:visLine from:1 to:selectionEndCol
+ with:selectionFgColor and:selectionBgColor.
+ (selectionEndCol ~~ len) ifTrue:[
+ super redrawVisibleLine:visLine
+ from:(selectionEndCol + 1)
+ ].
+ ^ self
+ ].
+
+ "its a full line in a multi-line selection"
+ self clearMarginOfVisible:visLine with:selectionBgColor.
+ ^ self drawVisibleLine:visLine with:selectionFgColor
+ and:selectionBgColor
+ ]
+ ].
+ ^ super redrawVisibleLine:visLine
+!
+
+redrawVisibleLine:visLine from:startCol
+ "redraw visible line lineNr from startCol to end of line"
+
+ |line|
+
+ line := self visibleLineToAbsoluteLine:visLine.
+ selectionStartLine notNil ifTrue:[
+ (line between:selectionStartLine and:selectionEndLine) ifTrue:[
+ ((line == selectionStartLine)
+ or:[line == selectionEndLine]) ifTrue:[
+ "since I'm lazy, redraw full line"
+ ^ self redrawVisibleLine:visLine
+ ].
+ "the line is fully within the selection"
+ ^ self drawVisibleLine:visLine from:startCol with:selectionFgColor
+ and:selectionBgColor
+ ]
+ ].
+ super redrawVisibleLine:visLine from:startCol
+!
+
+redrawVisibleLine:visLine from:startCol to:endCol
+ "redraw visible line lineNr from startCol to endCol"
+
+ |line allOut allIn leftCol rightCol|
+
+ line := self visibleLineToAbsoluteLine:visLine.
+
+ allIn := false.
+ allOut := false.
+ selectionStartLine isNil ifTrue:[
+ allOut := true
+ ] ifFalse:[
+ (line between:selectionStartLine and:selectionEndLine) ifFalse:[
+ allOut := true
+ ] ifTrue:[
+ (selectionStartLine == selectionEndLine) ifTrue:[
+ ((endCol < selectionStartCol)
+ or:[startCol > selectionEndCol]) ifTrue:[
+ allOut := true
+ ] ifFalse:[
+ ((startCol >= selectionStartCol)
+ and:[endCol <= selectionEndCol]) ifTrue:[
+ allIn := true
+ ]
+ ]
+ ] ifFalse:[
+ (line == selectionStartLine) ifTrue:[
+ (endCol < selectionStartCol) ifTrue:[
+ allOut := true
+ ] ifFalse:[
+ (startCol >= selectionStartCol) ifTrue:[
+ allIn := true
+ ]
+ ]
+ ] ifFalse:[
+ (line == selectionEndLine) ifTrue:[
+ (startCol > selectionEndCol) ifTrue:[
+ allOut := true
+ ] ifFalse:[
+ (endCol <= selectionEndCol) ifTrue:[
+ allIn := true
+ ]
+ ]
+ ] ifFalse:[
+ allIn := true
+ ]
+ ]
+ ]
+ ]
+ ].
+ allOut ifTrue:[
+ ^ super redrawVisibleLine:visLine from:startCol to:endCol
+ ].
+
+ allIn ifTrue:[
+ self drawVisibleLine:visLine from:startCol to:endCol
+ with:selectionFgColor and:selectionBgColor
+ ] ifFalse:[
+ "redraw part before selection"
+ ((line == selectionStartLine)
+ and:[startCol <= selectionStartCol]) ifTrue:[
+ super redrawVisibleLine:visLine from:startCol
+ to:(selectionStartCol - 1).
+ leftCol := selectionStartCol
+ ] ifFalse:[
+ leftCol := startCol
+ ].
+ "redraw selected part"
+ (selectionEndLine > line) ifTrue:[
+ rightCol := endCol
+ ] ifFalse:[
+ rightCol := selectionEndCol min:endCol
+ ].
+ self drawVisibleLine:visLine from:leftCol to:rightCol
+ with:selectionFgColor and:selectionBgColor.
+
+ "redraw part after selection"
+ (rightCol < endCol) ifTrue:[
+ super redrawVisibleLine:visLine from:(rightCol + 1) to:endCol
+ ]
+ ].
+
+ "special care for first and last line of selection:
+ must handle margin also"
+
+ ((line == selectionEndLine)
+ and:[(startCol == 1)
+ and:[selectionStartLine < selectionEndLine]])
+ ifTrue:[
+ self clearMarginOfVisible:visLine with:selectionBgColor.
+ ].
+
+ ((line == selectionStartLine)
+ and:[(startCol == 1)
+ and:[selectionStartLine < selectionEndLine]])
+ ifTrue:[
+ self clearMarginOfVisible:visLine with:bgColor.
+ ]
+! !
+
+!TextView methodsFor:'event processing'!
+
+keyPress:key x:x y:y
+ "handle some keyboard input (there is not much to be done here)"
+
+ (key == #Find) ifTrue:[self search. ^self].
+ (key == #Copy) ifTrue:[self copySelection. ^self].
+
+ (key == #FindNext) ifTrue:[self searchFwd. ^self].
+ (key == #FindPrev) ifTrue:[self searchBwd. ^self].
+
+ (key == #SelectAll) ifTrue:[self selectAll. ^self].
+
+ super keyPress:key x:x y:y
+!
+
+buttonPress:button x:x y:y
+ "mouse-click - prepare for selection change"
+
+ |clickVisibleLine|
+
+ (button == 1) ifTrue:[
+ clickVisibleLine := self visibleLineOfY:y.
+ clickCol := self colOfX:x inVisibleLine:clickVisibleLine.
+ clickLine := self visibleLineToAbsoluteLine:clickVisibleLine.
+ clickStartLine := clickLine.
+ clickStartCol := clickCol.
+ self unselect.
+ clickCount := 1
+ ] ifFalse:[
+ super buttonPress:button x:x y:y
+ ]
+!
+
+buttonShiftPress:button x:x y:y
+ "mouse-click with shift - adding to selection"
+
+ "very simple - just simulate a move"
+ ^ self buttonMotion:button x:x y:y
+!
+
+buttonMultiPress:button x:x y:y
+ "multi-mouse-click - select word under pointer"
+
+ (button == 1) ifTrue:[
+ clickCount notNil ifTrue:[
+ clickCount := clickCount + 1.
+ (clickCount == 2) ifTrue:[
+ self selectWordAtX:x y:y
+ ] ifFalse:[
+ (clickCount == 3) ifTrue:[
+ self selectLineAtY:y
+ ] ifFalse:[
+ (clickCount == 4) ifTrue:[
+ self selectAll
+ ]
+ ]
+ ]
+ ]
+ ] ifFalse:[
+ super buttonMultiPress:button x:x y:y
+ ]
+!
+
+buttonMotion:button x:x y:y
+ "mouse-move while button was pressed - handle selection changes"
+
+ |movedVisibleLine movedLine movedCol
+ movedUp
+ oldStartLine oldEndLine oldStartCol oldEndCol|
+
+ clickLine isNil ifTrue:[^ self].
+
+ "if moved outside of view, start autoscroll"
+ (y < 0) ifTrue:[
+ device compressMotionEvents:false.
+ self startScrollUp:y.
+ ^ self
+ ].
+ (y > height) ifTrue:[
+ device compressMotionEvents:false.
+ self startScrollDown:(y - height).
+ ^ self
+ ].
+
+ "move inside - stop autoscroll if any"
+ autoScrollBlock notNil ifTrue:[
+ self stopScrollSelect
+ ].
+
+ movedVisibleLine := self visibleLineOfY:y.
+ movedLine := self visibleLineToAbsoluteLine:movedVisibleLine.
+ (x < leftMargin) ifTrue:[
+ movedCol := 0
+ ] ifFalse:[
+ movedCol := self colOfX:x inVisibleLine:movedVisibleLine
+ ].
+ ((movedLine == clickLine) and:[movedCol == clickCol]) ifTrue:[^ self].
+
+ selectionStartLine isNil ifTrue:[
+ selectionStartLine := clickLine.
+ selectionStartCol := clickCol.
+ selectionEndLine := selectionStartLine.
+ selectionEndCol := selectionStartCol
+ ].
+ oldStartLine := selectionStartLine.
+ oldEndLine := selectionEndLine.
+ oldStartCol := selectionStartCol.
+ oldEndCol := selectionEndCol.
+
+
+ "find out if we are before or after initial click"
+ movedUp := false.
+ (movedLine < clickStartLine) ifTrue:[
+ movedUp := true
+ ] ifFalse:[
+ (movedLine == clickStartLine) ifTrue:[
+ (movedCol < clickStartCol) ifTrue:[
+ movedUp := true
+ ]
+ ]
+ ].
+
+ movedUp ifTrue:[
+ "change selectionStart"
+ selectionStartCol := movedCol.
+ selectionStartLine := movedLine.
+ selectionEndCol := clickStartCol.
+ selectionEndLine := clickStartLine
+ ] ifFalse:[
+ "change selectionEnd"
+ selectionEndCol := movedCol.
+ selectionEndLine := movedLine.
+ selectionStartCol := clickStartCol.
+ selectionStartLine := clickStartLine
+ ].
+
+ (selectionStartCol == 0) ifTrue:[
+ selectionStartCol := 1
+ ].
+
+ (oldStartLine == selectionStartLine) ifTrue:[
+ (oldStartCol ~~ selectionStartCol) ifTrue:[
+ self redrawLine:oldStartLine
+ from:((selectionStartCol min:oldStartCol) max:1)
+ to:((selectionStartCol max:oldStartCol) max:1)
+ ]
+ ] ifFalse:[
+ self redrawFromLine:(oldStartLine min:selectionStartLine)
+ to:(oldStartLine max:selectionStartLine)
+ ].
+
+ (oldEndLine == selectionEndLine) ifTrue:[
+ (oldEndCol ~~ selectionEndCol) ifTrue:[
+ self redrawLine:oldEndLine
+ from:((selectionEndCol min:oldEndCol) max:1)
+ to:((selectionEndCol max:oldEndCol) max:1)
+ ]
+ ] ifFalse:[
+ self redrawFromLine:(oldEndLine min:selectionEndLine)
+ to:(oldEndLine max:selectionEndLine)
+ ].
+ clickLine := movedLine.
+ clickCol := movedCol
+!
+
+buttonRelease:button x:x y:y
+ "mouse- button release - turn off autoScroll if any"
+
+ (button == 1) ifTrue:[
+ autoScrollBlock notNil ifTrue:[
+ self stopScrollSelect
+ ].
+ selectionStartLine notNil ifTrue:[
+ middleButtonMenu enable:#cut.
+ middleButtonMenu enable:#copySelection.
+ middleButtonMenu enable:#replace.
+ middleButtonMenu enable:#indent.
+ middleButtonMenu enable:#explain.
+ middleButtonMenu enable:#doIt.
+ middleButtonMenu enable:#printIt.
+ middleButtonMenu enable:#inspectIt
+ ]
+ ] ifFalse:[
+ super buttonRelease:button x:x y:y
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Toggle.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,73 @@
+"
+ COPYRIGHT (c) 1989/90/91 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+Button subclass:#Toggle
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+Toggle comment:'
+
+COPYRIGHT (c) 1989/90/91 by Claus Gittinger
+ All Rights Reserved
+
+this button changes state whenever pressed and stays pressed until pressed
+again. All the main action is in Button, Toggle just redefines buttonpress/
+release behavior.
+
+%W% %E%
+written spring/summer 89 by claus
+'!
+
+!Toggle methodsFor:'changing state'!
+
+toggleNoAction
+ "toggle, but do NOT perform any action - can be used to change a toggle
+ under program control (i.e. turn one toggle off from another one)"
+
+ pressed := pressed not.
+ self redraw
+!
+
+toggle
+ "toggle and perform the action"
+
+ enabled ifTrue:[
+ pressed := pressed not.
+ pressed ifTrue:[
+ self level:onLevel.
+ pressActionBlock notNil ifTrue:[pressActionBlock value]
+ ] ifFalse:[
+ self level:offLevel.
+ releaseActionBlock notNil ifTrue:[releaseActionBlock value]
+ ].
+ self redraw
+ ]
+! !
+
+!Toggle methodsFor:'events'!
+
+buttonPress:button x:x y:y
+ button == 1 ifFalse:[
+ ^ super buttonPress:button x:x y:y
+ ].
+ self toggle
+!
+
+buttonRelease:button x:x y:y
+ button == 1 ifFalse:[
+ ^ super buttonRelease:button x:x y:y
+ ].
+ "ignore"
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/VPanelV.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,129 @@
+"
+ COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+PanelView subclass:#VerticalPanelView
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Layout'
+!
+
+VerticalPanelView comment:'
+
+COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+a View for childViews oriented vertical
+all real work is done in PanelView - just redefine layout
+
+%W% %E%
+
+written spring/summer 89 by claus
+'!
+
+!VerticalPanelView methodsFor:'queries'!
+
+preferedExtent
+ "return a good extent, one that makes subviews fit"
+
+ |sumOfHeights maxWidth|
+
+ subViews isNil ifTrue:[^ horizontalSpace @ verticalSpace].
+
+ "compute net height needed"
+
+ sumOfHeights := 0.
+ maxWidth := 0.
+
+ subViews do:[:child |
+ sumOfHeights := sumOfHeights + child heightIncludingBorder.
+ maxWidth := maxWidth max:(child widthIncludingBorder)
+ ].
+ borderWidth ~~ 0 ifTrue:[
+ sumOfHeights := sumOfHeights + (horizontalSpace * 2).
+ maxWidth := maxWidth + (horizontalSpace * 2).
+ ].
+ sumOfHeights := sumOfHeights + ((subViews size - 1) * verticalSpace).
+
+ ^ maxWidth @ sumOfHeights
+! !
+
+!VerticalPanelView methodsFor:'layout'!
+
+setChildPositions
+ "(re)compute position of every child"
+
+ |xpos ypos space sumOfHeights numChilds l|
+
+ subViews isNil ifTrue:[^ self].
+
+ space := verticalSpace.
+
+ "compute net height needed"
+
+ sumOfHeights := 0.
+ numChilds := subViews size.
+
+ subViews do:[:child |
+ sumOfHeights := sumOfHeights + child heightIncludingBorder.
+ ].
+
+ l := layout.
+ ((l == #center) and:[numChilds == 1]) ifTrue:[
+ l := #spread
+ ].
+
+ "compute position of topmost subview and space between them;
+ if they do hardly fit, leave no space between them "
+
+ (sumOfHeights >= height) ifTrue:[
+ ypos := 0.
+ space := 0
+ ] ifFalse:[
+ (l == #bottom) ifTrue:[
+ ypos := height - (horizontalSpace * numChilds)
+ - sumOfHeights.
+ borderWidth == 0 ifTrue:[
+ ypos := ypos + horizontalSpace
+ ].
+ ] ifFalse: [
+ (l == #spread) ifTrue:[
+ space := (height - sumOfHeights) // (numChilds + 1).
+ ypos := space.
+ (space == 0) ifTrue:[
+ ypos := (height - sumOfHeights) // 2
+ ]
+ ] ifFalse: [
+ (l == #center) ifTrue:[
+ ypos := (height - (sumOfHeights
+ + ((numChilds - 1) * space))) // 2
+ ] ifFalse:[
+ borderWidth == 0 ifTrue:[
+ ypos := 0
+ ] ifFalse:[
+ ypos := verticalSpace
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ "now set positions"
+
+ subViews do:[:childView |
+ xpos := (width - childView widthIncludingBorder) // 2.
+ (xpos < 0) ifTrue:[ xpos := 0 ].
+
+ childView origin:(xpos@ypos).
+ ypos := ypos + (childView heightIncludingBorder) + space
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/VarHPanel.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,331 @@
+"
+ COPYRIGHT (c) 1992-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+VariableVerticalPanel subclass:#VariableHorizontalPanel
+ instanceVariableNames:''
+ classVariableNames:'hArrow'
+ poolDictionaries:''
+ category:'Views-Layout'
+!
+
+VariableHorizontalPanel comment:'
+
+COPYRIGHT (c) 1992-93 by Claus Gittinger
+ All Rights Reserved
+
+a View to separate its subviews horizontally by a movable bar
+to adjust the size-ratios.
+The bar-handle is either an exposed knob (knobStyle == #motif)
+or the forms defined in Scroller (knobStyle ~~ #motif)
+
+%W% %E%
+
+written summer 92 by claus
+'!
+
+!VariableHorizontalPanel methodsFor:'initializing'!
+
+initCursor
+ "set the cursor - a horizontal double arrow"
+
+ "which one looks better ?"
+ cursor := Cursor leftRightArrow
+ "cursor := Cursor leftLimitArrow"
+! !
+
+!VariableHorizontalPanel methodsFor:'private'!
+
+handleOriginsFrom:start to:stop do:aBlock
+ "evaluate the argument block for some handle-origins"
+
+ |y hh|
+
+ subViews notNil ifTrue:[
+ shadowForm notNil ifTrue:[
+ hh := shadowForm height
+ ] ifFalse:[
+ hh := barHeight
+ ].
+ (handlePosition == #left) ifTrue:[
+ y := hh * 2
+ ] ifFalse:[
+ (handlePosition == #right) ifTrue:[
+ y := height - (2 * hh) - margin
+ ] ifFalse:[
+ y := height // 2
+ ]
+ ].
+ (start + 1) to:stop do:[:index |
+ |x view|
+
+ view := subViews at:index.
+ x := view origin x - barHeight + 1.
+ aBlock value:(x @ y)
+ ]
+ ]
+!
+
+setupSubviewSizes
+ "setup subviews sizes (in case of non-relative sizes)"
+
+ |x w |
+
+ self anyNonRelativeSubviews ifTrue:[
+ "there is at least one subview without
+ relative origin/extent - setup all subviews
+ to spread evenly ..."
+
+ x := 0.0.
+ w := 1.0 / (subViews size).
+
+ 1 to:(subViews size) do:[:index |
+ |view|
+
+ view := subViews at:index.
+ index == subViews size ifTrue:[
+ view origin:(x @ 0.0) corner:(1.0 @ 1.0)
+ ] ifFalse:[
+ view origin:(x @ 0.0) corner:((x + w) @ 1.0)
+ ].
+ x := x + w
+ ]
+ ]
+!
+
+resizeSubviewsFrom:start to:stop
+ "readjust size of some subviews"
+
+ |step nSubviews|
+
+ subViews notNil ifTrue:[
+ (start <= stop) ifTrue:[
+ step := 1
+ ] ifFalse:[
+ step := -1
+ ].
+ nSubviews := subViews size.
+ start to:stop by:step do:[:index |
+ |bw view o1 o2 relCorner relOrg newCorner newOrg|
+
+ view := subViews at:index.
+ bw := view borderWidth.
+
+ index == 1 ifTrue:[
+ o1 := 0.
+ ] ifFalse:[
+ o1 := barHeight // 2 - bw
+ ].
+ index == nSubviews ifTrue:[
+ o2 := 0.
+ ] ifFalse:[
+ o2 := barHeight // 2 - bw
+ ].
+
+ relCorner := view relativeCorner.
+ relCorner isNil ifTrue:[
+ self error:'subview must have relative corner'
+ ].
+ newCorner := view cornerFromRelativeCorner.
+ newCorner notNil ifTrue:[
+ newCorner x:(newCorner x - o2)
+ ].
+
+ relOrg := view relativeOrigin.
+ relOrg isNil ifTrue:[
+ self error:'subview must have relative origin'
+ ].
+ newOrg := view originFromRelativeOrigin.
+ newOrg notNil ifTrue:[
+ (index ~~ 1) ifTrue:[
+ newOrg x:(newOrg x + o1)
+ ].
+ ].
+ view pixelOrigin:newOrg corner:newCorner
+ ]
+ ]
+! !
+
+!VariableHorizontalPanel methodsFor:'events'!
+
+buttonPress:button x:bx y:by
+ "button was pressed - if it hits a handle, start move"
+
+ |handle|
+
+ (button == 1) ifTrue:[
+ handle := 1.
+ self handleOriginsDo:[:hPoint |
+ |hx|
+
+ hx := hPoint x.
+ (bx between:hx and:(hx + barHeight)) ifTrue:[
+ movedHandle := handle.
+ prev := hx.
+ start := bx - hx.
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:hx y:0 width:barHeight height:height
+ ].
+ self clipByChildren.
+ ^ self
+ ].
+ handle := handle + 1
+ ].
+ movedHandle := nil
+ ] ifFalse:[
+ super buttonPress:button x:bx y:by
+ ]
+!
+
+buttonMotion:button x:bx y:by
+ "mouse-button was moved while pressed;
+ clear prev handleBar and draw handle bar at new position"
+
+ |xpos limitTop limitBot|
+
+ movedHandle isNil ifTrue: [^ self]. "should not happen"
+
+ "speedup - if there is already another movement,
+ ignore thisone ... "
+
+ device synchronizeOutput.
+ self buttonMotionEventPending ifTrue:[^ self].
+
+ xpos := bx - start.
+ limitTop := barHeight // 2.
+ limitBot := self width - barHeight.
+ movedHandle > 1 ifTrue:[
+ limitTop := (subViews at:movedHandle) origin x + (barHeight // 2)
+ ].
+ movedHandle < (subViews size - 1) ifTrue:[
+ limitBot := (subViews at:(movedHandle + 2)) origin x - barHeight
+ ].
+ limitBot := limitBot - barHeight.
+ (xpos < limitTop) ifTrue:[ "check against view limits"
+ xpos := limitTop
+ ] ifFalse:[
+ (xpos > limitBot) ifTrue:[
+ xpos := limitBot
+ ]
+ ].
+
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:prev y:0 width:barHeight height:height.
+ self fillRectangleX:xpos y:0 width:barHeight height:height
+ ].
+ self clipByChildren.
+ prev := xpos
+!
+
+buttonRelease:button x:x y:y
+ "end bar-move"
+
+ |aboveView belowView aboveIndex belowIndex newX|
+
+ (button == 1) ifTrue:[
+ movedHandle isNil ifTrue:[^ self].
+
+ "undo the last xor"
+
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:prev y:0 width:barHeight height:height
+ ].
+ self clipByChildren.
+
+ "compute the new relative heights"
+
+ aboveIndex := movedHandle.
+ belowIndex := movedHandle + 1.
+ aboveView := subViews at:aboveIndex.
+ belowView := subViews at:belowIndex.
+
+ newX := (prev + start / width) asFloat .
+ aboveView relativeCorner:newX @ aboveView relativeCorner y.
+ belowView relativeOrigin:newX @ belowView relativeOrigin y.
+ self resizeSubviewsFrom:aboveIndex to:belowIndex.
+
+ movedHandle := nil.
+
+ "and redraw handles"
+
+ self redrawHandlesFrom:aboveIndex to:belowIndex
+ ] ifFalse:[
+ super buttonRelease:button x:x y:y
+ ]
+! !
+
+!VariableHorizontalPanel methodsFor:'drawing'!
+
+drawHandleAtX:hx y:hy
+ |w x m|
+
+ (self is3D and:[shadowForm notNil]) ifTrue:[
+ w := shadowForm height
+ ] ifFalse:[
+ w := barHeight - 4
+ ].
+
+ self paint:viewBackground.
+ self fillRectangleX:hx y:margin
+ width:barHeight
+ height:(height - margin - margin).
+
+ self is3D ifTrue:[
+ m := (barHeight - w) // 2.
+ shadowForm isNil ifTrue:[
+ x := hx + (barHeight // 2).
+ style == #motif ifTrue:[
+ self paint:shadowColor.
+ self displayLineFromX:x y:margin toX:x y:(height - margin).
+ x := x + 1.
+ self paint:lightColor.
+ self displayLineFromX:x y:margin toX:x y:(height - margin).
+ ].
+ self paint:viewBackground.
+ self fillRectangleX:hx y:(hy - barWidth)
+ width:w height:(barWidth + barWidth).
+
+ self drawEdgesForX:(hx + m)
+ y:(hy - barWidth)
+ width:w height:(barWidth + barWidth)
+ level:2
+ ] ifFalse:[
+ self drawHandleFormAtX:(hx + m) y:hy
+ ]
+ ] ifFalse:[
+ x := hx + barHeight - 2.
+ self paint:handleColor.
+ self displayLineFromX:hx y:0 toX:hx y:height.
+ self displayLineFromX:x y:0 toX:x y:height.
+ self fillRectangleX:hx y:hy width:barHeight height:barHeight
+ ]
+!
+
+redrawHandlesFrom:start to:stop
+ "redraw some handles"
+
+ subViews notNil ifTrue:[
+ self handleOriginsFrom:start to:stop do:[:hPoint |
+ self drawHandleAtX:(hPoint x) y:(hPoint y)
+ ].
+ movedHandle notNil ifTrue:[
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:prev y:0 width:barHeight height:height
+ ].
+ self clipByChildren
+ ]
+ ]
+
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/VarVPanel.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,520 @@
+"
+ COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+View subclass:#VariableVerticalPanel
+ instanceVariableNames:'movedHandle prev start
+ barHeight barWidth
+ shadowForm lightForm
+ handlePosition
+ handleColor noColor'
+ classVariableNames:'arrow defaultPosition'
+ poolDictionaries:''
+ category:'Views-Layout'
+!
+
+VariableVerticalPanel comment:'
+
+COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+a View to separate its subviews vertically by a movable bar;
+the size-ratios of the subviews can be changed by moving this bar.
+
+The bar-handle is either an exposed knob (style == #motif)
+or the forms defined in Scroller (style ~~ #motif)
+
+%W% %E%
+
+written summer 91 by claus
+'!
+
+!VariableVerticalPanel class methodsFor:'initialization'!
+
+initialize
+ "read defaults"
+
+ super initialize.
+ defaultPosition := Resource name:'VARIABLE_PANEL_HANDLE_POSITION'
+ default:#right
+ fromFile:'Smalltalk.rs'
+! !
+
+!VariableVerticalPanel class methodsFor:'defaults'!
+
+shadowFormOn:aDisplay
+ "use same handle as Scroller"
+
+ ^ Scroller handleShadowFormOn:aDisplay
+!
+
+lightFormOn:aDisplay
+ "use same handle as Scroller"
+
+ ^ Scroller handleLightFormOn:aDisplay
+! !
+
+!VariableVerticalPanel methodsFor:'initializing'!
+
+initialize
+ super initialize.
+ handlePosition := defaultPosition.
+ noColor := Color noColor.
+ handleColor := Black.
+ self is3D ifTrue:[
+ self barHeight:(3 * ViewSpacing)
+ ] ifFalse:[
+ self barHeight:(2 * ViewSpacing)
+ ].
+ barWidth := 2 * ViewSpacing "motif style width"
+!
+
+initStyle
+ super initStyle.
+
+ (self is3D and:[style == #next]) ifTrue:[
+ shadowForm := self class shadowFormOn:device.
+ lightForm := self class lightFormOn:device
+ ].
+ shadowForm notNil ifTrue:[
+ self barHeight:(shadowForm height + 2).
+ barWidth := shadowForm width
+ ]
+!
+
+initCursor
+ "set the cursor - a double arrow"
+
+ "which one looks better ?"
+ cursor := Cursor upDownArrow
+ "cursor := Cursor upLimitArrow"
+!
+
+initEvents
+ self enableButtonEvents.
+ self enableButtonMotionEvents
+!
+
+fixSize
+ super fixSize.
+ self resizeSubviewsFrom:1 to:(subViews size)
+! !
+
+!VariableVerticalPanel methodsFor:'accessing'!
+
+add:aView
+ "a view is added; make its size relative (if not already done)"
+
+ super add:aView.
+ shown ifTrue:[
+ self setupSubviewSizes
+ ]
+!
+
+removeSubView:aView
+ "a view is removed; adjust other subviews sizes"
+
+ super removeSubView:aView.
+ shown ifTrue:[
+ self setupSubviewSizes
+ ]
+!
+
+barHeight:nPixel
+ "set the height of the separating bar"
+
+ barHeight := nPixel.
+
+ "if screen is very low-res, make certain bar is visible and catchable"
+ (barHeight < 4) ifTrue:[
+ barHeight := 4
+ ].
+
+ "make it even so spacing is equally spreadable among subviews"
+ barHeight odd ifTrue:[
+ barHeight := barHeight + 1
+ ]
+!
+
+handlePosition:aSymbol
+ "define the position of the handle; the argument aSymbol
+ may be one of #left, #right or #center"
+
+ handlePosition := aSymbol
+!
+
+handlePosition
+ "return the position of the handle"
+
+ ^ handlePosition
+!
+
+style:styleSymbol
+ "define the style of the handle;
+ styleSymbol may be #motif to draw a little knob or
+ enything else to draw scrollBars handleForm"
+
+ (styleSymbol ~~ style) ifTrue:[
+ style := styleSymbol.
+ shadowForm := self class shadowFormOn:device.
+ lightForm := self class lightFormOn:device.
+ (self is3D and:[style ~~ #motif]) ifTrue:[
+ shadowForm notNil ifTrue:[
+ self barHeight:(shadowForm height + 2).
+ barWidth := shadowForm width
+ ]
+ ].
+ self resizeSubviewsFrom:1 to:(subViews size).
+ self redraw
+ ]
+! !
+
+!VariableVerticalPanel methodsFor:'drawing'!
+
+drawHandleFormAtX:hx y:hy
+ "kludge for now"
+ (viewBackground colorId notNil
+ and:[shadowColor colorId notNil
+ and:[lightColor colorId notNil]]) ifTrue:[
+ self foreground:viewBackground background:noColor function:#xor.
+ self drawOpaqueForm:shadowForm x:hx y:hy.
+ self foreground:shadowColor function:#or.
+ self drawOpaqueForm:shadowForm x:hx y:hy.
+ self foreground:viewBackground function:#xor.
+ self drawOpaqueForm:lightForm x:hx y:hy.
+ self foreground:lightColor function:#or.
+ self drawOpaqueForm:lightForm x:hx y:hy.
+
+ self foreground:viewBackground.
+ paint := nil. "kludge to force paint to be really set"
+ self paint:viewBackground.
+ self function:#copy
+ ]
+!
+
+drawHandleAtX:hx y:hy
+ |h y m|
+
+ (self is3D and:[shadowForm notNil]) ifTrue:[
+ h := shadowForm height
+ ] ifFalse:[
+ h := barHeight - 4
+ ].
+
+ self paint:viewBackground.
+ self fillRectangleX:margin y:hy
+ width:(width - margin - margin)
+ height:barHeight.
+
+ self is3D ifTrue:[
+ m := (barHeight - h) // 2.
+ shadowForm isNil ifTrue:[
+ y := hy + (barHeight // 2).
+ style == #motif ifTrue:[
+ self paint:shadowColor.
+ self displayLineFromX:margin y:y toX:(width - margin) y:y.
+ y := y + 1.
+ self paint:lightColor.
+ self displayLineFromX:margin y:y toX:(width - margin) y:y.
+ ].
+ self paint:viewBackground.
+ self fillRectangleX:(hx - barWidth) y:hy
+ width:(barWidth + barWidth)
+ height:h.
+
+ self drawEdgesForX:(hx - barWidth)
+ y:(hy + m)
+ width:(barWidth + barWidth)
+ height:h level:2
+ ] ifFalse:[
+ self drawHandleFormAtX:hx y:(hy + m)
+ ]
+ ] ifFalse:[
+ y := hy + barHeight - 1.
+ self paint:handleColor.
+ self displayLineFromX:0 y:hy+1 toX:width y:hy+1.
+ self displayLineFromX:0 y:y toX:width y:y.
+ self fillRectangleX:hx y:hy width:barHeight height:barHeight
+ ]
+!
+
+redrawHandlesFrom:start to:stop
+ "redraw some handles"
+
+ subViews notNil ifTrue:[
+ self handleOriginsFrom:start to:stop do:[:hPoint |
+ self drawHandleAtX:(hPoint x) y:(hPoint y)
+ ].
+ movedHandle notNil ifTrue:[
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:0 y:prev width:width height:barHeight
+ ].
+ self clipByChildren
+ ]
+ ]
+!
+
+redraw
+ "redraw the handles"
+
+ self redrawHandlesFrom:1 to:(subViews size)
+! !
+
+!VariableVerticalPanel methodsFor:'events'!
+
+sizeChanged:how
+ "tell subviews if I change size"
+
+ (how == #smaller) ifTrue:[
+ self resizeSubviewsFrom:1 to:(subViews size)
+ ] ifFalse:[
+ self resizeSubviewsFrom:(subViews size) to:1
+ ]
+!
+
+buttonPress:button x:bx y:by
+ "button was pressed - if it hits a handle, start move"
+
+ |handle|
+
+ (button == 1) ifTrue:[
+ handle := 1.
+ self handleOriginsDo:[:hPoint |
+ |hy|
+
+ hy := hPoint y.
+ (by between:hy and:(hy + barHeight)) ifTrue:[
+ movedHandle := handle.
+ prev := hy.
+ start := by - hy.
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:0 y:hy width:width height:barHeight
+ ].
+ self clipByChildren.
+ ^ self
+ ].
+ handle := handle + 1
+ ].
+ movedHandle := nil
+ ] ifFalse:[
+ super buttonPress:button x:bx y:by
+ ]
+!
+
+buttonMotion:button x:bx y:by
+ "mouse-button was moved while pressed;
+ clear prev handleBar and draw handle bar at new position"
+
+ |ypos limitTop limitBot|
+
+ movedHandle isNil ifTrue: [^ self]. "should not happen"
+
+ "speedup - if there is already another movement,
+ ignore thisone ... "
+
+ device synchronizeOutput.
+ self buttonMotionEventPending ifTrue:[^ self].
+
+ ypos := by - start.
+ limitTop := barHeight // 2.
+ limitBot := self height - barHeight.
+ movedHandle > 1 ifTrue:[
+ limitTop := (subViews at:movedHandle) origin y + (barHeight // 2)
+ ].
+ movedHandle < (subViews size - 1) ifTrue:[
+ limitBot := (subViews at:(movedHandle + 2)) origin y - barHeight
+ ].
+ limitBot := limitBot - barHeight.
+ (ypos < limitTop) ifTrue:[ "check against view limits"
+ ypos := limitTop
+ ] ifFalse:[
+ (ypos > limitBot) ifTrue:[
+ ypos := limitBot
+ ]
+ ].
+
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:0 y:prev width:width height:barHeight.
+ self fillRectangleX:0 y:ypos width:width height:barHeight
+ ].
+ self clipByChildren.
+ prev := ypos
+!
+
+buttonRelease:button x:x y:y
+ "end bar-move"
+
+ |aboveView belowView aboveIndex belowIndex newY|
+
+ (button == 1) ifTrue:[
+ movedHandle isNil ifTrue:[^ self].
+
+ "undo the last xor"
+
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:0 y:prev width:width height:barHeight
+ ].
+ self clipByChildren.
+
+ "compute the new relative heights"
+
+ aboveIndex := movedHandle.
+ belowIndex := movedHandle + 1.
+ aboveView := subViews at:aboveIndex.
+ belowView := subViews at:belowIndex.
+
+ newY := (prev + start / height) asFloat.
+ aboveView relativeCorner:aboveView relativeCorner x @ newY.
+ belowView relativeOrigin:belowView relativeOrigin x @ newY.
+ self resizeSubviewsFrom:aboveIndex to:belowIndex.
+
+ movedHandle := nil.
+
+ self redrawHandlesFrom:aboveIndex to:belowIndex
+ ] ifFalse:[
+ super buttonRelease:button x:x y:y
+ ]
+! !
+
+!VariableVerticalPanel methodsFor:'private'!
+
+anyNonRelativeSubviews
+ "return true, if any of my subviews has no relative origin/extent"
+
+ 1 to:(subViews size) do:[:index |
+ |view|
+
+ view := subViews at:index.
+ view relativeExtent isNil ifTrue:[^ true].
+ view relativeOrigin isNil ifTrue:[^ true]
+ ].
+ ^ false
+!
+
+setupSubviewSizes
+ "setup subviews sizes (in case of non-relative sizes)"
+
+ |y h|
+
+ self anyNonRelativeSubviews ifTrue:[
+ "there is at least one subview without
+ relative origin/extent - setup all subviews
+ to spread evenly ..."
+
+ y := 0.0.
+ h := 1.0 / (subViews size).
+
+ 1 to:(subViews size) do:[:index |
+ |view|
+
+ view := subViews at:index.
+ index == subViews size ifTrue:[
+ view origin:(0.0 @ y) corner:(1.0 @ 1.0)
+ ] ifFalse:[
+ view origin:(0.0 @ y) corner:(1.0 @ (y + h))
+ ].
+ y := y + h
+ ]
+ ]
+!
+
+resizeSubviewsFrom:start to:stop
+ "readjust size of some subviews"
+
+ |step nSubviews|
+
+ subViews notNil ifTrue:[
+ (start <= stop) ifTrue:[
+ step := 1
+ ] ifFalse:[
+ step := -1
+ ].
+ nSubviews := subViews size.
+ start to:stop by:step do:[:index |
+ |bw view o1 o2 relOrg relCorner newOrg newCorner|
+
+ view := subViews at:index.
+ bw := view borderWidth.
+
+ index == 1 ifTrue:[
+ o1 := 0.
+ ] ifFalse:[
+ o1 := barHeight // 2 - bw
+ ].
+ index == nSubviews ifTrue:[
+ o2 := 0.
+ ] ifFalse:[
+ o2 := barHeight // 2 - bw
+ ].
+
+ relCorner := view relativeCorner.
+ relCorner isNil ifTrue:[
+ self error:'subview must have relative corner'
+ ].
+ newCorner := view cornerFromRelativeCorner.
+ newCorner notNil ifTrue:[
+ newCorner y:(newCorner y - o2)
+ ].
+
+ relOrg := view relativeOrigin.
+ relOrg isNil ifTrue:[
+ self error:'subview must have relative origin'
+ ].
+ newOrg := view originFromRelativeOrigin.
+ newOrg notNil ifTrue:[
+ (index ~~ 1) ifTrue:[
+ newOrg y:(newOrg y + o1)
+ ].
+ ].
+ view pixelOrigin:newOrg corner:newCorner
+ ]
+ ]
+!
+
+handleOriginsFrom:start to:stop do:aBlock
+ "evaluate the argument block for some handle-origins"
+
+ |x hw|
+
+ subViews notNil ifTrue:[
+ shadowForm notNil ifTrue:[
+ hw := shadowForm width
+ ] ifFalse:[
+ hw := barHeight
+ ].
+ (handlePosition == #left) ifTrue:[
+ x := hw * 2
+ ] ifFalse:[
+ (handlePosition == #right) ifTrue:[
+ x := width - (2 * hw) - margin
+ ] ifFalse:[
+ x := width // 2
+ ]
+ ].
+ (start + 1) to:stop do:[:index |
+ |view y|
+
+ view := subViews at:index.
+ y := view origin y - barHeight + 1.
+ aBlock value:(x @ y)
+ ]
+ ]
+!
+
+handleOriginsDo:aBlock
+ "evaluate the argument block for every handle-origin"
+
+ self handleOriginsFrom:1 to:(subViews size) do:aBlock
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/VariableHorizontalPanel.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,331 @@
+"
+ COPYRIGHT (c) 1992-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+VariableVerticalPanel subclass:#VariableHorizontalPanel
+ instanceVariableNames:''
+ classVariableNames:'hArrow'
+ poolDictionaries:''
+ category:'Views-Layout'
+!
+
+VariableHorizontalPanel comment:'
+
+COPYRIGHT (c) 1992-93 by Claus Gittinger
+ All Rights Reserved
+
+a View to separate its subviews horizontally by a movable bar
+to adjust the size-ratios.
+The bar-handle is either an exposed knob (knobStyle == #motif)
+or the forms defined in Scroller (knobStyle ~~ #motif)
+
+%W% %E%
+
+written summer 92 by claus
+'!
+
+!VariableHorizontalPanel methodsFor:'initializing'!
+
+initCursor
+ "set the cursor - a horizontal double arrow"
+
+ "which one looks better ?"
+ cursor := Cursor leftRightArrow
+ "cursor := Cursor leftLimitArrow"
+! !
+
+!VariableHorizontalPanel methodsFor:'private'!
+
+handleOriginsFrom:start to:stop do:aBlock
+ "evaluate the argument block for some handle-origins"
+
+ |y hh|
+
+ subViews notNil ifTrue:[
+ shadowForm notNil ifTrue:[
+ hh := shadowForm height
+ ] ifFalse:[
+ hh := barHeight
+ ].
+ (handlePosition == #left) ifTrue:[
+ y := hh * 2
+ ] ifFalse:[
+ (handlePosition == #right) ifTrue:[
+ y := height - (2 * hh) - margin
+ ] ifFalse:[
+ y := height // 2
+ ]
+ ].
+ (start + 1) to:stop do:[:index |
+ |x view|
+
+ view := subViews at:index.
+ x := view origin x - barHeight + 1.
+ aBlock value:(x @ y)
+ ]
+ ]
+!
+
+setupSubviewSizes
+ "setup subviews sizes (in case of non-relative sizes)"
+
+ |x w |
+
+ self anyNonRelativeSubviews ifTrue:[
+ "there is at least one subview without
+ relative origin/extent - setup all subviews
+ to spread evenly ..."
+
+ x := 0.0.
+ w := 1.0 / (subViews size).
+
+ 1 to:(subViews size) do:[:index |
+ |view|
+
+ view := subViews at:index.
+ index == subViews size ifTrue:[
+ view origin:(x @ 0.0) corner:(1.0 @ 1.0)
+ ] ifFalse:[
+ view origin:(x @ 0.0) corner:((x + w) @ 1.0)
+ ].
+ x := x + w
+ ]
+ ]
+!
+
+resizeSubviewsFrom:start to:stop
+ "readjust size of some subviews"
+
+ |step nSubviews|
+
+ subViews notNil ifTrue:[
+ (start <= stop) ifTrue:[
+ step := 1
+ ] ifFalse:[
+ step := -1
+ ].
+ nSubviews := subViews size.
+ start to:stop by:step do:[:index |
+ |bw view o1 o2 relCorner relOrg newCorner newOrg|
+
+ view := subViews at:index.
+ bw := view borderWidth.
+
+ index == 1 ifTrue:[
+ o1 := 0.
+ ] ifFalse:[
+ o1 := barHeight // 2 - bw
+ ].
+ index == nSubviews ifTrue:[
+ o2 := 0.
+ ] ifFalse:[
+ o2 := barHeight // 2 - bw
+ ].
+
+ relCorner := view relativeCorner.
+ relCorner isNil ifTrue:[
+ self error:'subview must have relative corner'
+ ].
+ newCorner := view cornerFromRelativeCorner.
+ newCorner notNil ifTrue:[
+ newCorner x:(newCorner x - o2)
+ ].
+
+ relOrg := view relativeOrigin.
+ relOrg isNil ifTrue:[
+ self error:'subview must have relative origin'
+ ].
+ newOrg := view originFromRelativeOrigin.
+ newOrg notNil ifTrue:[
+ (index ~~ 1) ifTrue:[
+ newOrg x:(newOrg x + o1)
+ ].
+ ].
+ view pixelOrigin:newOrg corner:newCorner
+ ]
+ ]
+! !
+
+!VariableHorizontalPanel methodsFor:'events'!
+
+buttonPress:button x:bx y:by
+ "button was pressed - if it hits a handle, start move"
+
+ |handle|
+
+ (button == 1) ifTrue:[
+ handle := 1.
+ self handleOriginsDo:[:hPoint |
+ |hx|
+
+ hx := hPoint x.
+ (bx between:hx and:(hx + barHeight)) ifTrue:[
+ movedHandle := handle.
+ prev := hx.
+ start := bx - hx.
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:hx y:0 width:barHeight height:height
+ ].
+ self clipByChildren.
+ ^ self
+ ].
+ handle := handle + 1
+ ].
+ movedHandle := nil
+ ] ifFalse:[
+ super buttonPress:button x:bx y:by
+ ]
+!
+
+buttonMotion:button x:bx y:by
+ "mouse-button was moved while pressed;
+ clear prev handleBar and draw handle bar at new position"
+
+ |xpos limitTop limitBot|
+
+ movedHandle isNil ifTrue: [^ self]. "should not happen"
+
+ "speedup - if there is already another movement,
+ ignore thisone ... "
+
+ device synchronizeOutput.
+ self buttonMotionEventPending ifTrue:[^ self].
+
+ xpos := bx - start.
+ limitTop := barHeight // 2.
+ limitBot := self width - barHeight.
+ movedHandle > 1 ifTrue:[
+ limitTop := (subViews at:movedHandle) origin x + (barHeight // 2)
+ ].
+ movedHandle < (subViews size - 1) ifTrue:[
+ limitBot := (subViews at:(movedHandle + 2)) origin x - barHeight
+ ].
+ limitBot := limitBot - barHeight.
+ (xpos < limitTop) ifTrue:[ "check against view limits"
+ xpos := limitTop
+ ] ifFalse:[
+ (xpos > limitBot) ifTrue:[
+ xpos := limitBot
+ ]
+ ].
+
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:prev y:0 width:barHeight height:height.
+ self fillRectangleX:xpos y:0 width:barHeight height:height
+ ].
+ self clipByChildren.
+ prev := xpos
+!
+
+buttonRelease:button x:x y:y
+ "end bar-move"
+
+ |aboveView belowView aboveIndex belowIndex newX|
+
+ (button == 1) ifTrue:[
+ movedHandle isNil ifTrue:[^ self].
+
+ "undo the last xor"
+
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:prev y:0 width:barHeight height:height
+ ].
+ self clipByChildren.
+
+ "compute the new relative heights"
+
+ aboveIndex := movedHandle.
+ belowIndex := movedHandle + 1.
+ aboveView := subViews at:aboveIndex.
+ belowView := subViews at:belowIndex.
+
+ newX := (prev + start / width) asFloat .
+ aboveView relativeCorner:newX @ aboveView relativeCorner y.
+ belowView relativeOrigin:newX @ belowView relativeOrigin y.
+ self resizeSubviewsFrom:aboveIndex to:belowIndex.
+
+ movedHandle := nil.
+
+ "and redraw handles"
+
+ self redrawHandlesFrom:aboveIndex to:belowIndex
+ ] ifFalse:[
+ super buttonRelease:button x:x y:y
+ ]
+! !
+
+!VariableHorizontalPanel methodsFor:'drawing'!
+
+drawHandleAtX:hx y:hy
+ |w x m|
+
+ (self is3D and:[shadowForm notNil]) ifTrue:[
+ w := shadowForm height
+ ] ifFalse:[
+ w := barHeight - 4
+ ].
+
+ self paint:viewBackground.
+ self fillRectangleX:hx y:margin
+ width:barHeight
+ height:(height - margin - margin).
+
+ self is3D ifTrue:[
+ m := (barHeight - w) // 2.
+ shadowForm isNil ifTrue:[
+ x := hx + (barHeight // 2).
+ style == #motif ifTrue:[
+ self paint:shadowColor.
+ self displayLineFromX:x y:margin toX:x y:(height - margin).
+ x := x + 1.
+ self paint:lightColor.
+ self displayLineFromX:x y:margin toX:x y:(height - margin).
+ ].
+ self paint:viewBackground.
+ self fillRectangleX:hx y:(hy - barWidth)
+ width:w height:(barWidth + barWidth).
+
+ self drawEdgesForX:(hx + m)
+ y:(hy - barWidth)
+ width:w height:(barWidth + barWidth)
+ level:2
+ ] ifFalse:[
+ self drawHandleFormAtX:(hx + m) y:hy
+ ]
+ ] ifFalse:[
+ x := hx + barHeight - 2.
+ self paint:handleColor.
+ self displayLineFromX:hx y:0 toX:hx y:height.
+ self displayLineFromX:x y:0 toX:x y:height.
+ self fillRectangleX:hx y:hy width:barHeight height:barHeight
+ ]
+!
+
+redrawHandlesFrom:start to:stop
+ "redraw some handles"
+
+ subViews notNil ifTrue:[
+ self handleOriginsFrom:start to:stop do:[:hPoint |
+ self drawHandleAtX:(hPoint x) y:(hPoint y)
+ ].
+ movedHandle notNil ifTrue:[
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:prev y:0 width:barHeight height:height
+ ].
+ self clipByChildren
+ ]
+ ]
+
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/VariableVerticalPanel.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,520 @@
+"
+ COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+View subclass:#VariableVerticalPanel
+ instanceVariableNames:'movedHandle prev start
+ barHeight barWidth
+ shadowForm lightForm
+ handlePosition
+ handleColor noColor'
+ classVariableNames:'arrow defaultPosition'
+ poolDictionaries:''
+ category:'Views-Layout'
+!
+
+VariableVerticalPanel comment:'
+
+COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+a View to separate its subviews vertically by a movable bar;
+the size-ratios of the subviews can be changed by moving this bar.
+
+The bar-handle is either an exposed knob (style == #motif)
+or the forms defined in Scroller (style ~~ #motif)
+
+%W% %E%
+
+written summer 91 by claus
+'!
+
+!VariableVerticalPanel class methodsFor:'initialization'!
+
+initialize
+ "read defaults"
+
+ super initialize.
+ defaultPosition := Resource name:'VARIABLE_PANEL_HANDLE_POSITION'
+ default:#right
+ fromFile:'Smalltalk.rs'
+! !
+
+!VariableVerticalPanel class methodsFor:'defaults'!
+
+shadowFormOn:aDisplay
+ "use same handle as Scroller"
+
+ ^ Scroller handleShadowFormOn:aDisplay
+!
+
+lightFormOn:aDisplay
+ "use same handle as Scroller"
+
+ ^ Scroller handleLightFormOn:aDisplay
+! !
+
+!VariableVerticalPanel methodsFor:'initializing'!
+
+initialize
+ super initialize.
+ handlePosition := defaultPosition.
+ noColor := Color noColor.
+ handleColor := Black.
+ self is3D ifTrue:[
+ self barHeight:(3 * ViewSpacing)
+ ] ifFalse:[
+ self barHeight:(2 * ViewSpacing)
+ ].
+ barWidth := 2 * ViewSpacing "motif style width"
+!
+
+initStyle
+ super initStyle.
+
+ (self is3D and:[style == #next]) ifTrue:[
+ shadowForm := self class shadowFormOn:device.
+ lightForm := self class lightFormOn:device
+ ].
+ shadowForm notNil ifTrue:[
+ self barHeight:(shadowForm height + 2).
+ barWidth := shadowForm width
+ ]
+!
+
+initCursor
+ "set the cursor - a double arrow"
+
+ "which one looks better ?"
+ cursor := Cursor upDownArrow
+ "cursor := Cursor upLimitArrow"
+!
+
+initEvents
+ self enableButtonEvents.
+ self enableButtonMotionEvents
+!
+
+fixSize
+ super fixSize.
+ self resizeSubviewsFrom:1 to:(subViews size)
+! !
+
+!VariableVerticalPanel methodsFor:'accessing'!
+
+add:aView
+ "a view is added; make its size relative (if not already done)"
+
+ super add:aView.
+ shown ifTrue:[
+ self setupSubviewSizes
+ ]
+!
+
+removeSubView:aView
+ "a view is removed; adjust other subviews sizes"
+
+ super removeSubView:aView.
+ shown ifTrue:[
+ self setupSubviewSizes
+ ]
+!
+
+barHeight:nPixel
+ "set the height of the separating bar"
+
+ barHeight := nPixel.
+
+ "if screen is very low-res, make certain bar is visible and catchable"
+ (barHeight < 4) ifTrue:[
+ barHeight := 4
+ ].
+
+ "make it even so spacing is equally spreadable among subviews"
+ barHeight odd ifTrue:[
+ barHeight := barHeight + 1
+ ]
+!
+
+handlePosition:aSymbol
+ "define the position of the handle; the argument aSymbol
+ may be one of #left, #right or #center"
+
+ handlePosition := aSymbol
+!
+
+handlePosition
+ "return the position of the handle"
+
+ ^ handlePosition
+!
+
+style:styleSymbol
+ "define the style of the handle;
+ styleSymbol may be #motif to draw a little knob or
+ enything else to draw scrollBars handleForm"
+
+ (styleSymbol ~~ style) ifTrue:[
+ style := styleSymbol.
+ shadowForm := self class shadowFormOn:device.
+ lightForm := self class lightFormOn:device.
+ (self is3D and:[style ~~ #motif]) ifTrue:[
+ shadowForm notNil ifTrue:[
+ self barHeight:(shadowForm height + 2).
+ barWidth := shadowForm width
+ ]
+ ].
+ self resizeSubviewsFrom:1 to:(subViews size).
+ self redraw
+ ]
+! !
+
+!VariableVerticalPanel methodsFor:'drawing'!
+
+drawHandleFormAtX:hx y:hy
+ "kludge for now"
+ (viewBackground colorId notNil
+ and:[shadowColor colorId notNil
+ and:[lightColor colorId notNil]]) ifTrue:[
+ self foreground:viewBackground background:noColor function:#xor.
+ self drawOpaqueForm:shadowForm x:hx y:hy.
+ self foreground:shadowColor function:#or.
+ self drawOpaqueForm:shadowForm x:hx y:hy.
+ self foreground:viewBackground function:#xor.
+ self drawOpaqueForm:lightForm x:hx y:hy.
+ self foreground:lightColor function:#or.
+ self drawOpaqueForm:lightForm x:hx y:hy.
+
+ self foreground:viewBackground.
+ paint := nil. "kludge to force paint to be really set"
+ self paint:viewBackground.
+ self function:#copy
+ ]
+!
+
+drawHandleAtX:hx y:hy
+ |h y m|
+
+ (self is3D and:[shadowForm notNil]) ifTrue:[
+ h := shadowForm height
+ ] ifFalse:[
+ h := barHeight - 4
+ ].
+
+ self paint:viewBackground.
+ self fillRectangleX:margin y:hy
+ width:(width - margin - margin)
+ height:barHeight.
+
+ self is3D ifTrue:[
+ m := (barHeight - h) // 2.
+ shadowForm isNil ifTrue:[
+ y := hy + (barHeight // 2).
+ style == #motif ifTrue:[
+ self paint:shadowColor.
+ self displayLineFromX:margin y:y toX:(width - margin) y:y.
+ y := y + 1.
+ self paint:lightColor.
+ self displayLineFromX:margin y:y toX:(width - margin) y:y.
+ ].
+ self paint:viewBackground.
+ self fillRectangleX:(hx - barWidth) y:hy
+ width:(barWidth + barWidth)
+ height:h.
+
+ self drawEdgesForX:(hx - barWidth)
+ y:(hy + m)
+ width:(barWidth + barWidth)
+ height:h level:2
+ ] ifFalse:[
+ self drawHandleFormAtX:hx y:(hy + m)
+ ]
+ ] ifFalse:[
+ y := hy + barHeight - 1.
+ self paint:handleColor.
+ self displayLineFromX:0 y:hy+1 toX:width y:hy+1.
+ self displayLineFromX:0 y:y toX:width y:y.
+ self fillRectangleX:hx y:hy width:barHeight height:barHeight
+ ]
+!
+
+redrawHandlesFrom:start to:stop
+ "redraw some handles"
+
+ subViews notNil ifTrue:[
+ self handleOriginsFrom:start to:stop do:[:hPoint |
+ self drawHandleAtX:(hPoint x) y:(hPoint y)
+ ].
+ movedHandle notNil ifTrue:[
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:0 y:prev width:width height:barHeight
+ ].
+ self clipByChildren
+ ]
+ ]
+!
+
+redraw
+ "redraw the handles"
+
+ self redrawHandlesFrom:1 to:(subViews size)
+! !
+
+!VariableVerticalPanel methodsFor:'events'!
+
+sizeChanged:how
+ "tell subviews if I change size"
+
+ (how == #smaller) ifTrue:[
+ self resizeSubviewsFrom:1 to:(subViews size)
+ ] ifFalse:[
+ self resizeSubviewsFrom:(subViews size) to:1
+ ]
+!
+
+buttonPress:button x:bx y:by
+ "button was pressed - if it hits a handle, start move"
+
+ |handle|
+
+ (button == 1) ifTrue:[
+ handle := 1.
+ self handleOriginsDo:[:hPoint |
+ |hy|
+
+ hy := hPoint y.
+ (by between:hy and:(hy + barHeight)) ifTrue:[
+ movedHandle := handle.
+ prev := hy.
+ start := by - hy.
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:0 y:hy width:width height:barHeight
+ ].
+ self clipByChildren.
+ ^ self
+ ].
+ handle := handle + 1
+ ].
+ movedHandle := nil
+ ] ifFalse:[
+ super buttonPress:button x:bx y:by
+ ]
+!
+
+buttonMotion:button x:bx y:by
+ "mouse-button was moved while pressed;
+ clear prev handleBar and draw handle bar at new position"
+
+ |ypos limitTop limitBot|
+
+ movedHandle isNil ifTrue: [^ self]. "should not happen"
+
+ "speedup - if there is already another movement,
+ ignore thisone ... "
+
+ device synchronizeOutput.
+ self buttonMotionEventPending ifTrue:[^ self].
+
+ ypos := by - start.
+ limitTop := barHeight // 2.
+ limitBot := self height - barHeight.
+ movedHandle > 1 ifTrue:[
+ limitTop := (subViews at:movedHandle) origin y + (barHeight // 2)
+ ].
+ movedHandle < (subViews size - 1) ifTrue:[
+ limitBot := (subViews at:(movedHandle + 2)) origin y - barHeight
+ ].
+ limitBot := limitBot - barHeight.
+ (ypos < limitTop) ifTrue:[ "check against view limits"
+ ypos := limitTop
+ ] ifFalse:[
+ (ypos > limitBot) ifTrue:[
+ ypos := limitBot
+ ]
+ ].
+
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:0 y:prev width:width height:barHeight.
+ self fillRectangleX:0 y:ypos width:width height:barHeight
+ ].
+ self clipByChildren.
+ prev := ypos
+!
+
+buttonRelease:button x:x y:y
+ "end bar-move"
+
+ |aboveView belowView aboveIndex belowIndex newY|
+
+ (button == 1) ifTrue:[
+ movedHandle isNil ifTrue:[^ self].
+
+ "undo the last xor"
+
+ self noClipByChildren.
+ self xoring:[
+ self fillRectangleX:0 y:prev width:width height:barHeight
+ ].
+ self clipByChildren.
+
+ "compute the new relative heights"
+
+ aboveIndex := movedHandle.
+ belowIndex := movedHandle + 1.
+ aboveView := subViews at:aboveIndex.
+ belowView := subViews at:belowIndex.
+
+ newY := (prev + start / height) asFloat.
+ aboveView relativeCorner:aboveView relativeCorner x @ newY.
+ belowView relativeOrigin:belowView relativeOrigin x @ newY.
+ self resizeSubviewsFrom:aboveIndex to:belowIndex.
+
+ movedHandle := nil.
+
+ self redrawHandlesFrom:aboveIndex to:belowIndex
+ ] ifFalse:[
+ super buttonRelease:button x:x y:y
+ ]
+! !
+
+!VariableVerticalPanel methodsFor:'private'!
+
+anyNonRelativeSubviews
+ "return true, if any of my subviews has no relative origin/extent"
+
+ 1 to:(subViews size) do:[:index |
+ |view|
+
+ view := subViews at:index.
+ view relativeExtent isNil ifTrue:[^ true].
+ view relativeOrigin isNil ifTrue:[^ true]
+ ].
+ ^ false
+!
+
+setupSubviewSizes
+ "setup subviews sizes (in case of non-relative sizes)"
+
+ |y h|
+
+ self anyNonRelativeSubviews ifTrue:[
+ "there is at least one subview without
+ relative origin/extent - setup all subviews
+ to spread evenly ..."
+
+ y := 0.0.
+ h := 1.0 / (subViews size).
+
+ 1 to:(subViews size) do:[:index |
+ |view|
+
+ view := subViews at:index.
+ index == subViews size ifTrue:[
+ view origin:(0.0 @ y) corner:(1.0 @ 1.0)
+ ] ifFalse:[
+ view origin:(0.0 @ y) corner:(1.0 @ (y + h))
+ ].
+ y := y + h
+ ]
+ ]
+!
+
+resizeSubviewsFrom:start to:stop
+ "readjust size of some subviews"
+
+ |step nSubviews|
+
+ subViews notNil ifTrue:[
+ (start <= stop) ifTrue:[
+ step := 1
+ ] ifFalse:[
+ step := -1
+ ].
+ nSubviews := subViews size.
+ start to:stop by:step do:[:index |
+ |bw view o1 o2 relOrg relCorner newOrg newCorner|
+
+ view := subViews at:index.
+ bw := view borderWidth.
+
+ index == 1 ifTrue:[
+ o1 := 0.
+ ] ifFalse:[
+ o1 := barHeight // 2 - bw
+ ].
+ index == nSubviews ifTrue:[
+ o2 := 0.
+ ] ifFalse:[
+ o2 := barHeight // 2 - bw
+ ].
+
+ relCorner := view relativeCorner.
+ relCorner isNil ifTrue:[
+ self error:'subview must have relative corner'
+ ].
+ newCorner := view cornerFromRelativeCorner.
+ newCorner notNil ifTrue:[
+ newCorner y:(newCorner y - o2)
+ ].
+
+ relOrg := view relativeOrigin.
+ relOrg isNil ifTrue:[
+ self error:'subview must have relative origin'
+ ].
+ newOrg := view originFromRelativeOrigin.
+ newOrg notNil ifTrue:[
+ (index ~~ 1) ifTrue:[
+ newOrg y:(newOrg y + o1)
+ ].
+ ].
+ view pixelOrigin:newOrg corner:newCorner
+ ]
+ ]
+!
+
+handleOriginsFrom:start to:stop do:aBlock
+ "evaluate the argument block for some handle-origins"
+
+ |x hw|
+
+ subViews notNil ifTrue:[
+ shadowForm notNil ifTrue:[
+ hw := shadowForm width
+ ] ifFalse:[
+ hw := barHeight
+ ].
+ (handlePosition == #left) ifTrue:[
+ x := hw * 2
+ ] ifFalse:[
+ (handlePosition == #right) ifTrue:[
+ x := width - (2 * hw) - margin
+ ] ifFalse:[
+ x := width // 2
+ ]
+ ].
+ (start + 1) to:stop do:[:index |
+ |view y|
+
+ view := subViews at:index.
+ y := view origin y - barHeight + 1.
+ aBlock value:(x @ y)
+ ]
+ ]
+!
+
+handleOriginsDo:aBlock
+ "evaluate the argument block for every handle-origin"
+
+ self handleOriginsFrom:1 to:(subViews size) do:aBlock
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/VerticalPanelView.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,129 @@
+"
+ COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+PanelView subclass:#VerticalPanelView
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Layout'
+!
+
+VerticalPanelView comment:'
+
+COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+a View for childViews oriented vertical
+all real work is done in PanelView - just redefine layout
+
+%W% %E%
+
+written spring/summer 89 by claus
+'!
+
+!VerticalPanelView methodsFor:'queries'!
+
+preferedExtent
+ "return a good extent, one that makes subviews fit"
+
+ |sumOfHeights maxWidth|
+
+ subViews isNil ifTrue:[^ horizontalSpace @ verticalSpace].
+
+ "compute net height needed"
+
+ sumOfHeights := 0.
+ maxWidth := 0.
+
+ subViews do:[:child |
+ sumOfHeights := sumOfHeights + child heightIncludingBorder.
+ maxWidth := maxWidth max:(child widthIncludingBorder)
+ ].
+ borderWidth ~~ 0 ifTrue:[
+ sumOfHeights := sumOfHeights + (horizontalSpace * 2).
+ maxWidth := maxWidth + (horizontalSpace * 2).
+ ].
+ sumOfHeights := sumOfHeights + ((subViews size - 1) * verticalSpace).
+
+ ^ maxWidth @ sumOfHeights
+! !
+
+!VerticalPanelView methodsFor:'layout'!
+
+setChildPositions
+ "(re)compute position of every child"
+
+ |xpos ypos space sumOfHeights numChilds l|
+
+ subViews isNil ifTrue:[^ self].
+
+ space := verticalSpace.
+
+ "compute net height needed"
+
+ sumOfHeights := 0.
+ numChilds := subViews size.
+
+ subViews do:[:child |
+ sumOfHeights := sumOfHeights + child heightIncludingBorder.
+ ].
+
+ l := layout.
+ ((l == #center) and:[numChilds == 1]) ifTrue:[
+ l := #spread
+ ].
+
+ "compute position of topmost subview and space between them;
+ if they do hardly fit, leave no space between them "
+
+ (sumOfHeights >= height) ifTrue:[
+ ypos := 0.
+ space := 0
+ ] ifFalse:[
+ (l == #bottom) ifTrue:[
+ ypos := height - (horizontalSpace * numChilds)
+ - sumOfHeights.
+ borderWidth == 0 ifTrue:[
+ ypos := ypos + horizontalSpace
+ ].
+ ] ifFalse: [
+ (l == #spread) ifTrue:[
+ space := (height - sumOfHeights) // (numChilds + 1).
+ ypos := space.
+ (space == 0) ifTrue:[
+ ypos := (height - sumOfHeights) // 2
+ ]
+ ] ifFalse: [
+ (l == #center) ifTrue:[
+ ypos := (height - (sumOfHeights
+ + ((numChilds - 1) * space))) // 2
+ ] ifFalse:[
+ borderWidth == 0 ifTrue:[
+ ypos := 0
+ ] ifFalse:[
+ ypos := verticalSpace
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ "now set positions"
+
+ subViews do:[:childView |
+ xpos := (width - childView widthIncludingBorder) // 2.
+ (xpos < 0) ifTrue:[ xpos := 0 ].
+
+ childView origin:(xpos@ypos).
+ ypos := ypos + (childView heightIncludingBorder) + space
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/WarnBox.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,52 @@
+"
+ COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+InfoBox subclass:#WarningBox
+ instanceVariableNames:''
+ classVariableNames:'WarnBitmap'
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+WarningBox comment:'
+
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+this class implements a pop-up box to show an information message
+
+%W% %E%
+written Summer 93 by claus
+'!
+
+!WarningBox methodsFor:'initialization'!
+
+initialize
+ WarnBitmap isNil ifTrue:[
+ WarnBitmap := Form fromFile:'Warning.xbm' resolution:100 on:device
+ ].
+
+ super initialize.
+!
+
+initFormBitmap
+ formLabel form:WarnBitmap
+! !
+
+!WarningBox methodsFor:'realization'!
+
+show
+ "added bell to wake up user"
+
+ device beep.
+ super show
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/WarningBox.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,52 @@
+"
+ COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+InfoBox subclass:#WarningBox
+ instanceVariableNames:''
+ classVariableNames:'WarnBitmap'
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+WarningBox comment:'
+
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+this class implements a pop-up box to show an information message
+
+%W% %E%
+written Summer 93 by claus
+'!
+
+!WarningBox methodsFor:'initialization'!
+
+initialize
+ WarnBitmap isNil ifTrue:[
+ WarnBitmap := Form fromFile:'Warning.xbm' resolution:100 on:device
+ ].
+
+ super initialize.
+!
+
+initFormBitmap
+ formLabel form:WarnBitmap
+! !
+
+!WarningBox methodsFor:'realization'!
+
+show
+ "added bell to wake up user"
+
+ device beep.
+ super show
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Workspace.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,339 @@
+"
+ COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+TextCollector subclass:#Workspace
+ instanceVariableNames:'doItAction
+ errorBox correctErrorBox
+ abortBlock codeStartPosition
+ errorFgColor errorBgColor'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Workspace'
+!
+
+Workspace comment:'
+
+COPYRIGHT (c) 1989-93 by Claus Gittinger
+ All Rights Reserved
+
+a view for editable text which can evaluate expressions.
+
+instance variables:
+
+doItAction <Block> block to evaluate for doIt
+
+errorBox <Box> queryBox used in case of errors,
+ kept for fast pop-up
+correctErrorBox <Box> same for correctable errors
+abortBlock <Block> internal use: to jump out of doIt
+ in case of abort from box
+codeStartPosition temporary
+errorFgColor <Color> fg-color used when highlighting error
+errorBgColor <Color> bg-Color used when highlighting error
+
+%W% %E%
+written winter-89 by claus
+'!
+
+!Workspace class methodsFor:'getting a System Workspace'!
+
+start
+ "launch a new workspace"
+
+ |topView workspace f|
+
+ topView := StandardSystemView label:'Workspace' minExtent:(100 @ 100).
+ workspace := super origin:(0.0 @ 0.0) corner:(1.0 @ 1.0) in:topView.
+ workspace level:0.
+
+ "adjust topViews extent"
+ f := workspace font.
+ topView extent:((f widthOf:'x') * 40) @ (f height * 10).
+
+ topView realize.
+ ^ topView
+
+ "Workspace start"
+! !
+
+!Workspace methodsFor:'initialize / release'!
+
+initialize
+ super initialize.
+ doItAction := [:theCode |
+ Compiler evaluate:theCode notifying:self
+ ].
+ errorFgColor := selectionFgColor.
+ device hasColors ifTrue:[
+ errorBgColor := Color name:'Red'
+ ] ifFalse:[
+ errorBgColor := selectionBgColor
+ ]
+!
+
+initializeMiddleButtonMenu
+ |labels|
+
+ labels := resources array:#(
+ "
+ 'undo'
+ '-'
+ "
+ 'copy'
+ 'cut'
+ 'paste'
+ 'replace'
+ '-'
+ 'font'
+ '-'
+ 'search'
+ 'goto'
+ '-'
+ 'save'
+ 'print'
+ " 'fileIn' "
+ '-'
+ 'doIt'
+ 'printIt'
+ 'inspectIt').
+
+ self middleButtonMenu:(PopUpMenu
+ labels:labels
+ selectors:#(copySelection
+ cut
+ paste
+ replace
+ nil
+ changeFont
+ nil
+ search
+ gotoLine
+ nil
+ save
+ print
+ " fileItIn "
+ nil
+ doIt
+ printIt
+ inspectIt)
+ receiver:self
+ for:self).
+
+!
+
+destroy
+ errorBox notNil ifTrue:[errorBox destroy].
+ correctErrorBox notNil ifTrue:[correctErrorBox destroy].
+ super destroy
+! !
+
+!Workspace methodsFor:'selections'!
+
+disableSelectionMenuEntries
+ "disable relevant menu entries for a selection"
+
+ super disableSelectionMenuEntries.
+ middleButtonMenu disable:#doIt.
+ middleButtonMenu disable:#printIt.
+ middleButtonMenu disable:#inspectIt
+!
+
+enableSelectionMenuEntries
+ "enable relevant menu entries for a selection"
+
+ super enableSelectionMenuEntries.
+ middleButtonMenu enable:#doIt.
+ middleButtonMenu enable:#printIt.
+ middleButtonMenu enable:#inspectIt
+! !
+
+!Workspace methodsFor:'accessing'!
+
+doItAction:aBlock
+ "define the action to be performed when 'doIt' is selected"
+
+ doItAction := aBlock
+!
+
+abortAction:aBlock
+ "define the action to be performed when an error occurs during
+ evaluation and user selects 'abort' in ErrorBox;
+ (this will usually be a block long-returning back)"
+
+ abortBlock := aBlock
+! !
+
+!Workspace methodsFor:'error handling'!
+
+error:aString position:relPos to:relEndPos
+ "compiler notifys us of an error; hilight the error (relPos to relEndPos)
+ and show a Box asking for continue/abort"
+
+ |absPosition fg bg|
+
+ "change color of selection"
+
+ fg := selectionFgColor.
+ bg := selectionBgColor.
+ selectionBgColor := errorBgColor.
+ selectionFgColor := errorFgColor.
+
+ "select the text - relEndPos may be nil in which case the whole line is selected"
+ codeStartPosition isNil ifTrue:[codeStartPosition := 1].
+ absPosition := codeStartPosition + relPos - 1.
+ relEndPos isNil ifTrue:[
+ self selectLineWhereCharacterPosition:absPosition
+ ] ifFalse:[
+ self selectFromCharacterPosition:absPosition to:(codeStartPosition + relEndPos - 1)
+ ].
+ self makeSelectionVisible.
+ self hideCursor.
+
+ "start Dialog - make certain, that dialog-actions clean up correctly"
+ device synchronizeOutput.
+ errorBox isNil ifTrue:[
+ errorBox := OptionBox title:aString numberOfOptions:2.
+ errorBox buttonTitles:#('abort' 'continue')
+ ].
+ errorBox actions:(Array with:[selectionFgColor := fg.
+ selectionBgColor := bg.
+ self showCursor.
+ abortBlock value.
+ ^ false]
+ with:[selectionFgColor := fg.
+ selectionBgColor := bg.
+ self showCursor.
+ self unselect.
+ ^ false]).
+ (errorBox title:aString) showAtPointer
+!
+
+warning:aString position:relPos to:relEndPos
+ "compiler notifys us of a warning - same behavior as error"
+
+ self error:aString position:relPos to:relEndPos
+!
+
+correctableError:aString position:relPos to:relEndPos
+ "compiler notifys us of a correctable error;
+ hilight the error (relPos to relEndPos) and show a Box asking for continue/correct/abort;
+ this method should return true to the compiler if user wants the error
+ to be corrected; false otherwise"
+
+ |absPosition fg bg|
+
+ "change selection color"
+
+ fg := selectionFgColor.
+ bg := selectionBgColor.
+ selectionBgColor := errorBgColor.
+ selectionFgColor := errorFgColor.
+
+ "select the error"
+ codeStartPosition isNil ifTrue:[codeStartPosition := 1].
+ absPosition := codeStartPosition + relPos - 1.
+ relEndPos isNil ifTrue:[
+ self selectLineWhereCharacterPosition:absPosition
+ ] ifFalse:[
+ self selectFromCharacterPosition:absPosition to:(codeStartPosition + relEndPos - 1)
+ ].
+ self makeSelectionVisible.
+ self hideCursor.
+
+ "start dialog - make certain cleanup is done"
+ device synchronizeOutput.
+ correctErrorBox isNil ifTrue:[
+ correctErrorBox := OptionBox title:aString numberOfOptions:3.
+ correctErrorBox buttonTitles:#('abort' 'correct' 'continue')
+ ].
+ correctErrorBox actions:(Array with:[selectionFgColor := fg.
+ selectionBgColor := bg.
+ self showCursor.
+ abortBlock value.
+ ^ false]
+ with:[selectionFgColor := fg.
+ selectionBgColor := bg.
+ self showCursor.
+ ^ true]
+ with:[selectionFgColor := fg.
+ selectionBgColor := bg.
+ self showCursor.
+ self unselect.
+ ^ false]).
+ (correctErrorBox title:aString) showAtPointer
+! !
+
+!Workspace methodsFor:'execution'!
+
+doItWithValueDo:aBlock
+ "helper for doIt, printIt and inspectIt. Evaluate the selection and,
+ if all went well, evaluate the argument, aBlock with the value."
+
+ |code value selLine selCol endLine endCol|
+
+ code := self selection.
+ code notNil ifTrue:[
+ codeStartPosition := self characterPositionOfSelection.
+ selLine := selectionStartLine.
+ selCol := selectionStartCol.
+ endLine := selectionEndLine.
+ endCol := selectionEndCol.
+
+ self cursor:Cursor execute.
+ abortBlock := [self cursor:Cursor normal.
+ self selectFromLine:selLine col:selCol
+ toLine:endLine col:endCol.
+ abortBlock := nil.
+ ^ nil].
+ [
+ value := doItAction value:(code asString)
+ ] valueNowOrOnUnwindDo:[
+ self cursor:Cursor normal.
+ self selectFromLine:selLine col:selCol toLine:endLine col:endCol.
+ abortBlock := nil
+ ].
+ aBlock value:value
+ ]
+!
+
+doIt
+ "user selected 'doIt' from menu; show a wait-cursor, evaluate the code
+ and finally restore cursor; return result of evaluation"
+
+ self doItWithValueDo:[:result | ]
+!
+
+inspectIt
+ "user selected 'inspectIt' from menu; use doIt to evaluate the code
+ and start an inspector on the result"
+
+ self doItWithValueDo:[:result | result inspect]
+!
+
+printIt
+ "user selected 'printIt' from menu; use doIt to evaluate the code
+ and insert result of evaluation into my text"
+
+ self doItWithValueDo:[:result |
+ self cursorLine:selectionEndLine col:(selectionEndCol + 1).
+ self insertSelectedStringAtCursor:(result printString)
+ ]
+! !
+
+!Workspace methodsFor:'events'!
+
+keyPress:key x:x y:y
+ (key == #Cmdd) ifTrue:[^ self doIt].
+ (key == #Cmdi) ifTrue:[^ self inspectIt].
+ (key == #Cmdp) ifTrue:[^ self printIt].
+ super keyPress:key x:x y:y
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/YesNoBox.st Fri Jul 16 11:44:44 1993 +0200
@@ -0,0 +1,157 @@
+"
+ COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+
+WarningBox subclass:#YesNoBox
+ instanceVariableNames:'noButton noAction'
+ classVariableNames:'RequestBitmap'
+ poolDictionaries:''
+ category:'Views-Interactors'
+!
+
+YesNoBox comment:'
+
+COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+this class implements yes-no boxes by adding another (no-)
+Button to the View.
+
+%W% %E%
+written spring/summer 89 by claus
+'!
+
+!YesNoBox methodsFor:'initialization'!
+
+initialize
+ |space3|
+
+ RequestBitmap isNil ifTrue:[
+ RequestBitmap := Form fromFile:'Request.xbm' resolution:100 on:device
+ ].
+
+ super initialize.
+
+ textLabel label:'Confirm'.
+ okButton label:(Resources at:'yes').
+
+ noButton := Button label:(Resources at:'no')
+ action:[
+ noButton turnOffWithoutRedraw.
+ self noPressed
+ ]
+ in:self.
+
+ space3 := 3 * ViewSpacing.
+ noButton origin:[ViewSpacing @ (height - ViewSpacing - noButton height)]
+ extent:[((width - space3) // 2) @ noButton height].
+ okButton origin:[((width + ViewSpacing) // 2)
+ @
+ (height - ViewSpacing - okButton height)]
+ extent:[((width - space3) // 2) @ okButton height]
+!
+
+initFormBitmap
+ formLabel form:RequestBitmap
+! !
+
+!YesNoBox methodsFor:'accessing'!
+
+yesButton
+ "return the yes-button"
+
+ ^ okButton
+!
+
+noButton
+ "return the no-button"
+
+ ^ noButton
+!
+
+yesAction:aBlock
+ "define the action to be performed when yes is pressed"
+
+ okAction := aBlock
+!
+
+noAction:aBlock
+ "define the action to be performed when no is pressed"
+
+ noAction := aBlock
+!
+
+yesAction:yesBlock noAction:noBlock
+ "define both actions"
+
+ okAction := yesBlock.
+ noAction := noBlock
+!
+
+yesText:aString
+ "define the label of the yes-button"
+
+ okButton label:aString.
+ self resize
+!
+
+noText:aString
+ "define the label of the no-button"
+
+ noButton label:aString.
+ self resize
+!
+
+yesText:yesString noText:noString
+ "define the labels of both buttons"
+
+ okButton label:yesString.
+ noButton label:noString.
+ self resize
+!
+
+title:aString yesAction:yesBlock noAction:noBlock
+ "define title and actions"
+
+ self title:aString.
+ okAction := yesBlock.
+ noAction := noBlock
+! !
+
+!YesNoBox methodsFor:'user interaction'!
+
+noPressed
+ "user pressed the no-button;
+ hide myself and evaluate the action"
+
+ self hideAndEvaluate:noAction
+! !
+
+!YesNoBox methodsFor:'private'!
+
+resize
+ "resize myself to make everything fit into myself"
+
+ |w h extra|
+
+ w := (formLabel width + textLabel width) max:(okButton width + noButton width).
+ w := w + (3 * ViewSpacing).
+ h := (3 * ViewSpacing)
+ + ((formLabel height) max:(textLabel height))
+ + okButton height.
+
+ extra := margin * 2.
+ super extent:(w + extra) @ (h + extra).
+ formLabel origin:(ViewSpacing @ ViewSpacing).
+ textLabel origin:(ViewSpacing + formLabel width + ViewSpacing) @ ViewSpacing.
+ noButton origin:((width // 4) - (noButton width // 2)) @ (height - ViewSpacing - noButton height).
+ okButton origin:((width // 4) * 3 - (okButton width // 2)) @ (height - ViewSpacing - okButton height)
+! !