--- a/View.st Wed May 03 02:04:18 1995 +0200
+++ b/View.st Wed May 03 02:27:48 1995 +0200
@@ -12,29 +12,18 @@
'From Smalltalk/X, Version:2.10.5 on 14-mar-1995 at 11:02:34 am'!
-PseudoView subclass:#View
- instanceVariableNames:'superView subViews components style resources viewport
- borderColor borderWidth borderShape viewShape top left
- extentChanged originChanged cornerChanged relativeOrigin
- relativeExtent relativeCorner originRule extentRule cornerRule
- insets shown hidden name level margin innerClipRect shadowColor
- lightColor bitGravity viewGravity
- model controller windowGroup aspectSymbol changeSymbol menuSymbol'
- classVariableNames:'Grey CentPoint ViewSpacing DefaultStyle StyleSheet
- DefaultViewBackgroundColor DefaultBorderColor DefaultLightColor
- DefaultShadowColor DefaultBorderWidth DefaultFont
- DefaultFocusColor DefaultFocusBorderWidth'
+SimpleView subclass:#View
+ instanceVariableNames:'model aspectMsg changeMsg menuMsg'
+ classVariableNames:''
poolDictionaries:''
category:'Views-Basic'
!
-View class instanceVariableNames:'ClassResources'!
-
View comment:'
-COPYRIGHT (c) 1989 by Claus Gittinger
+COPYRIGHT (c) 1995 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libview/View.st,v 1.40 1995-04-11 15:55:30 claus Exp $
+$Header: /cvs/stx/stx/libview/View.st,v 1.41 1995-05-03 00:26:19 claus Exp $
'!
!View class methodsFor:'documentation'!
@@ -55,312 +44,45 @@
version
"
-$Header: /cvs/stx/stx/libview/View.st,v 1.40 1995-04-11 15:55:30 claus Exp $
+$Header: /cvs/stx/stx/libview/View.st,v 1.41 1995-05-03 00:26:19 claus Exp $
"
!
documentation
"
- this class implements functions common to all Views.
+ this class adds provisions for views which show or work on a model.
+ This functionality used to be in View, but has been extracted into SimpleView and
+ this new View class, to take some of the stuff out of views which do not need
+ this functionality (i.e. all views which do only geometry management).
Instances of View are seldom used, most views in the system inherit
from this class.
- However, sometimes a view is used to create a dummy view for framing
- or layout purposes.
Instance variables:
- superView <View> my superview i.e. the view I am in
- subViews <Collection> the collection of subviews
- window <Rectangle> my window i.e. local coordinate-system
- viewport <Rectangle> my Rectangle in superviews coordinates
- borderColor <Color> color of border
- borderWidth <Number> borderWidth in pixels (device dep.)
- borderShape <Form> shape of border (if device supports it)
- viewShape <Form> shape of view (if device supports it)
- top <Number> top coordinate in superview
- left <Number> left coordinate in superview
- extendChanged <Boolean> true if extend changed during setup
- originChanged <Boolean> true if origin changed during setup
- relativeOrigin <Number> relative origin in percent within superview
- relativeExtent <Number> relative extent in percent within superview
- originRule <Block> rule to compute origin if superview changes size
- extentRule <Block> rule to compute extent if superview changes size
- shown <Boolean> true if visible (false if iconified, unmapped or covered)
- hidden <Boolean> dont show automatically when superview is realized
- name <String> my name (future use for resources)
- level <Number> 3D level relative to superview
- margin <Number> convenient margin
- innerClipRect <Rectangle> convenient inner clip (minus margin)
- shadowColor <Color> color used to draw 3D shadowed edges
- lightColor <Color> color used to draw 3D lighted edges
- contentsChanngeAction <Block> action to perform when model contents changes
- originChangeAction <Block> action to perform when model origin changes
- bitGravity <nil | Symbol> gravity of contents (if device supports it)
- viewGravity <nil | Symbol> gravity of view (if device supports it)
- model <nil | any> the model (if any)
- controller <nil | Controller> the controller (if any)
-
-
- Class variables:
-
- Grey <Color> the color grey - its used so often
- ViewSpacing <Number> prefered spacing between views; 1mm
-
- CentPoint <Point> 100 @ 100 - its used so often
-
- StyleSheet <ResourcePack> contains all view-style specifics
-
-
- styleSheet parameters:
-
- popupShadow <Boolean> if true, popupViews show a shadow below
- popupLevel <nil | Integer> 3D level
- borderWidth <nil | Integer> borderWidth (ignored in 3D styles)
- borderColor <nil | Color> borderColor (ignored in 3D styles)
- viewBackground <nil | Color> views background
- shadowColor <nil | Color> color for shadow edges (ignored in 2D styles)
- lightColor <nil | Color> color for light edges (ignored in 2D styles)
- font <nil | Font> font to use
-
-
- TODO:
- get rid of relativeOrigin, relativeCorner, originRule, extentRule,
- and insets; replace by a single object which defines the size
- (mhmh - ST-80 seems to call this LayoutFrame ?)
- -> be prepared for a change here in the near future and ONLY use
- access methods to those instance variables
-
- add components (could also call them gadgets or lightweight views)
- - views are expensive in terms of X resources. This would make all
- framing/edge and panel helper views become cheap ST objects, instead
- of views.
+ model <nil | any> the model (if any)
+ aspectMsg <nil | Symbol> the aspect; typically
+ dependentViews react on changes
+ of this aspect and update their contents.
+ changeMsg <nil | Symbol> the changeMessage; typically
+ dependentViews send this message to
+ the model to tell it about changes.
+ menuMsg <nil | Symbol> the menuMessage; typically
+ dependentViews send this message to
+ the model to ask for a popup menu.
"
! !
-!View class methodsFor:'initialization'!
-
-initialize
- DefaultStyle isNil ifTrue:[
- super initialize.
-
- Font initialize.
- Form initialize.
- Color initialize.
-
- Display notNil ifTrue:[
- self defaultStyle:#normal.
- ].
-
-"/ self updateStyleCache.
- self == View ifTrue:[
- Smalltalk addDependent:self "/ to get language changes
- ]
- ]
-! !
-
-!View class methodsFor:'change & update'!
-
-update:something
- something == #Language ifTrue:[
- "flush resources on language changes"
- self flushAllClassResources
- ]
-! !
-
!View class methodsFor:'instance creation'!
-in:aView
- "return a new view as a subview of aView.
- If aView is nil, it is left unspecified, in which superview
- the new view will be placed. The view can later be assigned
- by adding it to the superview via #addSubView:.
- If realized and no superview has ever been set, it will come
- up as a topview."
-
- |newView|
-
- newView := self basicNew.
- aView notNil ifTrue:[
- newView device:(aView device).
- newView superView:aView.
- ] ifFalse:[
- newView device:Display
- ].
- newView initialize.
- aView notNil ifTrue:[aView addSubView:newView].
- ^ newView
-!
-
-label:label in:aView
- "create a new view as subview of aView with given label"
-
- ^ self origin:nil extent:nil borderWidth:nil
- font:nil label:label in:aView
-!
-
-extent:extent in:aView
- "create a new view as a subview of aView with given extent"
-
- ^ self origin:nil extent:extent borderWidth:nil
- font:nil label:nil in:aView
-!
-
-origin:origin in:aView
- "create a new view as a subview of aView with given origin"
-
- ^ self origin:origin extent:nil borderWidth:nil
- font:nil label:nil in:aView
-!
-
-extent:extent
- "create a new view with given extent"
-
- ^ self origin:nil extent:extent borderWidth:nil
- font:nil label:nil in:nil
-!
-
-origin:origin extent:extent in:aView
- "create a new view as a subview of aView with given origin and extent"
-
- ^ self origin:origin extent:extent borderWidth:nil
- font:nil label:nil in:aView
-!
-
-origin:origin extent:extent
- "create a new view with given origin and extent"
-
- ^ self origin:origin extent:extent borderWidth:nil
- font:nil label:nil in:nil
-!
-
-origin:origin extent:extent borderWidth:bw in:aView
- "create a new view as a subview of aView with given origin, extent
- and borderWidth"
-
- ^ self origin:origin extent:extent borderWidth:bw
- font:nil label:nil in:aView
-!
-
-origin:anOrigin extent:anExtent borderWidth:bw font:aFont label:aLabel in:aView
- |newView|
-
- aView notNil ifTrue:[
- newView := self basicNew.
- newView device:(aView device).
- aView addSubView:newView.
- newView initialize
- ] ifFalse:[
- newView := self on:Display
- ].
- bw notNil ifTrue:[newView borderWidth:bw].
- anExtent notNil ifTrue:[newView extent:anExtent].
- anOrigin notNil ifTrue:[newView origin:anOrigin].
- aFont notNil ifTrue:[newView font:aFont].
- aLabel notNil ifTrue:[newView label:aLabel].
- ^ newView
-!
-
-origin:anOrigin corner:aCorner borderWidth:bw font:aFont label:aLabel in:aView
- |newView|
-
- aView notNil ifTrue:[
- newView := self basicNew.
- newView device:(aView device).
- aView addSubView:newView.
- newView initialize
- ] ifFalse:[
- newView := self on:Display
- ].
- bw notNil ifTrue:[newView borderWidth:bw].
- anOrigin notNil ifTrue:[newView origin:anOrigin].
- aCorner notNil ifTrue:[newView corner:aCorner].
- aFont notNil ifTrue:[newView font:aFont].
- aLabel notNil ifTrue:[newView label:aLabel].
- ^ newView
-!
-
-origin:origin corner:corner in:aView
- "create a new view as a subview of aView with given origin and extent"
-
- ^ self origin:origin corner:corner borderWidth:nil
- font:nil label:nil in:aView
-!
-
-origin:origin extent:extent borderWidth:bw
- "create a new view with given origin, extent and borderWidth"
-
- ^ self origin:origin extent:extent borderWidth:bw
- font:nil label:nil in:nil
-!
-
-label:label
- "create a new view with given label"
-
- ^ self origin:nil extent:nil borderWidth:nil
- font:nil label:label in:nil
-!
-
-origin:anOrigin extent:anExtent
- label:aLabel icon:aForm
- minExtent:minExtent maxExtent:maxExtent
- |newView|
-
- newView := self on:Display.
- anOrigin notNil ifTrue:[newView origin:anOrigin].
- anExtent notNil ifTrue:[newView extent:anExtent].
- aLabel notNil ifTrue:[newView label:aLabel].
- aForm notNil ifTrue:[newView icon:aForm].
- minExtent notNil ifTrue:[newView minExtent:minExtent].
- maxExtent notNil ifTrue:[newView maxExtent:maxExtent].
- ^ newView
-!
-
-extent:extent label:label
- "create a new view with given extent and label"
-
- ^ self origin:nil extent:extent borderWidth:nil
- font:nil label:label in:nil
-!
-
-origin:origin extent:extent label:label
- "create a new view with given origin, extent and label"
-
- ^ self origin:origin extent:extent borderWidth:nil
- font:nil label:label in:nil
-!
-
-origin:origin extent:extent font:aFont label:label
- ^ self origin:origin extent:extent borderWidth:nil
- font:nil label:label in:nil
-!
-
-origin:origin extent:extent font:aFont label:label in:aView
- ^ self origin:origin extent:extent borderWidth:nil
- font:aFont label:label in:aView
-!
-
-origin:origin corner:corner borderWidth:bw in:aView
- "create a new view as a subview of aView with given origin and extent"
-
- ^ self origin:origin corner:corner borderWidth:bw
- font:nil label:nil in:aView
-!
-
-origin:origin corner:corner
- "create a new view with given origin and extent"
-
- ^ self origin:origin corner:corner borderWidth:nil
- font:nil label:nil in:nil
-!
-
-on:anObject aspect:aspectMsg change:changeMsg menu:menuMsg
+on:aModel aspect:aspectMsg change:changeMsg menu:menuMsg
"st-80 style view creation: create a new view, set its model
and access selectors for aspect, change and menu"
- ^ self new on:anObject
- aspect:aspectMsg
- change:changeMsg
- menu:menuMsg
+ ^ self new
+ on:aModel
+ aspect:aspectMsg
+ change:changeMsg
+ menu:menuMsg
!
model:aModel
@@ -369,868 +91,71 @@
^ self new model:aModel
! !
-!View class methodsFor:'resources'!
-
-classResources
- "if not already loaded, get the classes resourcePack
- and return it"
-
- ClassResources isNil ifTrue:[
- ClassResources := ResourcePack for:self.
- ].
- ^ ClassResources
-!
-
-classResources:aResourcePack
- "allow setting of the classResources"
-
- ClassResources := aResourcePack
-!
-
-flushAllClassResources
- "flush all classes resource translations.
- Needed after a resource file has changed."
-
- ResourcePack flushCachedResourcePacks.
- self flushClassResources.
- self allSubclassesDo:[:aClass |
- aClass flushClassResources.
- ]
-
- "
- View flushAllClassResources
- "
- "to change the language:
- Language := #english.
- Smalltalk changed:#Language.
- View flushAllClassResources
- or:
- Language := #german.
- Smalltalk changed:#Language.
- View flushAllClassResources
- "
-!
-
-flushClassResources
- "flush classes resource string translations.
- Needed whenever a resource file or language has changed"
-
- ClassResources := nil.
-!
-
-updateClassResources
- "flush classes resource string translations and reload them.
- Needed whenever a resource file or language has changed"
-
- ClassResources := nil.
- self classResources
-! !
-
!View class methodsFor:'defaults'!
-viewSpacing
- "return a convenient number of pixels used to separate views (usually 1mm).
- Having this value here at a common place makes certain that all views
- get a common look"
-
- ^ ViewSpacing
-!
-
-defaultExtent
- "define the default extent"
-
- CentPoint isNil ifTrue:[CentPoint := 100 @ 100].
- ^ CentPoint
-!
-
-defaultStyle
- "return the default view style"
-
- ^ DefaultStyle
-
- "
- View defaultStyle
- "
-!
-
-defaultStyle:aStyle
- "set the view style for new views"
-
- aStyle ~~ DefaultStyle ifTrue:[
- DefaultStyle := aStyle.
- self updateAllStyleCaches.
- ]
-
- "
- View defaultStyle:#next. SystemBrowser start
- View defaultStyle:#motif. SystemBrowser start
- View defaultStyle:#iris. SystemBrowser start
- View defaultStyle:#st80. SystemBrowser start
- View defaultStyle:#normal. SystemBrowser start
- "
-!
-
-updateAllStyleCaches
- "reload all style caches in all view classes.
- Needed after a style change or when a style file has been changed"
-
- StyleSheet := ViewStyle fromFile:(DefaultStyle , '.style').
- StyleSheet fileReadFailed ifTrue:[
- ('***** WARNING: no styleSheet for ' , DefaultStyle , '-style.') errorPrintNL.
- DefaultStyle := #normal.
- StyleSheet := ViewStyle fromFile:(DefaultStyle , '.style').
- StyleSheet fileReadFailed ifTrue:[
- '***** FATAL: not even a styleSheet for normal-style.' errorPrintNL.
- Smalltalk exit
- ]
- ].
-
- "
- tell all view classes to flush any
- cached style-data
- "
- self changed:#style.
- self updateStyleCache.
- self allSubclassesDo:[:aClass |
- (aClass class implements:#updateStyleCache) ifTrue:[aClass updateStyleCache].
- ]
-
- "
- View updateAllStyleCaches
- "
-!
-
-updateStyleCache
- "this method gets some heavily used style stuff and keeps
- it in class-variables for faster access.
- Subclasses should redefine this to load any cached style-values
- into faster class variables as well. These should NOT do a
- super updateStyleCache, since this method is called for all view-classes
- anyway."
-
- |bgGrey|
-
- "
- when coming here the first time, we read the styleSheet
- and keep the values in fast class variables
- "
- StyleSheet isNil ifTrue:[
- DefaultStyle := #normal.
- StyleSheet := ViewStyle fromFile:'normal.style'.
- ].
-
- Grey := StyleSheet viewGrey.
- Grey isNil ifTrue:[
- Grey := Color grey
- ].
- Grey := Grey on:Display.
-
- Display hasGreyscales ifTrue:[
- bgGrey := Grey
- ] ifFalse:[
- bgGrey := White on:Display
- ].
-
- ViewSpacing := StyleSheet at:'viewSpacing'.
- ViewSpacing isNil ifTrue:[
- ViewSpacing := Display verticalPixelPerMillimeter rounded.
- ].
-
- DefaultBorderWidth := StyleSheet at:'borderWidth' default:0.
- DefaultBorderColor := StyleSheet colorAt:'borderColor' default:Black.
- DefaultViewBackgroundColor := StyleSheet colorAt:'viewBackground' default:bgGrey.
- DefaultShadowColor := StyleSheet colorAt:'shadowColor'.
- DefaultLightColor := StyleSheet colorAt:'lightColor'.
- DefaultFocusColor := StyleSheet colorAt:'focusColor' default:Color red.
- DefaultFocusBorderWidth := StyleSheet at:'focusBorderWidth' default:2.
-
- DefaultFont := StyleSheet at:'font'.
- DefaultFont isNil ifTrue:[
- DefaultFont := Font family:'courier' face:'medium' style:'roman' size:12.
- ].
-
- DefaultFont := DefaultFont on:Display.
-
- DefaultViewBackgroundColor isNil ifTrue:[
- 'bad viewBackground in style - using white' errorPrintNL.
- DefaultViewBackgroundColor := White
- ].
-!
-
-styleSheet:aViewStyle
- "set the view style from a style-sheet"
-
- StyleSheet := aViewStyle.
- DefaultStyle := (StyleSheet at:'name' ifAbsent:'unknown') asSymbol.
- self updateAllStyleCaches.
-! !
-
-!View methodsFor:'accessing-dimensions'!
-
-extent:extent
- "set the views extent; extent may be:
- a point where integer fields mean pixel-values
- and float values mean relative-to-superview;
- or a block returning a point"
-
- |w h pixelExtent e|
+defaultAspectMsg
+ "subclasses which by default do NOT want to be informed about changed
+ models should redefine this to return nil"
- extent isBlock ifTrue:[
- extentRule := extent.
- drawableId notNil ifTrue:[
- pixelExtent := extent value
- ] ifFalse:[
- extentChanged := true
- ]
- ] ifFalse:[
- w := extent x.
- h := extent y.
- w isNil ifTrue:[w := width].
- h isNil ifTrue:[h := height].
- e := w@h.
- ((w isInteger not) or:[h isInteger not]) ifTrue:[
- relativeExtent := e.
- pixelExtent := self extentFromRelativeExtent.
- pixelExtent isNil ifTrue:[
- extentChanged := true
- ]
- ] ifFalse:[
- pixelExtent := e
- ]
- ].
- pixelExtent notNil ifTrue:[
- self pixelExtent:pixelExtent
- ]
-!
-
-top
- "return the y position of the top border"
-
- ^ top
-!
-
-corner:corner
- "set the views corner; corner may be:
- a point where integer fields mean pixel-values
- and float values mean relative-to-superview;
- or a block returning a point"
-
- |x y pixelCorner c|
-
- corner isBlock ifTrue:[
- cornerRule := corner.
- drawableId notNil ifTrue:[
- pixelCorner := corner value
- ] ifFalse:[
- extentChanged := true
- ]
- ] ifFalse:[
- x := corner x.
- y := corner y.
- x isNil ifTrue:[x := self corner x].
- y isNil ifTrue:[y := self corner y].
- c := x @ y.
- ((x isInteger not) or:[y isInteger not]) ifTrue:[
- relativeCorner := c.
- pixelCorner := self cornerFromRelativeCorner.
- pixelCorner isNil ifTrue:[
- extentChanged := true
- ]
- ] ifFalse:[
- pixelCorner := c
- ]
- ].
-
- pixelCorner notNil ifTrue:[
- self pixelCorner:pixelCorner
- ]
-!
-
-origin:origin extent:extent
- "set both origin and extent"
-
- |newLeft newTop newWidth newHeight|
-
- "do it as one operation if possible"
-
- origin isBlock ifFalse:[
- extent isBlock ifFalse:[
- newLeft := origin x.
- (newLeft isMemberOf:Float) ifFalse:[
- newTop := origin y.
- (newTop isMemberOf:Float) ifFalse:[
- newWidth := extent x.
- (newWidth isMemberOf:Float) ifFalse:[
- newHeight := extent y.
- (newHeight isMemberOf:Float) ifFalse:[
- self pixelOrigin:origin extent:extent
- ]
- ]
- ]
- ]
- ]
- ].
- self extent:extent.
- self origin:origin
-!
-
-origin
- "return the origin (in pixels)"
-
- ^ left@top
-!
-
-innerWidth
- "return the width of the view minus any 3D-shadow-borders"
-
- (level == 0) ifTrue:[^ width].
- ^ width - (2 * margin)
-!
-
-origin:origin
- "set the views origin; origin may be:
- a point where integer fields mean pixel-values
- and float values mean relative-to-superview;
- or a block returning a point"
-
- |newLeft newTop pixelOrigin o|
-
- origin isBlock ifTrue:[
- originRule := origin.
- drawableId notNil ifTrue:[
- pixelOrigin := origin value
- ] ifFalse:[
- originChanged := true
- ]
- ] ifFalse:[
- o := origin.
- newLeft := origin x.
- newTop := origin y.
- newLeft isNil ifTrue:[newLeft := left].
- newTop isNil ifTrue:[newTop := top].
- o := newLeft @ newTop.
- ((newLeft isInteger not) or:[newTop isInteger not]) ifTrue:[
- relativeOrigin := o.
- pixelOrigin := self originFromRelativeOrigin.
- pixelOrigin isNil ifTrue:[
- originChanged := true
- ]
- ] ifFalse:[
- pixelOrigin := o
- ]
- ].
- pixelOrigin notNil ifTrue:[
- self pixelOrigin:pixelOrigin
- ].
-!
-
-height:aNumber
- "set the views height in pixels"
-
- self extent:(width @ aNumber)
-!
-
-sizeFixed:aBoolean
- "set/clear the fix-size attribute, if supported by concrete subclasses.
- Views which want to resize themselfes as appropriate to their contents
- should cease to do so and take their current size if sizeFixed is set to
- true. Currently, only supported by Labels.
- Added here to provide a common protocol for all views"
-
- ^ self
-!
-
-makeFullyVisible
- "make sure, that the view is fully visible by shifting it
- into the visible screen area if nescessary.
- This method will be moved to StandardSystemView ..."
-
- ((top + height) > (device height)) ifTrue:[
- self top:(device height - height)
- ].
- ((left + width) > (device width)) ifTrue:[
- self left:(device width - width)
- ].
- (top < 0) ifTrue:[
- self top:0
- ].
- (left < 0) ifTrue:[
- self left:0
- ].
+ ^ #value
!
-origin:origin corner:corner
- "set both origin and extent"
-
- |newLeft newTop newRight newBot|
-
- "do it as one operation if possible"
-
- origin isBlock ifFalse:[
- corner isBlock ifFalse:[
- newLeft := origin x.
- (newLeft isMemberOf:Float) ifFalse:[
- newTop := origin y.
- (newTop isMemberOf:Float) ifFalse:[
- newRight := corner x.
- (newRight isMemberOf:Float) ifFalse:[
- newBot := corner y.
- (newBot isMemberOf:Float) ifFalse:[
- self pixelOrigin:origin corner:corner
- ]
- ]
- ]
- ]
- ]
- ].
- self origin:origin.
- self corner:corner
-!
-
-relativeCorner
- "return the relative corner or nil"
-
- ^ relativeCorner
-!
-
-width:aNumber
- "set the views width in pixels"
-
- self extent:(aNumber @ height)
-!
-
-left:aNumber
- "set the x position"
-
- self origin:(aNumber @ top)
-!
-
-top:aNumber
- "set the y position"
-
- self origin:(left @ aNumber)
-!
-
-rightInset
- "return the inset of the right edge; positive is to the left,
- negative to the right"
-
- insets isNil ifTrue:[^ 0].
- ^ insets at:3
-!
-
-rightInset:aNumber
- "set the inset of the right edge; positive is to the left,
- negative to the right"
-
- insets isNil ifTrue:[
- insets := Array new:4 withAll:0.
- ].
- insets at:3 put:aNumber.
-
- "force recomputation"
- drawableId isNil ifTrue:[
- originChanged := true
- ] ifFalse:[
- self superViewChangedSize
- ]
-!
-
-leftInset
- "return the inset of the left edge; positive is to the right,
- negative to the left"
-
- insets isNil ifTrue:[^ 0].
- ^ insets at:1
-!
-
-leftInset:aNumber
- "set the inset of the left edge; positive is to the right,
- negative to the left"
-
- insets isNil ifTrue:[
- insets := Array new:4 withAll:0.
- ].
- insets at:1 put:aNumber.
-
- "force recomputation"
- drawableId isNil ifTrue:[
- originChanged := true
- ] ifFalse:[
- self superViewChangedSize
- ]
-!
-
-topInset
- "return the inset of the top edge; positive is to the bottom,
- negative to the top"
-
- insets isNil ifTrue:[^ 0].
- ^ insets at:2
-!
-
-topInset:aNumber
- "set the inset of the top edge; positive is to the bottom,
- negative to the top"
-
- insets isNil ifTrue:[
- insets := Array new:4 withAll:0.
- ].
- insets at:2 put:aNumber.
-
- "force recomputation"
- drawableId isNil ifTrue:[
- originChanged := true
- ] ifFalse:[
- self superViewChangedSize
- ]
-!
-
-bottomInset
- "return the inset of the bottom edge; positive is to the top,
- negative to the bottom"
-
- insets isNil ifTrue:[^ 0].
- ^ insets at:4
-!
-
-bottomInset:aNumber
- "set the inset of the bottom edge; positive is to the top,
- negative to the bottom"
-
- insets isNil ifTrue:[
- insets := Array new:4 withAll:0.
- ].
- insets at:4 put:aNumber.
-
- "force recomputation"
- drawableId isNil ifTrue:[
- originChanged := true
- ] ifFalse:[
- self superViewChangedSize
- ]
-!
-
-relativeOrigin
- "return the relative origin or nil"
-
- ^ relativeOrigin
-!
-
-right:aNumber
- "set the corners x position"
-
- self corner:(aNumber @ self corner y)
-!
-
-bottom:aNumber
- "set the corners y position"
-
- self corner:(self corner x @ aNumber)
-!
-
-corner
- "return the lower right corner-point"
-
- ^ (left + width - 1) @ (top + height - 1)
-!
-
-innerHeight
- "return the height of the view minus any 3D-shadow-borders"
-
- (margin == 0) ifTrue:[^ height].
- ^ height - (2 * margin)
-!
-
-relativeCorner:aPoint
- "set the relative corner"
-
- relativeCorner := aPoint
-!
-
-inset:aNumber
- "set all insets; positive makes the view smaller,
- negative makes it larger."
-
- insets isNil ifTrue:[
- insets := Array new:4.
- ].
- insets atAllPut:aNumber.
-
- "force recomputation"
- drawableId isNil ifTrue:[
- originChanged := true
- ] ifFalse:[
- self superViewChangedSize
- ]
-!
-
-left:newLeft top:newTop width:newWidth height:newHeight
- "another way of specifying origin and extent"
-
- self origin:(newLeft @ newTop) extent:(newWidth @ newHeight)
-!
-
-relativeExtent
- "return the relative extent or nil"
-
- ^ relativeExtent
-!
+defaultChangeMsg
+ "subclasses which by default do NOT want to inform the model
+ should redefine this to return nil"
-relativeOrigin:aPoint
- "set the relative origin"
-
- relativeOrigin := aPoint
-!
-
-originRelativeTo:aView
- "return the origin (in pixels) relative to a superView,
- or relative to the Display (if aView is nil).
- If the receiver is not a subview of aView, return nil."
-
- |currentView
- org "{ Class: Point }"
- sumX "{ Class: SmallInteger }"
- sumY "{ Class: SmallInteger }" |
-
- currentView := self.
- sumX := 0.
- sumY := 0.
- [currentView notNil] whileTrue:[
- (currentView == aView) ifTrue:[
- ^ (sumX @ sumY)
- ].
- org := currentView origin.
- sumX := sumX + org x.
- sumY := sumY + org y.
- currentView := currentView superView
- ].
- (aView isNil or:[aView == RootView]) ifTrue:[
- "return relative to screen ..."
- ^ (sumX @ sumY)
- ].
- ^ nil
-!
-
-relativeExtent:aPoint
- "set the relative extent"
-
- relativeExtent := aPoint
-!
-
-center:newCenter
- "move the receiver so that newCenter, aPoint becomes the center point"
-
- self origin:(newCenter - ((width // 2) @ (height // 2)))
-!
-
-center
- "return the point at the center of the receiver"
-
- ^ (left + (width // 2)) @ (top + (height // 2))
-!
-
-left
- "return the x position of the left border"
-
- ^ left
-!
-
-right
- "return the x position of the right border"
-
- ^ left + width - 1
-!
-
-bottom
- "return the y position of the bottom border"
-
- ^ top + height - 1
-!
-
-computeCorner
- "compute my corner; if I have relative
- origins or blocks to evaluate, do it now ..
- Blocks may return relative values or nil; nil means: take current value."
-
- |org newCorner newExt x y|
-
- (cornerRule notNil) ifTrue:[
- newCorner := cornerRule value.
- "
- allow return of relative values ...
- "
- x := newCorner x.
- y := newCorner y.
- x isNil ifTrue:[x := self corner x].
- y isNil ifTrue:[y := self corner y].
- ((x isInteger not) or:[y isInteger not]) ifTrue:[
- newCorner := self cornerFromRelativeCorner:x@y
- ]
- ] ifFalse:[
- (relativeCorner notNil) ifTrue:[
- newCorner := self cornerFromRelativeCorner:relativeCorner
- ] ifFalse:[
- org := self computeOrigin.
- (extentRule notNil) ifTrue:[
- newExt := extentRule value
- ] ifFalse:[
- (relativeExtent notNil) ifTrue:[
- newExt := self extentFromRelativeExtent:relativeExtent
- ]
- ].
- newCorner := org + newExt
- ]
- ].
- ^ newCorner
-!
-
-computeExtent
- "compute my extent; if I have relative
- extent or blocks to evaluate, do it now ..
- There is one catch here, if the dimension was defined
- by origin/corner, compute them here and take that value.
- I.e. origin/corner definition has precedence over extent definition."
-
- |newOrg newExt newCorner x y|
-
- (cornerRule notNil) ifTrue:[
- newCorner := cornerRule value.
- "
- allow return of relative values ...
- "
- x := newCorner x.
- y := newCorner y.
- x isNil ifTrue:[x := self corner x].
- y isNil ifTrue:[y := self corner y].
- ((x isInteger not) or:[y isInteger not]) ifTrue:[
- newCorner := self cornerFromRelativeCorner:x@y
- ]
- ] ifFalse:[
- (relativeCorner notNil) ifTrue:[
- newCorner := self cornerFromRelativeCorner:relativeCorner
- ] ifFalse:[
- (extentRule notNil) ifTrue:[
- newExt := extentRule value.
- "
- allow return of relative values ...
- "
- x := newExt x.
- y := newExt y.
- x isNil ifTrue:[x := width].
- y isNil ifTrue:[y := height].
- ((x isInteger not) or:[y isInteger not]) ifTrue:[
- newExt := self extentFromRelativeExtent:x@y
- ]
- ] ifFalse:[
- (relativeExtent notNil) ifTrue:[
- newExt := self extentFromRelativeExtent:relativeExtent
- ] ifFalse:[
- newExt := (width @ height).
- ].
- ].
- ].
- ].
-
- newCorner notNil ifTrue:[
- newOrg := self computeOrigin.
- ^ newCorner - newOrg.
- ].
- ^ newExt.
-!
-
-computeOrigin
- "compute my origin; if I have relative
- origins or blocks to evaluate, do it now ..
- Blocks may return relative values or nil; nil means: take current value."
-
- |newOrg x y|
-
- (originRule notNil) ifTrue:[
- newOrg := originRule value.
- "
- allow return of relative values ...
- "
- x := newOrg x.
- y := newOrg y.
- x isNil ifTrue:[x := self origin x].
- y isNil ifTrue:[y := self origin y].
- ((x isInteger not) or:[y isInteger not]) ifTrue:[
- newOrg := self originFromRelativeOrigin:x@y.
- ]
- ] ifFalse:[
- (relativeOrigin notNil) ifTrue:[
- newOrg := self originFromRelativeOrigin:relativeOrigin.
- ] ifFalse:[
- ^ (left @ top).
- ].
- ].
- ^ newOrg
-! !
-
-!View methodsFor:'informing others of changes'!
-
-originChanged:delta
- "this one is sent, after the origin of my contents has changed -
- tell dependents (i.e. scrollers) about this"
-
- self changed:#originOfContents with:delta.
-"/ subViews notNil ifTrue:[
-"/ subViews do:[:aSubView |
-"/ aSubView pixelOrigin:((aSubView left @ aSubView top) - delta)
-"/ ]
-"/ ]
-!
-
-contentsChanged
- "this one is sent, whenever contents changes size -
- tell dependents about the change (i.e. scrollers)."
-
- self changed:#sizeOfContents
-!
-
-originWillChange
- "this one is sent, just before viewOrigin changes -
- gives subclasses a chance to catch scrolls easily
- (for example to hide cursor before scroll)"
-
- ^ self
+ ^ #value:
! !
!View methodsFor:'accessing-mvc'!
sendChangeMessageWith:arg
- |n|
+ "tell the model about a change"
+
+ self sendChangeMessage:changeMsg with:arg
+!
+
+sendChangeMessage:aSelector with:arg
+ "tell the model about a change"
+
+ |n selector|
"/
- "/ MVC way of doing it
+ "/ MVC way of doing it:
+ "/ if the model is a block, evaluate it, optionally
+ "/ passing the arg and the receiver as arguments.
+ "/ otherwise (the common case) send it a changeMsg message
+ "/ also with arg and the receiver (depending on the number of arguments
+ "/ as defined by the selector.
"/
- (model notNil and:[changeSymbol notNil]) ifTrue:[
- n := changeSymbol numArgs.
+ (model notNil and:[aSelector notNil]) ifTrue:[
+ n := aSelector numArgs.
+ model isBlock ifTrue:[
+ n := model numArgs.
+ n == 0 ifTrue:[
+ selector := #value
+ ] ifFalse:[
+ n == 1 ifTrue:[
+ selector := #value:
+ ] ifFalse:[
+ selector := #value:value:
+ ]
+ ]
+ ] ifFalse:[
+ selector := aSelector
+ ].
n == 0 ifTrue:[
- model perform:changeSymbol
+ model perform:selector
] ifFalse:[
n == 1 ifTrue:[
- model perform:changeSymbol with:arg
+ model perform:selector with:arg
] ifFalse:[
- model perform:changeSymbol with:arg with:self
+ model perform:selector with:arg with:self
]
]
]
!
-windowGroup
- "return the window group. For old style views, return nil"
-
- ^ windowGroup
-!
-
-windowGroup:aGroup
- "set the window group."
-
- windowGroup := aGroup
-!
-
model
"return the model, for non-MVC views,
this is nil or the receiver"
@@ -1245,6 +170,18 @@
model removeDependent:self
].
model := aModel.
+
+ "/
+ "/ set default change- and aspectMsgs
+ "/ (for ST-80 compatibility)
+ "/
+ changeMsg isNil ifTrue:[
+ changeMsg := self class defaultChangeMsg
+ ].
+ aspectMsg isNil ifTrue:[
+ aspectMsg := self class defaultAspectMsg
+ ].
+
model notNil ifTrue:[
aModel addDependent:self
].
@@ -1253,1987 +190,115 @@
]
!
-controller
- "return the controller. For non MVC views, return nil"
-
- ^ controller
-!
-
controller:aController
"set the controller"
- controller := aController.
+ super controller:aController.
controller notNil ifTrue:[
- controller view:self.
controller model:model
]
!
-on:aModel aspect:aspectMsg
+on:aModel aspect:aspectSymbol
"ST-80 compatibility: set model and aspect
messages - needs a view which uses these"
- aspectSymbol := aspectMsg.
+ aspectMsg := aspectSymbol.
self model:aModel.
!
-on:aModel aspect:aspectMsg menu:menuMsg
+on:aModel aspect:aspectSymbol menu:menuSymbol
"ST-80 compatibility: set model, aspect and menu
messages - needs a view which uses these"
- aspectSymbol := aspectMsg.
- menuSymbol := menuMsg.
+ aspectMsg := aspectSymbol.
+ menuMsg := menuSymbol.
self model:aModel.
!
-on:aModel aspect:aspectMsg change:changeMsg menu:menuMsg
+on:aModel aspect:aspectSymbol change:changeSymbol menu:menuSymbol
"ST-80 compatibility: set model, aspect, change and menu
messages - needs a view which uses these"
- aspectSymbol := aspectMsg.
- changeSymbol := changeMsg.
- menuSymbol := menuMsg.
+ aspectMsg := aspectSymbol.
+ changeMsg := changeSymbol.
+ menuMsg := menuSymbol.
self model:aModel.
!
-menu:menuMsg
+menu:menuSymbol
"ST-80 style menus: If a views menuSymbol is nonNil, it
will send it to its model when the middleButton is pressed.
That method should return nil or the menu to be shown.
This is useful for very dynamic menus, where it does not
make sense to define an initial menu."
- menuSymbol := menuMsg
+ menuMsg := menuSymbol
!
-change:changeMsg
+change:changeSymbol
"ST-80 style change notification: If a views changeSymbol is nonNil,
it will send it to its model when something changes."
- changeSymbol := changeMsg
+ changeMsg := changeSymbol
!
-aspect:aspectMsg
+aspect:aspectSymbol
"ST-80 style updating: If a views aspectSymbol is nonNil,
it will respond to changes of this aspect from the model."
- aspectSymbol := aspectMsg
-!
-
-changeSymbol
- "Return the symbol sent to the model if nonNil when something changes."
-
- ^ changeSymbol
-!
-
-menuSymbol
- "Return the symbol sent to the model to aquire the menu"
-
- ^ menuSymbol
-!
-
-aspectSymbol
- "Return the aspect used with changes from/to the model"
-
- ^ menuSymbol
-! !
-
-!View methodsFor:'private'!
-
-pixelExtent:extent
- "set the views extent in pixels"
-
- self pixelOrigin:(left @ top) extent:extent
-!
-
-pixelOrigin:origin
- "set the views origin in pixels. For subviews. the origin is relative
- to the superviews top-left. For topViews, its the screen origin."
-
- |newLeft newTop|
-
- newLeft := origin x.
- newTop := origin y.
- ((newTop ~~ top) or:[newLeft ~~ left]) ifTrue:[
- top := newTop.
- left := newLeft.
-
- "
- if the receiver is visible, or is a topView, perform the
- operation right away - otherwise, simply remember that the
- origin has changed - will tell the display once we get realized
- "
- (shown
- or:[superView isNil and:[drawableId notNil]]) ifTrue:[
- device moveWindow:drawableId x:left y:top
- ] ifFalse:[
- originChanged := true
- ]
- ]
-!
-
-computeInnerClip
- "compute, but do not set the inside clip-area"
-
- |m2 nX nY nW nH|
-
- (margin ~~ 0) ifTrue:[
- m2 := margin + margin.
- nX := nY := margin.
- nW := width - m2.
- nH := height - m2.
- transformation notNil ifTrue:[
- nX := transformation applyInverseToX:nX.
- nY := transformation applyInverseToY:nY.
- nW := transformation applyInverseScaleX:nW.
- nH := transformation applyInverseScaleY:nH.
- ].
- innerClipRect := Rectangle
- left:nX
- top:nY
- width:nW
- height:nH
- ] ifFalse:[
- "no clipping"
- innerClipRect := nil
- ]
-!
-
-setInnerClip
- "compute, and set the inside clip-area"
-
- self computeInnerClip.
- self clipRect:innerClipRect
-!
-
-originFromRelativeOrigin
- "compute & return pixel origin from relativeOrigin"
-
- ^ self originFromRelativeOrigin:relativeOrigin
+ aspectMsg := aspectSymbol
!
-pixelOrigin:origin extent:extent
- "set the views origin and extent in pixels"
-
- |newLeft newTop newWidth newHeight how
- mustRedrawBottomEdge mustRedrawRightEdge mustRepaintBottom
- mustRepaintRight sameOrigin oldWidth oldHeight|
-
- newLeft := origin x.
- newTop := origin y.
- sameOrigin := ((newTop == top) and:[newLeft == left]).
-
- newWidth := extent x.
- newHeight := extent y.
-
- "
- X complains badly if you try to create/resize a view with
- a dimension <= 0 ... (although I think that 0 maks sense ...)
- "
- newWidth < 1 ifTrue:[
- newWidth := 1.
- ].
- newHeight < 1 ifTrue:[
- newHeight := 1
- ].
-
- ((newWidth == width) and:[newHeight == height]) ifTrue:[
- sameOrigin ifTrue:[^ self].
- ^ self pixelOrigin:origin
- ].
- top := newTop.
- left := newLeft.
-
- mustRedrawBottomEdge := (level ~~ 0) and:[newHeight < height].
- mustRedrawRightEdge := (level ~~ 0) and:[newWidth < width].
-
- ((newHeight <= height) and:[newWidth <= width]) ifTrue:[
- how := #smaller
- ].
-
-"/ shown ifTrue:[ "4-nov-94 actually correct,"
- drawableId notNil ifTrue:[ "but theres a bug in menus when resized while hidden"
- mustRepaintRight := false.
- mustRepaintBottom := false.
- (level ~~ 0) ifTrue:[
- "clear the old edges"
-
- newWidth > width ifTrue:[
- self clipRect:nil.
- self paint:viewBackground.
- self fillDeviceRectangleX:(width - margin)
- y:0
- width:margin
- height:height.
- mustRepaintRight := true.
- oldWidth := width
- ].
- newHeight > height ifTrue:[
- self clipRect:nil.
- self paint:viewBackground.
- self fillDeviceRectangleX:0
- y:(height - margin)
- width:width
- height:margin.
- mustRepaintBottom := true.
- oldHeight := height
- ]
- ].
-
- width := newWidth.
- height := newHeight.
-
- self setInnerClip.
-
- "if view becomes smaller, send sizeChanged first"
- (how == #smaller) ifTrue:[
- self sizeChanged:how
- ].
-
- "have to tell X, when extent of view is changed"
- sameOrigin ifTrue:[
- device resizeWindow:drawableId width:width height:height.
- ] ifFalse:[
- "claus: some xservers seem to do better when resizing
- first ...."
-"
- (how == #smaller) ifTrue:[
- device resizeWindow:drawableId width:width height:height.
- device moveWindow:drawableId x:left y:top
- ] ifFalse:[
- device moveResizeWindow:drawableId x:left y:top width:width height:height
- ].
-"
- device moveResizeWindow:drawableId x:left y:top
- width:width height:height.
-" "
- ].
-
- "if view becomes bigger, send sizeChanged after"
- (how ~~ #smaller) ifTrue:[
- self sizeChanged:how
- ].
-
- (mustRedrawBottomEdge or:[mustRedrawRightEdge]) ifTrue:[
- self clipRect:nil.
- mustRedrawBottomEdge ifTrue:[
- self drawBottomEdge
- ].
- mustRedrawRightEdge ifTrue:[
- self drawRightEdge
- ].
- self clipRect:innerClipRect
- ].
-
- mustRepaintRight ifTrue:[
- self redrawDeviceX:(oldWidth - margin)
- y:0
- width:margin
- height:height.
- ].
- mustRepaintBottom ifTrue:[
- self redrawDeviceX:0
- y:(oldHeight - margin)
- width:width
- height:margin.
- ].
- ] ifFalse:[
- "otherwise memorize the need for a sizeChanged message"
+changeMessage
+ "Return the symbol sent to the model if nonNil when something changes."
- width := newWidth.
- height := newHeight.
- sameOrigin ifFalse:[
- originChanged := true.
- ].
- extentChanged := true
- ]
-!
-
-cornerFromRelativeCorner
- "compute & return pixel corner from relativeCorner"
-
- ^ self cornerFromRelativeCorner:relativeCorner
-!
-
-pointFromRelative:p
- "compute absolute coordinate from p"
-
- |newX newY rel inRect bw superWidth superHeight superLeft superTop |
-
- bw := borderWidth.
-
- superView isNil ifTrue:[
- superWidth := device width + bw.
- superHeight := device height + bw.
- superLeft := superTop := 0.
- ] ifFalse:[
- inRect := superView viewRectangle.
- superWidth := inRect width.
- superHeight := inRect height.
- superLeft := inRect left.
- superTop := inRect top.
- ].
-
- rel := p x.
- rel isInteger ifTrue:[
- newX := rel
- ] ifFalse:[
- newX := (rel * superWidth) asInteger + superLeft.
- (bw ~~ 0) ifTrue:[
- rel ~= 1.0 ifTrue:[
- newX := newX - bw
- ]
- ]
- ].
-
- rel := p y.
- rel isInteger ifTrue:[
- newY := rel
- ] ifFalse:[
- newY := (rel * superHeight) asInteger + superTop.
- (bw ~~ 0) ifTrue:[
- rel ~= 1.0 ifTrue:[
- newY := newY - bw
- ]
- ]
- ].
- ^ newX @ newY
-!
-
-pixelCorner:corner
- "set the views corner in pixels"
-
- |w h|
-
- w := corner x - left.
- h := corner y - top.
- self pixelOrigin:(left @ top) extent:(w @ h)
-!
-
-originFromRelativeOrigin:aPoint
- "compute & return pixel origin from relativeOrigin, aPoint"
-
- |p l t|
-
- p := self pointFromRelative:aPoint.
-
- insets isNil ifTrue:[
- ^ p
- ].
- l := insets at:1.
- t := insets at:2.
-
-"/ l := t := 0.
-"/ leftInset notNil ifTrue:[
-"/ l := leftInset
-"/ ].
-"/ topInset notNil ifTrue:[
-"/ t := topInset
-"/ ].
- ((l ~~ 0) or:[t ~~ 0]) ifTrue:[
- ^ (p x + l) @ (p y + t)
- ].
- ^ p
-!
-
-cornerFromRelativeCorner:aPoint
- "compute & return pixel corner from a relativeCorner, aPoint"
-
- |p r b bw|
-
- p := self pointFromRelative:aPoint.
-
- bw := borderWidth.
- insets isNil ifTrue:[
- bw == 0 ifTrue:[
- ^ p
- ].
- ^ (p x - bw) @ (p y - bw)
- ].
- r := (insets at:3) + bw.
- b := (insets at:4) + bw.
-
-"/ r := b := bw.
-"/ rightInset notNil ifTrue:[
-"/ r := rightInset + bw
-"/ ].
-"/ bottomInset notNil ifTrue:[
-"/ b := bottomInset + bw
-"/ ].
- ((r ~~ 0) or:[b ~~ 0]) ifTrue:[
- ^ (p x - r) @ (p y - b)
- ].
- ^ p
-!
-
-pixelOrigin:origin corner:corner
- "set the views origin and extent in pixels"
-
- |w h|
-
- w := corner x - origin x.
- h := corner y - origin y.
- self pixelOrigin:origin extent:(w @ h)
-!
-
-extentFromRelativeExtent
- "compute & return pixel extent from relativeExtent"
-
- ^ self extentFromRelativeExtent:relativeExtent
+ ^ changeMsg
!
-extentFromRelativeExtent:aPoint
- "compute & return pixel extent from relativeExtent, aPoint"
-
- |rel newX newY inRect bw2 i|
-
- superView isNil ifTrue:[
- inRect := 0@0 extent:device extent
- ] ifFalse:[
- inRect := superView viewRectangle.
- ].
-
- bw2 := borderWidth * 2.
-
- rel := aPoint x.
- (rel isMemberOf:Float) ifTrue:[
- newX := (rel * (inRect width + bw2)) asInteger + inRect left.
- (borderWidth ~~ 0) ifTrue:[
- newX := newX - borderWidth
- ].
- ] ifFalse:[
- newX := rel
- ].
-
- rel := aPoint y.
- (rel isMemberOf:Float) ifTrue:[
- newY := (rel * (inRect height + bw2)) asInteger + inRect top.
- (borderWidth ~~ 0) ifTrue:[
- newY := newY - borderWidth
- ].
- ] ifFalse:[
- newY := rel
- ].
-
- insets notNil ifTrue:[
- i := insets at:1. "top"
- (i ~~ 0) ifTrue:[
- newX := newX - i
- ].
- i := insets at:3. "left"
- (i ~~ 0) ifTrue:[
- newX := newX - i
- ].
- i := insets at:2. "right"
- (i ~~ 0) ifTrue:[
- newY := newY - i
- ].
- i := insets at:4. "bottom"
- (i ~~ 0) ifTrue:[
- newY := newY - i
- ].
- ].
- ^ newX @ newY
-!
-
-setBorderColor
- "set my borderColor"
-
- |id dither|
-
- drawableId notNil ifTrue:[
- borderColor := borderColor on:device.
- id := borderColor colorId.
- id notNil ifTrue:[
- device setWindowBorderColor:id in:drawableId
- ] ifFalse:[
- dither := borderColor ditherForm.
- dither notNil ifTrue:[
- device setWindowBorderPixmap:(dither id) in:drawableId
- ] ifFalse:[
- 'bad borderColor' errorPrintNewline
- ]
- ]
- ]
-!
-
-dimensionFromViewport
- "define my origin/extend from viewport"
-
- |relW relH relX relY winW winH org ext|
+menuMessage
+ "Return the symbol sent to the model to aquire the menu"
- superView notNil ifTrue:[
- superView window isNil ifTrue:[
-"
- v := superView.
- (v notNil and:[v window isNil]) whileTrue:[
- v := v superview
- ].
- v notNil ifTrue:[
- w := v window
- ].
-"
-"
- winW := 1.
- winH := 1
-"
- winW := superView width.
- winH := superView height.
-
- ] ifFalse:[
- winW := superView window width.
- winH := superView window height
- ].
- relW := (viewport width / winW) asFloat.
- relH := (viewport height / winH) asFloat.
- relX := (viewport left / winW) asFloat.
- relY := (viewport top / winH) asFloat.
- "bad coding style ... misuse other method"
- relativeOrigin := (relX @ relY).
- org := self originFromRelativeOrigin.
- relativeOrigin := nil.
-
- "bad coding style ...misuse other method"
- relativeExtent := (relW @ relH).
- ext := self extentFromRelativeExtent.
- relativeExtent := nil.
-
- self pixelOrigin:org extent:ext.
- ]
-! !
-
-!View methodsFor:'accessing-transformation'!
-
-transformation
- "return the transformation"
-
- |vP|
-
- transformation isNil ifTrue:[
- "
- fake a transformation, if I have a non-nil window
- "
- window notNil ifTrue:[
- superView isNil ifTrue:[
- vP := (0@0 extent:self extent)
- ] ifFalse:[
- vP := (self origin extent:self extent)
- ].
- ^ WindowingTransformation
- window:window
- viewport:vP
- ]
- ].
- ^ transformation
-!
-
-viewRectangle
- "return the inside area"
-
- |m2|
-
- innerClipRect notNil ifTrue:[
- ^ innerClipRect
- ].
- m2 := margin + margin.
-
- ^ (margin @ margin) extent:((width - m2) @ (height - m2))
-!
-
-window
- "return my window (i.e. logical coordinate space).
- If there is no window, return the extent."
-
- window isNil ifTrue:[^ width @ height].
- ^ window
-!
-
-window:aRectangle
- "define my window (i.e. logical coordinate space)"
-
- window := aRectangle.
- subViews notNil ifTrue:[
- subViews do:[:s |
- s superViewChangedSize
- ]
- ]
-
-"
- viewport isNil ifTrue:[
- viewport := aRectangle.
- ].
-"
-"
- superView notNil ifTrue:[
- self superViewChangedSize
- ] ifFalse:[
- originChanged := true.
- extentChanged := true
- ]
-"
+ ^ menuMsg
!
-viewOrigin
- "return the viewOrigin; thats the coordinate of the contents
- which is shown topLeft in the view
- (i.e. the origin of the visible part of the contents)."
-
- transformation isNil ifTrue:[
- ^ 0@0
- ].
- ^ transformation translation negated
-!
-
-setViewOrigin:aPoint
- "set the viewOrigin - i.e. virtually scroll without redrawing"
-
- |p|
-
- p := aPoint negated.
- transformation isNil ifTrue:[
- transformation := WindowingTransformation scale:1 translation:p
- ] ifFalse:[
- transformation translation:p
- ].
- clipRect notNil ifTrue:[
- self setInnerClip.
- ].
-!
-
-viewport:aRectangle
- "define my extend in my superviews coordinate-system."
-
-"/ |relW relH relX relY winW winH|
-
- viewport := aRectangle.
- self dimensionFromViewport
-"/
-"/ superView notNil ifTrue:[
-"/ superView window isNil ifTrue:[
-"/ winW := 1.
-"/ winH := 1
-"/ ] ifFalse:[
-"/ winW := superView window width.
-"/ winH := superView window height
-"/ ].
-"/ relW := (aRectangle width / winW) asFloat.
-"/ relH := (aRectangle height / winH) asFloat.
-"/ relX := (aRectangle left / winW) asFloat.
-"/ relY := (aRectangle top / winH) asFloat.
-"/ self origin:(relX @ relY) extent:(relW @ relH)
-"/ ]
-"/
-!
-
-window:aRectangle viewport:vRect
- window := aRectangle.
- self viewport:vRect.
- subViews notNil ifTrue:[
- subViews do:[:s |
- s superViewChangedSize
- ]
- ]
-!
+aspectMessage
+ "Return the aspect used with changes from/to the model"
-scale
- "return the scale factor (as point) of the transformation"
-
- transformation isNil ifTrue:[^ 1].
- ^ transformation scale
-!
-
-scale:aPoint
- "set the scale factor of the transformation"
-
- transformation isNil ifTrue:[
- aPoint = 1 ifTrue:[^ self].
- transformation := WindowingTransformation scale:aPoint translation:0
- ].
-
- transformation scale:aPoint.
- self computeInnerClip
-!
-
-xOriginOfContents
- "return the x coordinate of the viewOrigin in pixels;
- used by scrollBars to compute thumb position within the document."
-
- ^ self viewOrigin x
-!
-
-yOriginOfContents
- "return the y coordinate of the viewOrigin in pixels;
- used by scrollBars to compute thumb position within the document."
-
- ^ self viewOrigin y
-!
-
-heightOfContents
- "return the height of the contents in logical units
- - defaults to views visible area here.
- This method MUST be redefined in all view classess which are
- going to be scrolled AND show data which has different size than
- the view. For example, a view showing A4-size documents should return
- the number of vertical pixels such a document has on this device.
- A view showing a bitmap of height 1000 should return 1000.
- If not redefined, scrollbars have no way of knowing the actual size
- of the contents being shown. This is called by scrollBars to compute
- the relative height of the document vs. the views actual size.
- The value returned here must be based on a scale of 1, since users
- of this will scale as appropriate."
-
- ^ self innerHeight max:(self maxSubViewBottom)
-!
-
-widthOfContents
-
- ^ self innerWidth max:(self maxSubViewRight)
-
-!
-
-maxSubViewBottom
-"/ subViews isNil ifTrue:[^ 0].
-"/ ^ subViews inject:0 into:[:maxSoFar :sub | (sub top + sub height) max:maxSoFar].
- ^ 0
-!
-
-maxSubViewRight
-"/ subViews isNil ifTrue:[^ 0].
-"/ ^ subViews inject:0 into:[:maxSoFar :sub | (sub left + sub width) max:maxSoFar].
- ^ 0
+ ^ aspectMsg
! !
-!View methodsFor:'accessing misc'!
-
-clipRect:aRectangle
- "set the clipping rectangle for drawing (in logical coordinates);
- a nil argument turn off clipping (i.e. whole view is drawable).
- Redefined to care for any margin."
-
- |x y w h|
+!View methodsFor:'accessing-menus'!
- aRectangle isNil ifTrue:[
- clipRect isNil ifTrue:[^ self].
- gcId notNil ifTrue:[
- device noClipIn:gcId
- ]
- ] ifFalse:[
- clipRect notNil ifTrue:[
- (clipRect = aRectangle) ifTrue:[^ self]
- ].
- gcId notNil ifTrue:[
- x := aRectangle left.
- y := aRectangle top.
- w := aRectangle width.
- h := aRectangle height.
- transformation notNil ifTrue:[
- x := transformation applyToX:x.
- y := transformation applyToY:y.
- w := transformation applyScaleX:w.
- h := transformation applyScaleY:h.
- ].
- (x isMemberOf:SmallInteger) ifFalse:[
- w := w + (x - x truncated).
- x := x truncated
- ].
- (y isMemberOf:SmallInteger) ifFalse:[
- h := h + (y - y truncated).
- y := y truncated
- ].
- (w isMemberOf:SmallInteger) ifFalse:[
- w := w truncated + 1
- ].
- (h isMemberOf:SmallInteger) ifFalse:[
- h := h truncated + 1
- ].
- x < margin ifTrue:[
- x := margin.
- ].
- y < margin ifTrue:[
- y := margin.
- ].
- x + w - 1 >= (width-margin) ifTrue:[
- w := width - margin - x
- ].
- y + h - 1 >= (height-margin) ifTrue:[
- h := height - margin - y
- ].
- device setClipX:x y:y width:w height:h in:gcId
- ]
- ].
- clipRect := aRectangle
-! !
+menuHolder
+ "who has the menu ?
+ By default, its the model if I have one."
-!View methodsFor:'ST-80 compatibility'!
-
-sensor
- "return the views sensor"
-
- windowGroup notNil ifTrue:[
- ^ windowGroup sensor.
- ].
- ^ nil
-!
-
-update:aspect
- "an update request - ignored here. Can be redefined in subclasses"
-
+ model notNil ifTrue:[^ model].
^ self
!
-on:aModel aspect:aspect change:change list:list menu:menu
- "ST-80 compatibility"
-
- aspectSymbol := aspect.
- changeSymbol := change.
- menuSymbol := menu.
- self model:aModel
-!
-
-update
- "an update request - ignored here. Can be redefined in subclasses."
-
- ^ self
-!
-
-update:aspect with:aParameter from:changedObject
- "an update request"
-
- aspect == #sizeOfView ifTrue:[
- "one of the views we depend on changed its size"
- ^ self superViewChangedSize.
- ].
- ^super update:aspect with:aParameter from:changedObject
-! !
-
-!View methodsFor:'accessing-misc'!
-
-shown
- "return true if the view is shown; false if hidden"
-
- ^ shown
-!
-
-inputOnly
- "return true, if this view is an input-only view;
- input only views are transparent and can be layed on top of a view to
- catch its input"
-
- ^ false
-!
-
-createOnTop
- "return true, if this view should be put on top (raised) automatically.
- usually this is true for alertBoxes etc."
-
- ^ false
-!
-
-is3D
- "return true, if my style is some kind of 3D style - will change"
-
- ^ StyleSheet is3D
-!
-
-raise
- "bring to front"
-
- drawableId isNil ifTrue:[self create].
- device raiseWindow:drawableId
-!
-
-viewGravity:gravity
- "set the viewGravity - thats the direction where the view will move
- when the superView is resized."
+menuPerformer
+ "who should perform the menu actions ?
+ By default, its the model if I have one."
- viewGravity ~~ gravity ifTrue:[
- viewGravity := gravity.
- drawableId notNil ifTrue:[
- device setWindowGravity:gravity in:drawableId
- ]
- ]
-!
-
-viewGravity
- "return the viewGravity - thats the direction where the view will move
- when the superView is resized."
-
- ^ viewGravity
-!
-
-hidden:aBoolean
- "if the argument is true, the receiver view will not
- be realized automatically when superview is realized"
-
- hidden := aBoolean
-!
-
-bitGravity
- "return the bitGravity - thats the direction where the contents will move
- when the the view is resized."
-
- ^ bitGravity
-!
-
-bitGravity:gravity
- "set the bitGravity - thats the direction where the contents will move
- when the view is resized."
-
- bitGravity ~~ gravity ifTrue:[
- bitGravity := gravity.
- drawableId notNil ifTrue:[
- device setBitGravity:gravity in:drawableId
- ]
- ]
-!
-
-canDrop:anObjectOrCollection
- "return true, if anObjectOrCollection can be
- dropped in the receiver. This method should be
- redefined in views which can take objects"
-
- ^ false
-!
-
-isCollapsed
- "ST80 compatibility: return true if the view is not shown (i.e. iconified)"
-
- ^ shown not
-!
-
-hidden
- "return true, if the view does not want to be realized
- automatically when superview is realized"
-
- ^ hidden
-!
-
-lower
- "bring to back"
-
- drawableId isNil ifTrue:[self create].
- device lowerWindow:drawableId
+ model notNil ifTrue:[^ model].
+ ^ self
! !
!View methodsFor:'initialization'!
-defaultControllerClass
- ^ nil "/ Controller
-!
-
-initEvents
- "will be sent by create - can be redefined by subclasses to enable
- view events"
-
- ^ self
-!
-
initialize
- "initialize all state of the view - usually redefined in subclasses,
- but always doing a 'super initialize'. Each class should setup its
- locals - and not forget the others.
- View setup is separated into two parts, the general setup done here
- and the style specific setup in initStyle. Each view should be prepared
- for a stylechange by being sent another initStyle with a new style value.
- (in this case, it should set all of its style-dependent things, but
- leave the state and contents as-is)"
-
- |ext controllerClass|
-
super initialize.
-
- font := DefaultFont.
-
- shown := hidden := realized := false.
-
- "fill in some defaults - some of them are usually redefined in subclasses
- initialize methods"
-
- name := self class name asString asLowercaseFirst.
- ext := self class defaultExtent.
-
- level := 0.
- margin := 0.
-
- resources := self class classResources.
-
- self initStyle.
-
- left := 0.
- top := 0.
- width := ext x.
- height := ext y.
-"/ leftInset := 0.
-"/ topInset := 0.
-"/ rightInset := 0.
-"/ bottomInset := 0.
-
- originChanged := extentChanged := false.
- bitGravity := nil.
- viewGravity := nil.
-
- controllerClass := self defaultControllerClass.
- controllerClass notNil ifTrue:[
- controller := controllerClass new.
- controller view:self.
- model notNil ifTrue:[
+ model notNil ifTrue:[
+ controller notNil ifTrue:[
controller model:model
]
].
-!
-
-initStyle
- "this method sets up all style dependent things"
-
- "
- when coming here the first time, we read the styleSheet
- and keep the values in fast class variables
- "
- StyleSheet isNil ifTrue:[
- self class updateStyleCache
- ].
-
- style := DefaultStyle.
-
- borderWidth := DefaultBorderWidth.
- borderWidth isNil ifTrue:[borderWidth := 1].
-
- viewBackground := DefaultViewBackgroundColor "on:device".
-
- DefaultLightColor notNil ifTrue:[
- lightColor := DefaultLightColor.
- ] ifFalse:[
- device hasGreyscales ifTrue:[
- DefaultLightColor := lightColor := viewBackground lightened.
- ] ifFalse:[
- "
- this seems strange: on B&W light color is darker than
- normal viewBackground (White) to make the boundary of
- the view visible
- "
- lightColor := Color grey:50
- ]
- ].
- DefaultShadowColor notNil ifTrue:[
- shadowColor := DefaultShadowColor.
- ] ifFalse:[
- shadowColor := Black
- ].
-
- lightColor := lightColor "on:device".
- shadowColor := shadowColor "on:device".
- borderColor := DefaultBorderColor " on:device".
- font := DefaultFont on:device.
-!
-
-prepareForReinit
- super prepareForReinit.
- windowGroup notNil ifTrue:[
- windowGroup reinitialize
- ]
-!
-
-reinitialize
- "this is called right snapIn"
-
- |myController|
-
- "if I have already been reinited - return"
- drawableId notNil ifTrue:[
- ^ self
- ].
-
- "
- superView must be there, first
- "
- superView notNil ifTrue:[
- superView id isNil ifTrue:[
- superView reinitialize
- ]
- ].
-
- myController := controller.
- controller := nil.
- self recreate.
-
- "if I was mapped, do it again"
- realized ifTrue:[
- "only remap if I have a superview - otherwise, I might be
- a hidden iconView or menu ..."
- superView notNil ifTrue:[
-"/ shown ifTrue:[
- device mapView:self id:drawableId iconified:false
- atX:left y:top width:width height:height
-"/ ].
- ].
- ].
-
- "restore controller"
- controller := myController
-!
-
-reinitStyle
- "this method is called for a style change"
-
- |t|
-
- self initStyle.
- drawableId notNil ifTrue:[
- "force a change"
- t := borderWidth. borderWidth := nil. self borderWidth:t.
- t := viewBackground. viewBackground := nil. self viewBackground:t.
- self clear.
- self redraw
- ].
! !
-!View methodsFor:'accessing-hierarchy'!
-
-superView:aView
- "set my superView to be aView"
-
- superView := aView
-!
-
-superView
- "return my superView"
-
- ^ superView
-!
-
-subViews
- "return the collection of subviews"
-
- ^ subViews
-!
-
-topView
- "return the topView - thats the one with no superview"
-
- |v|
-
- v := self.
- [v notNil] whileTrue:[
- v superView isNil ifTrue:[^ v].
- v := v superView
- ].
-
- ^ nil
-!
-
-subViews:aListOfViews
- "set the collection of subviews"
-
- subViews := aListOfViews.
- subViews notNil ifTrue:[
- subViews do:[:view |
- view superView:self
- ]
- ]
-! !
-
-!View methodsFor:'event handling'!
-
-exposeX:x y:y width:w height:h
- "a low level redraw event from device
- - let subclass handle the redraw and take care of edges here"
-
- |leftEdge topEdge rightEdge botEdge anyEdge nx ny nw nh old|
-
- nw := w.
- nh := h.
- nx := x.
- ny := y.
-
- anyEdge := false.
-
- "
- check if there is a need to draw an edge (i.e. if margin is hit)
- "
- (margin ~~ 0) ifTrue:[
- leftEdge := false.
- topEdge := false.
- rightEdge := false.
- botEdge := false.
- transformation notNil ifTrue:[
- "
- need device coordinates for this test
- "
- nx := transformation applyToX:nx.
- ny := transformation applyToY:ny.
- nw := transformation applyScaleX:nw.
- nh := transformation applyScaleY:nh.
- ].
- "
- adjust expose rectangle, to exclude the margin.
- Care for rounding errors ...
- "
- (nx isMemberOf:SmallInteger) ifFalse:[
- old := nx.
- nx := nx truncated.
- nw := nw + (nx - old).
- ].
- (ny isMemberOf:SmallInteger) ifFalse:[
- old := ny.
- ny := ny truncated.
- nh := nh + (ny - old).
- ].
- (nw isMemberOf:SmallInteger) ifFalse:[
- nw := nw truncated + 1
- ].
- (nh isMemberOf:SmallInteger) ifFalse:[
- nh := nh truncated + 1
- ].
- (nx < margin) ifTrue:[
- old := nx.
- nx := margin.
- nw := nw - (nx - old).
- leftEdge := anyEdge := true.
- ].
- ((nx + nw - 1) >= (width - margin)) ifTrue:[
- nw := (width - margin - nx).
- rightEdge := anyEdge := true.
- ].
- (ny < margin) ifTrue:[
- old := ny.
- ny := margin.
- nh := nh - (ny - old).
- topEdge := anyEdge := true.
- ].
- ((ny + nh - 1) >= (height - margin)) ifTrue:[
- nh := (height - margin - ny).
- botEdge := anyEdge := true.
- ].
- transformation notNil ifTrue:[
- "
- need logical coordinates for redraw
- "
- nx := transformation applyInverseToX:nx.
- ny := transformation applyInverseToY:ny.
- nw := transformation applyInverseScaleX:nw.
- nh := transformation applyInverseScaleY:nh.
- ].
- ].
-
- "
- redraw inside area
- "
- self redrawX:nx y:ny width:nw height:nh.
-
- "
- redraw edge(s)
- "
- anyEdge ifTrue:[
- self clipRect:nil.
- (topEdge and:[leftEdge and:[botEdge and:[rightEdge]]]) ifTrue:[
- self drawEdges
- ] ifFalse:[
- topEdge ifTrue:[
- self drawTopEdge
- ].
- leftEdge ifTrue:[
- self drawLeftEdge
- ].
- botEdge ifTrue:[
- self drawBottomEdge
- ].
- rightEdge ifTrue:[
- self drawRightEdge
- ]
- ].
- self clipRect:innerClipRect
- ]
-!
-
-superViewMapped
- "my superview was unmapped"
-
- realized ifTrue:[
- shown := true.
- subViews notNil ifTrue:[
- subViews do:[:v |
- v superViewMapped
- ]
- ]
- ].
-!
-
-configureX:x y:y width:newWidth height:newHeight
- "my size has changed by window manager action"
-
- |how anyEdge mustRedrawBottomEdge mustRedrawRightEdge|
-
- left := x.
- top := y.
- ((width ~~ newWidth) or:[height ~~ newHeight]) ifTrue:[
- realized ifFalse:[
- width := newWidth.
- height := newHeight.
- extentChanged := true.
- ^ self
- ].
-
- ((newWidth <= width) and:[newHeight <= height]) ifTrue:[
- how := #smaller
- ].
-
- level ~~ 0 ifTrue:[
- mustRedrawBottomEdge := newHeight < height.
- mustRedrawRightEdge := newWidth < width.
- anyEdge := mustRedrawBottomEdge or:[mustRedrawRightEdge]
- ] ifFalse:[
- anyEdge := false
- ].
-
- width := newWidth.
- height := newHeight.
-
- "recompute inner-clip if needed"
- self setInnerClip.
-
- "
- must first process pending exposes;
- otherwise, those may be drawn at a wrong position
- "
- windowGroup notNil ifTrue:[
- windowGroup processExposeEvents
- ].
- self sizeChanged:how.
-
- (anyEdge and:[shown]) ifTrue:[
- self clipRect:nil.
- mustRedrawBottomEdge ifTrue:[
- self drawBottomEdge
- ].
- mustRedrawRightEdge ifTrue:[
- self drawRightEdge
- ].
- self clipRect:innerClipRect
- ]
- ]
-!
-
-superViewChangedSize
- "my superView has changed size; if I have relative
- origin/extent or blocks to evaluate, do it now .."
-
- |oldWidth oldHeight oldTop oldLeft newExt newOrg
- winSuper newWidth newHeight newLeft newTop newCorner
- superWidth superHeight superWinWidth superWinHeight|
-
- oldWidth := width.
- oldHeight := height.
- oldTop := top.
- oldLeft := left.
-
- viewport notNil ifTrue:[
- "
- if this view has a viewPort, resize a la st-80
- this will vanish - dont use it.
- "
- superView isNil ifTrue:[^ self].
- winSuper := superView window.
- winSuper isNil ifTrue:[
- "take pixel size as window"
- winSuper := 0@0 extent:(superView width@superView height)
- ].
-
- superWidth := superView width.
- superHeight := superView height.
- superWinWidth := winSuper width.
- superWinHeight := winSuper height.
- newLeft := (viewport left - winSuper left) * superWidth // superWinWidth.
- newTop := (viewport top - winSuper top) * superHeight // superWinHeight.
- newWidth := superWidth * viewport width // superWinWidth.
- newHeight := superHeight * viewport height // superWinHeight.
- self pixelOrigin:(newLeft @ newTop).
- self pixelExtent:(newWidth @ newHeight).
- ^ self
- ].
-
- newOrg := self computeOrigin.
- newExt := self computeExtent.
-
- newOrg notNil ifTrue:[
- ((newOrg x == oldLeft) and:[newOrg y == oldTop]) ifTrue:[
- newOrg := nil
- ]
- ].
- newExt notNil ifTrue:[
- ((newExt x == width) and:[newExt y == height]) ifTrue:[
- newExt := nil
- ]
- ].
-
- newExt isNil ifTrue:[
- newOrg notNil ifTrue:[
- self pixelOrigin:newOrg
- ]
- ] ifFalse:[
- newOrg isNil ifTrue:[
- self pixelExtent:newExt
- ] ifFalse:[
- self pixelOrigin:newOrg extent:newExt
- ]
- ]
-!
-
-mapped
- "the view has been mapped (by some outside
- action - i.e. window manager de-iconified me)"
-
- "
- the old code was:
-
- realized := true.
- shown := true.
- ...
-
- this created a race condition, if the view was
- realized and shortly after unrealized - before the mapped event
- arrived. This lead to shown being set to true even thought the
- view was not. Boy - that was a bad one (hard to reproduce and hard to find).
- "
-
- realized ifTrue:[
- shown := true.
- "
- backed views will not get expose events - have
- to force a redraw here to get things drawn into
- backing store.
- "
- backed ifTrue:[
- self redraw
- ].
- subViews notNil ifTrue:[
- subViews do:[:v |
- v superViewMapped
- ]
- ]
- ]
-!
-
-buttonPress:button x:x y:y
- "button was pressed - if its the middle button
- and there is a middleButtonMenu, show it.
- If both a model and a menuSelector is is defined, ask the model for
- the menu and launch it. The menu is supposed to return an actionSelector
- which in turn is sent to the model."
-
- |menu actionSelector|
-
- components notNil ifTrue:[
- components do:[:aComponent |
- |thisFrame|
-
- thisFrame := aComponent frame.
- (thisFrame containsPointX:x y:y) ifTrue:[
- aComponent buttonPress:button x:x - thisFrame left
- y:y - thisFrame top.
- ^ self
- ]
- ]
- ].
-
- ((button == 2) or:[button == #menu]) ifTrue:[
- "
- try ST-80 style menus first:
- if there is a model, and a menuSymbol is defined,
- ask model for the menu and launch that if non-nil.
- "
- (model notNil
- and:[menuSymbol notNil
- and:[menuSymbol isSymbol]]) ifTrue:[
- "
- ask model for the menu
- "
- menu := model perform:menuSymbol.
- menu notNil ifTrue:[
- "
- got one, launch the menu. It is supposed
- to return an actionSelector.
- "
- menu receiver isNil ifTrue:[
- menu receiver: model
- ].
- actionSelector := menu startUp.
- (actionSelector notNil
- and:[actionSelector isSymbol]) ifTrue:[
- model perform:actionSelector
- ]
- ].
- ^ self
- ]
- ].
- super buttonPress:button x:x y:y
-!
-
-unmapped
- "the view has been unmapped (by some outside
- action - i.e. window manager iconified me)"
-
- shown := false.
- subViews notNil ifTrue:[
- subViews do:[:v |
- v superViewUnmapped
- ]
- ]
-!
-
-coveredBy:aView
- "the receiver has been covered by another view;
- we are not interrested in that here (but see modalBox for more)."
-!
-
-sizeChanged:how
- "tell subviews if I change size.
- How is either #smaller, #larger or nil, and is used to control the order,
- in which subviews are notified (possibly reducing redraw activity)"
-
- window notNil ifTrue:[
- "compute new transformation"
- ].
- subViews notNil ifTrue:[
- (how isNil "false"
- or:[how == #smaller]) ifTrue:[
- subViews do:[:view |
- view superViewChangedSize
- ]
- ] ifFalse:[
- "doing it reverse speeds up resizing - usually subviews
- are created from top-left to bottom-right; therefore
- bottom-right views will be moved/resized first, then top-left ones;
- this avoids multiple redraws of subviews"
-
- subViews reverseDo:[:view |
- view superViewChangedSize
- ]
- ]
- ].
- self changed:#sizeOfView with:how.
-!
-
-superViewUnmapped
- "my superView was unmapped"
-
- shown := false.
- subViews notNil ifTrue:[
- subViews do:[:v |
- v superViewUnmapped
- ]
- ]
-!
-
-reparented
- "the view has changed its parent by some outside
- action - i.e. window manager has added a frame.
- nothing done here"
-
- ^ self
-!
-
-terminate
- "window manager wants me to go away;
- - notice, that not all window managers are nice enough to
- send this event, but simply destroy the view instead.
- Can be redefined in subclasses to do whatever cleanup is
- required."
-
- ^ self destroy
-!
-
-focusIn
- "got keyboard focus"
-
- self showFocus
-!
-
-keyPress:key x:x y:y
- "a key has been pressed. If there are components,
- pass it to the corresponding one.
- Otherwise, forward it to the superview, if there is any."
-
- components notNil ifTrue:[
- components do:[:aComponent |
- |thisFrame|
-
- thisFrame := aComponent frame.
- (thisFrame containsPointX:x y:y) ifTrue:[
- aComponent keyPress:key x:x - thisFrame left
- y:y - thisFrame top.
- ^ self
- ]
- ]
- ].
-
- x >= 0 ifTrue:[
- superView notNil ifTrue:[
- WindowEvent
- sendEvent:#keyPress:x:y:
- arguments:(Array with:key with:x with:y)
- view:superView
- ] ifFalse:[
- super keyPress:key x:x y:y
- ]
- ]
-!
-
-focusOut
- "lost keyboard focus"
-
- self showNoFocus
-!
-
-visibilityChange:how
- "the visibility of the view has changed (by some outside
- action - i.e. window manager rearranged things).
- Using this knowledge avoids useless redraw in obsucred views."
-
- how == #fullyObscured ifTrue:[
- shown := false
- ] ifFalse:[
- shown := true.
- ]
-!
-
-destroyed
- "view has been destroyed by someone else (usually window system)"
-
- shown := false.
- super destroyed
-!
-
-saveAndTerminate
- "window manager wants me to save and go away;
- - notice, that not all window managers are nice enough to
- send this event, but simply destroy the view instead.
- Can be redefined in subclasses to do whatever is required
- to prepare for restart."
-
- ^ self destroy
-! !
-
-!View methodsFor:'accessing-bg & border'!
-
-margin
- "return my margin - this is usually the level,
- but can be more for some views"
-
- ^ margin
-!
-
-borderWidth
- "return my borderWidth"
-
- ^ borderWidth
-!
-
-borderWidth:aNumber
- "set my borderWidth"
-
- (aNumber ~~ borderWidth) ifTrue:[
- borderWidth := aNumber.
- drawableId notNil ifTrue:[
- device setWindowBorderWidth:aNumber in:drawableId
- ]
- ]
-!
-
-level:aNumber
- "set my level relative to superView (3D)"
-
- |oldMargin how|
-
- (aNumber ~~ level) ifTrue:[
- self is3D ifTrue:[
- level := aNumber.
- oldMargin := margin.
- margin := level abs.
-
- realized ifTrue:[
- margin ~~ oldMargin ifTrue:[
- (margin > oldMargin) ifTrue:[
- how := #smaller
- ] ifFalse:[
- how := #larger
- ].
- self sizeChanged:how.
- self setInnerClip.
- ].
- shown ifTrue:[
- self redrawEdges
- ]
- ]
- ]
- ]
-!
-
-viewBackground:something
- "set the viewBackground to something, a color, image or form.
- If its a color and we run on a color display, also set shadow and light
- colors - this means, that a red view will get light-red and dark-red
- edges."
-
- something isColor ifTrue:[
- device hasGreyscales ifTrue:[
- shadowColor := something darkened.
- lightColor := something lightened
- ]
- ].
- super viewBackground:something
-!
-
-heightIncludingBorder
- "return my height including border"
-
- ^ height + (2*borderWidth)
-!
-
-borderColor
- "return my borderColor"
-
- ^ borderColor
-!
-
-borderColor:aColor
- "set my borderColor"
-
- (aColor ~~ borderColor) ifTrue:[
- borderColor := aColor.
- drawableId notNil ifTrue:[
- self setBorderColor
- ]
- ]
-!
-
-borderShape:aForm
- "set the borderShape to aForm"
-
- borderShape := aForm.
- drawableId notNil ifTrue:[
- device setWindowBorderShape:(aForm id) in:drawableId
- ]
-!
-
-viewShape:aForm
- "set the viewShape to aForm"
-
- viewShape := aForm.
- drawableId notNil ifTrue:[
- device setWindowShape:(aForm id) in:drawableId
- ]
-!
-
-processName
- "return a string to be shown in the process monitor"
-
- ^ self name
-!
-
-name
- "return my name component to be used for resource-access"
-
- ^ name
-!
-
-fullName
- "return my full name to be used for resource-access"
-
- superView notNil ifTrue:[
- ^ superView fullName , '.' , name
- ].
- ^ name
-!
-
-widthIncludingBorder
- "return my width including border"
-
- ^ width + (2*borderWidth)
-!
-
-name:aString
- "set my name component to be used for resource-access"
-
- name := aString
-!
-
-level
- "return my level relative to superView (3D)"
-
- ^ level
-!
-
-lightColor:aColorOrImage
- "set the color to be used for lighted edges (3D only)"
-
- lightColor := aColorOrImage
-!
-
-shadowColor:aColorOrImage
- "set the color to be used for shadowed edges (3D only)"
-
- shadowColor := aColorOrImage
-! !
-
!View methodsFor:'drawing'!
-drawEdgesForX:x y:y width:w height:h level:l
- shadow:shadowColor light:lightColor
- halfShadow:halfShadowColor halfLight:halfLightColor
- style:edgeStyle
-
- "draw 3D edges into a rectangle"
-
- |topLeftFg botRightFg topLeftHalfFg botRightHalfFg
- count "{ Class: SmallInteger }"
- r "{ Class: SmallInteger }"
- b "{ Class: SmallInteger }"
- xi "{ Class: SmallInteger }"
- yi "{ Class: SmallInteger }"
- run paint|
-
- count := l.
- (count < 0) ifTrue:[
- topLeftFg := shadowColor.
- botRightFg := lightColor.
- topLeftHalfFg := halfShadowColor.
- botRightHalfFg := halfLightColor.
- count := count negated
- ] ifFalse:[
- topLeftFg := lightColor.
- botRightFg := shadowColor.
- topLeftHalfFg := halfLightColor.
- botRightHalfFg := halfShadowColor.
- ].
- topLeftHalfFg isNil ifTrue:[
- topLeftHalfFg := topLeftFg
- ].
- botRightHalfFg isNil ifTrue:[
- botRightHalfFg := botRightFg
- ].
-
- r := x + w - 1. "right"
- b := y + h - 1. "bottom"
-
- super lineWidth:0.
-
- "top and left edges"
- ((edgeStyle == #soft) and:[l > 0]) ifTrue:[
- paint := topLeftHalfFg
- ] ifFalse:[
- paint := topLeftFg
- ].
- super paint:paint.
-
- 0 to:(count - 1) do:[:i |
- run := y + i.
- super displayDeviceLineFromX:x y:run toX:r y:run. "top"
- run := x + i.
- super displayDeviceLineFromX:run y:y toX:run y:b "left"
- ].
- (edgeStyle == #soft) ifTrue:[
-"
- super paint:topLeftFg.
- super displayDeviceLineFromX:x y:y toX:r y:y.
- super displayDeviceLineFromX:x y:y toX:x y:b
-"
- (l > 2) ifTrue:[
- super paint:Black.
- super displayDeviceLineFromX:x y:y toX:r y:y.
- super displayDeviceLineFromX:x y:y toX:x y:b.
- ]
- ].
-
- xi := x + 1.
- yi := y + 1.
-
-"/ does not look good
-"/ style == #st80 iftrue:[
-"/ yi := yi + 1
-"/ ].
-
- "bottom and right edges"
- (edgeStyle == #soft) ifTrue:[
- paint := botRightHalfFg
- ] ifFalse:[
- paint := botRightFg
- ].
-
- super paint:paint.
- 0 to:(count - 1) do:[:i |
- run := b - i.
- super displayDeviceLineFromX:xi-1 y:run toX:r y:run. "bottom"
- run := r - i.
- super displayDeviceLineFromX:run y:yi-1 toX:run y:b. "right"
- xi := xi + 1.
- yi := yi + 1
- ].
- ((edgeStyle == #soft) and:[l > 1]) ifTrue:[
- super paint:Black "shadowColor".
- super displayDeviceLineFromX:(x + 1-1) y:b toX:r y:b.
- super displayDeviceLineFromX:r y:(y + 1 - 1) toX:r y:b
- ]
-!
-
-redrawX:x y:y width:w height:h
- "have to redraw part of myself, givel logical coordinates (if trans is nonNil)
- default is to redraw everything - subclasses should add intelligence"
-
- |area|
-
- area := Rectangle left:x top:y width:w height:h.
- self clippedTo:area do:[
-"/ controller notNil ifTrue:[
-"/ "ST-80 updating"
-"/ self update:#rectangle with:area
-"/ ] ifFalse:[
- components notNil ifTrue:[
- components do:[:aComponent |
- |thisFrame is|
-
- thisFrame := aComponent frame.
- (thisFrame intersects:area) ifTrue:[
- is := thisFrame intersect:(x@y extent:w@h).
- is = thisFrame ifTrue:[
- aComponent redraw
- ] ifFalse:[
- aComponent redrawX:is left
- y:is top
- width:is width
- height:is height.
- ].
- "/ aComponent drawIn:self offset:0@0
- ]
- ]
- ] ifFalse:[
- self redraw
- ]
-"/ ]
- ]
-!
-
-drawBottomEdge
- "draw bottom 3D edge into window frame"
-
- self drawBottomEdgeLevel:level
- shadow:shadowColor
- light:lightColor
- halfShadow:nil
- halfLight:nil
- style:nil.
-!
-
-drawEdges
- "draw all of my 3D edges"
-
- self drawEdgesForX:0 y:0 width:width height:height level:level
- shadow:shadowColor
- light:lightColor
- halfShadow:nil
- halfLight:nil
- style:nil
-!
-
redraw
"redraw myself
if there is a model, this one shall redraw itself,
@@ -3242,1293 +307,17 @@
model notNil ifTrue:[
model update:self
]
-!
-
-drawTopEdge
- "draw top 3D edge into window frame"
-
- self drawTopEdgeLevel:level
- shadow:shadowColor
- light:lightColor
- halfShadow:nil
- halfLight:nil
- style:nil.
-!
-
-drawLeftEdge
- "draw left 3D edge into window frame"
-
- self drawLeftEdgeLevel:level
- shadow:shadowColor
- light:lightColor
- halfShadow:nil
- halfLight:nil
- style:nil.
-!
-
-drawRightEdge
- "draw right 3D edge into window frame"
-
- self drawRightEdgeLevel:level
- shadow:shadowColor
- light:lightColor
- halfShadow:nil
- halfLight:nil
- style:nil.
-!
-
-drawRightEdgeLevel:level shadow:shadowColor light:lightColor halfShadow:halfShadowColor halfLight:halfLightColor style:edgeStyle
- |rightFg
- count "{ Class: SmallInteger }"
- r b|
-
- count := level.
- count == 0 ifTrue:[^ self].
-
- (count < 0) ifTrue:[
- rightFg := lightColor.
- count := count negated
- ] ifFalse:[
- ((edgeStyle == #soft) and:[level > 1]) ifTrue:[
- rightFg := halfShadowColor
- ] ifFalse:[
- rightFg := shadowColor
- ].
- ].
- super paint:rightFg.
- super lineWidth:0.
-
- b := height - 1.
- 0 to:(count - 1) do:[:i |
- r := width - 1 - i.
- super displayDeviceLineFromX:r y:i toX:r y:(b - i)
- ].
- ((edgeStyle == #soft) and:[level > 1]) ifTrue:[
- r := width - 1.
- super paint:shadowColor.
- super displayDeviceLineFromX:r y:1 toX:r y:b.
- ]
-!
-
-drawTopEdgeLevel:level shadow:shadowColor light:lightColor halfShadow:halfShadowColor halfLight:halfLightColor style:edgeStyle
- |topFg topHalfFg paint r
- count "{ Class: SmallInteger }" |
-
- count := level.
- count == 0 ifTrue:[^ self].
-
- (count < 0) ifTrue:[
- topFg := shadowColor.
- topHalfFg := halfShadowColor.
- count := count negated
- ] ifFalse:[
- topFg := lightColor.
- topHalfFg := halfLightColor.
- ].
- topHalfFg isNil ifTrue:[
- topHalfFg := topFg
- ].
-
- ((edgeStyle == #soft) and:[level > 0]) ifTrue:[
- paint := topHalfFg
- ] ifFalse:[
- paint := topFg
- ].
- super paint:paint.
- super lineWidth:0.
-
- r := width - 1.
- 0 to:(count - 1) do:[:i |
- super displayDeviceLineFromX:i y:i toX:(r - i) y:i
- ].
- ((edgeStyle == #soft) and:[level > 2]) ifTrue:[
- super paint:Black.
- super displayDeviceLineFromX:0 y:0 toX:r y:0.
- ]
-!
-
-drawBottomEdgeLevel:level shadow:shadowColor light:lightColor halfShadow:halfShadowColor halfLight:halfLightColor style:edgeStyle
- |botFg
- count "{ Class: SmallInteger }"
- b r|
-
- count := level.
- count == 0 ifTrue:[^ self].
-
- (count < 0) ifTrue:[
- botFg := lightColor.
- count := count negated
- ] ifFalse:[
- ((edgeStyle == #soft) and:[level > 1]) ifTrue:[
- botFg := halfShadowColor
- ] ifFalse:[
- botFg := shadowColor
- ].
- ].
- super paint:botFg.
- super lineWidth:0.
-
- r := width - 1.
- 0 to:(count - 1) do:[:i |
- b := height - 1 - i.
- super displayDeviceLineFromX:i y:b toX:(r - i) y:b
- ].
-
- ((edgeStyle == #soft) and:[level > 1]) ifTrue:[
- b := height - 1.
- super paint:shadowColor.
- super displayDeviceLineFromX:1 y:b toX:r y:b.
- ]
-!
-
-drawLeftEdgeLevel:level shadow:shadowColor light:lightColor halfShadow:halfShadowColor halfLight:halfLightColor style:edgeStyle
- |leftFg leftHalfFg paint b
- count "{ Class: SmallInteger }" |
-
- count := level.
- count == 0 ifTrue:[^ self].
-
- (count < 0) ifTrue:[
- leftFg := shadowColor.
- leftHalfFg := halfShadowColor.
- count := count negated.
- ] ifFalse:[
- leftFg := lightColor.
- leftHalfFg := halfLightColor.
- ].
- leftHalfFg isNil ifTrue:[
- leftHalfFg := leftFg
- ].
-
- ((edgeStyle == #soft) and:[level > 0]) ifTrue:[
- paint := leftHalfFg
- ] ifFalse:[
- paint := leftFg
- ].
- super paint:paint.
- super lineWidth:0.
-
- b := height - 1.
- 0 to:(count - 1) do:[:i |
- super displayDeviceLineFromX:i y:i toX:i y:(b - i)
- ].
-
- ((edgeStyle == #soft) and:[level > 2]) ifTrue:[
- super paint:Black.
- super displayDeviceLineFromX:0 y:0 toX:0 y:b.
- ]
-!
-
-drawEdgesForX:x y:y width:w height:h level:l
- "draw 3D edges into a rectangle"
-
- self drawEdgesForX:x y:y width:w height:h level:l
- shadow:shadowColor
- light:lightColor
- halfShadow:nil
- halfLight:nil
- style:nil
-!
-
-redrawDeviceX:x y:y width:w height:h
- "have to redraw part of the view.
- The coordinates are in device space - if there is a transformation,
- must inverse-transform back to logical coordinates. (since the view thinks
- in its coordinate space)"
-
- |lx ly lw lh|
-
- lx := x.
- ly := y.
- lw := w.
- lh := h.
-
- transformation notNil ifTrue:[
- lx := transformation applyInverseToX:lx.
- ly := transformation applyInverseToY:ly.
- lw := transformation applyInverseScaleX:lw.
- lh := transformation applyInverseScaleY:lh.
- ].
- self redrawX:lx y:ly width:lw height:lh
-!
-
-redrawEdges
- "redraw my edges (if any)"
-
- (level ~~ 0) ifTrue:[
- self clipRect:nil.
- self drawEdges.
- self clipRect:innerClipRect
- ]
-!
-
-showFocus
- "highlight myself somehow to tell user that I have the focus"
-
- |delta|
-
- drawableId notNil ifTrue:[
- delta := DefaultFocusBorderWidth - borderWidth.
- delta ~~ 0 ifTrue:[
- device moveWindow:drawableId x:left-delta y:top-delta
- ].
- device setWindowBorderWidth:DefaultFocusBorderWidth in:drawableId.
- device setWindowBorderColor:(DefaultFocusColor on:device) colorId in:drawableId.
- ]
-!
-
-showNoFocus
- "undo the effect of showFocus"
-
- |delta|
-
- drawableId notNil ifTrue:[
- delta := DefaultFocusBorderWidth - borderWidth.
- delta ~~ 0 ifTrue:[
- device moveWindow:drawableId x:left+delta y:top+delta
- ].
- device setWindowBorderWidth:borderWidth in:drawableId.
- self setBorderColor.
- ]
! !
!View methodsFor:'realization'!
-initializeMiddleButtonMenu
- "a place to initialize menu - this one is sent once when the view is
- first created; usually redefined in subclasses; default here is no menu"
-
- ^ self
-!
-
-fixSize
- "This is called right before the view is made visible.
- Adjust the size of the view according to either relative/abs or
- block extent; also set origin. Also, subclasses may redefine this
- method to adjust the size based on some extent (for example, PopUpMenus
- do so to take care of changed number of menu entries)."
-
- |org|
-
- window notNil ifTrue:[
- ^ self superViewChangedSize
- ].
-
- "if the extent is not the one we created the window with ..."
- extentChanged ifTrue:[
- self sizeChanged:nil.
- extentChanged := false
- ].
-
- originChanged ifTrue:[
-"/ org := self computeOrigin.
-"/ self pixelOrigin:org.
- originRule notNil ifTrue:[
- self pixelOrigin:(originRule value)
- ] ifFalse:[
- relativeOrigin notNil ifTrue:[
- self originFromRelativeOrigin
- ] ifFalse:[
- device moveWindow:drawableId x:left y:top.
- ].
- ].
- originChanged := false
- ]
-!
-
-realizeLeavingGroup:leaveGroupAsIs
- "common helper for realize and realizeInGroup"
-
- |superGroup groupChange|
-
- drawableId isNil ifTrue:[
- self create.
- ].
-
- leaveGroupAsIs ifFalse:[
- "
- put myself into superviews windowgroup if there is a superview
- "
- groupChange := false.
- superView notNil ifTrue:[
- superGroup := superView windowGroup.
- (windowGroup notNil and:[superGroup ~~ windowGroup]) ifTrue:[
- "
- mhmh - seems that the windowgroup has changed ....
- "
-"/ 'oops - wgroup change on realize' printNewline.
- windowGroup removeView:self.
- windowGroup := nil
- ].
- superGroup ~~ windowGroup ifTrue:[
- groupChange := true.
- windowGroup := superGroup.
- windowGroup notNil ifTrue:[
- windowGroup addView:self.
- ]
- ]
- ].
- ].
-
- hidden ifFalse:[
- (originChanged or:[extentChanged]) ifTrue:[self fixSize].
-
- (realized not or:[groupChange]) ifTrue:[
- subViews notNil ifTrue:[
- subViews do:[:subView |
- subView realize
- ]
- ].
- ].
- self setInnerClip.
-
- realized ifFalse:[
- "
- now, make the view visible
- "
- device mapWindow:drawableId.
- realized := true
- ]
- ].
-
- controller notNil ifTrue:[
- controller startUp
- ]
-!
-
-physicalCreate
- "common code for create & recreate"
-
- "associate colors to device"
-
- drawableId := device
- createWindowFor:self
- origin:(left @ top)
- extent:(width @ height)
- minExtent:nil
- maxExtent:nil
- borderWidth:borderWidth
- subViewOf:superView
- onTop:(self createOnTop)
- inputOnly:(self inputOnly)
- label:nil
- cursor:cursor
- icon:nil
- iconView:nil.
-
- Lobby changed:self.
- extentChanged := false.
- originChanged := false.
-
- (borderColor notNil and:[borderColor ~~ Black]) ifTrue:[
-"/ borderColor := borderColor on:device.
- self setBorderColor
- ].
- (viewGravity notNil "and:[viewGravity ~~ #NorthWest]") ifTrue:[
- device setWindowGravity:viewGravity in:drawableId
- ].
- (bitGravity notNil "and:[bitGravity ~~ #NorthWest]") ifTrue:[
- device setBitGravity:bitGravity in:drawableId
- ].
- borderShape notNil ifTrue:[
- device setWindowBorderShape:(borderShape id) in:drawableId
- ].
- viewShape notNil ifTrue:[
- device setWindowShape:(viewShape id) in:drawableId
- ].
- (backed notNil and:[backed ~~ false]) ifTrue:[
- device setBackingStore:backed in:drawableId
- ].
- saveUnder ifTrue:[
- device setSaveUnder:true in:drawableId
- ].
-!
-
-unrealize
- "hide me"
-
- realized ifTrue:[
- drawableId notNil ifTrue:[
- device unmapWindow:drawableId
- ].
- realized := shown := false.
- ]
-!
-
-realize
- "realize - make visible;
- realizing is done very late (after layout is fixed) to avoid
- visible rearranging of windows on the screen"
-
- self realizeLeavingGroup:false
-!
-
-create
- "create (i.e. tell X about me)
- this is kind of stupid - creation means XCreateWindow;
- realizing means XMapWindow"
-
- drawableId isNil ifTrue:[
- "
- make certain that superview is created also
- "
- superView notNil ifTrue:[
-"/ superView id isNil ifTrue:[
- superView create.
-"/ ].
-
-"/ "and put my controller into the superviews controller list"
-"/ controller notNil ifTrue:[
-"/ superView controller notNil ifTrue:[
-"/ controller manager:(superView controller manager)
-"/ ]
-"/ ]
- ].
-
- cursor := cursor on:device.
-
- self physicalCreate.
-
- viewBackground notNil ifTrue:[
- self setViewBackground
- ].
-
- self initializeMiddleButtonMenu.
- self initEvents.
-
- "
- this is the first create,
- force sizechange messages to be sent to the view
- "
- extentChanged := true.
- originChanged := true
- ]
-!
-
-open
- "open up the view - for normal views, this is a modeless open
- (i.e. the new view comes up as independent process).
- This is redefined in ModalBox, which comes up modal (i.e.
- control is under the current process, so that interaction with the
- current group is blocked while the modalBox is active)."
-
- ^ self openModeless
-!
-
-openModeless
- "create and schedule a new windowgroup for me and open the view.
- The view will be handled by its own process, effectively running in
- parallel."
-
- ProcessorScheduler isPureEventDriven ifFalse:[
- windowGroup isNil ifTrue:[
- windowGroup := WindowGroup new.
- windowGroup addTopView:self.
- ].
- windowGroup startup.
- ] ifTrue:[
- self realize
- ]
-!
-
-openModal
- "create a new windowgroup, but start processing in the current process
- actually suspending event processing for the currently active group.
- Stay in modalLoop while view is visible."
-
- self openModal:[true]
-!
-
-recreate
- "recreate (i.e. tell X about me) after a snapin"
-
- drawableId isNil ifTrue:[
- super recreate.
- self physicalCreate.
-
- viewBackground notNil ifTrue:[
- self setViewBackground
- ].
-
- "
- XXX has to be changed: eventmasks are device specific -
- XXX will not allow restart on another Workstation-type.
- XXX event masks must become symbolic
- "
- device setEventMask:eventMask in:drawableId
- ]
-!
-
-createWithAllSubViews
- "create, then create all subviews"
-
- drawableId isNil ifTrue:[self create].
- subViews notNil ifTrue:[
- subViews do:[:subView | subView createWithAllSubViews]
- ]
-!
-
destroy
"unrealize & destroy - make me invisible, destroy subviews then
make me unknown to the device"
- |subs|
-
- realized ifTrue:[
- self unrealize.
- "make it go away immediately
- - also, this hides the subview killing"
-"
- device synchronizeOutput.
-"
- ].
-
model notNil ifTrue:[
model removeDependent:self.
model := nil.
].
- controller notNil ifTrue:[
- controller release.
- controller := nil.
- ].
-
- subs := subViews.
- subs notNil ifTrue:[
- "stupid: destroy removes itself from the subview list
- - therefore we have to loop over a copy here"
-
- subViews := nil.
- subs do:[:aView |
- aView notNil ifTrue:[aView destroy]
- ]
- ].
- superView notNil ifTrue:[
- superView removeSubView:self.
- superView := nil
- ].
super destroy.
-
- windowGroup notNil ifTrue:[
- windowGroup removeView:self.
- windowGroup := nil
- ].
-!
-
-realizeInGroup
- "special realize - leave windowgroup as is;
- This allows a view to be realized in any windowgroup;
- for special applications, like the kill button in the Filebrowser which has
- another windowGroup as its superview and is handled as a separate process."
-
- self realizeLeavingGroup:true
-!
-
-openModal:aBlock
- "create a new windowgroup, but start processing in the current process -
- actually suspending event processing for the currently active group.
- Stay in this modal loop while aBlock evaluates to true AND the receiver is
- visible.
- This makes any interaction with the current window impossible -
- however, other views (in other windowgroups) still work."
-
- |activeGroup tops|
-
- Processor activeProcessIsSystemProcess ifTrue:[
- self realize
- ] ifFalse:[
- activeGroup := WindowGroup activeGroup.
-
- "
- create a new window group and put myself into it
- "
- windowGroup := WindowGroup new.
- windowGroup addTopView:self.
- "
- go dispatch events in this new group
- (thus current windowgroup is blocked from interaction)
- "
- Object abortSignal handle:[:ex |
- self hide.
- ex return.
- ] do:[
- [
- windowGroup startupModal:[realized and:aBlock]
- ] valueOnUnwindDo:[
- self hide.
- ]
- ].
- "
- return input focus to previously active groups top.
- This helps with windowmanagers which need an explicit click
- on the view for the focus.
- "
- activeGroup notNil ifTrue:[
- tops := activeGroup topViews.
- (tops notNil and:[tops notEmpty]) ifTrue:[
- tops first getKeyboardFocus
- ]
- ]
- ]
-!
-
-rerealizeWithAllSubViews
- "rerealize myself with all subviews"
-
- drawableId notNil ifTrue:[
- realized := true.
- subViews notNil ifTrue:[
- subViews do:[:aView |
- aView realize
- ]
- ].
- device mapView:self id:drawableId iconified:false
- atX:left y:top width:width height:height
- ]
-!
-
-rerealize
- "rerealize at old position"
-
- drawableId notNil ifTrue:[
- realized := true.
- device mapView:self id:drawableId iconified:false
- atX:left y:top width:width height:height
- ]
-!
-
-openAutonomous
- "create and schedule a new windowgroup for me and open the view.
- The view will be handled by its own process, effectively running in
- parallel. This entry is for non-topviews, which want to be served
- autonomous from the topview. (see the fileBrowsers kill-button
- when executing unix commands as an example)"
-
- |wg|
-
- ProcessorScheduler isPureEventDriven ifFalse:[
- wg := WindowGroup new.
- self windowGroup:wg.
- wg addView:self.
- wg startup.
- self realizeInGroup.
- ] ifTrue:[
- self realize
- ]
-! !
-
-!View methodsFor:'adding & removing components'!
-
-setParentViewIn:aView
- "common code for addSubView* methods"
-
- aView superView:self.
- (aView device ~~ device) ifTrue:[
- 'warning subview (' errorPrint. aView class name errorPrint.
- ') has different device than me (' errorPrint.
- self class name errorPrint. ').' errorPrintNewline.
- aView device:device
- ]
-!
-
-addSubView:newView
- "add a view to the collection of subviews"
-
- subViews isNil ifTrue:[
- subViews := OrderedCollection with:newView
- ] ifFalse:[
- subViews add:newView.
- ].
- self setParentViewIn:newView.
-!
-
-removeSubView:aView
- "remove a view from the collection of subviews"
-
- subViews notNil ifTrue:[
- subViews remove:aView ifAbsent:[nil].
- (subViews size == 0) ifTrue:[
- subViews := nil
- ]
- ]
-!
-
-addComponent:aComponent
- "components (i.e. gadgets or lightweight views) are being prepared.
- Dont use this right now"
-
- components isNil ifTrue:[
- components := OrderedCollection new
- ].
- components add:aComponent.
- aComponent setParentViewIn:self
-!
-
-component:aComponent
- "components (i.e. gadgets or lightweight views) are being prepared.
- Dont use this right now"
-
- components := OrderedCollection with:aComponent.
- aComponent setParentViewIn:self
-!
-
-removeComponent:aComponent
- "components (i.e. gadgets or lightweight views) are being prepared.
- Dont use this right now"
-
- components isNil ifTrue:[^self].
- components remove:aComponent ifAbsent:[].
- aComponent parent:nil
-!
-
-addSubView:newView after:aView
- "add a view to the collection of subviews after another view.
- This makes sense, in Panels and other layout views, to enter a new
- element at some defined place."
-
- subViews isNil ifTrue:[
- subViews := OrderedCollection with:newView
- ] ifFalse:[
- subViews add:newView after:aView.
- ].
- self setParentViewIn:newView.
-!
-
-addSubView:newView before:aView
- "add a view to the collection of subviews before another view.
- This makes sense, in Panels and other layout views, to enter a new
- element at some defined place."
-
- subViews isNil ifTrue:[
- subViews := OrderedCollection with:newView
- ] ifFalse:[
- subViews add:newView before:aView.
- ].
- self setParentViewIn:newView.
-!
-
-addSubView:aView in:bounds borderWidth:bw
- "for ST-80 compatibility"
-
- aView borderWidth:bw.
- aView origin:(bounds origin x asFloat) @ (bounds origin y asFloat)
- extent:(bounds extent x asFloat) @ (bounds extent y asFloat).
- self addSubView:aView
-!
-
-add:aView in:bounds
- "for ST-80 compatibility"
-
- aView origin:(bounds origin x asFloat) @ (bounds origin y asFloat)
- extent:(bounds extent x asFloat) @ (bounds extent y asFloat).
- self addSubView:aView
-!
-
-addSubView:aView viewport:aRectangle
- "Adds aView to the views list of subviews and uses the
- existing subviews window and the new viewport to position it"
-
- self addSubView:aView.
- aView viewport:aRectangle
-!
-
-addSubView:aView window:aWindowRectangle viewport:aViewportRectangle
- "Adds aView to the views list of subviews and uses
- aWindowRectangle and aViewportRectangle to position it"
-
- self addSubView:aView.
- aView window:aWindowRectangle.
- aView viewport:aViewportRectangle
-! !
-
-!View methodsFor:'queries'!
-
-canHandle:aKey
- "return true, if I like to handle the key (keyPress event)"
-
- ^ true
-!
-
-buttonMotionEventPending
- "return true, if a button motion event is pending.
- Normally, you dont want to use this, since no polling is needed
- (not even for mouse-tracking).
- Dont use it, since it does not honor the windowGroup, but
- goes directly to the device instead.
- Actually, its a historical leftover"
-
- windowGroup notNil ifTrue:[
- ^ windowGroup sensor hasButtonMotionEventsFor:self
- ].
- ^ super buttonMotionEventPending
-!
-
-preferedExtent
- "return my preferred extent - this is the minimum size I would like to have.
- The default here is the actual extent, the receiver currently has."
-
- ^ self extent
-! !
-
-!View methodsFor:'enumerating subviews'!
-
-allSubViewsDo:aBlock
- "evaluate aBlock for all subviews (recursively)"
-
- (subViews isNil or:[subViews isEmpty]) ifFalse:[
- subViews do:[:aSubview |
- aSubview withAllSubViewsDo:aBlock
- ]
- ]
-!
-
-withAllSubViewsDo:aBlock
- "evaluate aBlock for the receiver and all subviews (recursively)"
-
- aBlock value:self.
- self allSubViewsDo:aBlock
! !
-
-!View methodsFor:'scrolling-basic'!
-
-scrollUp:nPixels
- "change origin to scroll up (towards the origin) by some pixels"
-
- |count "{ Class:SmallInteger }"
- m2 "{ Class:SmallInteger }"
- w "{ Class:SmallInteger }"
- h "{ Class:SmallInteger }"
- orgX
- orgY "{ Class:SmallInteger }"
- newOrigin|
-
- transformation isNil ifTrue:[
- orgY := orgX := 0
- ] ifFalse:[
- orgY := transformation translation y negated.
- orgX := transformation translation x negated
- ].
-
- count := nPixels.
- (count > orgY) ifTrue:[
- count := orgY
- ].
- (count <= 0) ifTrue:[^ self].
-
- self originWillChange.
- newOrigin := orgX @ (orgY - count).
-
- shown ifFalse:[
- self setViewOrigin:newOrigin.
- ] ifTrue:[
- m2 := margin * 2. "top & bottom margins"
- (count >= self innerHeight) ifTrue:[
- self setViewOrigin:newOrigin.
- self redrawDeviceX:margin y:margin
- width:(width - m2)
- height:(height - m2).
- ] ifFalse:[
- h := height - m2 - count.
- w := width.
- self catchExpose.
- self setViewOrigin:newOrigin.
- self copyFrom:self x:margin y:margin
- toX:margin y:(count + margin)
- width:w height:h.
-
- self setInnerClip.
- self redrawDeviceX:margin y:margin
- width:(width - m2)
- height:count.
-
- self waitForExpose.
- ]
- ].
- self originChanged:(0 @ count negated).
-!
-
-scrollDown:nPixels
- "change origin to scroll down some pixels"
-
- |count "{ Class:SmallInteger }"
- m2 "{ Class:SmallInteger }"
- w "{ Class:SmallInteger }"
- h "{ Class:SmallInteger }"
- hCont
- ih "{ Class:SmallInteger }"
- orgX
- orgY "{ Class:SmallInteger }"
- newOrigin|
-
- hCont := self heightOfContents.
- transformation isNil ifTrue:[
- orgY := orgX := 0
- ] ifFalse:[
- hCont := (transformation applyScaleY:hCont) rounded.
- orgY := transformation translation y negated.
- orgX := transformation translation x negated.
- ].
-
- count := nPixels.
- ih := self innerHeight.
-
- ((orgY + nPixels + ih) > hCont) ifTrue:[
- count := hCont - orgY - ih
- ].
- (count <= 0) ifTrue:[^ self].
-
- self originWillChange.
- newOrigin := orgX @ (orgY + count).
- shown ifFalse:[
- self setViewOrigin:newOrigin.
- ] ifTrue:[
- m2 := margin * 2.
- (count >= ih) ifTrue:[
- self setViewOrigin:newOrigin.
- self redrawDeviceX:margin y:margin
- width:(width - m2)
- height:(height - m2).
- ] ifFalse:[
- h := height - m2 - count.
- w := self width.
- self catchExpose.
- self setViewOrigin:newOrigin.
- self copyFrom:self x:margin y:(count + margin)
- toX:margin y:margin
- width:w
- height:h.
-
- self setInnerClip.
- self redrawDeviceX:margin y:(h + margin)
- width:(width - m2) height:count.
-
- self waitForExpose.
- ]
- ].
- self originChanged:(0 @ count).
-!
-
-scrollLeft:nPixels
- "change origin to scroll left some pixels"
-
- |count "{ Class:SmallInteger }"
- m2 "{ Class:SmallInteger }"
- h "{ Class:SmallInteger }"
- orgX orgY newOrigin|
-
- transformation isNil ifTrue:[
- orgY := orgX := 0
- ] ifFalse:[
- orgY := transformation translation y negated.
- orgX := transformation translation x negated.
- ].
-
- count := nPixels.
- (count > orgX) ifTrue:[
- count := orgX
- ].
- (count <= 0) ifTrue:[^ self].
-
- self originWillChange.
- newOrigin := (orgX - count) @ orgY.
-
- shown ifFalse:[
- self setViewOrigin:newOrigin.
- ] ifTrue:[
- m2 := margin * 2.
- (count >= self innerWidth) ifTrue:[
- self setViewOrigin:newOrigin.
- self redrawDeviceX:margin y:margin
- width:(width - m2)
- height:(height - m2).
- ] ifFalse:[
- h := (height - m2).
-
- self catchExpose.
- self setViewOrigin:newOrigin.
- self copyFrom:self x:margin y:margin
- toX:(count + margin) y:margin
- width:(width - m2 - count)
- height:h.
-
- self setInnerClip.
- self redrawDeviceX:margin y:margin
- width:count height:(height - m2).
-
- self waitForExpose.
- ]
- ].
- self originChanged:(count negated @ 0).
-!
-
-scrollRight:nPixels
- "change origin to scroll right some pixels"
-
- |count "{ Class:SmallInteger }"
- m2 "{ Class:SmallInteger }"
- h "{ Class:SmallInteger }"
- wCont
- iw "{ Class:SmallInteger }"
- orgX orgY newOrigin|
-
- wCont := self widthOfContents.
- transformation isNil ifTrue:[
- orgY := orgX := 0
- ] ifFalse:[
- wCont := (transformation applyScaleX:wCont) rounded.
- orgY := transformation translation y negated.
- orgX := transformation translation x negated.
- ].
-
- count := nPixels.
- iw := self innerWidth.
-
- ((orgX + nPixels + iw) > wCont) ifTrue:[
- count := wCont - orgX - iw
- ].
- (count <= 0) ifTrue:[^ self].
-
- self originWillChange.
- newOrigin := (orgX + count) @ orgY.
-
- shown ifFalse:[
- self setViewOrigin:newOrigin.
- ] ifTrue:[
- m2 := margin * 2.
- (count >= iw) ifTrue:[
- self setViewOrigin:newOrigin.
- self redrawDeviceX:margin y:margin
- width:(width - m2)
- height:(height - m2).
- ] ifFalse:[
- m2 := margin * 2.
- h := (height - m2).
-
- self catchExpose.
- self setViewOrigin:newOrigin.
- self copyFrom:self x:(count + margin) y:margin
- toX:margin y:margin
- width:(width - m2 - count)
- height:h.
-
- self setInnerClip.
- self redrawDeviceX:(width - margin - count) y:margin
- width:count height:(height - m2).
-
- self waitForExpose.
- ].
- ].
- self originChanged:(count @ 0).
-! !
-
-!View methodsFor:'scrolling'!
-
-widthForScrollBetween:yStart and:yEnd
- "return the width in pixels for a scroll between yStart and yEnd
- - return full width here since we do not know how wide contents is.
- Views which only use part of their space (short lists, text) may redefine
- this method and return the number of pixels that have to be scrolled.
- On slow displays, this may make a difference; on fast ones you will probably
- not notice any difference."
-
- ^ (width - margin - margin)
-!
-
-verticalScrollStep
- "return the amount to scroll when stepping up/down.
- Subclasses may want to redefine this."
-
- ^ (device verticalPixelPerMillimeter * 20) asInteger
-!
-
-scrollVerticalToPercent:percent
- "scroll to a position given in percent of total"
-
- |hCont|
-
- hCont := self heightOfContents.
- transformation notNil ifTrue:[
- hCont := transformation applyScaleY:hCont.
- ].
- self scrollVerticalTo:
- ((((hCont * percent) / 100.0) + 0.5) asInteger)
-!
-
-scrollVerticalTo:aPixelOffset
- "change origin to make aPixelOffset be the top line"
-
- |orgY|
-
- orgY := self viewOrigin y.
-
- (aPixelOffset < orgY) ifTrue:[
- self scrollUp:(orgY - aPixelOffset)
- ] ifFalse:[
- (aPixelOffset > orgY) ifTrue:[
- self scrollDown:(aPixelOffset - orgY)
- ]
- ]
-!
-
-horizontalScrollStep
- "return the amount to scroll when stepping left/right.
- Subclasses may want to redefine this."
-
- ^ (device horizontalPixelPerMillimeter * 20) asInteger
-!
-
-scrollHorizontalToPercent:percent
- "scroll to a position given in percent of total"
-
- |wCont|
-
- wCont := self widthOfContents.
- transformation notNil ifTrue:[
- wCont := transformation applyScaleX:wCont.
- ].
- self scrollHorizontalTo:
- ((((wCont * percent) / 100.0) + 0.5) asInteger)
-!
-
-scrollHorizontalTo:aPixelOffset
- "change origin to make aPixelOffset be the left col"
-
- |orgX|
-
- orgX := self viewOrigin x.
-
- (aPixelOffset < orgX) ifTrue:[
- self scrollLeft:(orgX - aPixelOffset)
- ] ifFalse:[
- (aPixelOffset > orgX) ifTrue:[
- self scrollRight:(aPixelOffset - orgX)
- ]
- ]
-!
-
-scrollTo:aPixelOffset
- "only here for historic reasons - will vanish soon"
-
- ^ self scrollVerticalTo:aPixelOffset
-!
-
-scrollToTop
- "move viewOrigin to top"
-
- self scrollVerticalTo:0
-!
-
-scrollToTopLeft
- "move viewOrigin to top/left"
-
- self scrollVerticalTo:0.
- self scrollHorizontalTo:0
-!
-
-scrollUp
- "scroll up by some amount; this is called when the scrollbars
- scroll-step up button is pressed."
-
- self scrollUp:(self verticalScrollStep)
-!
-
-scrollDown
- "scroll down by some amount; this is called when the scrollbars
- scroll-step down button is pressed."
-
- self scrollDown:(self verticalScrollStep)
-!
-
-scrollLeft
- "scroll left by some amount; this is called when the scrollbars
- scroll-step left button is pressed."
-
- self scrollLeft:(self horizontalScrollStep)
-!
-
-scrollRight
- "scroll right by some amount; this is called when the scrollbars
- scroll-step right button is pressed."
-
- self scrollRight:(self horizontalScrollStep)
-! !
-
-!View methodsFor:'user notification'!
-
-warn:aString
- "like Objects warn, but translates the string via the
- resourcePack, thus giving a translated string automatically"
-
- super warn:(resources string:aString)
-!
-
-warn:aString with:argument
- "like Objects warn, but translates the string via the
- resourcePack, thus giving a translated string automatically"
-
- super warn:(resources string:aString with:argument)
-! !
-
-!View methodsFor:'cursor animation'!
-
-showBusyWhile:aBlock
- "evaluate some time consuming block, while doing this,
- show a spinning wheel cursor"
-
- |ok bitmaps cursors mask process oldCursor|
-
- oldCursor := cursor.
-
- ok := true.
- bitmaps := #('wheel1' 'wheel2' 'wheel3' 'wheel4')
- collect:[:name |
- |f|
-
- f := Form fromFile:(name , '.xbm').
- f isNil ifTrue:[
- ('no bitmap file: ' , name , '.xbm') errorPrintNL.
- ok := false
- ].
- f
- ].
-
- mask := Form fromFile:'wheelm.xbm'.
- mask isNil ifTrue:[
- ('no bitmap file: ' , mask , '.xbm') errorPrintNL.
- ok := false
- ].
-
- ok ifFalse:[
- self cursor:Cursor wait.
- aBlock valueNowOrOnUnwindDo:[
- self cursor:oldCursor
- ]
- ] ifTrue:[
- cursors := bitmaps collect:[:form | (Cursor sourceForm:form
- maskForm:mask
- hotX:8
- hotY:8) on:device].
-
- process := [
- (Delay forSeconds:0.25) wait.
- [true] whileTrue:[
- cursors do:[:curs |
- self cursor:curs.
- (Delay forSeconds:0.05) wait
- ]
- ]
- ] fork.
-
- Processor activeProcess priority:7.
- aBlock valueNowOrOnUnwindDo:[
- Processor activeProcess priority:8.
- process terminate.
- self cursor:oldCursor
- ]
- ].
-
- "
- View new realize showBusyWhile:[10 timesRepeat:[3000 factorial]]
- "
-! !
-
-View initialize!