--- a/HScrBar.st Thu Nov 17 15:34:12 1994 +0100
+++ b/HScrBar.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Attic/HScrBar.st,v 1.8 1994-10-28 03:25:04 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/HScrBar.st,v 1.9 1994-11-17 14:38:02 claus Exp $
'!
!HorizontalScrollBar class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Attic/HScrBar.st,v 1.8 1994-10-28 03:25:04 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/HScrBar.st,v 1.9 1994-11-17 14:38:02 claus Exp $
"
!
@@ -60,9 +60,7 @@
"private: create my elements"
button1 := ArrowButton leftIn:self.
- button1 name:'LeftButton'.
button2 := ArrowButton rightIn:self.
- button2 name:'RightButton'.
thumb := HorizontalScroller in:self.
!
@@ -238,7 +236,9 @@
thumbHeight := thumbHeight - (thumb borderWidth * 2).
thumbWidth := thumbWidth - 1
].
-
+ style == #motif ifTrue:[
+ thumbWidth := thumbWidth - margin
+ ].
"
a kludge: views with width or height of 0 are illegal
@@ -271,6 +271,9 @@
].
"button around thumb"
+style == #motif ifTrue:[
+ sep2 := sep2 + 1
+].
button1 origin:(bwn @ bwn).
button2 origin:((leftWidth + thumbWidth + sep2 - (margin // 2)) @ bwn).
thumb extent:((thumbWidth + margin - (margin // 2)) @ thumbHeight).
--- a/HVScrView.st Thu Nov 17 15:34:12 1994 +0100
+++ b/HVScrView.st Thu Nov 17 15:38:53 1994 +0100
@@ -22,11 +22,31 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Attic/HVScrView.st,v 1.7 1994-10-10 03:01:48 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/HVScrView.st,v 1.8 1994-11-17 14:38:05 claus Exp $
written jan 91 by claus
'!
-!HVScrollableView methodsFor:'documentation'!
+!HVScrollableView class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+!
+
+version
+"
+$Header: /cvs/stx/stx/libwidg/Attic/HVScrView.st,v 1.8 1994-11-17 14:38:05 claus Exp $
+"
+!
documentation
"
@@ -132,8 +152,7 @@
]
].
self setScrollActions
- ].
- self viewGravity:#south
+ ]
!
realize
--- a/HVScrollableView.st Thu Nov 17 15:34:12 1994 +0100
+++ b/HVScrollableView.st Thu Nov 17 15:38:53 1994 +0100
@@ -22,11 +22,31 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/HVScrollableView.st,v 1.7 1994-10-10 03:01:48 claus Exp $
+$Header: /cvs/stx/stx/libwidg/HVScrollableView.st,v 1.8 1994-11-17 14:38:05 claus Exp $
written jan 91 by claus
'!
-!HVScrollableView methodsFor:'documentation'!
+!HVScrollableView class methodsFor:'documentation'!
+
+copyright
+"
+ COPYRIGHT (c) 1991 by Claus Gittinger
+ All Rights Reserved
+
+ This software is furnished under a license and may be used
+ only in accordance with the terms of that license and with the
+ inclusion of the above copyright notice. This software may not
+ be provided or otherwise made available to, or used by, any
+ other person. No title to or ownership of the software is
+ hereby transferred.
+"
+!
+
+version
+"
+$Header: /cvs/stx/stx/libwidg/HVScrollableView.st,v 1.8 1994-11-17 14:38:05 claus Exp $
+"
+!
documentation
"
@@ -132,8 +152,7 @@
]
].
self setScrollActions
- ].
- self viewGravity:#south
+ ]
!
realize
--- a/HorizontalScrollBar.st Thu Nov 17 15:34:12 1994 +0100
+++ b/HorizontalScrollBar.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/HorizontalScrollBar.st,v 1.8 1994-10-28 03:25:04 claus Exp $
+$Header: /cvs/stx/stx/libwidg/HorizontalScrollBar.st,v 1.9 1994-11-17 14:38:02 claus Exp $
'!
!HorizontalScrollBar class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/HorizontalScrollBar.st,v 1.8 1994-10-28 03:25:04 claus Exp $
+$Header: /cvs/stx/stx/libwidg/HorizontalScrollBar.st,v 1.9 1994-11-17 14:38:02 claus Exp $
"
!
@@ -60,9 +60,7 @@
"private: create my elements"
button1 := ArrowButton leftIn:self.
- button1 name:'LeftButton'.
button2 := ArrowButton rightIn:self.
- button2 name:'RightButton'.
thumb := HorizontalScroller in:self.
!
@@ -238,7 +236,9 @@
thumbHeight := thumbHeight - (thumb borderWidth * 2).
thumbWidth := thumbWidth - 1
].
-
+ style == #motif ifTrue:[
+ thumbWidth := thumbWidth - margin
+ ].
"
a kludge: views with width or height of 0 are illegal
@@ -271,6 +271,9 @@
].
"button around thumb"
+style == #motif ifTrue:[
+ sep2 := sep2 + 1
+].
button1 origin:(bwn @ bwn).
button2 origin:((leftWidth + thumbWidth + sep2 - (margin // 2)) @ bwn).
thumb extent:((thumbWidth + margin - (margin // 2)) @ thumbHeight).
--- a/InfoBox.st Thu Nov 17 15:34:12 1994 +0100
+++ b/InfoBox.st Thu Nov 17 15:38:53 1994 +0100
@@ -23,7 +23,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/InfoBox.st,v 1.8 1994-10-28 03:25:02 claus Exp $
+$Header: /cvs/stx/stx/libwidg/InfoBox.st,v 1.9 1994-11-17 14:38:06 claus Exp $
written Spring/Summer 89 by claus
'!
@@ -76,8 +76,11 @@
aBox form:aForm
(the name 'form:' is historical - any bitmap or image is allowed).
+"
+!
-
+examples
+"
Examples:
|aBox|
@@ -309,7 +312,7 @@
]
! !
-!InfoBox methodsFor:'private'!
+!InfoBox methodsFor:'queries'!
preferedExtent
"return my prefered extent"
@@ -333,14 +336,6 @@
extra := 0 "margin * 2".
^ (w + extra) @ (h + extra)
-!
-
-resize
- "resize myself to make everything fit into myself.
- This method should be called after every change in
- the title, form-field or button(s)."
-
- super extent:(self preferedExtent)
! !
!InfoBox methodsFor:'user interaction'!
--- a/Label.st Thu Nov 17 15:34:12 1994 +0100
+++ b/Label.st Thu Nov 17 15:38:53 1994 +0100
@@ -26,7 +26,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Label.st,v 1.10 1994-10-28 03:25:05 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Label.st,v 1.11 1994-11-17 14:38:08 claus Exp $
'!
!Label class methodsFor:'documentation'!
@@ -47,7 +47,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Label.st,v 1.10 1994-10-28 03:25:05 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Label.st,v 1.11 1994-11-17 14:38:08 claus Exp $
"
!
@@ -56,27 +56,30 @@
This class implements labels, which are views to display a string or image.
The Label will try to do its best to make its contents fit into the
view. The contents can be a String, a collection of Strings (i.e.
- Text) or a Form/Image. The contents is drawn in fgColor/bgColor,
- which can be changed using:
+ Text) or a Form/Image.
+
+ The contents is drawn in fgColor/bgColor, which can be changed using:
+
aLabel foregroundColor:aColor
aLabel backgroundColor:aColor
When a label is assigned a contents, it will resize itself to fit
the required size. This resizing can be suppressed by setting the
fixsize attribute to true using:
+
aLabel sizeFixed:true
This can be used, if resizing of the label is not wanted.
+ However, in this case you have to make certain that the size is big enough
+ to hold changed logos later.
The placement of the contents within the label is controlled by
- the adjust attribute, it can be set with
+ the adjust attribute, it can be set with:
+
aLabel adjust:how
- , where how is one of the symbols left, #right, #center, #centerLeft or
- #centerRight (see the comment in Label>>adjust:).
- example:
- l := Label in:aView.
- l label:'hello world'.
+ where how is one of the symbols left, #right, #center, #centerLeft or
+ #centerRight (see the comment in Label>>adjust:). The default is #center.
Instance variables:
@@ -105,6 +108,182 @@
model sends #changed:aspectSymbol
---> label will redraw its label from value of model>>aspectSymbol
"
+!
+
+examples
+"
+ Notice, that Buttons and others inherit from Label;
+ therefore, the following geometry examples apply to all subclasses too.
+
+
+ simple:
+ |top l|
+
+ top := StandardSystemView new.
+ top extent:(200 @ 200).
+
+ l := Label in:top.
+ l label:'hello world'.
+
+ top open
+
+ placement:
+ |top l|
+
+ top := StandardSystemView new.
+ top extent:(200 @ 200).
+
+ l := Label in:top.
+ l label:'hello world'.
+ l origin:50@100.
+
+ top open
+
+ level:
+ |top l|
+
+ top := StandardSystemView new.
+ top extent:(200 @ 200).
+
+ l := Label in:top.
+ l level:5.
+ l label:'hello world'.
+ l origin:50@100.
+
+ top open
+
+ another level:
+ |top l|
+
+ top := StandardSystemView new.
+ top extent:(200 @ 200).
+
+ l := Label in:top.
+ l level:-1.
+ l label:'hello world'.
+ l origin:50@100.
+
+ top open
+
+ border & colors:
+ |top l|
+
+ top := StandardSystemView new.
+ top extent:(200 @ 200).
+
+ l := Label in:top.
+ l level:0.
+ l borderWidth:1.
+ l borderColor:Color red.
+ l foregroundColor:Color green darkened.
+ l backgroundColor:Color green lightened.
+ l label:'hello world'.
+ l origin:50@100.
+
+ top open
+
+ adjust (resize to see):
+ |top l|
+
+ top := StandardSystemView new.
+ top extent:(200 @ 200).
+
+ l := Label in:top.
+ l borderWidth:1.
+ l label:'default - centered'.
+ l origin:0.0@70.
+ l width:1.0.
+
+ l := Label in:top.
+ l borderWidth:1.
+ l adjust:#left.
+ l label:'left adjust'.
+ l origin:0.0@100.
+ l width:1.0.
+
+ l := Label in:top.
+ l borderWidth:1.
+ l adjust:#right.
+ l label:'right adjust'.
+ l origin:0.0@130.
+ l width:1.0.
+
+ top open
+
+ just a reminder, that instead of doing placement manually
+ as in:
+ |top l|
+
+ top := StandardSystemView new.
+ top extent:(200 @ 200).
+
+ l := Label in:top.
+ l borderWidth:1.
+ l label:'default - centered'.
+ l origin:0.1@70.
+ l width:0.8.
+
+ l := Label in:top.
+ l borderWidth:1.
+ l adjust:#left.
+ l label:'left adjust'.
+ l origin:0.1@100.
+ l width:0.8.
+
+ l := Label in:top.
+ l borderWidth:1.
+ l adjust:#right.
+ l label:'right adjust'.
+ l origin:0.1@130.
+ l width:0.8.
+
+ top open
+
+ it is much easier, to use a geometry handler, such as
+ a VerticalPanel. Try:
+ |top panel l|
+
+ top := StandardSystemView new.
+ top extent:(200 @ 200).
+
+ panel := VerticalPanelView
+ origin:0.0 @ 0.0
+ corner:1.0 @ 1.0
+ in:top.
+
+ panel horizontalLayout:#fit.
+ panel verticalLayout:#center.
+
+ l := Label in:panel.
+ l borderWidth:1.
+ l label:'default - centered'.
+
+ l := Label in:panel.
+ l borderWidth:1.
+ l adjust:#left.
+ l label:'left adjust'.
+
+ l := Label in:panel.
+ l borderWidth:1.
+ l adjust:#right.
+ l label:'right adjust'.
+
+ top open
+
+ labels with bitmaps or images:
+
+ |top l|
+
+ top := StandardSystemView new.
+ top extent:(200 @ 200).
+
+ l := Label in:top.
+ l level:-1.
+ l form:((Image fromFile:'bitmaps/garfield.gif') magnifyBy:0.2 @ 0.2).
+ l origin:50@100.
+
+ top open
+"
! !
!Label class methodsFor:'defaults'!
@@ -408,12 +587,20 @@
labelHeight isNil ifTrue:[^ self].
- " always center vertically "
- (labelHeight < height) ifTrue:[
- y := (height - labelHeight) // 2
- ] ifFalse:[
- y := 0
- ].
+ "if it does not fit, should we make the origin visible,
+ or the center (for text, the center seems better. For images,
+ I dont really know ehich is better ...
+ The commented code below makes the origin visible
+ "
+"/ (labelHeight < height) ifTrue:[
+"/ y := (height - labelHeight) // 2
+"/ ] ifFalse:[
+"/ y := 0
+"/ ].
+
+ "always center vertically"
+ y := (height - labelHeight) // 2.
+
labelOriginY := y.
(((adjust == #center)
--- a/ListView.st Thu Nov 17 15:34:12 1994 +0100
+++ b/ListView.st Thu Nov 17 15:38:53 1994 +0100
@@ -36,7 +36,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/ListView.st,v 1.11 1994-10-28 03:25:07 claus Exp $
+$Header: /cvs/stx/stx/libwidg/ListView.st,v 1.12 1994-11-17 14:38:09 claus Exp $
'!
!ListView class methodsFor:'documentation'!
@@ -57,7 +57,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/ListView.st,v 1.11 1994-10-28 03:25:07 claus Exp $
+$Header: /cvs/stx/stx/libwidg/ListView.st,v 1.12 1994-11-17 14:38:09 claus Exp $
"
!
@@ -273,6 +273,8 @@
This can be used to update a self-changing list
(for example: a file list being shown, without disturbing user too much)"
+ |oldFirst|
+
(aCollection isNil and:[list isNil]) ifTrue:[
"no change"
^ self
@@ -287,6 +289,16 @@
]
].
self contentsChanged.
+
+"/ new - reposition if too big
+ (firstLineShown + nFullLinesShown) > list size ifTrue:[
+ oldFirst := firstLineShown.
+ firstLineShown := list size - nFullLinesShown + 1.
+ firstLineShown < 1 ifTrue:[firstLineShown := 1].
+ self originChanged:(oldFirst - 1) negated.
+ self clear.
+ ].
+"/ end new
shown ifTrue:[
self redrawFromVisibleLine:1 to:nLinesShown
]
@@ -402,12 +414,12 @@
!
removeIndexWithoutRedraw:lineNr
- "delete line - no redraw;
- return true, if something was really deleted"
+ "delete a line, given its lineNr - no redraw;
+ return true, if something was really deleted (so sender knows,
+ if a redraw is needed)"
(list isNil or:[lineNr > list size]) ifTrue:[^ false].
list removeIndex:lineNr.
- (attributes notNil and:[lineNr <= attributes size]) ifTrue:[attributes removeIndex:lineNr].
lineNr < firstLineShown ifTrue:[
firstLineShown := firstLineShown - 1
@@ -417,7 +429,7 @@
!
removeIndex:lineNr
- "delete line"
+ "delete line, update view"
|visLine w
srcY "{ Class: SmallInteger }" |
@@ -435,6 +447,9 @@
toX:textStartLeft y:(srcY - fontHeight)
width:w height:((nLinesShown - visLine) * fontHeight).
self redrawVisibleLine:nFullLinesShown.
+ "
+ redraw last partial line - if any
+ "
(nFullLinesShown ~~ nLinesShown) ifTrue:[
self redrawVisibleLine:nLinesShown
].
@@ -443,7 +458,8 @@
!
font:aFont
- "set the font"
+ "set the font for all shown text.
+ Redraws everything."
aFont isNil ifTrue:[
^ self error:'nil font'
@@ -984,22 +1000,6 @@
^ ((y - textStartTop) // fontHeight) + 1
!
-visibleAttributeAt:visibleLineNr
- "return the attributes of what is visible at line (numbers start at 1)"
-
- |listLineNr listsize|
-
- listLineNr := visibleLineNr + firstLineShown - 1.
- (listLineNr == 0) ifTrue:[^ nil].
- (attributes notNil) ifTrue:[
- listsize := attributes size
- ] ifFalse:[
- listsize := 0
- ].
- (listLineNr <= listsize) ifTrue:[^ attributes at:listLineNr].
- ^ nil
-!
-
visibleAt:visibleLineNr
"return what is visible at line (numbers start at 1)"
@@ -1205,13 +1205,7 @@
!ListView methodsFor:'searching'!
-setSearchPattern:aString
- "set the searchpattern"
-
- searchPattern := aString withoutSeparators
-!
-
-searchForwardFor:pattern startingAtLine:startLine col:startCol ifFound:block1 else:block2
+searchForwardFor:pattern startingAtLine:startLine col:startCol ifFound:block1 ifAbsent:block2
"search for a pattern, if found evaluate block1 with row/col as arguments, if not
found evaluate block2.
Sorry, but pattern is no regular expression pattern (yet)"
@@ -1224,7 +1218,7 @@
(list notNil and:[patternSize ~~ 0]) ifTrue:[
savedCursor := cursor.
self cursor:(Cursor questionMark).
- searchPattern := pattern.
+"/ searchPattern := pattern.
col := startCol + 1.
line1 := startLine.
line2 := list size.
@@ -1246,7 +1240,7 @@
^ block2 value
!
-searchBackwardFor:pattern startingAtLine:startLine col:startCol ifFound:block1 else:block2
+searchBackwardFor:pattern startingAtLine:startLine col:startCol ifFound:block1 ifAbsent:block2
"search for a pattern, if found evaluate block1 with row/col as arguments, if not
found evaluate block2.
Sorry, but pattern is no regular expression pattern (yet)"
@@ -1258,7 +1252,7 @@
(list notNil and:[patternSize ~~ 0]) ifTrue:[
savedCursor := cursor.
self cursor:(Cursor questionMark).
- searchPattern := pattern.
+"/ searchPattern := pattern.
col := startCol - 1.
firstChar := pattern at:1.
col > (list at:startLine) size ifTrue:[
@@ -1504,7 +1498,7 @@
h "{ Class:SmallInteger }"
m2 "{ Class:SmallInteger }"
count "{ Class:SmallInteger }"
- prevFirst|
+ prevFirst nPixel|
count := nLines.
(firstLineShown + nLines + nFullLinesShown > list size) ifTrue:[
@@ -1515,11 +1509,13 @@
self originWillChange.
prevFirst := firstLineShown.
firstLineShown := firstLineShown + count.
+ nPixel := fontHeight * count.
+
shown ifFalse:[
- viewOrigin := viewOrigin x @ (viewOrigin y + (fontHeight * count)).
+ viewOrigin := viewOrigin x @ (viewOrigin y + nPixel).
] ifTrue:[
(count >= nLinesShown) ifTrue:[
- viewOrigin := viewOrigin x @ (viewOrigin y + (fontHeight * count)).
+ viewOrigin := viewOrigin x @ (viewOrigin y + nPixel).
self redrawFromVisibleLine:1 to:nLinesShown.
] ifFalse:[
m2 := margin * 2.
@@ -1527,13 +1523,13 @@
and:(prevFirst + nLinesShown).
w := w + leftMargin.
- h := (fontHeight * count) + textStartTop.
+ h := nPixel + textStartTop.
self catchExpose.
self copyFrom:self x:margin y:h
toX:margin y:textStartTop
width:w height:(height - m2 - h).
- viewOrigin := viewOrigin x @ (viewOrigin y + (fontHeight * count)).
+ viewOrigin := viewOrigin x @ (viewOrigin y + nPixel).
self redrawFromVisibleLine:(nFullLinesShown - count + 1)
to:nLinesShown.
self waitForExpose.
@@ -1554,7 +1550,7 @@
|w "{ Class:SmallInteger }"
h "{ Class:SmallInteger }"
count "{ Class:SmallInteger }"
- prevFirst|
+ prevFirst nPixel|
count := nLines.
count >= firstLineShown ifTrue:[
@@ -1565,22 +1561,23 @@
self originWillChange.
prevFirst := firstLineShown.
firstLineShown := firstLineShown - count.
+ nPixel := fontHeight * count.
shown ifFalse:[
- viewOrigin := viewOrigin x @ (viewOrigin y - (fontHeight * count)).
+ viewOrigin := viewOrigin x @ (viewOrigin y - nPixel).
] ifTrue:[
(count >= nLinesShown) ifTrue:[
- viewOrigin := viewOrigin x @ (viewOrigin y - (fontHeight * count)).
+ viewOrigin := viewOrigin x @ (viewOrigin y - nPixel).
self redrawFromVisibleLine:1 to:nLinesShown.
] ifFalse:[
w := self widthForScrollBetween:prevFirst
and:(prevFirst + nLinesShown).
w := w + leftMargin.
- h := (fontHeight * count) + topMargin.
+ h := nPixel + topMargin.
self catchExpose.
self copyFrom:self x:margin y:topMargin
toX:margin y:h
width:w height:(height - h - margin).
- viewOrigin := viewOrigin x @ (viewOrigin y - (fontHeight * count)).
+ viewOrigin := viewOrigin x @ (viewOrigin y - nPixel).
self redrawFromVisibleLine:1 to:count.
self waitForExpose.
].
@@ -2163,6 +2160,7 @@
|listSize newOrigin|
self computeNumberOfLinesShown.
+
innerWidth := width - textStartLeft - margin.
shown ifTrue:[
list notNil ifTrue:[
--- a/MenuView.st Thu Nov 17 15:34:12 1994 +0100
+++ b/MenuView.st Thu Nov 17 15:38:53 1994 +0100
@@ -32,7 +32,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/MenuView.st,v 1.11 1994-10-28 03:25:11 claus Exp $
+$Header: /cvs/stx/stx/libwidg/MenuView.st,v 1.12 1994-11-17 14:38:13 claus Exp $
'!
!MenuView class methodsFor:'documentation'!
@@ -53,13 +53,14 @@
version
"
-$Header: /cvs/stx/stx/libwidg/MenuView.st,v 1.11 1994-10-28 03:25:11 claus Exp $
+$Header: /cvs/stx/stx/libwidg/MenuView.st,v 1.12 1994-11-17 14:38:13 claus Exp $
"
!
documentation
"
- a menu view used for both pull-down-menus and pop-up-menus
+ a menu view used for both pull-down-menus and pop-up-menus (and also,
+ for nonModal menus, such as the Launchers click-menu).
the action to be performed can be defined either as:
1) action:aBlockWithOneArg
@@ -72,9 +73,17 @@
It is also possible to define both actionBlock and selectorArray.
+ The wellknown popups are created by wrapping a MenuView into an instance of
+ PopUpMenu (read the description of popupmenu).
+
menu entries starting with '\c' are check-entries.
menu entries conisting of '-' alone, are separating lines.
+ menu entries conisting of '=' alone, are double separating lines.
+"
+!
+examples
+"
Examples:
Notice: normally, menuviews are wrapped into either a popup-
menu or pulldown-menu. But they can also be used stand-alone
@@ -833,8 +842,10 @@
"
realize the submenu in MY windowgroup
"
- subMenuShown windowGroup:windowGroup.
- subMenuShown windowGroup addTopView:subMenuShown.
+ windowGroup notNil ifTrue:[
+ subMenuShown windowGroup:windowGroup.
+ windowGroup addTopView:subMenuShown.
+ ].
subMenuShown fixSize.
subMenuShown origin:org.
subMenuShown makeFullyVisible.
@@ -861,7 +872,7 @@
!MenuView methodsFor:'redrawing'!
drawMarkInVisibleLine:visLineNr with:fg and:bg
- "draw an on-mark"
+ "draw an on-mark (or the space for it)"
|w h y x l check|
@@ -882,6 +893,7 @@
self paint:bg.
self fillRectangleX:x y:y width:w height:fontHeight.
self paint:fg.
+
check ifTrue:[
self paint:checkColor.
self displayLineFromX:x
@@ -897,21 +909,20 @@
!
drawVisibleLine:visLineNr with:fg and:bg
- |line isSpecial special|
+ |line isSpecial|
line := self visibleAt:visLineNr.
- isSpecial := false.
-
- ((line at:1) == $\) ifTrue:[
- special := line at:2.
- (special == $c) ifTrue:[
- isSpecial := true
- ]
- ].
+ isSpecial := line includes:$\.
isSpecial ifFalse:[
+ "
+ a normal entry
+ "
super drawVisibleLine:visLineNr with:fg and:bg
] ifTrue:[
+ "
+ some speciality in this line (check-mark)
+ "
super drawVisibleLine:visLineNr "from:3" with:fg and:bg.
self drawMarkInVisibleLine:visLineNr with:fg and:bg
]
@@ -1012,20 +1023,32 @@
!
redrawVisibleLine:visLineNr
- |line lineNr y isSpecial isSeparatingLine right clr1 clr2|
+ "redefined from normal list-line drawing, to handle special
+ lines. These are:
+ lines consisting of '-' only: draw a horizontal separating line
+ lines consisting of '=' only: draw double separating line
+ empty line : leave blank
+ there may be more in the future.
+ "
+
+ |line lineNr y isSpecial isSeparatingLine
+ isDoubleLine right clr1 clr2|
line := self visibleAt:visLineNr.
- isSpecial := false.
+ isSpecial := isDoubleLine := isSeparatingLine := false.
(line = '-') ifTrue:[
- isSeparatingLine := true.
- isSpecial := true
+ isSeparatingLine := isSpecial := true.
] ifFalse:[
- (line = '') ifTrue:[
- isSeparatingLine := false.
- isSpecial := true
+ (line = '=') ifTrue:[
+ isSeparatingLine := isSpecial := isDoubleLine := true.
+ ] ifFalse:[
+ (line = '') ifTrue:[
+ isSpecial := true
+ ]
]
].
+
isSpecial ifFalse:[
lineNr := self visibleLineToListLine:visLineNr.
(enableFlags at:lineNr) ifFalse:[
@@ -1049,9 +1072,16 @@
isSeparatingLine ifTrue:[
y := y + (fontHeight // 2).
+ isDoubleLine ifTrue:[
+ y := y - (fontHeight // 8).
+ ].
lineLevel == 0 ifTrue:[
self paint:fgColor.
- self displayLineFromX:0 y:y toX:width y:y
+ self displayLineFromX:0 y:y toX:width y:y.
+ isDoubleLine ifTrue:[
+ y := y + (fontHeight // 4).
+ self displayLineFromX:0 y:y toX:width y:y
+ ]
] ifFalse:[
"the inset on each side"
@@ -1062,18 +1092,26 @@
clr1 := lightColor.
clr2 := shadowColor.
].
+ right := width - 1 - lineInset.
+
self paint:clr1.
- right := width - 1 - lineInset.
self displayLineFromX:lineInset y:y toX:right y:y.
self paint:clr2.
y := y + 1.
- self displayLineFromX:lineInset y:y toX:right y:y
+ self displayLineFromX:lineInset y:y toX:right y:y.
+ isDoubleLine ifTrue:[
+ y := y + (fontHeight // 4).
+ self displayLineFromX:lineInset y:y toX:right y:y.
+ y := y - 1.
+ self paint:clr1.
+ self displayLineFromX:lineInset y:y toX:right y:y.
+ ]
]
]
!
redrawFromVisibleLine:start to:stop
- "redraw a line range"
+ "redraw a line range - redefined to care for special entries."
"the natural way to do it is:
@@ -1092,7 +1130,10 @@
[current <= stop] whileTrue:[
line := self visibleAt:current.
- special := (line = '-') or:[(line = '') or:[(line at:1) == $\]].
+ special := (line = '-')
+ or:[(line = '')
+ or:[(line at:1) == $\
+ or:[(line = '=')]]].
(special
or:[(enableFlags at:index) not]) ifTrue:[
"a special case"
@@ -1206,9 +1247,8 @@
]
] ifFalse:[
selectors notNil ifTrue: [
- ActiveGrab == self ifTrue:[
+ device activePointerGrab == self ifTrue:[
device ungrabPointer.
- ActiveGrab := nil.
].
(selectors isKindOf:Symbol) ifFalse:[
(selection notNil
--- a/ObjView.st Thu Nov 17 15:34:12 1994 +0100
+++ b/ObjView.st Thu Nov 17 15:38:53 1994 +0100
@@ -10,27 +10,19 @@
hereby transferred.
"
+'From Smalltalk/X, Version:2.10.4 on 7-nov-1994 at 1:19:10'!
+
View subclass:#ObjectView
- instanceVariableNames:'contents
- sorted
- lastButt lastPointer lastButtonTime
- pressAction releaseAction
- shiftPressAction doublePressAction
- motionAction keyPressAction
- selection
- gridShown gridPixmap
- scaleShown scaleMetric
- dragObject
- leftHandCursor readCursor oldCursor
- movedObject moveStartPoint
- moveDelta
- buffer
- documentFormat
- leftMarginForScale topMarginForScale
- canDragOutOfView rootMotion rootView aligning'
- classVariableNames:''
- poolDictionaries:''
- category:'Views-Basic'
+ instanceVariableNames:'contents sorted lastButt lastPointer lastButtonTime pressAction
+ releaseAction shiftPressAction doublePressAction motionAction
+ keyPressAction selection gridShown gridPixmap
+ scaleMetric dragObject leftHandCursor readCursor oldCursor
+ movedObject moveStartPoint moveDelta buffer documentFormat
+ canDragOutOfView rootMotion
+ rootView aligning gridAlign'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Basic'
!
ObjectView comment:'
@@ -56,7 +48,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Attic/ObjView.st,v 1.10 1994-10-28 03:25:14 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/ObjView.st,v 1.11 1994-11-17 14:38:16 claus Exp $
"
!
@@ -75,102 +67,147 @@
hitDelta
"when clicking an object, allow for hitDelta pixels around object;
0 is exact; 1*pixelPerMillimeter is good for draw programs"
+
^ 0
! !
-!ObjectView methodsFor:'initialization'!
+!ObjectView methodsFor:'events'!
-initialize
- |pixPerMM|
-
- super initialize.
-
- viewBackground := White.
+redrawX:x y:y width:w height:h
+ |innerX innerY innerW innerH redrawFrame |
- bitGravity := #NorthWest.
- contents := OrderedCollection new.
- gridShown := false.
- scaleShown := false.
- canDragOutOfView := false.
- rootView := DisplayRootView new.
- rootView noClipByChildren.
- rootMotion := false.
- (Language == #english) ifTrue:[
- documentFormat := 'letter'.
- scaleMetric := #inch
- ] ifFalse:[
- documentFormat := 'a4'.
- scaleMetric := #mm
- ].
- pixPerMM := self verticalPixelPerMillimeter:1.
- topMarginForScale := ((pixPerMM * 2.0) + 0.5) asInteger.
- pixPerMM := self horizontalPixelPerMillimeter:1.
- leftMarginForScale := ((pixPerMM * 2.0) + 0.5) asInteger.
- readCursor := Cursor read.
- leftHandCursor := Cursor leftHand.
- sorted := false.
- aligning := false
+ innerX := x.
+ innerY := y.
+ innerW := w.
+ innerH := h.
+
+ ((contents size ~~ 0) or:[gridShown]) ifTrue:[
+ redrawFrame := Rectangle left:innerX top:innerY
+ width:innerW height:innerH.
+ self redrawObjectsInVisible:redrawFrame
+ ]
!
-initEvents
- self backingStore:true.
- self enableButtonEvents.
- self enableButtonMotionEvents
+buttonMotion:buttonMask x:buttX y:buttY
+ "user moved mouse while button pressed"
+
+ |xpos ypos movePoint limitW limitH|
+
+ "is it the select or 1-button ?"
+ (device buttonMotionMask:buttonMask includesButton:#select) ifFalse:[
+ (device buttonMotionMask:buttonMask includesButton:1) ifFalse:[
+ ^ self
+ ].
+ ].
+
+ lastButt notNil ifTrue:[
+ xpos := buttX.
+ ypos := buttY.
+
+ "check against visible limits if move outside is not allowed"
+ rootMotion ifFalse:[
+ limitW := width.
+ limitH := height.
+ transformation notNil ifTrue:[
+ limitW := transformation applyInverseToX:width.
+ limitH := transformation applyInverseToY:height.
+ ].
+
+ (xpos < 0) ifTrue:[
+ xpos := 0
+ ] ifFalse: [
+ (xpos > limitW) ifTrue:[xpos := limitW]
+ ].
+ (ypos < 0) ifTrue:[
+ ypos := 0
+ ] ifFalse: [
+ (ypos > limitH) ifTrue:[ypos := limitH]
+ ]
+ ].
+ movePoint := xpos @ ypos.
+
+ (xpos == (lastButt x)) ifTrue:[
+ (ypos == (lastButt y)) ifTrue:[
+ ^ self "no move"
+ ]
+ ].
+
+ motionAction notNil ifTrue:[
+ motionAction value:movePoint
+ ].
+ lastButt := movePoint
+ ]
+!
+
+buttonPress:button x:x y:y
+ "user pressed left button"
+
+ ((button == 1) or:[button == #select]) ifTrue:[
+ pressAction notNil ifTrue:[
+ lastButt := x @ y.
+ pressAction value:lastButt
+ ]
+ ] ifFalse:[
+ super buttonPress:button x:x y:y
+ ]
+!
+
+buttonRelease:button x:x y:y
+ ((button == 1) or:[button == #select]) ifTrue:[
+ releaseAction notNil ifTrue:[releaseAction value]
+ ] ifFalse:[
+ super buttonRelease:button x:x y:y
+ ]
+!
+
+buttonShiftPress:button x:x y:y
+ "user pressed left button with shift"
+
+ ((button == 1) or:[button == #select]) ifTrue:[
+ shiftPressAction notNil ifTrue:[
+ lastButt := x @ y.
+ shiftPressAction value:lastButt
+ ]
+ ] ifFalse:[
+ super buttonShiftPress:button x:x y:y
+ ]
+!
+
+buttonMultiPress:button x:x y:y
+ "user pressed left button twice (or more)"
+
+ ((button == 1) or:[button == #select]) ifTrue:[
+ doublePressAction notNil ifTrue:[
+ doublePressAction value:(x @ y)
+ ]
+ ] ifFalse:[
+ super buttonMultiPress:button x:x y:y
+ ]
+!
+
+keyPress:key x:x y:y
+ keyPressAction notNil ifTrue:[
+ selection notNil ifTrue:[
+ self selectionDo: [:obj |
+ obj keyInput:key
+ ]
+ ]
+ ]
! !
!ObjectView methodsFor:'queries'!
-heightOfContentsInMM
- "answer the height of the document in millimeters"
+heightOfContents
+ "answer the height of the document in pixels"
- "landscape"
- (documentFormat = 'a1l') ifTrue:[
- ^ 592
- ].
- (documentFormat = 'a2l') ifTrue:[
- ^ 420
- ].
- (documentFormat = 'a3l') ifTrue:[
- ^ 296
- ].
- (documentFormat = 'a4l') ifTrue:[
- ^ 210
- ].
- (documentFormat = 'a5l') ifTrue:[
- ^ 148
- ].
- (documentFormat = 'a6l') ifTrue:[
- ^ 105
- ].
- (documentFormat = 'letterl') ifTrue:[
- ^ 8.5 * 25.4
- ].
+ |h|
- (documentFormat = 'a1') ifTrue:[
- ^ 840
- ].
- (documentFormat = 'a2') ifTrue:[
- ^ 592
- ].
- (documentFormat = 'a3') ifTrue:[
- ^ 420
- ].
- (documentFormat = 'a4') ifTrue:[
- ^ 296
+ h := self heightOfContentsInMM * (self verticalPixelPerMillimeter:1).
+
+ transformation isNil ifTrue:[
+ ^ h rounded
].
- (documentFormat = 'a5') ifTrue:[
- ^ 210
- ].
- (documentFormat = 'a6') ifTrue:[
- ^ 148
- ].
- (documentFormat = 'letter') ifTrue:[
- ^ 11 * 25.4
- ].
- "*** more formats needed here ...***"
-
- "assuming window size is document size"
- ^ (height / self verticalPixelPerMillimeter:1) asInteger
+ ^ (transformation applyScaleY:h) rounded
!
widthOfContentsInMM
@@ -226,117 +263,242 @@
^ (width / self horizontalPixelPerMillimeter:1) asInteger
!
-heightOfContents
- "answer the height of the document in pixels"
+heightOfContentsInMM
+ "answer the height of the document in millimeters"
+
+ "landscape"
+ (documentFormat = 'a1l') ifTrue:[
+ ^ 592
+ ].
+ (documentFormat = 'a2l') ifTrue:[
+ ^ 420
+ ].
+ (documentFormat = 'a3l') ifTrue:[
+ ^ 296
+ ].
+ (documentFormat = 'a4l') ifTrue:[
+ ^ 210
+ ].
+ (documentFormat = 'a5l') ifTrue:[
+ ^ 148
+ ].
+ (documentFormat = 'a6l') ifTrue:[
+ ^ 105
+ ].
+ (documentFormat = 'letterl') ifTrue:[
+ ^ 8.5 * 25.4
+ ].
- ^ ((self heightOfContentsInMM
- * (self verticalPixelPerMillimeter:1)) + 0.5) asInteger
+ (documentFormat = 'a1') ifTrue:[
+ ^ 840
+ ].
+ (documentFormat = 'a2') ifTrue:[
+ ^ 592
+ ].
+ (documentFormat = 'a3') ifTrue:[
+ ^ 420
+ ].
+ (documentFormat = 'a4') ifTrue:[
+ ^ 296
+ ].
+ (documentFormat = 'a5') ifTrue:[
+ ^ 210
+ ].
+ (documentFormat = 'a6') ifTrue:[
+ ^ 148
+ ].
+ (documentFormat = 'letter') ifTrue:[
+ ^ 11 * 25.4
+ ].
+ "*** more formats needed here ...***"
+
+ "assuming window size is document size"
+ ^ (height / self verticalPixelPerMillimeter:1) asInteger
!
widthOfContents
"answer the width of the document in pixels"
- ^ ((self widthOfContentsInMM
- * (self horizontalPixelPerMillimeter:1)) + 0.5) asInteger
+ |w|
+
+ w := self widthOfContentsInMM * (self horizontalPixelPerMillimeter:1).
+
+ transformation isNil ifTrue:[
+ ^ w rounded
+ ].
+ ^ (transformation applyScaleX:w) rounded
+! !
+
+!ObjectView methodsFor:'user interface'!
+
+alignToGrid:aPoint
+ "round aPoint to the next nearest point on the grid"
+
+ |p0 pG|
+
+ aligning ifFalse:[
+ ^ aPoint
+ ].
+
+ viewOrigin ~= (0@0) ifTrue:[
+ p0 := aPoint - viewOrigin.
+ pG := (p0 grid:gridAlign) rounded. "/grid:(1 @ 1).
+ ^ pG + viewOrigin
+ ].
+ ^ (aPoint grid:gridAlign) rounded
+!
+
+startSelectOrMove:aPoint
+ "start a rectangleDrag or objectMove - if aPoint hits an object,
+ an object move is started, otherwise a rectangleDrag.
+ This is typically the button pressAction."
+
+ |anObject|
+
+ anObject := self findObjectAtVisible:aPoint.
+ anObject notNil ifTrue:[
+ (self isSelected:anObject) ifFalse:[self unselect].
+ self startObjectMove:anObject at:aPoint.
+ ^ self
+ ].
+ "nothing was hit by this click - this starts a group select"
+ self unselect.
+ self startRectangleDrag:aPoint
+!
+
+selectMore:aPoint
+ "add/remove an object from the selection"
+
+ |anObject|
+
+ anObject := self findObjectAtVisible:aPoint.
+ anObject notNil ifTrue:[
+ (self isSelected:anObject) ifTrue:[
+ "remove from selection"
+ self removeFromSelection:anObject
+ ] ifFalse:[
+ "add to selection"
+ self addToSelection:anObject
+ ]
+ ].
+ ^ self
+!
+
+startSelectMoreOrMove:aPoint
+ "add/remove object hit by aPoint, then start a rectangleDrag or move
+ - if aPoint hits an object, a move is started, otherwise a rectangleDrag.
+ This is typically the button shiftPressAction."
+
+ |anObject|
+
+ anObject := self findObjectAtVisible:aPoint.
+ anObject notNil ifTrue:[
+ (self isSelected:anObject) ifTrue:[
+ "remove from selection"
+ self removeFromSelection:anObject
+ ] ifFalse:[
+ "add to selection"
+ self addToSelection:anObject
+ ].
+ self startObjectMove:selection at:aPoint.
+ ^ self
+ ].
+ self unselect.
+ self startRectangleDrag:aPoint
+! !
+
+!ObjectView methodsFor:'initialization'!
+
+setInitialDocumentFormat
+ (Language == #english) ifTrue:[
+ documentFormat := 'letter'.
+ scaleMetric := #inch
+ ] ifFalse:[
+ documentFormat := 'a4'.
+ scaleMetric := #mm
+ ].
+!
+
+initialize
+ |pixPerMM|
+
+ super initialize.
+
+ viewBackground := White.
+
+ bitGravity := #NorthWest.
+ contents := OrderedCollection new.
+ gridShown := false.
+
+ canDragOutOfView := false.
+ rootView := DisplayRootView new.
+ rootView noClipByChildren.
+ rootMotion := false.
+ self setInitialDocumentFormat.
+
+ readCursor := Cursor read.
+ leftHandCursor := Cursor leftHand.
+ sorted := false.
+ aligning := false
+!
+
+initEvents
+ self backingStore:true.
+ self enableButtonEvents.
+ self enableButtonMotionEvents
! !
!ObjectView methodsFor:'drawing'!
+redrawObjectsInVisible:visRect
+ "redraw all objects which have part of themselfes in a vis rectangle
+ draw only in (i.e. clip output to) aRectangle"
+
+ |vis|
+
+ shown ifTrue:[
+ vis := visRect.
+ clipRect notNil ifTrue:[
+ vis := vis intersect:clipRect
+ ].
+ transformation notNil ifTrue:[
+ vis := vis origin truncated
+ corner:(vis corner + (1@1)) truncated.
+ ].
+
+ self clippedTo:vis do:[
+ self clearRectangle:vis.
+ self redrawObjectsIntersectingVisible:vis
+ ]
+ ]
+!
+
+redrawObjectsIntersectingVisible:aRectangle
+ "redraw all objects which have part of themself in a vis rectangle"
+
+ self objectsIntersectingVisible:aRectangle do:[:theObject |
+ self show:theObject
+ ]
+
+!
+
redraw
"redraw complete View"
- shown "realized" ifTrue:[
-"/ gridShown ifTrue:[
-"/ self redrawGrid
-"/ ] ifFalse:[
-"/ self fill:viewBackground
-"/ ].
-self clear.
- scaleShown ifTrue:[
- self redrawScale
- ].
+ shown ifTrue:[
+ self clear.
self redrawObjects
]
!
-redrawGrid
- "redraw the grid"
-
- gridPixmap notNil ifTrue:[
- self clear.
- self paint:Black on:White.
- self displayOpaqueForm:gridPixmap x:viewOrigin x negated
- y:viewOrigin y negated
- ]
-!
-
-redrawHorizontalScale
- "redraw the horizontal scale"
-
- |x mmH short step xRounded shortLen longLen len|
-
- self clearRectangle:((0 @ 0) corner:(width @ topMarginForScale)).
- scaleShown ifFalse:[^ self].
- (scaleMetric == #mm) ifTrue:[
- "long blibs every centimeter; short ones every half"
+redrawObjectsIntersecting:aRectangle
+ "redraw all objects which have part of themself in aRectangle"
- mmH := self horizontalPixelPerMillimeter.
- step := mmH * 5.0.
- x := step.
- short := true.
- shortLen := (topMarginForScale / 2) asInteger.
- longLen := topMarginForScale.
- [x < width] whileTrue:[
- xRounded := (x + 0.5) asInteger.
- short ifTrue:[
- len := shortLen
- ] ifFalse:[
- len := longLen
- ].
- self displayLineFromX:xRounded y:0 toX:xRounded y:len.
- short := short not.
- x := x + step
- ]
+ self objectsIntersecting:aRectangle do:[:theObject |
+ self show:theObject
]
!
-redrawVerticalScale
- "redraw the vertical scale"
-
- |y mmV short step yRounded shortLen longLen len|
-
- self clearRectangle:((0 @ 0) corner:(leftMarginForScale @ height)).
- scaleShown ifFalse:[^ self].
- (scaleMetric == #mm) ifTrue:[
- "long blibs every centimeter; short ones every half"
-
- mmV := self verticalPixelPerMillimeter.
- step := mmV * 5.0.
- y := step.
- short := true.
- shortLen := (leftMarginForScale / 2) asInteger.
- longLen := leftMarginForScale.
- [y < height] whileTrue:[
- yRounded := (y + 0.5) asInteger.
- short ifTrue:[
- len := shortLen
- ] ifFalse:[
- len := longLen
- ].
- self displayLineFromX:0 y:yRounded toX:len y:yRounded.
- short := short not.
- y := y + step
- ]
- ]
-!
-
-redrawScale
- "redraw the scales"
-
- self redrawHorizontalScale.
- self redrawVerticalScale
-!
-
redrawObjectsOn:aGC
"redraw all objects on a graphic context"
@@ -344,7 +506,7 @@
(aGC == self) ifTrue:[
shown "realized" ifFalse:[^ self].
- org := viewOrigin + (leftMarginForScale @ topMarginForScale).
+ org := viewOrigin.
vFrame := Rectangle origin:org
corner:(viewOrigin + (width @ height)).
@@ -371,137 +533,6 @@
self redrawObjectsOn:self
!
-redrawObjectsIntersecting:aRectangle
- "redraw all objects which have part of themself in aRectangle"
-
- self objectsIntersecting:aRectangle do:[:theObject |
- self show:theObject
- ]
-!
-
-redrawObjectsIntersectingVisible:aRectangle
- "redraw all objects which have part of themself in a vis rectangle"
-
- self objectsIntersectingVisible:aRectangle do:[:theObject |
- self show:theObject
- ]
-
-!
-
-redrawObjectsAbove:anObject intersecting:aRectangle
- "redraw all objects which have part of themself in aRectangle
- and are above (in front of) anObject"
-
- self objectsAbove:anObject intersecting:aRectangle do:[:theObject |
- self show:theObject
- ]
-!
-
-redrawObjectsAbove:anObject intersectingVisible:aRectangle
- "redraw all objects which have part of themself in a vis rectangle
- and are above (in front of) anObject"
-
- self objectsAbove:anObject intersectingVisible:aRectangle do:[:theObject |
- self show:theObject
- ]
-!
-
-redrawObjectsIn:aRectangle
- "redraw all objects which have part of themselfes in aRectangle
- draw only in (i.e. clip output to) aRectangle"
-
- |visRect|
-
- shown "realized" ifTrue:[
- visRect := Rectangle origin:(aRectangle origin - viewOrigin)
- extent:(aRectangle extent).
- clipRect notNil ifTrue:[
- visRect := visRect intersect:clipRect
- ].
- self clippedTo:visRect do:[
-self clearRectangle:visRect.
-"/ gridShown ifTrue:[
-"/ self redrawGrid
-"/ ] ifFalse:[
-"/ self paint:viewBackground.
-"/ self fillRectangle:visRect
-"/ ].
- self redrawObjectsIntersecting:aRectangle
- ]
- ]
-!
-
-redrawObjectsInVisible:visRect
- "redraw all objects which have part of themselfes in a vis rectangle
- draw only in (i.e. clip output to) aRectangle"
-
- |vis|
-
- shown "realized" ifTrue:[
- vis := visRect.
- clipRect notNil ifTrue:[
- vis := vis intersect:clipRect
- ].
-
- self clippedTo:vis do:[
-"/ gridShown ifTrue:[
-"/ self redrawGrid
-"/ ] ifFalse:[
-"/ self paint:viewBackground.
-"/ self fillRectangle:vis
-"/ ].
-self clearRectangle:vis.
- self redrawObjectsIntersectingVisible:vis
- ]
- ]
-!
-
-redrawObjectsAbove:anObject in:aRectangle
- "redraw all objects which have part of themselfes in aRectangle
- and are above (in front of) anObject.
- draw only in (i.e. clip output to) aRectangle"
-
- |vis|
-
- shown "realized" ifTrue:[
- vis := aRectangle.
- clipRect notNil ifTrue:[
- vis := vis intersect:clipRect
- ].
- self clippedTo:vis do:[
- self redrawObjectsAbove:anObject intersecting:vis
- ]
- ]
-!
-
-redrawObjectsAbove:anObject inVisible:aRectangle
- "redraw all objects which have part of themselfes in a vis rectangle
- and are above (in front of) anObject.
- draw only in (i.e. clip output to) aRectangle"
-
- |vis|
-
- shown "realized" ifTrue:[
- vis := aRectangle.
- clipRect notNil ifTrue:[
- vis := vis intersect:clipRect
- ].
- self clippedTo:vis do:[
- self redrawObjectsAbove:anObject intersectingVisible:vis
- ]
- ]
-!
-
-show:anObject
- "show the object, either selected or not"
-
- (self isSelected:anObject) ifTrue:[
- self showSelected:anObject
- ] ifFalse:[
- self showUnselected:anObject
- ]
-!
-
showDragging:something offset:anOffset
"show an object while dragging"
@@ -523,6 +554,100 @@
]
!
+redrawObjectsIn:aRectangle
+ "redraw all objects which have part of themselfes in aRectangle
+ draw only in (i.e. clip output to) aRectangle"
+
+ |visRect|
+
+ shown ifTrue:[
+ visRect := Rectangle origin:(aRectangle origin - viewOrigin)
+ extent:(aRectangle extent).
+ clipRect notNil ifTrue:[
+ visRect := visRect intersect:clipRect
+ ].
+ transformation notNil ifTrue:[
+ visRect := visRect origin truncated
+ corner:(visRect corner + (1@1)) truncated.
+ ].
+ self clippedTo:visRect do:[
+ self clearRectangle:visRect.
+ self redrawObjectsIntersecting:aRectangle
+ ]
+ ]
+!
+
+redrawScale
+ "redraw the scales"
+
+ self redrawHorizontalScale.
+ self redrawVerticalScale
+!
+
+redrawObjectsAbove:anObject intersecting:aRectangle
+ "redraw all objects which have part of themself in aRectangle
+ and are above (in front of) anObject"
+
+ self objectsAbove:anObject intersecting:aRectangle do:[:theObject |
+ self show:theObject
+ ]
+!
+
+redrawObjectsAbove:anObject intersectingVisible:aRectangle
+ "redraw all objects which have part of themself in a vis rectangle
+ and are above (in front of) anObject"
+
+ self objectsAbove:anObject intersectingVisible:aRectangle do:[:theObject |
+ self show:theObject
+ ]
+!
+
+redrawObjectsAbove:anObject in:aRectangle
+ "redraw all objects which have part of themselfes in aRectangle
+ and are above (in front of) anObject.
+ draw only in (i.e. clip output to) aRectangle"
+
+ |vis|
+
+ shown ifTrue:[
+ vis := aRectangle.
+ clipRect notNil ifTrue:[
+ vis := vis intersect:clipRect
+ ].
+ self clippedTo:vis do:[
+ self redrawObjectsAbove:anObject intersecting:vis
+ ]
+ ]
+!
+
+redrawObjectsAbove:anObject inVisible:aRectangle
+ "redraw all objects which have part of themselfes in a vis rectangle
+ and are above (in front of) anObject.
+ draw only in (i.e. clip output to) aRectangle"
+
+ |vis|
+
+ shown ifTrue:[
+ vis := aRectangle.
+ clipRect notNil ifTrue:[
+ vis := vis intersect:clipRect
+ ].
+ self clippedTo:vis do:[
+ self redrawObjectsAbove:anObject intersectingVisible:vis
+ ]
+ ]
+!
+
+show:anObject
+ "show the object, either selected or not"
+
+ (self isSelected:anObject) ifTrue:[
+ self showSelected:anObject
+ ] ifFalse:[
+ self showUnselected:anObject
+ ]
+!
+
showSelected:anObject
"show an object as selected"
@@ -537,6 +662,34 @@
!ObjectView methodsFor:'selections'!
+unselect
+ "unselect - hide selection; clear selection buffer"
+
+ self hideSelection.
+ selection := nil
+!
+
+select:something
+ "select something - hide previouse selection, set to something and hilight"
+
+ (selection == something) ifFalse:[
+ self hideSelection.
+ selection := something.
+ self showSelection
+ ]
+!
+
+withSelectionHiddenDo:aBlock
+ "evaluate aBlock while selection is hidden"
+
+ |sel|
+
+ sel := selection.
+ self unselect.
+ aBlock value.
+ self select:sel
+!
+
selectionDo:aBlock
"apply block to every object in selection"
@@ -559,23 +712,6 @@
]
!
-unselect
- "unselect - hide selection; clear selection buffer"
-
- self hideSelection.
- selection := nil
-!
-
-select:something
- "select something - hide previouse selection, set to something and hilight"
-
- (selection == something) ifFalse:[
- self hideSelection.
- selection := something.
- self showSelection
- ]
-!
-
selectAll
"select all objects"
@@ -610,23 +746,6 @@
self showUnselected:anObject
!
-selectAllIntersecting:aRectangle
- "select all objects touched by aRectangle"
-
- self hideSelection.
- selection := OrderedCollection new.
-
- self objectsIntersecting:aRectangle do:[:theObject |
- selection add:theObject
- ].
- (selection size == 0) ifTrue:[
- selection := nil
- ] ifFalse:[
- (selection size == 1) ifTrue:[selection := selection first]
- ].
- self showSelection
-!
-
selectAllIn:aRectangle
"select all objects fully in aRectangle"
@@ -643,19 +762,56 @@
self showSelection
!
-withSelectionHiddenDo:aBlock
- "evaluate aBlock while selection is hidden"
+selectAllIntersecting:aRectangle
+ "select all objects touched by aRectangle"
- |sel|
+ self hideSelection.
+ selection := OrderedCollection new.
- sel := selection.
- self unselect.
- aBlock value.
- self select:sel
+ self objectsIntersecting:aRectangle do:[:theObject |
+ selection add:theObject
+ ].
+ (selection size == 0) ifTrue:[
+ selection := nil
+ ] ifFalse:[
+ (selection size == 1) ifTrue:[selection := selection first]
+ ].
+ self showSelection
! !
!ObjectView methodsFor:'testing objects'!
+frameOf:anObjectOrCollection
+ "answer the maximum extent defined by the argument, anObject or a
+ collection of objects"
+
+ |first frameAll|
+
+ anObjectOrCollection isNil ifTrue:[^ nil ].
+ first := true.
+ self forEach:anObjectOrCollection do:[:theObject |
+ first ifTrue:[
+ frameAll := theObject frame.
+ first := false
+ ] ifFalse:[
+ frameAll := frameAll merge:(theObject frame)
+ ]
+ ].
+ ^ frameAll
+!
+
+isObscured:something
+ "return true, if the argument something, anObject or a collection of
+ objects is obscured (partially or whole) by any other object"
+
+ self forEach:something do:[:anObject |
+ (self objectIsObscured:anObject) ifTrue:[
+ ^ true
+ ]
+ ].
+ ^ false
+!
+
findObjectAt:aPoint
"find the last object (by looking from back to front) which is hit by
the argument, aPoint - this is the topmost object hit"
@@ -700,25 +856,6 @@
^ self findObjectAt:(aPoint + viewOrigin) suchThat:aBlock
!
-frameOf:anObjectOrCollection
- "answer the maximum extent defined by the argument, anObject or a
- collection of objects"
-
- |first frameAll|
-
- anObjectOrCollection isNil ifTrue:[^ nil ].
- first := true.
- self forEach:anObjectOrCollection do:[:theObject |
- first ifTrue:[
- frameAll := theObject frame.
- first := false
- ] ifFalse:[
- frameAll := frameAll merge:(theObject frame)
- ]
- ].
- ^ frameAll
-!
-
canMove:something
"return true, if the argument, anObject or a collection can be moved"
@@ -776,34 +913,310 @@
]
].
^ false
+! !
+
+!ObjectView methodsFor:'misc'!
+
+forEach:aCollection do:aBlock
+ "apply block to every object in a collectioni;
+ (adds a check for non-collection)"
+
+ aCollection isNil ifTrue:[^self].
+ (aCollection isKindOf:Collection) ifTrue:[
+ aCollection do:[:object |
+ object notNil ifTrue:[
+ aBlock value:object
+ ]
+ ]
+ ] ifFalse: [
+ aBlock value:aCollection
+ ]
+!
+
+objectsIntersecting:aRectangle do:aBlock
+ "do something to every object which intersects a rectangle"
+
+ |f top bot
+ firstIndex "{ Class: SmallInteger }"
+ delta "{ Class: SmallInteger }"
+ theObject
+ nObjects "{ Class: SmallInteger }"|
+
+ sorted ifFalse:[
+ "have to check every object"
+ contents do:[:theObject |
+ (theObject frame intersects:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ]
+ ].
+ ^ self
+ ].
+ nObjects := contents size.
+ (nObjects == 0) ifTrue:[^ self].
+
+ "can break, when 1st object below aRectangle is reached"
+ bot := aRectangle bottom.
+ top := aRectangle top.
+
+ "binary search an object in aRectangle ..."
+ delta := nObjects // 2.
+ firstIndex := delta.
+ (firstIndex == 0) ifTrue:[
+ firstIndex := 1
+ ].
+ theObject := contents at:firstIndex.
+ (theObject frame bottom < top) ifTrue:[
+ [theObject frame bottom < top and:[delta > 1]] whileTrue:[
+ delta := delta // 2.
+ firstIndex := firstIndex + delta.
+ theObject := contents at:firstIndex
+ ]
+ ] ifFalse:[
+ [theObject frame top > bot and:[delta > 1]] whileTrue:[
+ delta := delta // 2.
+ firstIndex := firstIndex - delta.
+ theObject := contents at:firstIndex
+ ]
+ ].
+ "now, theObject at:firstIndex is in aRectangle; go backward to the object
+ following first non-visible"
+
+ [theObject frame bottom > top and:[firstIndex > 1]] whileTrue:[
+ firstIndex := firstIndex - 1.
+ theObject := contents at:firstIndex
+ ].
+
+ firstIndex to:nObjects do:[:index |
+ theObject := contents at:index.
+ f := theObject frame.
+ (f intersects:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ] ifFalse:[
+ (f top > bot) ifTrue:[^ self]
+ ]
+ ]
+!
+
+setDefaultActions
+ motionAction := [:movePoint | nil].
+ releaseAction := [nil]
+!
+
+setMoveActions
+ motionAction := [:movePoint | self doObjectMove:movePoint].
+ releaseAction := [self endObjectMove]
+!
+
+objectsIntersectingVisible:aRectangle do:aBlock
+ "do something to every object which intersects a visible rectangle"
+
+ |absRect|
+
+ absRect := Rectangle left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+ self objectsIntersecting:absRect do:aBlock
+!
+
+objectsIntersecting:aRectangle
+ "answer a Collection of objects intersecting the argument, aRectangle"
+
+ |newCollection|
+
+ newCollection := OrderedCollection new.
+ self objectsIntersecting:aRectangle do:[:theObject |
+ newCollection add:theObject
+ ].
+ (newCollection size == 0) ifTrue:[^ nil].
+ ^ newCollection
+!
+
+documentFormat:aFormatString
+ "set the document format (mostly used by scrollbars).
+ The argument should be a string such as 'a4', 'a5'
+ or 'letter'. See widthOfContentsInMM for supported formats."
+
+ aFormatString ~= documentFormat ifTrue:[
+ documentFormat := aFormatString.
+ self contentsChanged.
+ self defineGrid.
+ gridShown ifTrue:[
+ self clear.
+ self redraw
+ ]
+ ]
+!
+
+setRectangleDragActions
+ motionAction := [:movePoint | self doRectangleDrag:movePoint].
+ releaseAction := [self endRectangleDrag]
+!
+
+setLineDragActions
+ motionAction := [:movePoint | self doLineDrag:movePoint].
+ releaseAction := [self endLineDrag]
!
-isObscured:something
- "return true, if the argument something, anObject or a collection of
- objects is obscured (partially or whole) by any other object"
+objectsIn:aRectangle do:aBlock
+ "do something to every object which is completely in a rectangle"
+
+ |bot|
+
+ sorted ifTrue:[
+ bot := aRectangle bottom.
+ contents do:[:theObject |
+ (theObject isContainedIn:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ] ifFalse:[
+ theObject frame top > bot ifTrue:[^ self]
+ ]
+ ].
+ ^ self
+ ].
+
+ contents do:[:theObject |
+ (theObject isContainedIn:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ]
+ ]
+!
+
+objectsInVisible:aRectangle do:aBlock
+ "do something to every object which is completely in a
+ visible rectangle"
+
+ |absRect|
- self forEach:something do:[:anObject |
- (self objectIsObscured:anObject) ifTrue:[
- ^ true
+ absRect := Rectangle left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+ self objectsIn:absRect do:aBlock
+!
+
+visibleObjectsDo:aBlock
+ "do something to every visible object"
+
+ |absRect|
+
+ absRect := Rectangle left:viewOrigin x
+ top:viewOrigin y
+ width:width
+ height:height.
+ self objectsIntersecting:absRect do:aBlock
+!
+
+numberOfObjectsIntersectingVisible:aRectangle
+ "answer the number of objects intersecting the argument, aRectangle"
+
+ |absRect|
+
+ absRect := Rectangle
+ left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+
+ ^ self numberOfObjectsIntersecting:aRectangle
+!
+
+numberOfObjectsIntersecting:aRectangle
+ "answer the number of objects intersecting the argument, aRectangle"
+
+ |tally|
+
+ tally := 0.
+ contents do:[:theObject |
+ (theObject frame intersects:aRectangle) ifTrue:[
+ tally := tally + 1
]
].
- ^ false
+ ^ tally
+!
+
+objectsIntersectingVisible:aRectangle
+ "answer a Collection of objects intersecting a visible aRectangle"
+
+ |absRect|
+
+ absRect := Rectangle left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+ ^ self objectsIntersecting:absRect
+!
+
+objectsBelow:objectToBeTested do:aBlock
+ "do something to every object below objectToBeTested
+ (does not mean obscured by - simply below in hierarchy)"
+
+ |endIndex|
+
+ endIndex := contents identityIndexOf:objectToBeTested ifAbsent:[self error].
+ contents from:1 to:(endIndex - 1) do:aBlock
+!
+
+objectsAbove:objectToBeTested do:aBlock
+ "do something to every object above objectToBeTested
+ (does not mean obscured - simply above in hierarchy)"
+
+ |startIndex|
+
+ startIndex := contents identityIndexOf:objectToBeTested
+ ifAbsent:[self error].
+ contents from:startIndex to:(contents size) do:aBlock
+!
+
+objectsAbove:anObject intersecting:aRectangle do:aBlock
+ "do something to every object above objectToBeTested
+ and intersecting aRectangle"
+
+ self objectsAbove:anObject do:[:theObject |
+ (theObject frame intersects:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ]
+ ]
+!
+
+rectangleForScroll
+ "find the area occupied by visible objects"
+
+ |left right top bottom frame oLeft oRight oTop oBottom orgX orgY|
+
+ orgX := viewOrigin x.
+ orgY := viewOrigin y.
+ left := 9999.
+ right := 0.
+ top := 9999.
+ bottom := 0.
+ self visibleObjectsDo:[:anObject |
+ frame := anObject frame.
+ oLeft := frame left - orgX.
+ oRight := frame right - orgX.
+ oTop := frame top - orgY.
+ oBottom := frame bottom - orgY.
+ (oLeft < left) ifTrue:[left := oLeft].
+ (oRight > right) ifTrue:[right := oRight].
+ (oTop < top) ifTrue:[top := oTop].
+ (oBottom > bottom) ifTrue:[bottom := oBottom]
+ ].
+ (left < margin) ifTrue:[left := margin].
+ (top < margin) ifTrue:[top := margin].
+ (right > (width - margin)) ifTrue:[right := width - margin].
+ (bottom > (height - margin)) ifTrue:[bottom := height - margin].
+
+ ((left > right) or:[top > bottom]) ifTrue:[^ nil].
+
+ ^ Rectangle left:left right:right top:top bottom:bottom
! !
!ObjectView methodsFor:'layout manipulation'!
-move:something to:aPoint in:aView
- "can only happen when dragOutOfView is true
- - should be redefined in subclasses"
+moveObject:anObject by:delta
+ "change the position of anObject by delta, aPoint"
- self notify:'cannot move object(s) out of view'
-!
-
-move:something to:aPoint inAlienViewId:aViewId
- "can only happen when dragOutOfView is true
- - should be redefined in subclasses"
-
- self notify:'cannot move object(s) to alien views'
+ self moveObject:anObject to:(anObject origin + delta)
!
move:something by:delta
@@ -819,12 +1232,6 @@
]
!
-moveObject:anObject by:delta
- "change the position of anObject by delta, aPoint"
-
- self moveObject:anObject to:(anObject origin + delta)
-!
-
moveObject:anObject to:newOrigin
"move anObject to newOrigin, aPoint"
@@ -878,9 +1285,10 @@
].
((oldLeft < width) and:[oldTop < height]) ifTrue:[
((oldLeft >= 0) and:[oldTop >= 0]) ifTrue:[
- self clearRectangleX:oldLeft y:oldTop width:w height:h.
- "/ self fillRectangleX:oldLeft y:oldTop width:w height:h
- "/ with:viewBackground
+ self clearRectangleX:oldLeft y:oldTop width:w height:h.
+
+"/ self fillRectangleX:oldLeft y:oldTop width:w height:h
+"/ with:viewBackground
]
].
^ self
@@ -908,6 +1316,20 @@
]
!
+move:something to:aPoint in:aView
+ "can only happen when dragOutOfView is true
+ - should be redefined in subclasses"
+
+ self notify:'cannot move object(s) out of view'
+!
+
+move:something to:aPoint inAlienViewId:aViewId
+ "can only happen when dragOutOfView is true
+ - should be redefined in subclasses"
+
+ self notify:'cannot move object(s) to alien views'
+!
+
objectToFront:anObject
"bring the argument, anObject to front"
@@ -1097,6 +1519,18 @@
]
!
+addObject:anObject
+ "add the argument, anObject to the contents - with redraw"
+
+ anObject notNil ifTrue:[
+ contents addLast:anObject.
+ "its on top - only draw this one"
+ shown "realized" ifTrue:[
+ self showUnselected:anObject
+ ]
+ ]
+!
+
addObjectWithoutRedraw:anObject
"add the argument, anObject to the contents - no redraw"
@@ -1114,18 +1548,6 @@
]
!
-addObject:anObject
- "add the argument, anObject to the contents - with redraw"
-
- anObject notNil ifTrue:[
- contents addLast:anObject.
- "its on top - only draw this one"
- shown "realized" ifTrue:[
- self showUnselected:anObject
- ]
- ]
-!
-
remove:something
"remove something, anObject or a collection of objects from the contents
do redraw"
@@ -1179,370 +1601,73 @@
self redraw
! !
-!ObjectView methodsFor:'misc'!
-
-documentFormat:aFormatString
- "set the document format (mostly used by scrollbars).
- The argument should be a string such as 'a4', 'a5'
- or 'letter'. See widthOfContentsInMM for supported formats."
-
- aFormatString ~= documentFormat ifTrue:[
- documentFormat := aFormatString.
- self contentsChanged.
- self defineGrid.
- gridShown ifTrue:[
- self clear.
- self redraw
- ]
- ]
-!
-
-setDefaultActions
- motionAction := [:movePoint | nil].
- releaseAction := [nil]
-!
-
-setRectangleDragActions
- motionAction := [:movePoint | self doRectangleDrag:movePoint].
- releaseAction := [self endRectangleDrag]
-!
-
-setLineDragActions
- motionAction := [:movePoint | self doLineDrag:movePoint].
- releaseAction := [self endLineDrag]
-!
-
-setMoveActions
- motionAction := [:movePoint | self doObjectMove:movePoint].
- releaseAction := [self endObjectMove]
-!
-
-forEach:aCollection do:aBlock
- "apply block to every object in a collectioni;
- (adds a check for non-collection)"
-
- aCollection isNil ifTrue:[^self].
- (aCollection isKindOf:Collection) ifTrue:[
- aCollection do:[:object |
- object notNil ifTrue:[
- aBlock value:object
- ]
- ]
- ] ifFalse: [
- aBlock value:aCollection
- ]
-!
-
-objectsInVisible:aRectangle do:aBlock
- "do something to every object which is completely in a
- visible rectangle"
-
- |absRect|
-
- absRect := Rectangle left:(aRectangle left + viewOrigin x)
- top:(aRectangle top + viewOrigin y)
- width:(aRectangle width)
- height:(aRectangle height).
- self objectsIn:absRect do:aBlock
-!
-
-objectsIn:aRectangle do:aBlock
- "do something to every object which is completely in a rectangle"
-
- |bot|
-
- sorted ifTrue:[
- bot := aRectangle bottom.
- contents do:[:theObject |
- (theObject isContainedIn:aRectangle) ifTrue:[
- aBlock value:theObject
- ] ifFalse:[
- theObject frame top > bot ifTrue:[^ self]
- ]
- ].
- ^ self
- ].
-
- contents do:[:theObject |
- (theObject isContainedIn:aRectangle) ifTrue:[
- aBlock value:theObject
- ]
- ]
-!
-
-visibleObjectsDo:aBlock
- "do something to every visible object"
-
- |absRect|
-
- absRect := Rectangle left:viewOrigin x
- top:viewOrigin y
- width:width
- height:height.
- self objectsIntersecting:absRect do:aBlock
-!
-
-numberOfObjectsIntersectingVisible:aRectangle
- "answer the number of objects intersecting the argument, aRectangle"
-
- |absRect|
-
- absRect := Rectangle
- left:(aRectangle left + viewOrigin x)
- top:(aRectangle top + viewOrigin y)
- width:(aRectangle width)
- height:(aRectangle height).
-
- ^ self numberOfObjectsIntersecting:aRectangle
-!
-
-numberOfObjectsIntersecting:aRectangle
- "answer the number of objects intersecting the argument, aRectangle"
-
- |tally|
-
- tally := 0.
- contents do:[:theObject |
- (theObject frame intersects:aRectangle) ifTrue:[
- tally := tally + 1
- ]
- ].
- ^ tally
-!
-
-objectsIntersecting:aRectangle
- "answer a Collection of objects intersecting the argument, aRectangle"
-
- |newCollection|
-
- newCollection := OrderedCollection new.
- self objectsIntersecting:aRectangle do:[:theObject |
- newCollection add:theObject
- ].
- (newCollection size == 0) ifTrue:[^ nil].
- ^ newCollection
-!
-
-objectsIntersectingVisible:aRectangle
- "answer a Collection of objects intersecting a visible aRectangle"
-
- |absRect|
-
- absRect := Rectangle left:(aRectangle left + viewOrigin x)
- top:(aRectangle top + viewOrigin y)
- width:(aRectangle width)
- height:(aRectangle height).
- ^ self objectsIntersecting:absRect
-!
-
-objectsIntersecting:aRectangle do:aBlock
- "do something to every object which intersects a rectangle"
-
- |f top bot
- firstIndex "{ Class: SmallInteger }"
- delta "{ Class: SmallInteger }"
- theObject
- nObjects "{ Class: SmallInteger }"|
-
- sorted ifFalse:[
- "have to check every object"
- contents do:[:theObject |
- (theObject frame intersects:aRectangle) ifTrue:[
- aBlock value:theObject
- ]
- ].
- ^ self
- ].
- nObjects := contents size.
- (nObjects == 0) ifTrue:[^ self].
-
- "can break, when 1st object below aRectangle is reached"
- bot := aRectangle bottom.
- top := aRectangle top.
-
- "binary search an object in aRectangle ..."
- delta := nObjects // 2.
- firstIndex := delta.
- (firstIndex == 0) ifTrue:[
- firstIndex := 1
- ].
- theObject := contents at:firstIndex.
- (theObject frame bottom < top) ifTrue:[
- [theObject frame bottom < top and:[delta > 1]] whileTrue:[
- delta := delta // 2.
- firstIndex := firstIndex + delta.
- theObject := contents at:firstIndex
- ]
- ] ifFalse:[
- [theObject frame top > bot and:[delta > 1]] whileTrue:[
- delta := delta // 2.
- firstIndex := firstIndex - delta.
- theObject := contents at:firstIndex
- ]
- ].
- "now, theObject at:firstIndex is in aRectangle; go backward to the object
- following first non-visible"
-
- [theObject frame bottom > top and:[firstIndex > 1]] whileTrue:[
- firstIndex := firstIndex - 1.
- theObject := contents at:firstIndex
- ].
-
- firstIndex to:nObjects do:[:index |
- theObject := contents at:index.
- f := theObject frame.
- (f intersects:aRectangle) ifTrue:[
- aBlock value:theObject
- ] ifFalse:[
- (f top > bot) ifTrue:[^ self]
- ]
- ]
-!
-
-objectsIntersectingVisible:aRectangle do:aBlock
- "do something to every object which intersects a visible rectangle"
-
- |absRect|
-
- absRect := Rectangle left:(aRectangle left + viewOrigin x)
- top:(aRectangle top + viewOrigin y)
- width:(aRectangle width)
- height:(aRectangle height).
- self objectsIntersecting:absRect do:aBlock
-!
-
-objectsBelow:objectToBeTested do:aBlock
- "do something to every object below objectToBeTested
- (does not mean obscured by - simply below in hierarchy)"
-
- |endIndex|
-
- endIndex := contents identityIndexOf:objectToBeTested ifAbsent:[self error].
- contents from:1 to:(endIndex - 1) do:aBlock
-!
-
-objectsAbove:objectToBeTested do:aBlock
- "do something to every object above objectToBeTested
- (does not mean obscured - simply above in hierarchy)"
-
- |startIndex|
-
- startIndex := contents identityIndexOf:objectToBeTested
- ifAbsent:[self error].
- contents from:startIndex to:(contents size) do:aBlock
-!
-
-objectsAbove:anObject intersecting:aRectangle do:aBlock
- "do something to every object above objectToBeTested
- and intersecting aRectangle"
-
- self objectsAbove:anObject do:[:theObject |
- (theObject frame intersects:aRectangle) ifTrue:[
- aBlock value:theObject
- ]
- ]
-!
-
-rectangleForScroll
- "find the area occupied by visible objects"
-
- |left right top bottom frame oLeft oRight oTop oBottom orgX orgY|
-
- orgX := viewOrigin x.
- orgY := viewOrigin y.
- left := 9999.
- right := 0.
- top := 9999.
- bottom := 0.
- self visibleObjectsDo:[:anObject |
- frame := anObject frame.
- oLeft := frame left - orgX.
- oRight := frame right - orgX.
- oTop := frame top - orgY.
- oBottom := frame bottom - orgY.
- (oLeft < left) ifTrue:[left := oLeft].
- (oRight > right) ifTrue:[right := oRight].
- (oTop < top) ifTrue:[top := oTop].
- (oBottom > bottom) ifTrue:[bottom := oBottom]
- ].
- (left < margin) ifTrue:[left := margin].
- (top < margin) ifTrue:[top := margin].
- (right > (width - margin)) ifTrue:[right := width - margin].
- (bottom > (height - margin)) ifTrue:[bottom := height - margin].
-
- ((left > right) or:[top > bottom]) ifTrue:[^ nil].
-
- ^ Rectangle left:left right:right top:top bottom:bottom
-! !
-
!ObjectView methodsFor:'view manipulation'!
zoom:factor
- factor isNil ifTrue:[
+ "set a zoom factor; nil or 1 is identity; 2 is magnify by 2;
+ 0.5 is shrink by 2"
+
+ (factor isNil or:[factor = 1]) ifTrue:[
transformation := nil
] ifFalse:[
- transformation := WindowingTransformation scale:(1 / factor) translation:0.
+ transformation := WindowingTransformation scale:factor translation:0.
].
+ self setInnerClip.
gridShown ifTrue:[
- gridPixmap := nil.
- self defineGrid.
- viewBackground := gridPixmap
+ self newGrid
].
shown ifTrue:[
self clear.
self redraw
- ]
-!
-
-showScale
- "show the scale"
-
- scaleShown := true.
- self redrawScale
-!
-
-hideScale
- "hide the scale"
-
- scaleShown := false.
- self redrawScale
+ ].
+ self contentsChanged
!
millimeterMetric
- (scaleMetric == #inch) ifTrue:[
+ (scaleMetric ~~ #mm) ifTrue:[
scaleMetric := #mm.
- gridShown ifTrue:[
- self defineGrid.
- self redraw
- ]
+ self newGrid
]
!
inchMetric
- (scaleMetric == #mm) ifTrue:[
+ (scaleMetric ~~ #inch) ifTrue:[
scaleMetric := #inch.
- gridShown ifTrue:[
- self defineGrid.
- self redraw
- ]
+ self newGrid
]
-!
+! !
+
+!ObjectView methodsFor:'grid manipulation'!
+
+gridParameters
+ "used by defineGrid, and in a separate method for
+ easier redefinition in subclasses.
+ Returns the parameters in an array of 7 elements,
+ which control the appearance of the grid-pattern.
+ elements:
-defineGrid
- "define the grid pattern"
+ bigStepH number of pixels horizontally between 2 major steps
+ bigStepV number of pixels vertically between 2 major steps
+ littleStepH number of pixels horizontally between 2 minor steps
+ littleStepV number of pixels vertically between 2 minor steps
+ gridAlignH number of pixels for horizontal grid align
+ gridAlignV number of pixels for vertical grid align
+ docBounds true, if document boundary shouldbe shown
+ "
- |mmH mmV gridW gridH xp yp y x
- bigStepH bigStepV littleStepH littleStepV hires
- oldCursor|
+ |mmH mmV bigStepH bigStepV littleStepH littleStepV arr|
+
+ "example: 12grid & 12snapIn"
+"/ ^ #(12 12 nil nil 12 12 false).
+
+ "example: 12grid & 24snapIn"
+"/ ^ #(12 12 nil nil 24 24 false).
+
+ "default: cm/mm grid & mm snapIn for metric,
+ 1inch , 1/8inch grid & 1/8 inch snapIn"
mmH := self horizontalPixelPerMillimeter.
mmV := self verticalPixelPerMillimeter.
- hires := self horizontalPixelPerInch > 120.
-
- transformation notNil ifTrue:[
- mmH := mmH * transformation scale x.
- mmV := mmV * transformation scale y
- ].
(scaleMetric == #mm) ifTrue:[
"dots every mm; lines every cm"
@@ -1558,119 +1683,197 @@
littleStepH := mmH * (25.4 / 8).
littleStepV := mmV * (25.4 / 8)
].
- bigStepH isNil ifTrue:[^ self].
+
+ arr := Array new:8.
+ arr at:1 put:bigStepH.
+ arr at:2 put:bigStepV.
+ arr at:3 put:littleStepH.
+ arr at:4 put:littleStepV.
+ arr at:5 put:littleStepH.
+ arr at:6 put:littleStepV.
+ arr at:7 put:false.
- oldCursor := cursor.
- self cursor:Cursor wait.
+ ^ arr
+!
+
+defineGrid
+ "define the grid pattern"
+
+ |mmH mmV params showDocumentBoundary gridW gridH
+ bigStepH bigStepV littleStepH littleStepV hires|
+
+ mmH := self horizontalPixelPerMillimeter.
+ mmV := self verticalPixelPerMillimeter.
+ hires := self horizontalPixelPerInch > 120.
- gridW := (self widthOfContentsInMM * mmH + 1) asInteger.
- gridH := (self heightOfContentsInMM * mmV + 1) asInteger.
- gridPixmap := Form width:gridW height:gridH depth:1 ."/ (device depth).
-"/ gridPixmap fill:White.
-"/ gridPixmap paint:Black.
-gridPixmap colorMap:(Array with:Color white
- with:Color black).
-gridPixmap clear.
-gridPixmap paint:(Color colorId:1).
+ gridW := (self widthOfContentsInMM * mmH).
+ gridH := (self heightOfContentsInMM * mmV).
+
+ params := self gridParameters.
+
+ bigStepH := params at:1.
+ bigStepV := params at:2.
+ littleStepH := params at:3.
+ littleStepV := params at:4.
+ showDocumentBoundary := params at:7.
- "draw first row point-by-point"
- yp := 0.0.
- xp := 0.0.
- y := yp asInteger.
- [xp <= gridW] whileTrue:[
- x := xp rounded.
- hires ifTrue:[
- gridPixmap displayPointX:(x + 1) y:y.
- gridPixmap displayPointX:(x + 2) y:y
+ transformation notNil ifTrue:[
+ mmH := mmH * transformation scale x.
+ mmV := mmV * transformation scale y.
+ bigStepH := bigStepH * transformation scale x.
+ bigStepV := bigStepV * transformation scale y.
+ littleStepH notNil ifTrue:[
+ littleStepH := littleStepH * transformation scale x.
].
- gridPixmap displayPointX:x y:y.
- xp := xp + littleStepH
+ littleStepV notNil ifTrue:[
+ littleStepV := littleStepV * transformation scale y.
+ ].
].
- "copy rest from what has been drawn already"
- yp := yp + bigStepV.
- [yp <= gridH] whileTrue:[
- y := yp rounded.
- hires ifTrue:[
+ bigStepH isNil ifTrue:[^ self].
+
+ self withCursor:(Cursor wait) do:[
+ |xp yp y x|
+
+ "
+ up to next full unit
+ "
+ gridW := ((gridW // bigStepH) + 1 * bigStepH) asInteger.
+ gridH := ((gridH // bigStepV) + 1 * bigStepV) asInteger.
+
+ gridPixmap := Form width:gridW height:gridH depth:1.
+ gridPixmap colorMap:(Array with:White with:Black).
+ gridPixmap clear.
+ gridPixmap paint:(Color colorId:1).
+
+ "draw first row point-by-point"
+ yp := 0.0.
+ xp := 0.0.
+ y := yp asInteger.
+ [xp <= gridW] whileTrue:[
+ x := xp rounded.
+ hires ifTrue:[
+ gridPixmap displayPointX:(x + 1) y:y.
+ gridPixmap displayPointX:(x + 2) y:y
+ ].
+ gridPixmap displayPointX:x y:y.
+ littleStepH notNil ifTrue:[
+ xp := xp + littleStepH
+ ] ifFalse:[
+ xp := xp + bigStepH
+ ]
+ ].
+
+ "copy rest from what has been drawn already"
+ yp := yp + bigStepV.
+ [yp <= gridH] whileTrue:[
+ y := yp rounded.
+ hires ifTrue:[
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:0 y:(y + 1)
+ width:gridW height:1.
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:0 y:(y + 2)
+ width:gridW height:1
+ ].
gridPixmap copyFrom:gridPixmap x:0 y:0
- toX:0 y:(y + 1)
+ toX:0 y:y
width:gridW height:1.
- gridPixmap copyFrom:gridPixmap x:0 y:0
- toX:0 y:(y + 2)
- width:gridW height:1
+ yp := yp + bigStepV
+ ].
+
+ "draw first col point-by-point"
+ xp := 0.0.
+ yp := 0.0.
+ x := xp asInteger.
+ [yp <= gridH] whileTrue:[
+ y := yp rounded.
+ hires ifTrue:[
+ gridPixmap displayPointX:x y:(y + 1).
+ gridPixmap displayPointX:x y:(y + 2)
+ ].
+ gridPixmap displayPointX:x y:y.
+ littleStepV notNil ifTrue:[
+ yp := yp + littleStepV
+ ] ifFalse:[
+ yp := yp + bigStepV
+ ]
].
- gridPixmap copyFrom:gridPixmap x:0 y:0
- toX:0 y:y
- width:gridW height:1.
- yp := yp + bigStepV
+
+ "copy rest from what has been drawn already"
+ xp := xp + bigStepH.
+ [xp <= gridW] whileTrue:[
+ x := xp rounded.
+ hires ifTrue:[
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:(x + 1) y:0
+ width:1 height:gridH.
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:(x + 2) y:0
+ width:1 height:gridH
+ ].
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:x y:0
+ width:1 height:gridH.
+ xp := xp + bigStepH
+ ].
+
+ showDocumentBoundary ifTrue:[
+ "
+ mark the right-end and bottom of the document
+ "
+ gridPixmap displayLineFromX:gridW-1 y:0 toX:gridW-1 y:gridH-1.
+ gridPixmap displayLineFromX:0 y:gridH-1 toX:gridW-1 y:gridH-1.
+ ].
+ ]
+!
+
+newGrid
+ "define a new grid"
+
+ gridPixmap := nil.
+ shown ifTrue:[
+ self viewBackground:White.
+ self clear.
].
- "draw first col point-by-point"
- xp := 0.0.
- yp := 0.0.
- x := xp asInteger.
- [yp <= gridH] whileTrue:[
- y := yp rounded.
- hires ifTrue:[
- gridPixmap displayPointX:x y:(y + 1).
- gridPixmap displayPointX:x y:(y + 2)
- ].
- gridPixmap displayPointX:x y:y.
- yp := yp + littleStepV
+ gridShown ifTrue:[
+ self defineGrid.
+ self viewBackground:gridPixmap.
].
-
- "copy rest from what has been drawn already"
- xp := xp + bigStepH.
- [xp <= gridW] whileTrue:[
- x := xp rounded.
- hires ifTrue:[
- gridPixmap copyFrom:gridPixmap x:0 y:0
- toX:(x + 1) y:0
- width:1 height:gridH.
- gridPixmap copyFrom:gridPixmap x:0 y:0
- toX:(x + 2) y:0
- width:1 height:gridH
- ].
- gridPixmap copyFrom:gridPixmap x:0 y:0
- toX:x y:0
- width:1 height:gridH.
- xp := xp + bigStepH
+ shown ifTrue:[
+ self redraw
].
-
- false ifTrue:[
- "
- mark the right-end and bottom of the document
- "
- gridPixmap displayLineFromX:gridW-1 y:0 toX:gridW-1 y:gridH-1.
- gridPixmap displayLineFromX:0 y:gridH-1 toX:gridW-1 y:gridH-1.
- ].
-
- self cursor:oldCursor
!
showGrid
"show the grid"
gridShown := true.
- gridPixmap isNil ifTrue:[
- self defineGrid.
- ].
- self viewBackground:gridPixmap.
- self redraw
+ self newGrid
!
hideGrid
"hide the grid"
gridShown := false.
- self viewBackground:White.
- self redraw
+ self newGrid
+!
+
+getAlignParameters
+ |params|
+
+ params := self gridParameters.
+ gridAlign := (params at:5) @ (params at:6)
!
alignOn
"align points to grid"
- aligning := true
+ |params|
+
+ aligning := true.
+ self getAlignParameters
!
alignOff
@@ -1679,68 +1882,50 @@
aligning := false
! !
-!ObjectView methodsFor:'user interface'!
-
-alignToGrid:aPoint
- "round aPoint to the next nearest point on the grid"
-
- |mmH mmV aH aV|
-
- aligning ifFalse:[
- ^ aPoint
- ].
-
- mmH := self horizontalPixelPerMillimeter.
- mmV := self verticalPixelPerMillimeter.
-
- (scaleMetric == #mm) ifTrue:[
- "align to mm"
- aH := mmH.
- aV := mmV
- ].
- (scaleMetric == #inch) ifTrue:[
- "align to eights inch"
- aH := mmH * (25.4 / 8).
- aV := mmV * (25.4 / 8)
- ].
-
- ^ (aPoint grid:(aH @ aV)) grid:(1 @ 1)
-!
+!ObjectView methodsFor:'dragging rectangle'!
startRectangleDrag:startPoint
"start a rectangle drag"
self setRectangleDragActions.
dragObject := Rectangle origin:startPoint corner:startPoint.
- self xoring:[self displayRectangle:dragObject].
+ self invertDragRectangle.
oldCursor := cursor.
self cursor:leftHandCursor
!
+endRectangleDrag
+ "cleanup after rectangle drag; select them"
+
+ self invertDragRectangle.
+ self cursor:oldCursor.
+ self selectAllIn:(dragObject + viewOrigin)
+!
+
doRectangleDrag:aPoint
"do drag a rectangle"
- self xoring:[
- self displayRectangle:dragObject.
- dragObject corner:aPoint.
- self displayRectangle:dragObject
- ]
+ self invertDragRectangle.
+ dragObject corner:aPoint.
+ self invertDragRectangle.
!
-endRectangleDrag
- "cleanup after rectangle drag; select them"
+invertDragRectangle
+ "helper for rectangle drag - invert the dragRectangle.
+ Extracted into a separate method to allow easier redefinition
+ (different lineWidth etc)"
self xoring:[self displayRectangle:dragObject].
- self cursor:oldCursor.
- self selectAllIn:(dragObject + viewOrigin)
-!
+! !
+
+!ObjectView methodsFor:'dragging line'!
startLineDrag:startPoint
"start a line drag"
self setLineDragActions.
dragObject := Rectangle origin:startPoint corner:startPoint.
- self xoring:[self displayLineFrom:dragObject origin to:dragObject corner].
+ self invertDragLine.
oldCursor := cursor.
self cursor:leftHandCursor
!
@@ -1751,7 +1936,7 @@
self setLineDragActions.
rootMotion := true.
dragObject := Rectangle origin:startPoint corner:startPoint.
- self xoring:[self displayLineFrom:dragObject origin to:dragObject corner].
+ self invertDragLine.
oldCursor := cursor.
self cursor:leftHandCursor
!
@@ -1772,11 +1957,9 @@
offs2 := 0@0.
].
- dragger xoring:[
- dragger displayLineFrom:dragObject origin-offs2 to:dragObject corner-offs2.
- dragObject corner:aPoint.
- dragger displayLineFrom:dragObject origin-offs2 to:dragObject corner-offs2
- ]
+ self invertDragLine.
+ dragObject corner:aPoint.
+ self invertDragLine.
!
endLineDrag
@@ -1874,62 +2057,15 @@
^ self notify:'dont know how to connect to external views'
!
-selectMore:aPoint
- "add/remove an object from the selection"
-
- |anObject|
-
- anObject := self findObjectAtVisible:aPoint.
- anObject notNil ifTrue:[
- (self isSelected:anObject) ifTrue:[
- "remove from selection"
- self removeFromSelection:anObject
- ] ifFalse:[
- "add to selection"
- self addToSelection:anObject
- ]
- ].
- ^ self
-!
-
-startSelectOrMove:aPoint
- "start a rectangleDrag or objectMove - if aPoint hits an object,
- an object move is started, otherwise a rectangleDrag"
-
- |anObject|
+invertDragLine
+ "helper for line dragging - invert the dragged line.
+ Extracted for easier redefinition in subclasses
+ (different line width etc.)"
- anObject := self findObjectAtVisible:aPoint.
- anObject notNil ifTrue:[
- (self isSelected:anObject) ifFalse:[self unselect].
- self startObjectMove:anObject at:aPoint.
- ^ self
- ].
- "nothing was hit by this click - this starts a group select"
- self unselect.
- self startRectangleDrag:aPoint
-!
-
-startSelectMoreOrMove:aPoint
- "add/remove object hit by aPoint, then start a rectangleDrag or move
- - if aPoint hits an object, a move is started, otherwise a rectangleDrag"
+ self xoring:[self displayLineFrom:dragObject origin to:dragObject corner].
+! !
- |anObject|
-
- anObject := self findObjectAtVisible:aPoint.
- anObject notNil ifTrue:[
- (self isSelected:anObject) ifTrue:[
- "remove from selection"
- self removeFromSelection:anObject
- ] ifFalse:[
- "add to selection"
- self addToSelection:anObject
- ].
- self startObjectMove:selection at:aPoint.
- ^ self
- ].
- self unselect.
- self startRectangleDrag:aPoint
-!
+!ObjectView methodsFor:'dragging object move'!
startObjectMove:something at:aPoint
"start an object move"
@@ -1947,43 +2083,6 @@
]
!
-doObjectMove:aPoint
- "do an object move"
-
- |dragger offs2|
-
- rootMotion ifTrue:[
- dragger := rootView.
- offs2 := viewOrigin.
- ] ifFalse:[
- dragger := self.
- offs2 := 0@0.
- ].
- movedObject isNil ifTrue:[
- movedObject := selection.
- "
- draw first outline
- "
- movedObject notNil ifTrue:[
- moveDelta := 0@0.
- dragger xoring:[
- self showDragging:movedObject offset:(self alignToGrid:(moveDelta - offs2))
- ]
- ]
- ].
- movedObject notNil ifTrue:[
- "
- clear prev outline,
- draw new outline
- "
- dragger xoring:[
- self showDragging:movedObject offset:(self alignToGrid:(moveDelta - offs2)).
- moveDelta := aPoint - moveStartPoint.
- self showDragging:movedObject offset:(self alignToGrid:(moveDelta - offs2))
- ]
- ]
-!
-
endObjectMove
"cleanup after object move - find the destination view and dispatch to
one of the moveObjectXXX-methods. These can be redefined in subclasses."
@@ -2000,8 +2099,7 @@
offs2 := 0@0
].
dragger xoring:[
- self showDragging:movedObject
- offset:(self alignToGrid:(moveDelta - offs2))
+ self showDragging:movedObject offset:moveDelta - offs2
].
dragger device synchronizeOutput.
@@ -2046,131 +2144,76 @@
self setDefaultActions.
movedObject := nil
]
-! !
-
-!ObjectView methodsFor:'events'!
-
-buttonPress:button x:x y:y
- "user pressed left button"
-
- ((button == 1) or:[button == #select]) ifTrue:[
- pressAction notNil ifTrue:[
- lastButt := x @ y.
- pressAction value:lastButt
- ]
- ] ifFalse:[
- super buttonPress:button x:x y:y
- ]
-!
-
-buttonShiftPress:button x:x y:y
- "user pressed left button with shift"
-
- ((button == 1) or:[button == #select]) ifTrue:[
- shiftPressAction notNil ifTrue:[
- lastButt := x @ y.
- shiftPressAction value:lastButt
- ]
- ] ifFalse:[
- super buttonShiftPress:button x:x y:y
- ]
-!
-
-buttonMultiPress:button x:x y:y
- "user pressed left button twice (or more)"
-
- ((button == 1) or:[button == #select]) ifTrue:[
- doublePressAction notNil ifTrue:[
- doublePressAction value:(x @ y)
- ]
- ] ifFalse:[
- super buttonMultiPress:button x:x y:y
- ]
!
-buttonMotion:button x:buttX y:buttY
- "user moved mouse while button pressed"
+doObjectMove:aPoint
+ "do an object move.
+ moveStartPoint is the original click-point.
+ moveDelta"
- |xpos ypos movePoint|
-
- (lastButt == nil) ifFalse:[
- xpos := buttX.
- ypos := buttY.
+ |dragger offset d p|
- "check against view limits if move outside is not allowed"
- rootMotion ifFalse:[
- (xpos < 0) ifTrue:[
- xpos := 0
- ] ifFalse: [
- (xpos > width) ifTrue:[xpos := width]
- ].
- (ypos < 0) ifTrue:[
- ypos := 0
- ] ifFalse: [
- (ypos > height) ifTrue:[ypos := height]
- ]
- ].
- movePoint := xpos @ ypos.
+ rootMotion ifTrue:[
+ dragger := rootView.
+ offset := viewOrigin.
+ ] ifFalse:[
+ dragger := self.
+ offset := 0@0.
+ ].
- (xpos == (lastButt x)) ifTrue:[
- (ypos == (lastButt y)) ifTrue:[
- ^ self "no move"
- ]
- ].
-
- motionAction notNil ifTrue:[
- motionAction value:movePoint
- ].
- lastButt := movePoint
- ]
-!
+ "
+ when drawing in the root window, we have to use its coordinates
+ this is kept in offset.
+ "
+ movedObject isNil ifTrue:[
+ movedObject := selection.
+ "
+ draw first outline
+ "
+ movedObject notNil ifTrue:[
+ moveDelta := 0@0.
-buttonRelease:button x:x y:y
- ((button == 1) or:[button == #select]) ifTrue:[
- releaseAction notNil ifTrue:[releaseAction value]
- ] ifFalse:[
- super buttonRelease:button x:x y:y
- ]
-!
+ dragger xoring:[
+ "tricky, the moved object may not currently be aligned.
+ if so, simulate a frame move of the delta"
-keyPress:key x:x y:y
- keyPressAction notNil ifTrue:[
- selection notNil ifTrue:[
- self selectionDo: [:obj |
- obj keyInput:key
+ aligning ifTrue:[
+ d := movedObject origin
+ - (self alignToGrid:(movedObject origin)).
+d printNL.
+ moveDelta := d negated.
+].
+moveDelta printNL.
+ self showDragging:movedObject offset:moveDelta - offset.
]
]
- ]
-!
-
-redrawX:x y:y width:w height:h
- |innerX innerY innerW innerH redrawFrame |
-
- innerX := x.
- innerY := y.
- innerW := w.
- innerH := h.
- scaleShown ifTrue:[
- (x < leftMarginForScale) ifTrue:[
- self redrawVerticalScale.
- innerW := w - (leftMarginForScale - x).
- innerX := leftMarginForScale
- ].
- (y < topMarginForScale) ifTrue:[
- self redrawHorizontalScale.
- innerH := h - (topMarginForScale - y).
- innerY := topMarginForScale
+ ].
+ movedObject notNil ifTrue:[
+ "
+ clear prev outline,
+ draw new outline
+ "
+ dragger xoring:[
+ self showDragging:movedObject offset:moveDelta - offset.
+ moveDelta := aPoint - moveStartPoint.
+ aligning ifTrue:[
+ moveDelta := self alignToGrid:moveDelta
+ ].
+ self showDragging:movedObject offset:moveDelta - offset.
]
- ].
- ((contents size ~~ 0) or:[gridShown]) ifTrue:[
- redrawFrame := Rectangle left:innerX top:innerY
- width:innerW height:innerH.
- self redrawObjectsInVisible:redrawFrame
]
! !
!ObjectView methodsFor:'saving / restoring'!
+initializeFileInObject:anObject
+ "each object may be processed here after its being filed-in
+ - subclasses may do whatever they want here ...
+ (see LogicView for example)"
+
+ ^ self
+!
+
storeContentsOn:aStream
"store the contents in textual representation on aStream.
Notice, that for huge objects (such as DrawImages) this ascii output
@@ -2190,14 +2233,6 @@
]
!
-initializeFileInObject:anObject
- "each object may be processed here after its being filed-in
- - subclasses may do whatever they want here ...
- (see LogicView for example)"
-
- ^ self
-!
-
withoutRedrawFileInContentsFrom:aStream
self fileInContentsFrom:aStream redraw:false
!
@@ -2208,13 +2243,6 @@
self fileInContentsFrom:aStream redraw:true
!
-fileInContentsFrom:aStream redraw:redraw
- "remove all objects, load new contents from aStream
- and redraw if the redraw argument is true"
-
- self fileInContentsFrom:aStream redraw:redraw new:true
-!
-
fileInContentsFrom:aStream redraw:redraw new:new
"if the new argument is true, remove all objects.
Then load objects from aStream,
@@ -2240,4 +2268,12 @@
]
].
]
+!
+
+fileInContentsFrom:aStream redraw:redraw
+ "remove all objects, load new contents from aStream
+ and redraw if the redraw argument is true"
+
+ self fileInContentsFrom:aStream redraw:redraw new:true
! !
+
--- a/ObjectView.st Thu Nov 17 15:34:12 1994 +0100
+++ b/ObjectView.st Thu Nov 17 15:38:53 1994 +0100
@@ -10,27 +10,19 @@
hereby transferred.
"
+'From Smalltalk/X, Version:2.10.4 on 7-nov-1994 at 1:19:10'!
+
View subclass:#ObjectView
- instanceVariableNames:'contents
- sorted
- lastButt lastPointer lastButtonTime
- pressAction releaseAction
- shiftPressAction doublePressAction
- motionAction keyPressAction
- selection
- gridShown gridPixmap
- scaleShown scaleMetric
- dragObject
- leftHandCursor readCursor oldCursor
- movedObject moveStartPoint
- moveDelta
- buffer
- documentFormat
- leftMarginForScale topMarginForScale
- canDragOutOfView rootMotion rootView aligning'
- classVariableNames:''
- poolDictionaries:''
- category:'Views-Basic'
+ instanceVariableNames:'contents sorted lastButt lastPointer lastButtonTime pressAction
+ releaseAction shiftPressAction doublePressAction motionAction
+ keyPressAction selection gridShown gridPixmap
+ scaleMetric dragObject leftHandCursor readCursor oldCursor
+ movedObject moveStartPoint moveDelta buffer documentFormat
+ canDragOutOfView rootMotion
+ rootView aligning gridAlign'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Basic'
!
ObjectView comment:'
@@ -56,7 +48,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/ObjectView.st,v 1.10 1994-10-28 03:25:14 claus Exp $
+$Header: /cvs/stx/stx/libwidg/ObjectView.st,v 1.11 1994-11-17 14:38:16 claus Exp $
"
!
@@ -75,102 +67,147 @@
hitDelta
"when clicking an object, allow for hitDelta pixels around object;
0 is exact; 1*pixelPerMillimeter is good for draw programs"
+
^ 0
! !
-!ObjectView methodsFor:'initialization'!
+!ObjectView methodsFor:'events'!
-initialize
- |pixPerMM|
-
- super initialize.
-
- viewBackground := White.
+redrawX:x y:y width:w height:h
+ |innerX innerY innerW innerH redrawFrame |
- bitGravity := #NorthWest.
- contents := OrderedCollection new.
- gridShown := false.
- scaleShown := false.
- canDragOutOfView := false.
- rootView := DisplayRootView new.
- rootView noClipByChildren.
- rootMotion := false.
- (Language == #english) ifTrue:[
- documentFormat := 'letter'.
- scaleMetric := #inch
- ] ifFalse:[
- documentFormat := 'a4'.
- scaleMetric := #mm
- ].
- pixPerMM := self verticalPixelPerMillimeter:1.
- topMarginForScale := ((pixPerMM * 2.0) + 0.5) asInteger.
- pixPerMM := self horizontalPixelPerMillimeter:1.
- leftMarginForScale := ((pixPerMM * 2.0) + 0.5) asInteger.
- readCursor := Cursor read.
- leftHandCursor := Cursor leftHand.
- sorted := false.
- aligning := false
+ innerX := x.
+ innerY := y.
+ innerW := w.
+ innerH := h.
+
+ ((contents size ~~ 0) or:[gridShown]) ifTrue:[
+ redrawFrame := Rectangle left:innerX top:innerY
+ width:innerW height:innerH.
+ self redrawObjectsInVisible:redrawFrame
+ ]
!
-initEvents
- self backingStore:true.
- self enableButtonEvents.
- self enableButtonMotionEvents
+buttonMotion:buttonMask x:buttX y:buttY
+ "user moved mouse while button pressed"
+
+ |xpos ypos movePoint limitW limitH|
+
+ "is it the select or 1-button ?"
+ (device buttonMotionMask:buttonMask includesButton:#select) ifFalse:[
+ (device buttonMotionMask:buttonMask includesButton:1) ifFalse:[
+ ^ self
+ ].
+ ].
+
+ lastButt notNil ifTrue:[
+ xpos := buttX.
+ ypos := buttY.
+
+ "check against visible limits if move outside is not allowed"
+ rootMotion ifFalse:[
+ limitW := width.
+ limitH := height.
+ transformation notNil ifTrue:[
+ limitW := transformation applyInverseToX:width.
+ limitH := transformation applyInverseToY:height.
+ ].
+
+ (xpos < 0) ifTrue:[
+ xpos := 0
+ ] ifFalse: [
+ (xpos > limitW) ifTrue:[xpos := limitW]
+ ].
+ (ypos < 0) ifTrue:[
+ ypos := 0
+ ] ifFalse: [
+ (ypos > limitH) ifTrue:[ypos := limitH]
+ ]
+ ].
+ movePoint := xpos @ ypos.
+
+ (xpos == (lastButt x)) ifTrue:[
+ (ypos == (lastButt y)) ifTrue:[
+ ^ self "no move"
+ ]
+ ].
+
+ motionAction notNil ifTrue:[
+ motionAction value:movePoint
+ ].
+ lastButt := movePoint
+ ]
+!
+
+buttonPress:button x:x y:y
+ "user pressed left button"
+
+ ((button == 1) or:[button == #select]) ifTrue:[
+ pressAction notNil ifTrue:[
+ lastButt := x @ y.
+ pressAction value:lastButt
+ ]
+ ] ifFalse:[
+ super buttonPress:button x:x y:y
+ ]
+!
+
+buttonRelease:button x:x y:y
+ ((button == 1) or:[button == #select]) ifTrue:[
+ releaseAction notNil ifTrue:[releaseAction value]
+ ] ifFalse:[
+ super buttonRelease:button x:x y:y
+ ]
+!
+
+buttonShiftPress:button x:x y:y
+ "user pressed left button with shift"
+
+ ((button == 1) or:[button == #select]) ifTrue:[
+ shiftPressAction notNil ifTrue:[
+ lastButt := x @ y.
+ shiftPressAction value:lastButt
+ ]
+ ] ifFalse:[
+ super buttonShiftPress:button x:x y:y
+ ]
+!
+
+buttonMultiPress:button x:x y:y
+ "user pressed left button twice (or more)"
+
+ ((button == 1) or:[button == #select]) ifTrue:[
+ doublePressAction notNil ifTrue:[
+ doublePressAction value:(x @ y)
+ ]
+ ] ifFalse:[
+ super buttonMultiPress:button x:x y:y
+ ]
+!
+
+keyPress:key x:x y:y
+ keyPressAction notNil ifTrue:[
+ selection notNil ifTrue:[
+ self selectionDo: [:obj |
+ obj keyInput:key
+ ]
+ ]
+ ]
! !
!ObjectView methodsFor:'queries'!
-heightOfContentsInMM
- "answer the height of the document in millimeters"
+heightOfContents
+ "answer the height of the document in pixels"
- "landscape"
- (documentFormat = 'a1l') ifTrue:[
- ^ 592
- ].
- (documentFormat = 'a2l') ifTrue:[
- ^ 420
- ].
- (documentFormat = 'a3l') ifTrue:[
- ^ 296
- ].
- (documentFormat = 'a4l') ifTrue:[
- ^ 210
- ].
- (documentFormat = 'a5l') ifTrue:[
- ^ 148
- ].
- (documentFormat = 'a6l') ifTrue:[
- ^ 105
- ].
- (documentFormat = 'letterl') ifTrue:[
- ^ 8.5 * 25.4
- ].
+ |h|
- (documentFormat = 'a1') ifTrue:[
- ^ 840
- ].
- (documentFormat = 'a2') ifTrue:[
- ^ 592
- ].
- (documentFormat = 'a3') ifTrue:[
- ^ 420
- ].
- (documentFormat = 'a4') ifTrue:[
- ^ 296
+ h := self heightOfContentsInMM * (self verticalPixelPerMillimeter:1).
+
+ transformation isNil ifTrue:[
+ ^ h rounded
].
- (documentFormat = 'a5') ifTrue:[
- ^ 210
- ].
- (documentFormat = 'a6') ifTrue:[
- ^ 148
- ].
- (documentFormat = 'letter') ifTrue:[
- ^ 11 * 25.4
- ].
- "*** more formats needed here ...***"
-
- "assuming window size is document size"
- ^ (height / self verticalPixelPerMillimeter:1) asInteger
+ ^ (transformation applyScaleY:h) rounded
!
widthOfContentsInMM
@@ -226,117 +263,242 @@
^ (width / self horizontalPixelPerMillimeter:1) asInteger
!
-heightOfContents
- "answer the height of the document in pixels"
+heightOfContentsInMM
+ "answer the height of the document in millimeters"
+
+ "landscape"
+ (documentFormat = 'a1l') ifTrue:[
+ ^ 592
+ ].
+ (documentFormat = 'a2l') ifTrue:[
+ ^ 420
+ ].
+ (documentFormat = 'a3l') ifTrue:[
+ ^ 296
+ ].
+ (documentFormat = 'a4l') ifTrue:[
+ ^ 210
+ ].
+ (documentFormat = 'a5l') ifTrue:[
+ ^ 148
+ ].
+ (documentFormat = 'a6l') ifTrue:[
+ ^ 105
+ ].
+ (documentFormat = 'letterl') ifTrue:[
+ ^ 8.5 * 25.4
+ ].
- ^ ((self heightOfContentsInMM
- * (self verticalPixelPerMillimeter:1)) + 0.5) asInteger
+ (documentFormat = 'a1') ifTrue:[
+ ^ 840
+ ].
+ (documentFormat = 'a2') ifTrue:[
+ ^ 592
+ ].
+ (documentFormat = 'a3') ifTrue:[
+ ^ 420
+ ].
+ (documentFormat = 'a4') ifTrue:[
+ ^ 296
+ ].
+ (documentFormat = 'a5') ifTrue:[
+ ^ 210
+ ].
+ (documentFormat = 'a6') ifTrue:[
+ ^ 148
+ ].
+ (documentFormat = 'letter') ifTrue:[
+ ^ 11 * 25.4
+ ].
+ "*** more formats needed here ...***"
+
+ "assuming window size is document size"
+ ^ (height / self verticalPixelPerMillimeter:1) asInteger
!
widthOfContents
"answer the width of the document in pixels"
- ^ ((self widthOfContentsInMM
- * (self horizontalPixelPerMillimeter:1)) + 0.5) asInteger
+ |w|
+
+ w := self widthOfContentsInMM * (self horizontalPixelPerMillimeter:1).
+
+ transformation isNil ifTrue:[
+ ^ w rounded
+ ].
+ ^ (transformation applyScaleX:w) rounded
+! !
+
+!ObjectView methodsFor:'user interface'!
+
+alignToGrid:aPoint
+ "round aPoint to the next nearest point on the grid"
+
+ |p0 pG|
+
+ aligning ifFalse:[
+ ^ aPoint
+ ].
+
+ viewOrigin ~= (0@0) ifTrue:[
+ p0 := aPoint - viewOrigin.
+ pG := (p0 grid:gridAlign) rounded. "/grid:(1 @ 1).
+ ^ pG + viewOrigin
+ ].
+ ^ (aPoint grid:gridAlign) rounded
+!
+
+startSelectOrMove:aPoint
+ "start a rectangleDrag or objectMove - if aPoint hits an object,
+ an object move is started, otherwise a rectangleDrag.
+ This is typically the button pressAction."
+
+ |anObject|
+
+ anObject := self findObjectAtVisible:aPoint.
+ anObject notNil ifTrue:[
+ (self isSelected:anObject) ifFalse:[self unselect].
+ self startObjectMove:anObject at:aPoint.
+ ^ self
+ ].
+ "nothing was hit by this click - this starts a group select"
+ self unselect.
+ self startRectangleDrag:aPoint
+!
+
+selectMore:aPoint
+ "add/remove an object from the selection"
+
+ |anObject|
+
+ anObject := self findObjectAtVisible:aPoint.
+ anObject notNil ifTrue:[
+ (self isSelected:anObject) ifTrue:[
+ "remove from selection"
+ self removeFromSelection:anObject
+ ] ifFalse:[
+ "add to selection"
+ self addToSelection:anObject
+ ]
+ ].
+ ^ self
+!
+
+startSelectMoreOrMove:aPoint
+ "add/remove object hit by aPoint, then start a rectangleDrag or move
+ - if aPoint hits an object, a move is started, otherwise a rectangleDrag.
+ This is typically the button shiftPressAction."
+
+ |anObject|
+
+ anObject := self findObjectAtVisible:aPoint.
+ anObject notNil ifTrue:[
+ (self isSelected:anObject) ifTrue:[
+ "remove from selection"
+ self removeFromSelection:anObject
+ ] ifFalse:[
+ "add to selection"
+ self addToSelection:anObject
+ ].
+ self startObjectMove:selection at:aPoint.
+ ^ self
+ ].
+ self unselect.
+ self startRectangleDrag:aPoint
+! !
+
+!ObjectView methodsFor:'initialization'!
+
+setInitialDocumentFormat
+ (Language == #english) ifTrue:[
+ documentFormat := 'letter'.
+ scaleMetric := #inch
+ ] ifFalse:[
+ documentFormat := 'a4'.
+ scaleMetric := #mm
+ ].
+!
+
+initialize
+ |pixPerMM|
+
+ super initialize.
+
+ viewBackground := White.
+
+ bitGravity := #NorthWest.
+ contents := OrderedCollection new.
+ gridShown := false.
+
+ canDragOutOfView := false.
+ rootView := DisplayRootView new.
+ rootView noClipByChildren.
+ rootMotion := false.
+ self setInitialDocumentFormat.
+
+ readCursor := Cursor read.
+ leftHandCursor := Cursor leftHand.
+ sorted := false.
+ aligning := false
+!
+
+initEvents
+ self backingStore:true.
+ self enableButtonEvents.
+ self enableButtonMotionEvents
! !
!ObjectView methodsFor:'drawing'!
+redrawObjectsInVisible:visRect
+ "redraw all objects which have part of themselfes in a vis rectangle
+ draw only in (i.e. clip output to) aRectangle"
+
+ |vis|
+
+ shown ifTrue:[
+ vis := visRect.
+ clipRect notNil ifTrue:[
+ vis := vis intersect:clipRect
+ ].
+ transformation notNil ifTrue:[
+ vis := vis origin truncated
+ corner:(vis corner + (1@1)) truncated.
+ ].
+
+ self clippedTo:vis do:[
+ self clearRectangle:vis.
+ self redrawObjectsIntersectingVisible:vis
+ ]
+ ]
+!
+
+redrawObjectsIntersectingVisible:aRectangle
+ "redraw all objects which have part of themself in a vis rectangle"
+
+ self objectsIntersectingVisible:aRectangle do:[:theObject |
+ self show:theObject
+ ]
+
+!
+
redraw
"redraw complete View"
- shown "realized" ifTrue:[
-"/ gridShown ifTrue:[
-"/ self redrawGrid
-"/ ] ifFalse:[
-"/ self fill:viewBackground
-"/ ].
-self clear.
- scaleShown ifTrue:[
- self redrawScale
- ].
+ shown ifTrue:[
+ self clear.
self redrawObjects
]
!
-redrawGrid
- "redraw the grid"
-
- gridPixmap notNil ifTrue:[
- self clear.
- self paint:Black on:White.
- self displayOpaqueForm:gridPixmap x:viewOrigin x negated
- y:viewOrigin y negated
- ]
-!
-
-redrawHorizontalScale
- "redraw the horizontal scale"
-
- |x mmH short step xRounded shortLen longLen len|
-
- self clearRectangle:((0 @ 0) corner:(width @ topMarginForScale)).
- scaleShown ifFalse:[^ self].
- (scaleMetric == #mm) ifTrue:[
- "long blibs every centimeter; short ones every half"
+redrawObjectsIntersecting:aRectangle
+ "redraw all objects which have part of themself in aRectangle"
- mmH := self horizontalPixelPerMillimeter.
- step := mmH * 5.0.
- x := step.
- short := true.
- shortLen := (topMarginForScale / 2) asInteger.
- longLen := topMarginForScale.
- [x < width] whileTrue:[
- xRounded := (x + 0.5) asInteger.
- short ifTrue:[
- len := shortLen
- ] ifFalse:[
- len := longLen
- ].
- self displayLineFromX:xRounded y:0 toX:xRounded y:len.
- short := short not.
- x := x + step
- ]
+ self objectsIntersecting:aRectangle do:[:theObject |
+ self show:theObject
]
!
-redrawVerticalScale
- "redraw the vertical scale"
-
- |y mmV short step yRounded shortLen longLen len|
-
- self clearRectangle:((0 @ 0) corner:(leftMarginForScale @ height)).
- scaleShown ifFalse:[^ self].
- (scaleMetric == #mm) ifTrue:[
- "long blibs every centimeter; short ones every half"
-
- mmV := self verticalPixelPerMillimeter.
- step := mmV * 5.0.
- y := step.
- short := true.
- shortLen := (leftMarginForScale / 2) asInteger.
- longLen := leftMarginForScale.
- [y < height] whileTrue:[
- yRounded := (y + 0.5) asInteger.
- short ifTrue:[
- len := shortLen
- ] ifFalse:[
- len := longLen
- ].
- self displayLineFromX:0 y:yRounded toX:len y:yRounded.
- short := short not.
- y := y + step
- ]
- ]
-!
-
-redrawScale
- "redraw the scales"
-
- self redrawHorizontalScale.
- self redrawVerticalScale
-!
-
redrawObjectsOn:aGC
"redraw all objects on a graphic context"
@@ -344,7 +506,7 @@
(aGC == self) ifTrue:[
shown "realized" ifFalse:[^ self].
- org := viewOrigin + (leftMarginForScale @ topMarginForScale).
+ org := viewOrigin.
vFrame := Rectangle origin:org
corner:(viewOrigin + (width @ height)).
@@ -371,137 +533,6 @@
self redrawObjectsOn:self
!
-redrawObjectsIntersecting:aRectangle
- "redraw all objects which have part of themself in aRectangle"
-
- self objectsIntersecting:aRectangle do:[:theObject |
- self show:theObject
- ]
-!
-
-redrawObjectsIntersectingVisible:aRectangle
- "redraw all objects which have part of themself in a vis rectangle"
-
- self objectsIntersectingVisible:aRectangle do:[:theObject |
- self show:theObject
- ]
-
-!
-
-redrawObjectsAbove:anObject intersecting:aRectangle
- "redraw all objects which have part of themself in aRectangle
- and are above (in front of) anObject"
-
- self objectsAbove:anObject intersecting:aRectangle do:[:theObject |
- self show:theObject
- ]
-!
-
-redrawObjectsAbove:anObject intersectingVisible:aRectangle
- "redraw all objects which have part of themself in a vis rectangle
- and are above (in front of) anObject"
-
- self objectsAbove:anObject intersectingVisible:aRectangle do:[:theObject |
- self show:theObject
- ]
-!
-
-redrawObjectsIn:aRectangle
- "redraw all objects which have part of themselfes in aRectangle
- draw only in (i.e. clip output to) aRectangle"
-
- |visRect|
-
- shown "realized" ifTrue:[
- visRect := Rectangle origin:(aRectangle origin - viewOrigin)
- extent:(aRectangle extent).
- clipRect notNil ifTrue:[
- visRect := visRect intersect:clipRect
- ].
- self clippedTo:visRect do:[
-self clearRectangle:visRect.
-"/ gridShown ifTrue:[
-"/ self redrawGrid
-"/ ] ifFalse:[
-"/ self paint:viewBackground.
-"/ self fillRectangle:visRect
-"/ ].
- self redrawObjectsIntersecting:aRectangle
- ]
- ]
-!
-
-redrawObjectsInVisible:visRect
- "redraw all objects which have part of themselfes in a vis rectangle
- draw only in (i.e. clip output to) aRectangle"
-
- |vis|
-
- shown "realized" ifTrue:[
- vis := visRect.
- clipRect notNil ifTrue:[
- vis := vis intersect:clipRect
- ].
-
- self clippedTo:vis do:[
-"/ gridShown ifTrue:[
-"/ self redrawGrid
-"/ ] ifFalse:[
-"/ self paint:viewBackground.
-"/ self fillRectangle:vis
-"/ ].
-self clearRectangle:vis.
- self redrawObjectsIntersectingVisible:vis
- ]
- ]
-!
-
-redrawObjectsAbove:anObject in:aRectangle
- "redraw all objects which have part of themselfes in aRectangle
- and are above (in front of) anObject.
- draw only in (i.e. clip output to) aRectangle"
-
- |vis|
-
- shown "realized" ifTrue:[
- vis := aRectangle.
- clipRect notNil ifTrue:[
- vis := vis intersect:clipRect
- ].
- self clippedTo:vis do:[
- self redrawObjectsAbove:anObject intersecting:vis
- ]
- ]
-!
-
-redrawObjectsAbove:anObject inVisible:aRectangle
- "redraw all objects which have part of themselfes in a vis rectangle
- and are above (in front of) anObject.
- draw only in (i.e. clip output to) aRectangle"
-
- |vis|
-
- shown "realized" ifTrue:[
- vis := aRectangle.
- clipRect notNil ifTrue:[
- vis := vis intersect:clipRect
- ].
- self clippedTo:vis do:[
- self redrawObjectsAbove:anObject intersectingVisible:vis
- ]
- ]
-!
-
-show:anObject
- "show the object, either selected or not"
-
- (self isSelected:anObject) ifTrue:[
- self showSelected:anObject
- ] ifFalse:[
- self showUnselected:anObject
- ]
-!
-
showDragging:something offset:anOffset
"show an object while dragging"
@@ -523,6 +554,100 @@
]
!
+redrawObjectsIn:aRectangle
+ "redraw all objects which have part of themselfes in aRectangle
+ draw only in (i.e. clip output to) aRectangle"
+
+ |visRect|
+
+ shown ifTrue:[
+ visRect := Rectangle origin:(aRectangle origin - viewOrigin)
+ extent:(aRectangle extent).
+ clipRect notNil ifTrue:[
+ visRect := visRect intersect:clipRect
+ ].
+ transformation notNil ifTrue:[
+ visRect := visRect origin truncated
+ corner:(visRect corner + (1@1)) truncated.
+ ].
+ self clippedTo:visRect do:[
+ self clearRectangle:visRect.
+ self redrawObjectsIntersecting:aRectangle
+ ]
+ ]
+!
+
+redrawScale
+ "redraw the scales"
+
+ self redrawHorizontalScale.
+ self redrawVerticalScale
+!
+
+redrawObjectsAbove:anObject intersecting:aRectangle
+ "redraw all objects which have part of themself in aRectangle
+ and are above (in front of) anObject"
+
+ self objectsAbove:anObject intersecting:aRectangle do:[:theObject |
+ self show:theObject
+ ]
+!
+
+redrawObjectsAbove:anObject intersectingVisible:aRectangle
+ "redraw all objects which have part of themself in a vis rectangle
+ and are above (in front of) anObject"
+
+ self objectsAbove:anObject intersectingVisible:aRectangle do:[:theObject |
+ self show:theObject
+ ]
+!
+
+redrawObjectsAbove:anObject in:aRectangle
+ "redraw all objects which have part of themselfes in aRectangle
+ and are above (in front of) anObject.
+ draw only in (i.e. clip output to) aRectangle"
+
+ |vis|
+
+ shown ifTrue:[
+ vis := aRectangle.
+ clipRect notNil ifTrue:[
+ vis := vis intersect:clipRect
+ ].
+ self clippedTo:vis do:[
+ self redrawObjectsAbove:anObject intersecting:vis
+ ]
+ ]
+!
+
+redrawObjectsAbove:anObject inVisible:aRectangle
+ "redraw all objects which have part of themselfes in a vis rectangle
+ and are above (in front of) anObject.
+ draw only in (i.e. clip output to) aRectangle"
+
+ |vis|
+
+ shown ifTrue:[
+ vis := aRectangle.
+ clipRect notNil ifTrue:[
+ vis := vis intersect:clipRect
+ ].
+ self clippedTo:vis do:[
+ self redrawObjectsAbove:anObject intersectingVisible:vis
+ ]
+ ]
+!
+
+show:anObject
+ "show the object, either selected or not"
+
+ (self isSelected:anObject) ifTrue:[
+ self showSelected:anObject
+ ] ifFalse:[
+ self showUnselected:anObject
+ ]
+!
+
showSelected:anObject
"show an object as selected"
@@ -537,6 +662,34 @@
!ObjectView methodsFor:'selections'!
+unselect
+ "unselect - hide selection; clear selection buffer"
+
+ self hideSelection.
+ selection := nil
+!
+
+select:something
+ "select something - hide previouse selection, set to something and hilight"
+
+ (selection == something) ifFalse:[
+ self hideSelection.
+ selection := something.
+ self showSelection
+ ]
+!
+
+withSelectionHiddenDo:aBlock
+ "evaluate aBlock while selection is hidden"
+
+ |sel|
+
+ sel := selection.
+ self unselect.
+ aBlock value.
+ self select:sel
+!
+
selectionDo:aBlock
"apply block to every object in selection"
@@ -559,23 +712,6 @@
]
!
-unselect
- "unselect - hide selection; clear selection buffer"
-
- self hideSelection.
- selection := nil
-!
-
-select:something
- "select something - hide previouse selection, set to something and hilight"
-
- (selection == something) ifFalse:[
- self hideSelection.
- selection := something.
- self showSelection
- ]
-!
-
selectAll
"select all objects"
@@ -610,23 +746,6 @@
self showUnselected:anObject
!
-selectAllIntersecting:aRectangle
- "select all objects touched by aRectangle"
-
- self hideSelection.
- selection := OrderedCollection new.
-
- self objectsIntersecting:aRectangle do:[:theObject |
- selection add:theObject
- ].
- (selection size == 0) ifTrue:[
- selection := nil
- ] ifFalse:[
- (selection size == 1) ifTrue:[selection := selection first]
- ].
- self showSelection
-!
-
selectAllIn:aRectangle
"select all objects fully in aRectangle"
@@ -643,19 +762,56 @@
self showSelection
!
-withSelectionHiddenDo:aBlock
- "evaluate aBlock while selection is hidden"
+selectAllIntersecting:aRectangle
+ "select all objects touched by aRectangle"
- |sel|
+ self hideSelection.
+ selection := OrderedCollection new.
- sel := selection.
- self unselect.
- aBlock value.
- self select:sel
+ self objectsIntersecting:aRectangle do:[:theObject |
+ selection add:theObject
+ ].
+ (selection size == 0) ifTrue:[
+ selection := nil
+ ] ifFalse:[
+ (selection size == 1) ifTrue:[selection := selection first]
+ ].
+ self showSelection
! !
!ObjectView methodsFor:'testing objects'!
+frameOf:anObjectOrCollection
+ "answer the maximum extent defined by the argument, anObject or a
+ collection of objects"
+
+ |first frameAll|
+
+ anObjectOrCollection isNil ifTrue:[^ nil ].
+ first := true.
+ self forEach:anObjectOrCollection do:[:theObject |
+ first ifTrue:[
+ frameAll := theObject frame.
+ first := false
+ ] ifFalse:[
+ frameAll := frameAll merge:(theObject frame)
+ ]
+ ].
+ ^ frameAll
+!
+
+isObscured:something
+ "return true, if the argument something, anObject or a collection of
+ objects is obscured (partially or whole) by any other object"
+
+ self forEach:something do:[:anObject |
+ (self objectIsObscured:anObject) ifTrue:[
+ ^ true
+ ]
+ ].
+ ^ false
+!
+
findObjectAt:aPoint
"find the last object (by looking from back to front) which is hit by
the argument, aPoint - this is the topmost object hit"
@@ -700,25 +856,6 @@
^ self findObjectAt:(aPoint + viewOrigin) suchThat:aBlock
!
-frameOf:anObjectOrCollection
- "answer the maximum extent defined by the argument, anObject or a
- collection of objects"
-
- |first frameAll|
-
- anObjectOrCollection isNil ifTrue:[^ nil ].
- first := true.
- self forEach:anObjectOrCollection do:[:theObject |
- first ifTrue:[
- frameAll := theObject frame.
- first := false
- ] ifFalse:[
- frameAll := frameAll merge:(theObject frame)
- ]
- ].
- ^ frameAll
-!
-
canMove:something
"return true, if the argument, anObject or a collection can be moved"
@@ -776,34 +913,310 @@
]
].
^ false
+! !
+
+!ObjectView methodsFor:'misc'!
+
+forEach:aCollection do:aBlock
+ "apply block to every object in a collectioni;
+ (adds a check for non-collection)"
+
+ aCollection isNil ifTrue:[^self].
+ (aCollection isKindOf:Collection) ifTrue:[
+ aCollection do:[:object |
+ object notNil ifTrue:[
+ aBlock value:object
+ ]
+ ]
+ ] ifFalse: [
+ aBlock value:aCollection
+ ]
+!
+
+objectsIntersecting:aRectangle do:aBlock
+ "do something to every object which intersects a rectangle"
+
+ |f top bot
+ firstIndex "{ Class: SmallInteger }"
+ delta "{ Class: SmallInteger }"
+ theObject
+ nObjects "{ Class: SmallInteger }"|
+
+ sorted ifFalse:[
+ "have to check every object"
+ contents do:[:theObject |
+ (theObject frame intersects:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ]
+ ].
+ ^ self
+ ].
+ nObjects := contents size.
+ (nObjects == 0) ifTrue:[^ self].
+
+ "can break, when 1st object below aRectangle is reached"
+ bot := aRectangle bottom.
+ top := aRectangle top.
+
+ "binary search an object in aRectangle ..."
+ delta := nObjects // 2.
+ firstIndex := delta.
+ (firstIndex == 0) ifTrue:[
+ firstIndex := 1
+ ].
+ theObject := contents at:firstIndex.
+ (theObject frame bottom < top) ifTrue:[
+ [theObject frame bottom < top and:[delta > 1]] whileTrue:[
+ delta := delta // 2.
+ firstIndex := firstIndex + delta.
+ theObject := contents at:firstIndex
+ ]
+ ] ifFalse:[
+ [theObject frame top > bot and:[delta > 1]] whileTrue:[
+ delta := delta // 2.
+ firstIndex := firstIndex - delta.
+ theObject := contents at:firstIndex
+ ]
+ ].
+ "now, theObject at:firstIndex is in aRectangle; go backward to the object
+ following first non-visible"
+
+ [theObject frame bottom > top and:[firstIndex > 1]] whileTrue:[
+ firstIndex := firstIndex - 1.
+ theObject := contents at:firstIndex
+ ].
+
+ firstIndex to:nObjects do:[:index |
+ theObject := contents at:index.
+ f := theObject frame.
+ (f intersects:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ] ifFalse:[
+ (f top > bot) ifTrue:[^ self]
+ ]
+ ]
+!
+
+setDefaultActions
+ motionAction := [:movePoint | nil].
+ releaseAction := [nil]
+!
+
+setMoveActions
+ motionAction := [:movePoint | self doObjectMove:movePoint].
+ releaseAction := [self endObjectMove]
+!
+
+objectsIntersectingVisible:aRectangle do:aBlock
+ "do something to every object which intersects a visible rectangle"
+
+ |absRect|
+
+ absRect := Rectangle left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+ self objectsIntersecting:absRect do:aBlock
+!
+
+objectsIntersecting:aRectangle
+ "answer a Collection of objects intersecting the argument, aRectangle"
+
+ |newCollection|
+
+ newCollection := OrderedCollection new.
+ self objectsIntersecting:aRectangle do:[:theObject |
+ newCollection add:theObject
+ ].
+ (newCollection size == 0) ifTrue:[^ nil].
+ ^ newCollection
+!
+
+documentFormat:aFormatString
+ "set the document format (mostly used by scrollbars).
+ The argument should be a string such as 'a4', 'a5'
+ or 'letter'. See widthOfContentsInMM for supported formats."
+
+ aFormatString ~= documentFormat ifTrue:[
+ documentFormat := aFormatString.
+ self contentsChanged.
+ self defineGrid.
+ gridShown ifTrue:[
+ self clear.
+ self redraw
+ ]
+ ]
+!
+
+setRectangleDragActions
+ motionAction := [:movePoint | self doRectangleDrag:movePoint].
+ releaseAction := [self endRectangleDrag]
+!
+
+setLineDragActions
+ motionAction := [:movePoint | self doLineDrag:movePoint].
+ releaseAction := [self endLineDrag]
!
-isObscured:something
- "return true, if the argument something, anObject or a collection of
- objects is obscured (partially or whole) by any other object"
+objectsIn:aRectangle do:aBlock
+ "do something to every object which is completely in a rectangle"
+
+ |bot|
+
+ sorted ifTrue:[
+ bot := aRectangle bottom.
+ contents do:[:theObject |
+ (theObject isContainedIn:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ] ifFalse:[
+ theObject frame top > bot ifTrue:[^ self]
+ ]
+ ].
+ ^ self
+ ].
+
+ contents do:[:theObject |
+ (theObject isContainedIn:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ]
+ ]
+!
+
+objectsInVisible:aRectangle do:aBlock
+ "do something to every object which is completely in a
+ visible rectangle"
+
+ |absRect|
- self forEach:something do:[:anObject |
- (self objectIsObscured:anObject) ifTrue:[
- ^ true
+ absRect := Rectangle left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+ self objectsIn:absRect do:aBlock
+!
+
+visibleObjectsDo:aBlock
+ "do something to every visible object"
+
+ |absRect|
+
+ absRect := Rectangle left:viewOrigin x
+ top:viewOrigin y
+ width:width
+ height:height.
+ self objectsIntersecting:absRect do:aBlock
+!
+
+numberOfObjectsIntersectingVisible:aRectangle
+ "answer the number of objects intersecting the argument, aRectangle"
+
+ |absRect|
+
+ absRect := Rectangle
+ left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+
+ ^ self numberOfObjectsIntersecting:aRectangle
+!
+
+numberOfObjectsIntersecting:aRectangle
+ "answer the number of objects intersecting the argument, aRectangle"
+
+ |tally|
+
+ tally := 0.
+ contents do:[:theObject |
+ (theObject frame intersects:aRectangle) ifTrue:[
+ tally := tally + 1
]
].
- ^ false
+ ^ tally
+!
+
+objectsIntersectingVisible:aRectangle
+ "answer a Collection of objects intersecting a visible aRectangle"
+
+ |absRect|
+
+ absRect := Rectangle left:(aRectangle left + viewOrigin x)
+ top:(aRectangle top + viewOrigin y)
+ width:(aRectangle width)
+ height:(aRectangle height).
+ ^ self objectsIntersecting:absRect
+!
+
+objectsBelow:objectToBeTested do:aBlock
+ "do something to every object below objectToBeTested
+ (does not mean obscured by - simply below in hierarchy)"
+
+ |endIndex|
+
+ endIndex := contents identityIndexOf:objectToBeTested ifAbsent:[self error].
+ contents from:1 to:(endIndex - 1) do:aBlock
+!
+
+objectsAbove:objectToBeTested do:aBlock
+ "do something to every object above objectToBeTested
+ (does not mean obscured - simply above in hierarchy)"
+
+ |startIndex|
+
+ startIndex := contents identityIndexOf:objectToBeTested
+ ifAbsent:[self error].
+ contents from:startIndex to:(contents size) do:aBlock
+!
+
+objectsAbove:anObject intersecting:aRectangle do:aBlock
+ "do something to every object above objectToBeTested
+ and intersecting aRectangle"
+
+ self objectsAbove:anObject do:[:theObject |
+ (theObject frame intersects:aRectangle) ifTrue:[
+ aBlock value:theObject
+ ]
+ ]
+!
+
+rectangleForScroll
+ "find the area occupied by visible objects"
+
+ |left right top bottom frame oLeft oRight oTop oBottom orgX orgY|
+
+ orgX := viewOrigin x.
+ orgY := viewOrigin y.
+ left := 9999.
+ right := 0.
+ top := 9999.
+ bottom := 0.
+ self visibleObjectsDo:[:anObject |
+ frame := anObject frame.
+ oLeft := frame left - orgX.
+ oRight := frame right - orgX.
+ oTop := frame top - orgY.
+ oBottom := frame bottom - orgY.
+ (oLeft < left) ifTrue:[left := oLeft].
+ (oRight > right) ifTrue:[right := oRight].
+ (oTop < top) ifTrue:[top := oTop].
+ (oBottom > bottom) ifTrue:[bottom := oBottom]
+ ].
+ (left < margin) ifTrue:[left := margin].
+ (top < margin) ifTrue:[top := margin].
+ (right > (width - margin)) ifTrue:[right := width - margin].
+ (bottom > (height - margin)) ifTrue:[bottom := height - margin].
+
+ ((left > right) or:[top > bottom]) ifTrue:[^ nil].
+
+ ^ Rectangle left:left right:right top:top bottom:bottom
! !
!ObjectView methodsFor:'layout manipulation'!
-move:something to:aPoint in:aView
- "can only happen when dragOutOfView is true
- - should be redefined in subclasses"
+moveObject:anObject by:delta
+ "change the position of anObject by delta, aPoint"
- self notify:'cannot move object(s) out of view'
-!
-
-move:something to:aPoint inAlienViewId:aViewId
- "can only happen when dragOutOfView is true
- - should be redefined in subclasses"
-
- self notify:'cannot move object(s) to alien views'
+ self moveObject:anObject to:(anObject origin + delta)
!
move:something by:delta
@@ -819,12 +1232,6 @@
]
!
-moveObject:anObject by:delta
- "change the position of anObject by delta, aPoint"
-
- self moveObject:anObject to:(anObject origin + delta)
-!
-
moveObject:anObject to:newOrigin
"move anObject to newOrigin, aPoint"
@@ -878,9 +1285,10 @@
].
((oldLeft < width) and:[oldTop < height]) ifTrue:[
((oldLeft >= 0) and:[oldTop >= 0]) ifTrue:[
- self clearRectangleX:oldLeft y:oldTop width:w height:h.
- "/ self fillRectangleX:oldLeft y:oldTop width:w height:h
- "/ with:viewBackground
+ self clearRectangleX:oldLeft y:oldTop width:w height:h.
+
+"/ self fillRectangleX:oldLeft y:oldTop width:w height:h
+"/ with:viewBackground
]
].
^ self
@@ -908,6 +1316,20 @@
]
!
+move:something to:aPoint in:aView
+ "can only happen when dragOutOfView is true
+ - should be redefined in subclasses"
+
+ self notify:'cannot move object(s) out of view'
+!
+
+move:something to:aPoint inAlienViewId:aViewId
+ "can only happen when dragOutOfView is true
+ - should be redefined in subclasses"
+
+ self notify:'cannot move object(s) to alien views'
+!
+
objectToFront:anObject
"bring the argument, anObject to front"
@@ -1097,6 +1519,18 @@
]
!
+addObject:anObject
+ "add the argument, anObject to the contents - with redraw"
+
+ anObject notNil ifTrue:[
+ contents addLast:anObject.
+ "its on top - only draw this one"
+ shown "realized" ifTrue:[
+ self showUnselected:anObject
+ ]
+ ]
+!
+
addObjectWithoutRedraw:anObject
"add the argument, anObject to the contents - no redraw"
@@ -1114,18 +1548,6 @@
]
!
-addObject:anObject
- "add the argument, anObject to the contents - with redraw"
-
- anObject notNil ifTrue:[
- contents addLast:anObject.
- "its on top - only draw this one"
- shown "realized" ifTrue:[
- self showUnselected:anObject
- ]
- ]
-!
-
remove:something
"remove something, anObject or a collection of objects from the contents
do redraw"
@@ -1179,370 +1601,73 @@
self redraw
! !
-!ObjectView methodsFor:'misc'!
-
-documentFormat:aFormatString
- "set the document format (mostly used by scrollbars).
- The argument should be a string such as 'a4', 'a5'
- or 'letter'. See widthOfContentsInMM for supported formats."
-
- aFormatString ~= documentFormat ifTrue:[
- documentFormat := aFormatString.
- self contentsChanged.
- self defineGrid.
- gridShown ifTrue:[
- self clear.
- self redraw
- ]
- ]
-!
-
-setDefaultActions
- motionAction := [:movePoint | nil].
- releaseAction := [nil]
-!
-
-setRectangleDragActions
- motionAction := [:movePoint | self doRectangleDrag:movePoint].
- releaseAction := [self endRectangleDrag]
-!
-
-setLineDragActions
- motionAction := [:movePoint | self doLineDrag:movePoint].
- releaseAction := [self endLineDrag]
-!
-
-setMoveActions
- motionAction := [:movePoint | self doObjectMove:movePoint].
- releaseAction := [self endObjectMove]
-!
-
-forEach:aCollection do:aBlock
- "apply block to every object in a collectioni;
- (adds a check for non-collection)"
-
- aCollection isNil ifTrue:[^self].
- (aCollection isKindOf:Collection) ifTrue:[
- aCollection do:[:object |
- object notNil ifTrue:[
- aBlock value:object
- ]
- ]
- ] ifFalse: [
- aBlock value:aCollection
- ]
-!
-
-objectsInVisible:aRectangle do:aBlock
- "do something to every object which is completely in a
- visible rectangle"
-
- |absRect|
-
- absRect := Rectangle left:(aRectangle left + viewOrigin x)
- top:(aRectangle top + viewOrigin y)
- width:(aRectangle width)
- height:(aRectangle height).
- self objectsIn:absRect do:aBlock
-!
-
-objectsIn:aRectangle do:aBlock
- "do something to every object which is completely in a rectangle"
-
- |bot|
-
- sorted ifTrue:[
- bot := aRectangle bottom.
- contents do:[:theObject |
- (theObject isContainedIn:aRectangle) ifTrue:[
- aBlock value:theObject
- ] ifFalse:[
- theObject frame top > bot ifTrue:[^ self]
- ]
- ].
- ^ self
- ].
-
- contents do:[:theObject |
- (theObject isContainedIn:aRectangle) ifTrue:[
- aBlock value:theObject
- ]
- ]
-!
-
-visibleObjectsDo:aBlock
- "do something to every visible object"
-
- |absRect|
-
- absRect := Rectangle left:viewOrigin x
- top:viewOrigin y
- width:width
- height:height.
- self objectsIntersecting:absRect do:aBlock
-!
-
-numberOfObjectsIntersectingVisible:aRectangle
- "answer the number of objects intersecting the argument, aRectangle"
-
- |absRect|
-
- absRect := Rectangle
- left:(aRectangle left + viewOrigin x)
- top:(aRectangle top + viewOrigin y)
- width:(aRectangle width)
- height:(aRectangle height).
-
- ^ self numberOfObjectsIntersecting:aRectangle
-!
-
-numberOfObjectsIntersecting:aRectangle
- "answer the number of objects intersecting the argument, aRectangle"
-
- |tally|
-
- tally := 0.
- contents do:[:theObject |
- (theObject frame intersects:aRectangle) ifTrue:[
- tally := tally + 1
- ]
- ].
- ^ tally
-!
-
-objectsIntersecting:aRectangle
- "answer a Collection of objects intersecting the argument, aRectangle"
-
- |newCollection|
-
- newCollection := OrderedCollection new.
- self objectsIntersecting:aRectangle do:[:theObject |
- newCollection add:theObject
- ].
- (newCollection size == 0) ifTrue:[^ nil].
- ^ newCollection
-!
-
-objectsIntersectingVisible:aRectangle
- "answer a Collection of objects intersecting a visible aRectangle"
-
- |absRect|
-
- absRect := Rectangle left:(aRectangle left + viewOrigin x)
- top:(aRectangle top + viewOrigin y)
- width:(aRectangle width)
- height:(aRectangle height).
- ^ self objectsIntersecting:absRect
-!
-
-objectsIntersecting:aRectangle do:aBlock
- "do something to every object which intersects a rectangle"
-
- |f top bot
- firstIndex "{ Class: SmallInteger }"
- delta "{ Class: SmallInteger }"
- theObject
- nObjects "{ Class: SmallInteger }"|
-
- sorted ifFalse:[
- "have to check every object"
- contents do:[:theObject |
- (theObject frame intersects:aRectangle) ifTrue:[
- aBlock value:theObject
- ]
- ].
- ^ self
- ].
- nObjects := contents size.
- (nObjects == 0) ifTrue:[^ self].
-
- "can break, when 1st object below aRectangle is reached"
- bot := aRectangle bottom.
- top := aRectangle top.
-
- "binary search an object in aRectangle ..."
- delta := nObjects // 2.
- firstIndex := delta.
- (firstIndex == 0) ifTrue:[
- firstIndex := 1
- ].
- theObject := contents at:firstIndex.
- (theObject frame bottom < top) ifTrue:[
- [theObject frame bottom < top and:[delta > 1]] whileTrue:[
- delta := delta // 2.
- firstIndex := firstIndex + delta.
- theObject := contents at:firstIndex
- ]
- ] ifFalse:[
- [theObject frame top > bot and:[delta > 1]] whileTrue:[
- delta := delta // 2.
- firstIndex := firstIndex - delta.
- theObject := contents at:firstIndex
- ]
- ].
- "now, theObject at:firstIndex is in aRectangle; go backward to the object
- following first non-visible"
-
- [theObject frame bottom > top and:[firstIndex > 1]] whileTrue:[
- firstIndex := firstIndex - 1.
- theObject := contents at:firstIndex
- ].
-
- firstIndex to:nObjects do:[:index |
- theObject := contents at:index.
- f := theObject frame.
- (f intersects:aRectangle) ifTrue:[
- aBlock value:theObject
- ] ifFalse:[
- (f top > bot) ifTrue:[^ self]
- ]
- ]
-!
-
-objectsIntersectingVisible:aRectangle do:aBlock
- "do something to every object which intersects a visible rectangle"
-
- |absRect|
-
- absRect := Rectangle left:(aRectangle left + viewOrigin x)
- top:(aRectangle top + viewOrigin y)
- width:(aRectangle width)
- height:(aRectangle height).
- self objectsIntersecting:absRect do:aBlock
-!
-
-objectsBelow:objectToBeTested do:aBlock
- "do something to every object below objectToBeTested
- (does not mean obscured by - simply below in hierarchy)"
-
- |endIndex|
-
- endIndex := contents identityIndexOf:objectToBeTested ifAbsent:[self error].
- contents from:1 to:(endIndex - 1) do:aBlock
-!
-
-objectsAbove:objectToBeTested do:aBlock
- "do something to every object above objectToBeTested
- (does not mean obscured - simply above in hierarchy)"
-
- |startIndex|
-
- startIndex := contents identityIndexOf:objectToBeTested
- ifAbsent:[self error].
- contents from:startIndex to:(contents size) do:aBlock
-!
-
-objectsAbove:anObject intersecting:aRectangle do:aBlock
- "do something to every object above objectToBeTested
- and intersecting aRectangle"
-
- self objectsAbove:anObject do:[:theObject |
- (theObject frame intersects:aRectangle) ifTrue:[
- aBlock value:theObject
- ]
- ]
-!
-
-rectangleForScroll
- "find the area occupied by visible objects"
-
- |left right top bottom frame oLeft oRight oTop oBottom orgX orgY|
-
- orgX := viewOrigin x.
- orgY := viewOrigin y.
- left := 9999.
- right := 0.
- top := 9999.
- bottom := 0.
- self visibleObjectsDo:[:anObject |
- frame := anObject frame.
- oLeft := frame left - orgX.
- oRight := frame right - orgX.
- oTop := frame top - orgY.
- oBottom := frame bottom - orgY.
- (oLeft < left) ifTrue:[left := oLeft].
- (oRight > right) ifTrue:[right := oRight].
- (oTop < top) ifTrue:[top := oTop].
- (oBottom > bottom) ifTrue:[bottom := oBottom]
- ].
- (left < margin) ifTrue:[left := margin].
- (top < margin) ifTrue:[top := margin].
- (right > (width - margin)) ifTrue:[right := width - margin].
- (bottom > (height - margin)) ifTrue:[bottom := height - margin].
-
- ((left > right) or:[top > bottom]) ifTrue:[^ nil].
-
- ^ Rectangle left:left right:right top:top bottom:bottom
-! !
-
!ObjectView methodsFor:'view manipulation'!
zoom:factor
- factor isNil ifTrue:[
+ "set a zoom factor; nil or 1 is identity; 2 is magnify by 2;
+ 0.5 is shrink by 2"
+
+ (factor isNil or:[factor = 1]) ifTrue:[
transformation := nil
] ifFalse:[
- transformation := WindowingTransformation scale:(1 / factor) translation:0.
+ transformation := WindowingTransformation scale:factor translation:0.
].
+ self setInnerClip.
gridShown ifTrue:[
- gridPixmap := nil.
- self defineGrid.
- viewBackground := gridPixmap
+ self newGrid
].
shown ifTrue:[
self clear.
self redraw
- ]
-!
-
-showScale
- "show the scale"
-
- scaleShown := true.
- self redrawScale
-!
-
-hideScale
- "hide the scale"
-
- scaleShown := false.
- self redrawScale
+ ].
+ self contentsChanged
!
millimeterMetric
- (scaleMetric == #inch) ifTrue:[
+ (scaleMetric ~~ #mm) ifTrue:[
scaleMetric := #mm.
- gridShown ifTrue:[
- self defineGrid.
- self redraw
- ]
+ self newGrid
]
!
inchMetric
- (scaleMetric == #mm) ifTrue:[
+ (scaleMetric ~~ #inch) ifTrue:[
scaleMetric := #inch.
- gridShown ifTrue:[
- self defineGrid.
- self redraw
- ]
+ self newGrid
]
-!
+! !
+
+!ObjectView methodsFor:'grid manipulation'!
+
+gridParameters
+ "used by defineGrid, and in a separate method for
+ easier redefinition in subclasses.
+ Returns the parameters in an array of 7 elements,
+ which control the appearance of the grid-pattern.
+ elements:
-defineGrid
- "define the grid pattern"
+ bigStepH number of pixels horizontally between 2 major steps
+ bigStepV number of pixels vertically between 2 major steps
+ littleStepH number of pixels horizontally between 2 minor steps
+ littleStepV number of pixels vertically between 2 minor steps
+ gridAlignH number of pixels for horizontal grid align
+ gridAlignV number of pixels for vertical grid align
+ docBounds true, if document boundary shouldbe shown
+ "
- |mmH mmV gridW gridH xp yp y x
- bigStepH bigStepV littleStepH littleStepV hires
- oldCursor|
+ |mmH mmV bigStepH bigStepV littleStepH littleStepV arr|
+
+ "example: 12grid & 12snapIn"
+"/ ^ #(12 12 nil nil 12 12 false).
+
+ "example: 12grid & 24snapIn"
+"/ ^ #(12 12 nil nil 24 24 false).
+
+ "default: cm/mm grid & mm snapIn for metric,
+ 1inch , 1/8inch grid & 1/8 inch snapIn"
mmH := self horizontalPixelPerMillimeter.
mmV := self verticalPixelPerMillimeter.
- hires := self horizontalPixelPerInch > 120.
-
- transformation notNil ifTrue:[
- mmH := mmH * transformation scale x.
- mmV := mmV * transformation scale y
- ].
(scaleMetric == #mm) ifTrue:[
"dots every mm; lines every cm"
@@ -1558,119 +1683,197 @@
littleStepH := mmH * (25.4 / 8).
littleStepV := mmV * (25.4 / 8)
].
- bigStepH isNil ifTrue:[^ self].
+
+ arr := Array new:8.
+ arr at:1 put:bigStepH.
+ arr at:2 put:bigStepV.
+ arr at:3 put:littleStepH.
+ arr at:4 put:littleStepV.
+ arr at:5 put:littleStepH.
+ arr at:6 put:littleStepV.
+ arr at:7 put:false.
- oldCursor := cursor.
- self cursor:Cursor wait.
+ ^ arr
+!
+
+defineGrid
+ "define the grid pattern"
+
+ |mmH mmV params showDocumentBoundary gridW gridH
+ bigStepH bigStepV littleStepH littleStepV hires|
+
+ mmH := self horizontalPixelPerMillimeter.
+ mmV := self verticalPixelPerMillimeter.
+ hires := self horizontalPixelPerInch > 120.
- gridW := (self widthOfContentsInMM * mmH + 1) asInteger.
- gridH := (self heightOfContentsInMM * mmV + 1) asInteger.
- gridPixmap := Form width:gridW height:gridH depth:1 ."/ (device depth).
-"/ gridPixmap fill:White.
-"/ gridPixmap paint:Black.
-gridPixmap colorMap:(Array with:Color white
- with:Color black).
-gridPixmap clear.
-gridPixmap paint:(Color colorId:1).
+ gridW := (self widthOfContentsInMM * mmH).
+ gridH := (self heightOfContentsInMM * mmV).
+
+ params := self gridParameters.
+
+ bigStepH := params at:1.
+ bigStepV := params at:2.
+ littleStepH := params at:3.
+ littleStepV := params at:4.
+ showDocumentBoundary := params at:7.
- "draw first row point-by-point"
- yp := 0.0.
- xp := 0.0.
- y := yp asInteger.
- [xp <= gridW] whileTrue:[
- x := xp rounded.
- hires ifTrue:[
- gridPixmap displayPointX:(x + 1) y:y.
- gridPixmap displayPointX:(x + 2) y:y
+ transformation notNil ifTrue:[
+ mmH := mmH * transformation scale x.
+ mmV := mmV * transformation scale y.
+ bigStepH := bigStepH * transformation scale x.
+ bigStepV := bigStepV * transformation scale y.
+ littleStepH notNil ifTrue:[
+ littleStepH := littleStepH * transformation scale x.
].
- gridPixmap displayPointX:x y:y.
- xp := xp + littleStepH
+ littleStepV notNil ifTrue:[
+ littleStepV := littleStepV * transformation scale y.
+ ].
].
- "copy rest from what has been drawn already"
- yp := yp + bigStepV.
- [yp <= gridH] whileTrue:[
- y := yp rounded.
- hires ifTrue:[
+ bigStepH isNil ifTrue:[^ self].
+
+ self withCursor:(Cursor wait) do:[
+ |xp yp y x|
+
+ "
+ up to next full unit
+ "
+ gridW := ((gridW // bigStepH) + 1 * bigStepH) asInteger.
+ gridH := ((gridH // bigStepV) + 1 * bigStepV) asInteger.
+
+ gridPixmap := Form width:gridW height:gridH depth:1.
+ gridPixmap colorMap:(Array with:White with:Black).
+ gridPixmap clear.
+ gridPixmap paint:(Color colorId:1).
+
+ "draw first row point-by-point"
+ yp := 0.0.
+ xp := 0.0.
+ y := yp asInteger.
+ [xp <= gridW] whileTrue:[
+ x := xp rounded.
+ hires ifTrue:[
+ gridPixmap displayPointX:(x + 1) y:y.
+ gridPixmap displayPointX:(x + 2) y:y
+ ].
+ gridPixmap displayPointX:x y:y.
+ littleStepH notNil ifTrue:[
+ xp := xp + littleStepH
+ ] ifFalse:[
+ xp := xp + bigStepH
+ ]
+ ].
+
+ "copy rest from what has been drawn already"
+ yp := yp + bigStepV.
+ [yp <= gridH] whileTrue:[
+ y := yp rounded.
+ hires ifTrue:[
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:0 y:(y + 1)
+ width:gridW height:1.
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:0 y:(y + 2)
+ width:gridW height:1
+ ].
gridPixmap copyFrom:gridPixmap x:0 y:0
- toX:0 y:(y + 1)
+ toX:0 y:y
width:gridW height:1.
- gridPixmap copyFrom:gridPixmap x:0 y:0
- toX:0 y:(y + 2)
- width:gridW height:1
+ yp := yp + bigStepV
+ ].
+
+ "draw first col point-by-point"
+ xp := 0.0.
+ yp := 0.0.
+ x := xp asInteger.
+ [yp <= gridH] whileTrue:[
+ y := yp rounded.
+ hires ifTrue:[
+ gridPixmap displayPointX:x y:(y + 1).
+ gridPixmap displayPointX:x y:(y + 2)
+ ].
+ gridPixmap displayPointX:x y:y.
+ littleStepV notNil ifTrue:[
+ yp := yp + littleStepV
+ ] ifFalse:[
+ yp := yp + bigStepV
+ ]
].
- gridPixmap copyFrom:gridPixmap x:0 y:0
- toX:0 y:y
- width:gridW height:1.
- yp := yp + bigStepV
+
+ "copy rest from what has been drawn already"
+ xp := xp + bigStepH.
+ [xp <= gridW] whileTrue:[
+ x := xp rounded.
+ hires ifTrue:[
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:(x + 1) y:0
+ width:1 height:gridH.
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:(x + 2) y:0
+ width:1 height:gridH
+ ].
+ gridPixmap copyFrom:gridPixmap x:0 y:0
+ toX:x y:0
+ width:1 height:gridH.
+ xp := xp + bigStepH
+ ].
+
+ showDocumentBoundary ifTrue:[
+ "
+ mark the right-end and bottom of the document
+ "
+ gridPixmap displayLineFromX:gridW-1 y:0 toX:gridW-1 y:gridH-1.
+ gridPixmap displayLineFromX:0 y:gridH-1 toX:gridW-1 y:gridH-1.
+ ].
+ ]
+!
+
+newGrid
+ "define a new grid"
+
+ gridPixmap := nil.
+ shown ifTrue:[
+ self viewBackground:White.
+ self clear.
].
- "draw first col point-by-point"
- xp := 0.0.
- yp := 0.0.
- x := xp asInteger.
- [yp <= gridH] whileTrue:[
- y := yp rounded.
- hires ifTrue:[
- gridPixmap displayPointX:x y:(y + 1).
- gridPixmap displayPointX:x y:(y + 2)
- ].
- gridPixmap displayPointX:x y:y.
- yp := yp + littleStepV
+ gridShown ifTrue:[
+ self defineGrid.
+ self viewBackground:gridPixmap.
].
-
- "copy rest from what has been drawn already"
- xp := xp + bigStepH.
- [xp <= gridW] whileTrue:[
- x := xp rounded.
- hires ifTrue:[
- gridPixmap copyFrom:gridPixmap x:0 y:0
- toX:(x + 1) y:0
- width:1 height:gridH.
- gridPixmap copyFrom:gridPixmap x:0 y:0
- toX:(x + 2) y:0
- width:1 height:gridH
- ].
- gridPixmap copyFrom:gridPixmap x:0 y:0
- toX:x y:0
- width:1 height:gridH.
- xp := xp + bigStepH
+ shown ifTrue:[
+ self redraw
].
-
- false ifTrue:[
- "
- mark the right-end and bottom of the document
- "
- gridPixmap displayLineFromX:gridW-1 y:0 toX:gridW-1 y:gridH-1.
- gridPixmap displayLineFromX:0 y:gridH-1 toX:gridW-1 y:gridH-1.
- ].
-
- self cursor:oldCursor
!
showGrid
"show the grid"
gridShown := true.
- gridPixmap isNil ifTrue:[
- self defineGrid.
- ].
- self viewBackground:gridPixmap.
- self redraw
+ self newGrid
!
hideGrid
"hide the grid"
gridShown := false.
- self viewBackground:White.
- self redraw
+ self newGrid
+!
+
+getAlignParameters
+ |params|
+
+ params := self gridParameters.
+ gridAlign := (params at:5) @ (params at:6)
!
alignOn
"align points to grid"
- aligning := true
+ |params|
+
+ aligning := true.
+ self getAlignParameters
!
alignOff
@@ -1679,68 +1882,50 @@
aligning := false
! !
-!ObjectView methodsFor:'user interface'!
-
-alignToGrid:aPoint
- "round aPoint to the next nearest point on the grid"
-
- |mmH mmV aH aV|
-
- aligning ifFalse:[
- ^ aPoint
- ].
-
- mmH := self horizontalPixelPerMillimeter.
- mmV := self verticalPixelPerMillimeter.
-
- (scaleMetric == #mm) ifTrue:[
- "align to mm"
- aH := mmH.
- aV := mmV
- ].
- (scaleMetric == #inch) ifTrue:[
- "align to eights inch"
- aH := mmH * (25.4 / 8).
- aV := mmV * (25.4 / 8)
- ].
-
- ^ (aPoint grid:(aH @ aV)) grid:(1 @ 1)
-!
+!ObjectView methodsFor:'dragging rectangle'!
startRectangleDrag:startPoint
"start a rectangle drag"
self setRectangleDragActions.
dragObject := Rectangle origin:startPoint corner:startPoint.
- self xoring:[self displayRectangle:dragObject].
+ self invertDragRectangle.
oldCursor := cursor.
self cursor:leftHandCursor
!
+endRectangleDrag
+ "cleanup after rectangle drag; select them"
+
+ self invertDragRectangle.
+ self cursor:oldCursor.
+ self selectAllIn:(dragObject + viewOrigin)
+!
+
doRectangleDrag:aPoint
"do drag a rectangle"
- self xoring:[
- self displayRectangle:dragObject.
- dragObject corner:aPoint.
- self displayRectangle:dragObject
- ]
+ self invertDragRectangle.
+ dragObject corner:aPoint.
+ self invertDragRectangle.
!
-endRectangleDrag
- "cleanup after rectangle drag; select them"
+invertDragRectangle
+ "helper for rectangle drag - invert the dragRectangle.
+ Extracted into a separate method to allow easier redefinition
+ (different lineWidth etc)"
self xoring:[self displayRectangle:dragObject].
- self cursor:oldCursor.
- self selectAllIn:(dragObject + viewOrigin)
-!
+! !
+
+!ObjectView methodsFor:'dragging line'!
startLineDrag:startPoint
"start a line drag"
self setLineDragActions.
dragObject := Rectangle origin:startPoint corner:startPoint.
- self xoring:[self displayLineFrom:dragObject origin to:dragObject corner].
+ self invertDragLine.
oldCursor := cursor.
self cursor:leftHandCursor
!
@@ -1751,7 +1936,7 @@
self setLineDragActions.
rootMotion := true.
dragObject := Rectangle origin:startPoint corner:startPoint.
- self xoring:[self displayLineFrom:dragObject origin to:dragObject corner].
+ self invertDragLine.
oldCursor := cursor.
self cursor:leftHandCursor
!
@@ -1772,11 +1957,9 @@
offs2 := 0@0.
].
- dragger xoring:[
- dragger displayLineFrom:dragObject origin-offs2 to:dragObject corner-offs2.
- dragObject corner:aPoint.
- dragger displayLineFrom:dragObject origin-offs2 to:dragObject corner-offs2
- ]
+ self invertDragLine.
+ dragObject corner:aPoint.
+ self invertDragLine.
!
endLineDrag
@@ -1874,62 +2057,15 @@
^ self notify:'dont know how to connect to external views'
!
-selectMore:aPoint
- "add/remove an object from the selection"
-
- |anObject|
-
- anObject := self findObjectAtVisible:aPoint.
- anObject notNil ifTrue:[
- (self isSelected:anObject) ifTrue:[
- "remove from selection"
- self removeFromSelection:anObject
- ] ifFalse:[
- "add to selection"
- self addToSelection:anObject
- ]
- ].
- ^ self
-!
-
-startSelectOrMove:aPoint
- "start a rectangleDrag or objectMove - if aPoint hits an object,
- an object move is started, otherwise a rectangleDrag"
-
- |anObject|
+invertDragLine
+ "helper for line dragging - invert the dragged line.
+ Extracted for easier redefinition in subclasses
+ (different line width etc.)"
- anObject := self findObjectAtVisible:aPoint.
- anObject notNil ifTrue:[
- (self isSelected:anObject) ifFalse:[self unselect].
- self startObjectMove:anObject at:aPoint.
- ^ self
- ].
- "nothing was hit by this click - this starts a group select"
- self unselect.
- self startRectangleDrag:aPoint
-!
-
-startSelectMoreOrMove:aPoint
- "add/remove object hit by aPoint, then start a rectangleDrag or move
- - if aPoint hits an object, a move is started, otherwise a rectangleDrag"
+ self xoring:[self displayLineFrom:dragObject origin to:dragObject corner].
+! !
- |anObject|
-
- anObject := self findObjectAtVisible:aPoint.
- anObject notNil ifTrue:[
- (self isSelected:anObject) ifTrue:[
- "remove from selection"
- self removeFromSelection:anObject
- ] ifFalse:[
- "add to selection"
- self addToSelection:anObject
- ].
- self startObjectMove:selection at:aPoint.
- ^ self
- ].
- self unselect.
- self startRectangleDrag:aPoint
-!
+!ObjectView methodsFor:'dragging object move'!
startObjectMove:something at:aPoint
"start an object move"
@@ -1947,43 +2083,6 @@
]
!
-doObjectMove:aPoint
- "do an object move"
-
- |dragger offs2|
-
- rootMotion ifTrue:[
- dragger := rootView.
- offs2 := viewOrigin.
- ] ifFalse:[
- dragger := self.
- offs2 := 0@0.
- ].
- movedObject isNil ifTrue:[
- movedObject := selection.
- "
- draw first outline
- "
- movedObject notNil ifTrue:[
- moveDelta := 0@0.
- dragger xoring:[
- self showDragging:movedObject offset:(self alignToGrid:(moveDelta - offs2))
- ]
- ]
- ].
- movedObject notNil ifTrue:[
- "
- clear prev outline,
- draw new outline
- "
- dragger xoring:[
- self showDragging:movedObject offset:(self alignToGrid:(moveDelta - offs2)).
- moveDelta := aPoint - moveStartPoint.
- self showDragging:movedObject offset:(self alignToGrid:(moveDelta - offs2))
- ]
- ]
-!
-
endObjectMove
"cleanup after object move - find the destination view and dispatch to
one of the moveObjectXXX-methods. These can be redefined in subclasses."
@@ -2000,8 +2099,7 @@
offs2 := 0@0
].
dragger xoring:[
- self showDragging:movedObject
- offset:(self alignToGrid:(moveDelta - offs2))
+ self showDragging:movedObject offset:moveDelta - offs2
].
dragger device synchronizeOutput.
@@ -2046,131 +2144,76 @@
self setDefaultActions.
movedObject := nil
]
-! !
-
-!ObjectView methodsFor:'events'!
-
-buttonPress:button x:x y:y
- "user pressed left button"
-
- ((button == 1) or:[button == #select]) ifTrue:[
- pressAction notNil ifTrue:[
- lastButt := x @ y.
- pressAction value:lastButt
- ]
- ] ifFalse:[
- super buttonPress:button x:x y:y
- ]
-!
-
-buttonShiftPress:button x:x y:y
- "user pressed left button with shift"
-
- ((button == 1) or:[button == #select]) ifTrue:[
- shiftPressAction notNil ifTrue:[
- lastButt := x @ y.
- shiftPressAction value:lastButt
- ]
- ] ifFalse:[
- super buttonShiftPress:button x:x y:y
- ]
-!
-
-buttonMultiPress:button x:x y:y
- "user pressed left button twice (or more)"
-
- ((button == 1) or:[button == #select]) ifTrue:[
- doublePressAction notNil ifTrue:[
- doublePressAction value:(x @ y)
- ]
- ] ifFalse:[
- super buttonMultiPress:button x:x y:y
- ]
!
-buttonMotion:button x:buttX y:buttY
- "user moved mouse while button pressed"
+doObjectMove:aPoint
+ "do an object move.
+ moveStartPoint is the original click-point.
+ moveDelta"
- |xpos ypos movePoint|
-
- (lastButt == nil) ifFalse:[
- xpos := buttX.
- ypos := buttY.
+ |dragger offset d p|
- "check against view limits if move outside is not allowed"
- rootMotion ifFalse:[
- (xpos < 0) ifTrue:[
- xpos := 0
- ] ifFalse: [
- (xpos > width) ifTrue:[xpos := width]
- ].
- (ypos < 0) ifTrue:[
- ypos := 0
- ] ifFalse: [
- (ypos > height) ifTrue:[ypos := height]
- ]
- ].
- movePoint := xpos @ ypos.
+ rootMotion ifTrue:[
+ dragger := rootView.
+ offset := viewOrigin.
+ ] ifFalse:[
+ dragger := self.
+ offset := 0@0.
+ ].
- (xpos == (lastButt x)) ifTrue:[
- (ypos == (lastButt y)) ifTrue:[
- ^ self "no move"
- ]
- ].
-
- motionAction notNil ifTrue:[
- motionAction value:movePoint
- ].
- lastButt := movePoint
- ]
-!
+ "
+ when drawing in the root window, we have to use its coordinates
+ this is kept in offset.
+ "
+ movedObject isNil ifTrue:[
+ movedObject := selection.
+ "
+ draw first outline
+ "
+ movedObject notNil ifTrue:[
+ moveDelta := 0@0.
-buttonRelease:button x:x y:y
- ((button == 1) or:[button == #select]) ifTrue:[
- releaseAction notNil ifTrue:[releaseAction value]
- ] ifFalse:[
- super buttonRelease:button x:x y:y
- ]
-!
+ dragger xoring:[
+ "tricky, the moved object may not currently be aligned.
+ if so, simulate a frame move of the delta"
-keyPress:key x:x y:y
- keyPressAction notNil ifTrue:[
- selection notNil ifTrue:[
- self selectionDo: [:obj |
- obj keyInput:key
+ aligning ifTrue:[
+ d := movedObject origin
+ - (self alignToGrid:(movedObject origin)).
+d printNL.
+ moveDelta := d negated.
+].
+moveDelta printNL.
+ self showDragging:movedObject offset:moveDelta - offset.
]
]
- ]
-!
-
-redrawX:x y:y width:w height:h
- |innerX innerY innerW innerH redrawFrame |
-
- innerX := x.
- innerY := y.
- innerW := w.
- innerH := h.
- scaleShown ifTrue:[
- (x < leftMarginForScale) ifTrue:[
- self redrawVerticalScale.
- innerW := w - (leftMarginForScale - x).
- innerX := leftMarginForScale
- ].
- (y < topMarginForScale) ifTrue:[
- self redrawHorizontalScale.
- innerH := h - (topMarginForScale - y).
- innerY := topMarginForScale
+ ].
+ movedObject notNil ifTrue:[
+ "
+ clear prev outline,
+ draw new outline
+ "
+ dragger xoring:[
+ self showDragging:movedObject offset:moveDelta - offset.
+ moveDelta := aPoint - moveStartPoint.
+ aligning ifTrue:[
+ moveDelta := self alignToGrid:moveDelta
+ ].
+ self showDragging:movedObject offset:moveDelta - offset.
]
- ].
- ((contents size ~~ 0) or:[gridShown]) ifTrue:[
- redrawFrame := Rectangle left:innerX top:innerY
- width:innerW height:innerH.
- self redrawObjectsInVisible:redrawFrame
]
! !
!ObjectView methodsFor:'saving / restoring'!
+initializeFileInObject:anObject
+ "each object may be processed here after its being filed-in
+ - subclasses may do whatever they want here ...
+ (see LogicView for example)"
+
+ ^ self
+!
+
storeContentsOn:aStream
"store the contents in textual representation on aStream.
Notice, that for huge objects (such as DrawImages) this ascii output
@@ -2190,14 +2233,6 @@
]
!
-initializeFileInObject:anObject
- "each object may be processed here after its being filed-in
- - subclasses may do whatever they want here ...
- (see LogicView for example)"
-
- ^ self
-!
-
withoutRedrawFileInContentsFrom:aStream
self fileInContentsFrom:aStream redraw:false
!
@@ -2208,13 +2243,6 @@
self fileInContentsFrom:aStream redraw:true
!
-fileInContentsFrom:aStream redraw:redraw
- "remove all objects, load new contents from aStream
- and redraw if the redraw argument is true"
-
- self fileInContentsFrom:aStream redraw:redraw new:true
-!
-
fileInContentsFrom:aStream redraw:redraw new:new
"if the new argument is true, remove all objects.
Then load objects from aStream,
@@ -2240,4 +2268,12 @@
]
].
]
+!
+
+fileInContentsFrom:aStream redraw:redraw
+ "remove all objects, load new contents from aStream
+ and redraw if the redraw argument is true"
+
+ self fileInContentsFrom:aStream redraw:redraw new:true
! !
+
--- a/OptBox.st Thu Nov 17 15:34:12 1994 +0100
+++ b/OptBox.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Attic/OptBox.st,v 1.8 1994-10-10 03:02:29 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/OptBox.st,v 1.9 1994-11-17 14:38:21 claus Exp $
'!
!OptionBox class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Attic/OptBox.st,v 1.8 1994-10-10 03:02:29 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/OptBox.st,v 1.9 1994-11-17 14:38:21 claus Exp $
"
!
@@ -200,7 +200,7 @@
formLabel form:WarnBitmap
! !
-!OptionBox methodsFor:'private'!
+!OptionBox methodsFor:'queries'!
positionOffset
"return the delta, by which the box should be displayed
@@ -210,12 +210,6 @@
^ (buttons last originRelativeTo:self) + (buttons last extent // 2)
!
-resize
- "resize myself to make everything fit into myself"
-
- super extent:(self preferedExtent)
-!
-
preferedExtent
"return a size to make everything fit into myself"
--- a/OptionBox.st Thu Nov 17 15:34:12 1994 +0100
+++ b/OptionBox.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/OptionBox.st,v 1.8 1994-10-10 03:02:29 claus Exp $
+$Header: /cvs/stx/stx/libwidg/OptionBox.st,v 1.9 1994-11-17 14:38:21 claus Exp $
'!
!OptionBox class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/OptionBox.st,v 1.8 1994-10-10 03:02:29 claus Exp $
+$Header: /cvs/stx/stx/libwidg/OptionBox.st,v 1.9 1994-11-17 14:38:21 claus Exp $
"
!
@@ -200,7 +200,7 @@
formLabel form:WarnBitmap
! !
-!OptionBox methodsFor:'private'!
+!OptionBox methodsFor:'queries'!
positionOffset
"return the delta, by which the box should be displayed
@@ -210,12 +210,6 @@
^ (buttons last originRelativeTo:self) + (buttons last extent // 2)
!
-resize
- "resize myself to make everything fit into myself"
-
- super extent:(self preferedExtent)
-!
-
preferedExtent
"return a size to make everything fit into myself"
--- a/PanelView.st Thu Nov 17 15:34:12 1994 +0100
+++ b/PanelView.st Thu Nov 17 15:38:53 1994 +0100
@@ -11,7 +11,7 @@
"
View subclass:#PanelView
- instanceVariableNames:'layout verticalSpace horizontalSpace mustRearrange'
+ instanceVariableNames:'hLayout vLayout verticalSpace horizontalSpace mustRearrange'
classVariableNames:''
poolDictionaries:''
category:'Views-Layout'
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/PanelView.st,v 1.6 1994-10-28 03:25:18 claus Exp $
+$Header: /cvs/stx/stx/libwidg/PanelView.st,v 1.7 1994-11-17 14:38:22 claus Exp $
'!
!PanelView class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/PanelView.st,v 1.6 1994-10-28 03:25:18 claus Exp $
+$Header: /cvs/stx/stx/libwidg/PanelView.st,v 1.7 1994-11-17 14:38:22 claus Exp $
"
!
@@ -56,13 +56,32 @@
If you dont like its layout, define a new subclass or use one of
the existing subclasses: HorizontalPanelView and VerticalPanelView.
- PanelViews normally delay the actual positioning/sizing if their elements,
+ PanelViews normally delay the actual positioning/sizing of their elements,
until actually displayed. This is useful, if more elements are to
be added, to avoid repeated configuration of the elements.
If you want to query for the relative position of an element BEFORE
the view is visible, you have to send #setChildPositionsIfChanged before
- doing so (otherwise, you may get invalid origins from the subviews).
+ doing so (otherwise, you may get invalid origins from the subviews). As
+ an example, the modalBoxes do so before showing themselfes to ask for the
+ position of the ok-button relative to the top-left box-origin, in order to
+ position the ok-button under the mouse-pointer.
+
+ Instance variables:
+
+ hLayout <Symbol> controls horizontal layout; ignored in this
+ class, but used in Horizontal- and
+ VerticalPanelViews. See more info there.
+
+ vLayout <Symbol> controls vertical layout; ignored in this
+ class, but used in Horizontal- and
+ VerticalPanelViews. See more info there.
+
+ horizontalSpace <Integer> number of pixels to use as space between elements
+
+ verticalSpace <Integer> number of pixels to use as space between elements
+
+ mustRearrange <Boolean> internal flag, if rearrangement is needed
"
! !
@@ -71,7 +90,7 @@
initialize
super initialize.
- layout := #center.
+"/ layout := #center.
verticalSpace := ViewSpacing.
horizontalSpace := ViewSpacing.
mustRearrange := false
@@ -101,38 +120,31 @@
!PanelView methodsFor:'accessing'!
verticalSpace:numberOfPixels
- "set the space between elements (default is 1mm)"
+ "set the vertical space between elements (in pixels).
+ The default is computed for 1mm spacing."
- verticalSpace := numberOfPixels
+ verticalSpace ~= numberOfPixels ifTrue:[
+ verticalSpace := numberOfPixels.
+ self layoutChanged
+ ]
!
horizontalSpace:numberOfPixels
- "set the space between elements (default is 1mm)"
+ "set the horizontal space between elements on pixels (default is 1mm)"
- horizontalSpace := numberOfPixels
+ horizontalSpace ~= numberOfPixels ifTrue:[
+ horizontalSpace := numberOfPixels.
+ self layoutChanged
+ ]
!
space:numberOfPixels
- "set the space between elements (default is 1mm)"
-
- horizontalSpace := numberOfPixels.
- verticalSpace := numberOfPixels
-!
-
-layout
- "return the layout as symbol.
- the returned value is #left / #top; #spread; #center or #right / #bottom"
+ "set the space between elements in pixels (default is 1mm) for both directions"
- ^ layout
-!
-
-layout:aSymbol
- "change the layout - the argument, aSymbol is interpreted in subclasses
- HorizontalPanelView and VerticalPanelView;
- it may be: #left / #top; #spread; #center or #right / #bottom"
-
- (layout ~~ aSymbol) ifTrue:[
- layout := aSymbol.
+ (verticalSpace ~= numberOfPixels
+ or:[horizontalSpace ~= numberOfPixels]) ifTrue:[
+ horizontalSpace := numberOfPixels.
+ verticalSpace := numberOfPixels.
self layoutChanged
]
!
@@ -176,7 +188,9 @@
!
setChildPositions
- "(re)compute position of every child"
+ "(re)compute position of every child.
+ This method is redefined for different layout characteristics - you may
+ even create subclasses with completely different geometry management."
|first xpos ypos maxHeightInRow thisRow|
--- a/PopUpList.st Thu Nov 17 15:34:12 1994 +0100
+++ b/PopUpList.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1994 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/PopUpList.st,v 1.3 1994-10-10 03:02:34 claus Exp $
+$Header: /cvs/stx/stx/libwidg/PopUpList.st,v 1.4 1994-11-17 14:38:24 claus Exp $
'!
!PopUpList class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/PopUpList.st,v 1.3 1994-10-10 03:02:34 claus Exp $
+$Header: /cvs/stx/stx/libwidg/PopUpList.st,v 1.4 1994-11-17 14:38:24 claus Exp $
"
!
@@ -51,7 +51,11 @@
a PopUpList is basically a button with a popup menu.
The PopUpLists label is showing the current selection from the
list.
+"
+!
+examples
+"
example use:
|p|
--- a/PopUpMenu.st Thu Nov 17 15:34:12 1994 +0100
+++ b/PopUpMenu.st Thu Nov 17 15:38:53 1994 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/PopUpMenu.st,v 1.8 1994-10-10 03:02:35 claus Exp $
+$Header: /cvs/stx/stx/libwidg/PopUpMenu.st,v 1.9 1994-11-17 14:38:25 claus Exp $
'!
!PopUpMenu class methodsFor:'documentation'!
@@ -43,7 +43,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/PopUpMenu.st,v 1.8 1994-10-10 03:02:35 claus Exp $
+$Header: /cvs/stx/stx/libwidg/PopUpMenu.st,v 1.9 1994-11-17 14:38:25 claus Exp $
"
!
@@ -56,7 +56,11 @@
PopUpMenus are usually created with a list of labels, selectors and a
receivier. Once activated, the specified receiver will be sent a
'selector'-message.
+"
+!
+examples
+"
Examples:
|p|
@@ -244,6 +248,12 @@
!
labels:labels selectors:selectors receiver:anObject for:aView
+ "create and return a popup menu with labels as entries.
+ Each item will send a corresponding selector from the selectors-array
+ to anObject. The menu is created on the same physical device
+ as aView (which is only of interrest in multi-Display applications;
+ typical applications can use the sibbling message without the for: argument)."
+
|newMenu|
newMenu := self onSameDeviceAs:aView.
@@ -255,15 +265,22 @@
^ newMenu
!
-labels:labels selectors:selectors args:args receiver:anObject
- ^ self labels:labels
- selectors:selectors
- args:args
- receiver:anObject
- for:nil
+labels:labels selectors:selectors receiver:anObject
+ "create and return a popup menu with labels as entries.
+ Each item will send a message with a selector from the corresponding
+ selectors-array.
+ The menu is created on the default Display."
+
+ ^ self labels:labels selectors:selectors receiver:anObject for:nil
!
labels:labels selectors:selectors args:args receiver:anObject for:aView
+ "create and return a popup menu with labels as entries.
+ Each item will send a corresponding selector:argument from the selectors-
+ and args array to anObject. The menu is created on the same physical device
+ as aView (which is only of interrest in multi-Display applications;
+ typical applications can use the sibbling message without the for: argument)."
+
|newMenu|
newMenu := self onSameDeviceAs:aView.
@@ -276,19 +293,25 @@
^ newMenu
!
-labels:labels selector:aSelector args:args receiver:anObject
+labels:labels selectors:selectors args:args receiver:anObject
+ "create and return a popup menu with labels as entries.
+ Each item will send a corresponding selector:argument from the selectors-
+ and args array to anObject. The menu is created on the default Display"
+
^ self labels:labels
- selector:aSelector
+ selectors:selectors
args:args
receiver:anObject
for:nil
!
-labels:labels selectors:selectors receiver:anObject
- ^ self labels:labels selectors:selectors receiver:anObject for:nil
-!
+labels:labels selector:aSelector args:args receiver:anObject for:aView
+ "create and return a popup menu with labels as entries.
+ Each item will send aSelector with a corresponding argument from the
+ args array to anObject. The menu is created on the same physical device
+ as aView (which is only of interrest in multi-Display applications;
+ typical applications can use the sibbling message without the for: argument)."
-labels:labels selector:aSelector args:args receiver:anObject for:aView
|newMenu|
newMenu := self onSameDeviceAs:aView.
@@ -299,6 +322,25 @@
receiver:anObject
in:newMenu).
^ newMenu
+!
+
+labels:labels selector:aSelector args:args receiver:anObject
+ "create and return a popup menu with labels as entries.
+ Each item will send aSelector with a corresponding argument from the
+ args array to anObject. The menu is created on the default DIsplay"
+
+ ^ self labels:labels
+ selector:aSelector
+ args:args
+ receiver:anObject
+ for:nil
+!
+
+labels:labels selectors:selectors
+ "create and return a menu with label-items and selectors. The receiver
+ will either be defined later, or not used at all (if opened via startUp)"
+
+ ^ self labels:labels selectors:selectors receiver:nil for:nil
! !
!PopUpMenu class methodsFor:'ST-80 instance creation'!
@@ -332,21 +374,17 @@
initialize
super initialize.
- "dont need any fancy colors"
-"/ viewBackground := White on:device.
-
memorize := true.
hideOnLeave := false.
- style == #iris ifTrue:[
- borderWidth := 1
- ].
- (style == #st80) ifTrue:[
-"/ viewBackground := White.
- borderWidth := 1.
- level := 0.
- margin := 0.
- shadowView := nil
- ].
+"/ style == #iris ifTrue:[
+"/ borderWidth := 1
+"/ ].
+"/ (style == #st80) ifTrue:[
+"/ borderWidth := 1.
+"/ level := 0.
+"/ margin := 0.
+"/ shadowView := nil
+"/ ].
!
initEvents
@@ -598,7 +636,7 @@
XXregainControl
" "
device ungrabPointer.
- device grabPointerIn:drawableId
+ device grabPointerInView:self
" "
! !
@@ -611,29 +649,37 @@
Modal - i.e. stay in the menu until finished.
This is the ST-80 way of launching a menu."
+ |return|
+
menuView action:[:selected |
- |actionIndex value|
+ |actionIndex value sel retVal|
+ retVal := 0.
menuView args isNil ifTrue:[
- menuView selectors isNil ifTrue:[
- ^ 0
- ].
- ^ menuView receiver perform:(menuView selectors at:selected)
+ menuView selectors notNil ifTrue:[
+ sel := menuView selectors at:selected.
+ sel notNil ifTrue:[menuView receiver perform:sel].
+ ]
+ ] ifFalse:[
+ actionIndex := menuView args at:selected.
+ actionIndex notNil ifTrue:[
+ actionValues isNil ifTrue:[
+ retVal := actionIndex
+ ] ifFalse:[
+ retVal := actionValues at:actionIndex.
+ (retVal isKindOf:PopUpMenu) ifTrue:[
+ retVal := retVal startUp
+ ]
+ ]
+ ]
].
- actionIndex := menuView args at:selected.
- actionIndex isNil ifTrue:[^ 0].
- actionValues isNil ifTrue:[^ actionIndex].
- value := actionValues at:actionIndex.
- (value isKindOf:PopUpMenu) ifTrue:[
- ^ value startUp
- ].
- ^ value
+ return := retVal
].
self showAtPointer.
- ^ 0
+ ^ return
"
- Transcript showCr:(PopUpMenu labels:#('foo' 'bar' 'baz')) startUp
+ Transcript showCr:(PopUpMenu labels:#('foo' 'bar' 'baz')) startUp
Transcript showCr:(PopUpMenu labels:#('foo' 'bar' 'baz')
values:#(foo bar baz)) startUp
"
--- a/PullDMenu.st Thu Nov 17 15:34:12 1994 +0100
+++ b/PullDMenu.st Thu Nov 17 15:38:53 1994 +0100
@@ -14,7 +14,7 @@
instanceVariableNames:'menus titles activeMenuNumber
showSeparatingLines topMargin
fgColor bgColor activeFgColor activeBgColor
- onLevel offLevel
+ onLevel offLevel edgeStyle
keepMenu'
classVariableNames:'DefaultFont
DefaultViewBackground
@@ -23,7 +23,8 @@
DefaultHilightForegroundColor
DefaultHilightBackgroundColor
DefaultLevel DefaultHilightLevel
- DefaultShadowColor DefaultLightColor'
+ DefaultShadowColor DefaultLightColor
+ DefaultEdgeStyle DefaultKeep'
poolDictionaries:''
category:'Views-Menus'
!
@@ -32,7 +33,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Attic/PullDMenu.st,v 1.7 1994-10-28 03:25:19 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/PullDMenu.st,v 1.8 1994-11-17 14:38:32 claus Exp $
'!
!PullDownMenu class methodsFor:'documentation'!
@@ -53,7 +54,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Attic/PullDMenu.st,v 1.7 1994-10-28 03:25:19 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/PullDMenu.st,v 1.8 1994-11-17 14:38:32 claus Exp $
"
!
@@ -108,6 +109,8 @@
DefaultHilightLevel isNil ifTrue:[
DefaultHilightLevel := StyleSheet at:'menuHilightLevel' default:0.
].
+ DefaultEdgeStyle := StyleSheet at:'pullDownMenuEdgeStyle'.
+ DefaultKeepMenu := StyleSheet at:'pullDownMenuKeepMenu'.
DefaultLevel := StyleSheet at:'pullDownMenuLevel' default:1.
DefaultFont := StyleSheet fontAt:'pullDownMenuFont'.
DefaultFont isNil ifTrue:[
@@ -172,7 +175,6 @@
((style == #iris) or:[style == #motif]) ifTrue:[
self level:2.
- softEdge := true.
onLevel := 2.
offLevel := 0.
activeFgColor := fgColor
@@ -183,6 +185,9 @@
topMargin := 0
].
+ edgeStyle := DefaultEdgeStyle.
+ keepMenu := DefaultKeepMenu.
+
DefaultHilightForegroundColor notNil ifTrue:[
activeFgColor := DefaultHilightForegroundColor
].
@@ -200,8 +205,6 @@
fgColor := fgColor on:device.
activeBgColor := activeBgColor on:device.
activeFgColor := activeFgColor on:device.
-
- keepMenu := (style == #motif) or:[(style == #iris) or:[style == #mswindows]].
!
initEvents
--- a/PullDownMenu.st Thu Nov 17 15:34:12 1994 +0100
+++ b/PullDownMenu.st Thu Nov 17 15:38:53 1994 +0100
@@ -14,7 +14,7 @@
instanceVariableNames:'menus titles activeMenuNumber
showSeparatingLines topMargin
fgColor bgColor activeFgColor activeBgColor
- onLevel offLevel
+ onLevel offLevel edgeStyle
keepMenu'
classVariableNames:'DefaultFont
DefaultViewBackground
@@ -23,7 +23,8 @@
DefaultHilightForegroundColor
DefaultHilightBackgroundColor
DefaultLevel DefaultHilightLevel
- DefaultShadowColor DefaultLightColor'
+ DefaultShadowColor DefaultLightColor
+ DefaultEdgeStyle DefaultKeep'
poolDictionaries:''
category:'Views-Menus'
!
@@ -32,7 +33,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/PullDownMenu.st,v 1.7 1994-10-28 03:25:19 claus Exp $
+$Header: /cvs/stx/stx/libwidg/PullDownMenu.st,v 1.8 1994-11-17 14:38:32 claus Exp $
'!
!PullDownMenu class methodsFor:'documentation'!
@@ -53,7 +54,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/PullDownMenu.st,v 1.7 1994-10-28 03:25:19 claus Exp $
+$Header: /cvs/stx/stx/libwidg/PullDownMenu.st,v 1.8 1994-11-17 14:38:32 claus Exp $
"
!
@@ -108,6 +109,8 @@
DefaultHilightLevel isNil ifTrue:[
DefaultHilightLevel := StyleSheet at:'menuHilightLevel' default:0.
].
+ DefaultEdgeStyle := StyleSheet at:'pullDownMenuEdgeStyle'.
+ DefaultKeepMenu := StyleSheet at:'pullDownMenuKeepMenu'.
DefaultLevel := StyleSheet at:'pullDownMenuLevel' default:1.
DefaultFont := StyleSheet fontAt:'pullDownMenuFont'.
DefaultFont isNil ifTrue:[
@@ -172,7 +175,6 @@
((style == #iris) or:[style == #motif]) ifTrue:[
self level:2.
- softEdge := true.
onLevel := 2.
offLevel := 0.
activeFgColor := fgColor
@@ -183,6 +185,9 @@
topMargin := 0
].
+ edgeStyle := DefaultEdgeStyle.
+ keepMenu := DefaultKeepMenu.
+
DefaultHilightForegroundColor notNil ifTrue:[
activeFgColor := DefaultHilightForegroundColor
].
@@ -200,8 +205,6 @@
fgColor := fgColor on:device.
activeBgColor := activeBgColor on:device.
activeFgColor := activeFgColor on:device.
-
- keepMenu := (style == #motif) or:[(style == #iris) or:[style == #mswindows]].
!
initEvents
--- a/RButtGrp.st Thu Nov 17 15:34:12 1994 +0100
+++ b/RButtGrp.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Attic/RButtGrp.st,v 1.6 1994-10-10 03:02:43 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/RButtGrp.st,v 1.7 1994-11-17 14:38:30 claus Exp $
'!
!RadioButtonGroup class methodsFor:'documentation '!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Attic/RButtGrp.st,v 1.6 1994-10-10 03:02:43 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/RButtGrp.st,v 1.7 1994-11-17 14:38:30 claus Exp $
"
!
@@ -50,6 +50,18 @@
"
RadioButtonGroups control the interaction between RadioButtons
turning off other button(s) when one of the group is pressed.
+ To group some buttons (and have one-on behavior) use:
+
+ |g|
+
+ g := RadioButtonGroup new.
+ ...
+ b1 := RadioButton label:....
+ g add:b1
+ ...
+ b2 := RadioButton label:....
+ g add:b2
+ ...
"
! !
--- a/RadioButtonGroup.st Thu Nov 17 15:34:12 1994 +0100
+++ b/RadioButtonGroup.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/RadioButtonGroup.st,v 1.6 1994-10-10 03:02:43 claus Exp $
+$Header: /cvs/stx/stx/libwidg/RadioButtonGroup.st,v 1.7 1994-11-17 14:38:30 claus Exp $
'!
!RadioButtonGroup class methodsFor:'documentation '!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/RadioButtonGroup.st,v 1.6 1994-10-10 03:02:43 claus Exp $
+$Header: /cvs/stx/stx/libwidg/RadioButtonGroup.st,v 1.7 1994-11-17 14:38:30 claus Exp $
"
!
@@ -50,6 +50,18 @@
"
RadioButtonGroups control the interaction between RadioButtons
turning off other button(s) when one of the group is pressed.
+ To group some buttons (and have one-on behavior) use:
+
+ |g|
+
+ g := RadioButtonGroup new.
+ ...
+ b1 := RadioButton label:....
+ g add:b1
+ ...
+ b2 := RadioButton label:....
+ g add:b2
+ ...
"
! !
--- a/ScrView.st Thu Nov 17 15:34:12 1994 +0100
+++ b/ScrView.st Thu Nov 17 15:38:53 1994 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Attic/ScrView.st,v 1.7 1994-10-10 03:02:53 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/ScrView.st,v 1.8 1994-11-17 14:38:28 claus Exp $
'!
!ScrollableView class methodsFor:'documentation'!
@@ -43,7 +43,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Attic/ScrView.st,v 1.7 1994-10-10 03:02:53 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/ScrView.st,v 1.8 1994-11-17 14:38:28 claus Exp $
"
!
@@ -58,7 +58,11 @@
v := ScrollableView in:someSuperView.
...
v scrolledView:aViewToBeScrolled
+"
+!
+examples
+"
example1:
|top scr txt|
--- a/ScrollBar.st Thu Nov 17 15:34:12 1994 +0100
+++ b/ScrollBar.st Thu Nov 17 15:38:53 1994 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/ScrollBar.st,v 1.8 1994-10-28 03:25:21 claus Exp $
+$Header: /cvs/stx/stx/libwidg/ScrollBar.st,v 1.9 1994-11-17 14:38:27 claus Exp $
'!
!ScrollBar class methodsFor:'documentation'!
@@ -43,7 +43,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/ScrollBar.st,v 1.8 1994-10-28 03:25:21 claus Exp $
+$Header: /cvs/stx/stx/libwidg/ScrollBar.st,v 1.9 1994-11-17 14:38:27 claus Exp $
"
!
@@ -151,9 +151,7 @@
createElements
button1 := ArrowButton upIn:self.
- button1 name:'UpButton'.
button2 := ArrowButton downIn:self.
- button2 name:'DownButton'.
thumb := Scroller in:self.
!
@@ -178,17 +176,19 @@
^ self
].
(layout == #bottom) ifTrue:[
- button1 viewGravity:#North.
- button2 viewGravity:#North.
+ device supportsViewGravity ifTrue:[
+ button1 viewGravity:#South.
+ button2 viewGravity:#South.
+ thumb viewGravity:#North.
+ ].
thumb origin:(bwn @ bwn).
- thumb viewGravity:#North.
^ self
].
"layout == #around"
button1 origin:(bwn @ bwn).
button1 viewGravity:#North.
- button2 viewGravity:#North.
+"/ button2 viewGravity:#North.
thumb origin:(bwn @ (button1 height + elementSpacing)).
thumb viewGravity:#North
!
@@ -405,6 +405,9 @@
thumbWidth := thumbWidth - (thumb borderWidth * 2).
thumbHeight := thumbHeight - 1
].
+ style == #motif ifTrue:[
+ thumbHeight := thumbHeight - margin
+ ].
"
a kludge: views with width or height of 0 are illegal
@@ -426,8 +429,8 @@
thumbHeight := thumbHeight + borderWidth.
(how == #smaller) ifTrue:[
thumb extent:(thumbWidth @ thumbHeight).
- button1 origin:(bwn @ (thumbHeight + sep2)).
- button2 origin:(bwn @ (thumbHeight + sep2 + upHeight))
+"/ button1 origin:(bwn @ (thumbHeight + sep2)).
+"/ button2 origin:(bwn @ (thumbHeight + sep2 + upHeight))
] ifFalse:[
button1 origin:(bwn @ (thumbHeight + sep2)).
button2 origin:(bwn @ (thumbHeight + sep2 + upHeight)).
@@ -437,6 +440,9 @@
].
"buttons around thumb"
+style == #motif ifTrue:[
+ sep2 := sep2 + 1
+].
button1 origin:(bwn @ bwn).
button2 origin:(bwn @ (upHeight + thumbHeight + sep2 - (margin // 2) "+ borderWidth")).
thumb extent:(thumbWidth @ (thumbHeight + margin - (margin // 2))).
--- a/ScrollableView.st Thu Nov 17 15:34:12 1994 +0100
+++ b/ScrollableView.st Thu Nov 17 15:38:53 1994 +0100
@@ -22,7 +22,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/ScrollableView.st,v 1.7 1994-10-10 03:02:53 claus Exp $
+$Header: /cvs/stx/stx/libwidg/ScrollableView.st,v 1.8 1994-11-17 14:38:28 claus Exp $
'!
!ScrollableView class methodsFor:'documentation'!
@@ -43,7 +43,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/ScrollableView.st,v 1.7 1994-10-10 03:02:53 claus Exp $
+$Header: /cvs/stx/stx/libwidg/ScrollableView.st,v 1.8 1994-11-17 14:38:28 claus Exp $
"
!
@@ -58,7 +58,11 @@
v := ScrollableView in:someSuperView.
...
v scrolledView:aViewToBeScrolled
+"
+!
+examples
+"
example1:
|top scr txt|
--- a/Scroller.st Thu Nov 17 15:34:12 1994 +0100
+++ b/Scroller.st Thu Nov 17 15:38:53 1994 +0100
@@ -18,17 +18,23 @@
synchronousOperation
shadowForm lightForm inset
thumbShadowColor thumbLightColor
- thumbSoftEdge
+ thumbEdgeStyle
thumbHalfShadowColor thumbHalfLightColor
thumbFrameSizeDifference
tallyLevel tallyMarks
- fixThumbHeight'
+ fixThumbHeight frameBeforeMove
+ ghostColor ghostFrameColor ghostLevel'
classVariableNames: 'HandleShadowForm HandleLightForm
DefaultViewBackground
- DefaultThumbColor DefaultTallyMarks DefaultTallyLevel
+ DefaultShadowColor DefaultLightColor DefaultThumbColor
+ DefaultThumbShadowColor DefaultThumbLightColor
+ DefaultThumbHalfShadowColor DefaultThumbHalfLightColor
+ DefaultHalfShadowColor DefaultHalfLightColor
+ DefaultTallyMarks DefaultTallyLevel
DefaultLevel DefaultBorderWidth DefaultThumbLevel
- DefaultInset DefaultThumbFrameColor
- DefaultFixThumbHeight DefaultSoftEdge'
+ DefaultInset DefaultThumbFrameColor
+ DefaultGhostColor DefaultGhostFrameColor DefaultGhostLevel
+ DefaultFixThumbHeight DefaultEdgeStyle'
poolDictionaries:''
category:'Views-Interactors'
!
@@ -37,7 +43,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Scroller.st,v 1.9 1994-10-28 03:25:23 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Scroller.st,v 1.10 1994-11-17 14:38:34 claus Exp $
'!
!Scroller class methodsFor:'documentation'!
@@ -58,7 +64,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Scroller.st,v 1.9 1994-10-28 03:25:23 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Scroller.st,v 1.10 1994-11-17 14:38:34 claus Exp $
"
!
@@ -66,17 +72,20 @@
"
this class implements the scroller for scrollbars.
it can also be used by itself for scrollbars without step-buttons.
- When moved, a predefined action is performed.
+ When moved, either a predefined action is performed (scrollAction),
+ or a model is informed via the changeSymbol.
+
Beside the obvious 3D rectangle, a scroller may draw a know-form
(as in NeXT) or little tally marks (as on SGI) in itself.
These are controlled by the shadowForm, lightForm, tallyLevel and tallyMarks
instance variables.
+
The scroller can work synchronous (i.e. every move leads to an immediate evaluation
of the action, or asynchronous (i.e. perform action on end-of move).
- By default, scrollers are synchronous - asynchronous makes sense, if the scroll
- operation (redraw) is expensive.
+ By default, scrollers are synchronous. Asynchronous operation makes sense,
+ if the scroll operation (redraw) is expensive and takes a long time.
- Instance variables:
+ Instance variables:
thumbOrigin <Number> origin of thumb (in percent)
thumbHeight <Number> height of thumb (in percent)
@@ -96,7 +105,7 @@
inset <Integer> number of pixels to inset thumb from view borders
thumbShadowColor <Color> color do draw dark parts of thumb
thumblightColor <Color> color to draw light parts of thumb
- thumbSoftEdge <Boolean> true if edges of thumb are to appear smooth
+ thumbEdgeStyle <SymbolOrNil> #soft or nil
thumbHalfShadowColor <Color> used to draw smooth edges
thumbHalfLightColor <Color> used to draw smooth edges
thumbFrameSizeDifference <Integer> number of pixels the thumb is larger than
@@ -107,9 +116,35 @@
tallyMarks <Integer> number of tally marks
fixThumbHeight <Boolean> perform 'wrong' height computation a la mswindows
+
+ style settings:
+
+ scrollerLevel <Integer> the level of the scroller w.r.t. its enclosing view
+ scrollerBorderWidth <Integer> the borderWidth (ignored for 3D styles)
+
+ scrollerViewBackground <Color> the viewBackground (color or image)
+ scrollerShadowColor <Color> the color of 3D shadowed edges (ignored in 2D styles)
+ scrollerLightColor <Color> the color of 3D lighted edges (ignored in 2D styles)
+
+ scrollerThumbColor <Color> the thumbs color (color or image)
+ scrollerThumbShadowColor <Color> the color of the thumbs shadowed edges (ignored in 2D styles)
+ scrollerThumbLightColor <Color> the color of the thumbs shadowed edges (ignored in 2D styles)
+ scrollerThumbEdgeStyle <Symbol> the edge style for the thumb (#soft or nil)
+ scrollerThumbLevel <Integer> the 3D height of the thumb
+ scrollerThumbHalfShadowColor<Color> the halfShadow for soft edged thumbs
+ scrollerThumbHalfLightColor <Color> the halfLight for soft edged thumbs
+ scrollerThumbFrameColor <Color> if non-nil, a rectangle is drawn around the thumb is this color
+ scrollerThumbInset <Integer> inset of thumb from the scrollers boundary
+ scrollerThumbFixHeight <Boolean> if true, use a fix thumb height (as in mswindows)
+ scrollerGhostColor <Color> the color in which a ghost-rectangle is drawn
+ scrollerGhostFrameColor <Color> if non-nil, a rectangle is drawn around the ghost is this color
+ scrollerGhostLevel <Color> the 3D level of the ghost rectangle
+ scrollerNTallyMarks <Integer> number of tally-marks to draw on the thumb
+ scrollerTallyLevel. <Integer> the 3D level of any tally marks
+
notice: for mswindows style, we force a WRONG thumb-frame
computation, to make the thumb have constant size;
- if you dont like that (I do not :-), set fixThumbHeight to false (in initStyle).
+ if you dont like that (I do not :-), set scrollerThumbFixHeight to false (in the StyleSheet).
"
! !
@@ -118,7 +153,16 @@
updateStyleCache
DefaultViewBackground := StyleSheet colorAt:'scrollerViewBackground'.
DefaultThumbColor := StyleSheet colorAt:'scrollerThumbColor'.
+ DefaultShadowColor := StyleSheet colorAt:'scrollerShadowColor'.
+ DefaultLightColor := StyleSheet colorAt:'scrollerLightColor'.
+ DefaultThumbShadowColor := StyleSheet colorAt:'scrollerThumbShadowColor'.
+ DefaultThumbLightColor := StyleSheet colorAt:'scrollerThumbLightColor'.
+ DefaultThumbHalfShadowColor := StyleSheet colorAt:'scrollerThumbHalfShadowColor'.
+ DefaultThumbHalfLightColor := StyleSheet colorAt:'scrollerThumbHalfLightColor'.
DefaultThumbFrameColor := StyleSheet colorAt:'scrollerThumbFrameColor'.
+ DefaultGhostColor := StyleSheet colorAt:'scrollerGhostColor' default:nil.
+ DefaultGhostFrameColor := StyleSheet colorAt:'scrollerGhostFrameColor' default:nil.
+ DefaultGhostLevel := StyleSheet at:'scrollerGhostLevel' default:0.
DefaultTallyMarks := StyleSheet at:'scrollerNTallyMarks' default:0.
DefaultTallyLevel := 0.
DefaultTallyMarks ~~ 0 ifTrue:[
@@ -129,7 +173,7 @@
DefaultThumbLevel := StyleSheet at:'scrollerThumbLevel' default:0.
DefaultInset := StyleSheet at:'scrollerThumbInset' default:0.
DefaultFixThumbHeight := StyleSheet at:'scrollerThumbFixHeight' default:false.
- DefaultSoftEdge := StyleSheet at:'scrollerThumbSoftEdge' default:false.
+ DefaultEdgeStyle := StyleSheet at:'scrollerThumbEdgeStyle'.
!
handleShadowFormOn:aDisplay
@@ -219,6 +263,12 @@
DefaultViewBackground notNil ifTrue:[
viewBackground := DefaultViewBackground on:device.
].
+ DefaultShadowColor notNil ifTrue:[
+ shadowColor := DefaultShadowColor on:device.
+ ].
+ DefaultLightColor notNil ifTrue:[
+ lightColor := DefaultLightColor on:device.
+ ].
tallyMarks := DefaultTallyMarks.
tallyLevel := DefaultTallyLevel.
@@ -231,25 +281,51 @@
thumbLevel := DefaultThumbLevel.
inset := DefaultInset.
fixThumbHeight := DefaultFixThumbHeight.
- thumbSoftEdge := DefaultSoftEdge.
+ thumbEdgeStyle := DefaultEdgeStyle.
+
+ DefaultGhostColor notNil ifTrue:[
+ ghostColor := DefaultGhostColor on:device.
+ ].
+ DefaultGhostFrameColor notNil ifTrue:[
+ ghostFrameColor := DefaultGhostFrameColor on:device.
+ ].
+ ghostLevel := DefaultGhostLevel.
- thumbShadowColor := shadowColor.
- thumbLightColor := lightColor.
- thumbSoftEdge ifTrue:[
- device hasGreyscales ifTrue:[
- thumbHalfShadowColor := halfShadowColor.
- thumbHalfLightColor := halfLightColor
- ] ifFalse:[
+ DefaultThumbFrameColor notNil ifTrue:[
+ thumbFrameColor := DefaultThumbFrameColor on:device.
+ ].
+ DefaultThumbShadowColor notNil ifTrue:[
+ thumbShadowColor := DefaultThumbShadowColor
+ ] ifFalse:[
+ thumbShadowColor := shadowColor.
+ ].
+ DefaultThumbLightColor notNil ifTrue:[
+ thumbLightColor := DefaultThumbLightColor
+ ] ifFalse:[
+ thumbLightColor := lightColor.
+ ].
+
+ thumbEdgeStyle notNil ifTrue:[
+ DefaultThumbHalfShadowColor notNil ifTrue:[
+ thumbHalfShadowColor := DefaultThumbHalfShadowColor
+ ].
+ DefaultThumbHalfLightColor notNil ifTrue:[
+ thumbHalfLightColor := DefaultThumbHalfLightColor
+ ].
+ ].
+
+ device hasGreyscales ifFalse:[
+ thumbEdgeStyle notNil ifTrue:[
thumbHalfShadowColor := Color darkGrey.
thumbHalfLightColor := White
- ]
- ].
- device hasGreyscales ifFalse:[
+ ].
+
thumbShadowColor := Black.
"/ thumbLightColor := White.
+
StyleSheet name = #motif ifTrue:[
DefaultThumbColor isNil ifTrue:[
- thumbColor := White "Color grey".
+ thumbColor := White .
].
]
].
@@ -265,8 +341,23 @@
].
].
- DefaultThumbFrameColor notNil ifTrue:[
- thumbFrameColor := DefaultThumbFrameColor on:device.
+ thumbColor := thumbColor on:device.
+ thumbShadowColor notNil ifTrue:[
+ thumbShadowColor := thumbShadowColor on:device.
+ ].
+ thumbLightColor notNil ifTrue:[
+ thumbLightColor := thumbLightColor on:device.
+ ].
+ thumbHalfShadowColor notNil ifTrue:[
+ thumbHalfShadowColor := thumbHalfShadowColor on:device.
+ ].
+ thumbHalfLightColor notNil ifTrue:[
+ thumbHalfLightColor := thumbHalfLightColor on:device.
+ ].
+ thumbEdgeStyle notNil ifTrue:[
+ thumbHalfShadowColor isNil ifTrue:[
+ thumbHalfShadowColor := thumbShadowColor lightened on:device
+ ]
].
StyleSheet name = #next ifTrue:[
@@ -396,8 +487,6 @@
toX:left y:thumbTop
width:tW height:tH.
-"/ self catchExpose.
-
oldTop > thumbTop ifTrue:[
delta := oldTop - thumbTop.
oldTop > thumbBot ifTrue:[
@@ -757,9 +846,31 @@
drawThumbBackgroundInX:x y:y width:w height:h
"draw part of the thumbs background; defined as a separate
- method, to allow drawing of arbitrary patterns under thumb (see ColorSlider)."
+ method, to allow drawing of arbitrary patterns under thumb
+ (see ColorSlider)."
+
+ shown ifTrue:[
+ self clearRectangleX:x y:y width:w height:h.
+ frameBeforeMove notNil ifTrue:[
+ self clippedTo:(Rectangle left:x top:y width:w height:h) do:[
+ |gX gY gW gH|
- self clearRectangleX:x y:y width:w height:h.
+ gX := frameBeforeMove left.
+ gY := frameBeforeMove top.
+ gW := frameBeforeMove width.
+ gH := frameBeforeMove height.
+
+ self fillRectangle:frameBeforeMove with:ghostColor.
+ (ghostLevel ~~ 0) ifTrue:[
+ self drawEdgesForX:gX y:gY width:gW height:gH level:ghostLevel
+ ].
+ ghostFrameColor notNil ifTrue:[
+ self paint:ghostFrameColor.
+ self displayRectangleX:gX y:gY width:gW height:gH
+ ]
+ ]
+ ]
+ ]
!
drawThumb
@@ -770,7 +881,7 @@
h "{ Class: SmallInteger }"
x "{ Class: SmallInteger }"
y "{ Class: SmallInteger }"
- mm xL xR yT yB color1 color2 savEdge|
+ mm xL xR yT yB color1 color2|
(thumbHeight >= 100) ifTrue:[^ self].
moveDirection == #y ifTrue:[
@@ -795,12 +906,10 @@
].
"what a kludge - must be a parameter to drawEdge..."
- savEdge := softEdge.
- softEdge := thumbSoftEdge.
self drawEdgesForX:l y:t width:w height:h level:thumbLevel
shadow:thumbShadowColor light:thumbLightColor
- halfShadow:thumbHalfShadowColor halfLight:thumbHalfLightColor.
- softEdge := savEdge.
+ halfShadow:thumbHalfShadowColor halfLight:thumbHalfLightColor
+ style:thumbEdgeStyle.
thumbFrameColor notNil ifTrue:[
self paint:thumbFrameColor.
@@ -987,7 +1096,7 @@
buttonShiftPress:button x:x y:y
"mouse-click with shift - jump to position"
- |pos newThumbOrigin curr limit org|
+ |pos curr limit org|
(moveDirection == #y) ifTrue:[
curr := y.
@@ -1009,11 +1118,23 @@
]
].
- newThumbOrigin := self percentFromAbs:pos.
- self thumbOrigin:newThumbOrigin.
+ self thumbOrigin:(self percentFromAbs:pos).
+ "
+ the ST/X way of notifying scrolls
+ "
scrollAction notNil ifTrue:[
scrollAction value:thumbOrigin
].
+ "
+ the ST-80 way of notifying scrolls
+ "
+ (model notNil
+ and:[changeSymbol notNil])
+ ifTrue:[
+ model perform:changeSymbol
+ ].
+ self changed:#scrollerPosition.
+
pressOffset := curr - org.
scrolling := true
!
@@ -1023,9 +1144,15 @@
redraw thumb at its new position and, if scroll-mode is asynchronous,
the scroll action is performed"
- |pos newThumbOrigin curr limit|
+ |pos curr limit|
+
+ scrolling ifFalse: [^ self]. "should not happen"
- scrolling ifFalse: [ ^ self ]. "should not happen"
+ frameBeforeMove isNil ifTrue:[
+ ghostColor notNil ifTrue:[
+ frameBeforeMove := thumbFrame insetBy:1@1
+ ]
+ ].
(moveDirection == #y) ifTrue:[
curr := y.
@@ -1045,13 +1172,24 @@
]
].
- newThumbOrigin := self percentFromAbs:(pos - pressOffset).
+ self thumbOrigin:(self percentFromAbs:(pos - pressOffset)).
- self thumbOrigin:newThumbOrigin.
synchronousOperation ifTrue: [
+ "
+ the ST/X way of notifying scrolls
+ "
scrollAction notNil ifTrue:[
scrollAction value:thumbOrigin
- ]
+ ].
+ "
+ the ST-80 way of notifying scrolls
+ "
+ (model notNil
+ and:[changeSymbol notNil])
+ ifTrue:[
+ model perform:changeSymbol
+ ].
+ self changed:#scrollerPosition.
]
!
@@ -1059,12 +1197,38 @@
"mouse-button was released - if scroll-mode is asynchronous, the scroll
action is now performed"
+ |rect|
+
scrolling ifTrue:[
+ frameBeforeMove notNil ifTrue:[
+ rect := frameBeforeMove.
+ frameBeforeMove := nil.
+ self drawThumbBackgroundInX:rect left
+ y:rect top
+ width:rect width
+ height:rect height.
+ (rect intersects:thumbFrame) ifTrue:[
+ self drawThumb
+ ]
+ ].
+
scrolling := false.
synchronousOperation ifFalse: [
+ "
+ the ST/X way of notifying scrolls
+ "
scrollAction notNil ifTrue:[
scrollAction value:thumbOrigin
- ]
+ ].
+ "
+ the ST-80 way of notifying scrolls
+ "
+ (model notNil
+ and:[changeSymbol notNil])
+ ifTrue:[
+ model perform:changeSymbol
+ ].
+ self changed:#scrollerPosition.
]
]
! !
--- a/SelListV.st Thu Nov 17 15:34:12 1994 +0100
+++ b/SelListV.st Thu Nov 17 15:38:53 1994 +0100
@@ -19,7 +19,8 @@
listAttributes multipleSelectOk clickLine
listSymbol initialSelectionSymbol printItems oneItem
hilightLevel hilightFrameColor ignoreReselect
- arrowLevel smallArrow keyActionStyle'
+ arrowLevel smallArrow keyActionStyle toggleSelect
+ strikeOut iSearchString'
classVariableNames:'RightArrowShadowForm RightArrowLightForm RightArrowForm
SmallRightArrowShadowForm SmallRightArrowLightForm
DefaultForegroundColor DefaultBackgroundColor
@@ -36,7 +37,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Attic/SelListV.st,v 1.12 1994-10-28 03:25:26 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/SelListV.st,v 1.13 1994-11-17 14:38:36 claus Exp $
'!
!SelectionInListView class methodsFor:'documentation'!
@@ -57,7 +58,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Attic/SelListV.st,v 1.12 1994-10-28 03:25:26 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/SelListV.st,v 1.13 1994-11-17 14:38:36 claus Exp $
"
!
@@ -66,6 +67,8 @@
this one is a ListView with a selected line (which is shown highlighted)
If multipleSelectionsOk is true, it is also allowed to shift-click multiple
entries.
+ If toggleSelect is true, clicking toggles (i.e. click on a seleted item
+ will deselect).
Whenever the selection changes, an action-block is evaluated, passing the
current selection as argument.
@@ -101,8 +104,11 @@
Currently, some limited form of line attributes are supported. These
are kept in the instance variable lineAttributes.
This may change (using mechanisms similar to MultiColListEntry), so
- be prepared. (dont use attributes, if possible - use MultiColListEntry or
- subclasses of it).
+ be prepared. (dont use the listAttributes instvar directly; if possible,
+ use MultiColListEntry or subclasses of it.
+ Although currently based on the listAttributes instVar, the implementation of
+ text attributes will be changed in the near future. However, the protocol
+ will probably be kept (i.e. use attributeAt: / attributeAt:put etc.).
InstanceVariables:
selection <misc> the current selection. nil, a number or collection of numbers
@@ -122,12 +128,19 @@
listAttributes dont use - will vanish
- multipleSelectOk <Boolean> if true, multiple selections (with shift) are ok
hilightLevel <Integer> level to draw selections (i.e. for 3D effect)
hilightFrameColor <Color> rectangle around highlighted items
+ multipleSelectOk <Boolean> if true, multiple selections (with shift) are ok.
+ default: false
+
ignoreReselect <Boolean> if true, selecting same again does not trigger action;
- if false, every select triggers it
+ if false, every select triggers it.
+ default: true
+
+ toggleSelect <Boolean> if true, click toggles;
+ if false, click selects.
+ default: false
arrowLevel <Integer> level to draw right-arrows (for submenus etc.)
smallArrow <Boolean> if true, uses a small arrow bitmap
@@ -342,9 +355,11 @@
super initialize.
fontHeight := font height + lineSpacing.
+ enabled := true.
multipleSelectOk := false.
- enabled := true.
ignoreReselect := true.
+ toggleSelect := false.
+ strikeOut := false.
keyActionStyle := #select.
!
@@ -365,7 +380,7 @@
device hasGreyscales ifTrue:[
"
- must get rid of these explicit name-checks
+ must get rid of these hard codings
"
nm := StyleSheet name asSymbol.
(nm == #next) ifTrue:[
@@ -399,7 +414,7 @@
fgColor := DefaultForegroundColor
].
DefaultBackgroundColor notNil ifTrue:[
- bgColor := DefaultBackgroundColor
+ bgColor := viewBackground := DefaultBackgroundColor
].
DefaultHilightForegroundColor notNil ifTrue:[
hilightFgColor := DefaultHilightForegroundColor
@@ -480,20 +495,36 @@
#pass -> will pass key to superclass (i.e. no special treatment)
nil -> will ignore key
+
+ the default (set in #initialize) is #select
"
keyActionStyle := aSymbol
!
-setList:aCollection
- "set the list - redefined, since setting the list implies unselecting"
+contents:aCollection
+ "set the list - redefined, since setting the list implies unselecting
+ and clearing attributes."
selection := nil.
- super setList:aCollection
+ listAttributes := nil.
+ super contents:aCollection.
+!
+
+setList:aCollection
+ "set the list - redefined, since setting the list implies unselecting
+ and clearing attributes.
+ No redraw is done - the caller should make sure to redraw afterwards
+ (or use this only before the view is visible)."
+
+ selection := nil.
+ listAttributes := nil.
+ super setList:aCollection.
!
list:aCollection
- "set the list - redefined, since setting the list implies unselecting"
+ "set the list - redefined, since setting the list implies unselecting
+ and clearing attributes."
"somewhat of a kludge: if selection is first line,
we have to remove the highlight frame by hand here"
@@ -508,17 +539,25 @@
].
selection := nil.
- super list:aCollection
+ listAttributes := nil.
+ super list:aCollection.
!
-attributes:aList
- "set the attribute list"
+setAttributes:aList
+ "set the attribute list.
+ No redraw is done - the caller should make sure to redraw afterwards
+ (or use this only before the view is visible)."
- listAttributes := attributes
+ listAttributes := aList
!
attributeAt:index
- "return the line attribute of list line index"
+ "return the line attribute of list line index.
+ currently supported are:
+ #halfIntensity
+ #disabled
+ #bold
+ "
listAttributes isNil ifFalse:[
(index > listAttributes size) ifFalse:[
@@ -529,15 +568,16 @@
!
attributeAt:index put:aSymbolOrCollectionOfSymbolsOrNil
- "set a line attribute;
+ "set a lines attribute(s);
currently supported are:
#halfIntensity
#disabled
+ #bold
"
(index > list size) ifFalse:[
listAttributes isNil ifTrue:[
- listAttributes := VariableArray new:index
+ listAttributes := (OrderedCollection new:index) grow:index
] ifFalse:[
(index > listAttributes size) ifTrue:[
listAttributes grow:index
@@ -550,11 +590,71 @@
]
!
+attributeAt:index add:aSymbolOrCollectionOfSymbols
+ "add to a lines attribute(s);
+ currently supported are:
+ #halfIntensity
+ #disabled
+ #bold
+ "
+
+ |current|
+
+ current := self attributeAt:index.
+ current isNil ifTrue:[
+ current := Set new.
+ ] ifFalse:[
+ current isSymbol ifTrue:[
+ current == aSymbolOrCollectionOfSymbols ifTrue:[^ self].
+ current := Set with:current
+ ]
+ ].
+
+ aSymbolOrCollectionOfSymbols isSymbol ifTrue:[
+ current := current add:aSymbolOrCollectionOfSymbols
+ ] ifFalse:[
+ (current includes:aSymbolOrCollectionOfSymbols) ifTrue:[^ self].
+ current addAll:aSymbolOrCollectionOfSymbols
+ ].
+ self attributeAt:index put:current
+!
+
+attributeAt:index remove:aSymbolOrCollectionOfSymbols
+ "remove a line attribute;
+ currently supported are:
+ #halfIntensity
+ #disabled
+ #bold
+ "
+
+ |current|
+
+ current := self attributeAt:index.
+ current isNil ifTrue:[^ self].
+ current isSymbol ifTrue:[
+ aSymbolOrCollectionOfSymbols isSymbol ifTrue:[
+ current == aSymbolOrCollectionOfSymbols ifTrue:[current := nil]
+ ] ifFalse:[
+ (aSymbolOrCollectionOfSymbols includes:current) ifTrue:[
+ current := nil
+ ]
+ ]
+ ] ifFalse:[
+ aSymbolOrCollectionOfSymbols isSymbol ifTrue:[
+ current := current remove:aSymbolOrCollectionOfSymbols ifAbsent:[]
+ ] ifFalse:[
+ aSymbolOrCollectionOfSymbols removeAll:aSymbolOrCollectionOfSymbols
+ ]
+ ].
+ self attributeAt:index put:current
+!
+
line:lineNr hasAttribute:aSymbol
"return true, if line nr has attribute, aSymbol;
- currently suppoerted attributes are:
+ currently supported attributes are:
#halfIntensity
#disabled
+ #bold
"
|attr|
@@ -619,6 +719,18 @@
!SelectionInListView methodsFor:'selections'!
+toggleSelect:aBoolean
+ "turn on/off toggle select"
+
+ toggleSelect := aBoolean.
+!
+
+strikeOut:aBoolean
+ "turn on/off strikeOut mode"
+
+ strikeOut := aBoolean.
+!
+
multipleSelectOk:aBoolean
"allow/disallow multiple selections"
@@ -672,8 +784,33 @@
^ 1
!
+isInSelection:aNumber
+ "return true, if line, aNumber is in the selection"
+
+ selection isNil ifTrue:[^ false].
+ (selection isKindOf:Collection) ifTrue:[
+ ^ (selection includes:aNumber)
+ ].
+ ^ (aNumber == selection)
+!
+
+valueIsInSelection:someString
+ "return true, if someString is in the selection"
+
+ |sel|
+
+ selection isNil ifTrue:[^ false].
+ sel := self selectionValue.
+ self numberOfSelections > 1 ifTrue:[
+ ^ (sel includes:someString)
+ ].
+ ^ (someString = sel)
+!
+
hasSelection
- ^ selection isNil
+ "return true, if the view has a selection"
+
+ ^ selection notNil
!
selectionValue
@@ -712,8 +849,8 @@
|lineNo|
list notNil ifTrue:[
- lineNo := list indexOf:(anObject printString) ifAbsent:[0].
- lineNo ~~ 0 ifTrue:[self selectWithoutScroll:lineNo]
+ lineNo := list indexOf:(anObject printString) ifAbsent:[].
+ lineNo notNil ifTrue:[self selectWithoutScroll:lineNo]
]
!
@@ -724,8 +861,8 @@
|lineNo|
list notNil ifTrue:[
- lineNo := list indexOf:(anObject printString) ifAbsent:[0].
- lineNo ~~ 0 ifTrue:[self selection:lineNo]
+ lineNo := list indexOf:(anObject printString) ifAbsent:[].
+ lineNo notNil ifTrue:[self selection:lineNo]
]
!
@@ -766,28 +903,42 @@
self selectWithoutScroll:aNumberOrNil.
selection notNil ifTrue:[
- shown ifTrue:[
+"/ shown ifTrue:[
self makeLineVisible:selection
- ]
+"/ ]
]
!
+selectAll
+ "select all entries."
+
+ selection := OrderedCollection withAll:(1 to:list size).
+ shown ifTrue:[self redraw]
+!
+
addElementToSelection:anObject
"add the element with the same printstring as the argument, anObject
- to the selection. No scrolling is done"
+ to the selection. The entry is searched by comparing printStrings.
+ No scrolling is done. Returns true, if ok, false if no such entry
+ was found."
+
+ |lineNo str|
- |lineNo|
-
- lineNo := list indexOf:(anObject printString) ifAbsent:[0].
- lineNo ~~ 0 ifTrue:[self addToSelection:lineNo]
+ str := anObject printString.
+ lineNo := list findFirst:[:entry | str = entry printString].
+ lineNo ~~ 0 ifTrue:[
+ self addToSelection:lineNo.
+ ^ true
+ ].
+ ^ false
!
addToSelection:aNumber
- "add line, aNumber to the selection. No scrolling is done."
+ "add entry, aNumber to the selection. No scrolling is done."
+
+ (self isValidSelection:aNumber) ifFalse:[^ self].
selection isNil ifTrue:[^ self selectWithoutScroll:aNumber].
-
- (self isValidSelection:aNumber) ifFalse:[^ self].
(selection isKindOf:Collection) ifTrue:[
(selection includes:aNumber) ifTrue:[^ self].
selection add:aNumber
@@ -798,6 +949,31 @@
self redrawElement:aNumber
!
+removeFromSelection:aNumber
+ "remove entry, aNumber from the selection."
+
+ selection isNil ifTrue:[^ self].
+
+ (selection isKindOf:Collection) ifTrue:[
+ (selection includes:aNumber) ifFalse:[^ self].
+ selection remove:aNumber
+ ] ifFalse:[
+ (aNumber == selection) ifFalse:[^ self].
+ selection := nil
+ ].
+ self redrawElement:aNumber
+!
+
+toggleSelection:aNumber
+ "toggle selection-state of entry, aNumber"
+
+ (self isInSelection:aNumber) ifTrue:[
+ self removeFromSelection:aNumber
+ ] ifFalse:[
+ self addToSelection:aNumber
+ ]
+!
+
nextAfterSelection
"return the number of the next selectable entry after the selection.
Wrap at end."
@@ -822,13 +998,6 @@
^ next
!
-selectNext
- "select next line or first visible if there is currrently no selection.
- Wrap at end."
-
- self selection:(self nextAfterSelection)
-!
-
previousBeforeSelection
"return the number of the previous selectable entry before the selection.
Wrap at beginning."
@@ -853,11 +1022,34 @@
^ prev
!
+selectNext
+ "select next line or first visible if there is currrently no selection.
+ Wrap at end."
+
+ self selection:(self nextAfterSelection)
+!
+
selectPrevious
"select previous line or previous visible if there is currently no selection.
Wrap at beginning."
self selection:(self previouseBeforeSelection).
+!
+
+selectionDo:aBlock
+ "perform aBlock for each nr in the selection.
+ For single selection, it is called once for the items nr.
+ For multiple selections, it is called for each."
+
+ |sz|
+
+ selection isNil ifTrue:[^ self].
+ sz := selection size.
+ sz > 0 ifTrue:[
+ selection do:aBlock
+ ] ifFalse:[
+ aBlock value:selection
+ ].
! !
!SelectionInListView methodsFor:'private'!
@@ -908,16 +1100,6 @@
^ (aNumber between:1 and:list size)
!
-isInSelection:aNumber
- "return true, if line, aNumber is in the selection"
-
- selection isNil ifTrue:[^ false].
- (selection isKindOf:Collection) ifTrue:[
- ^ (selection includes:aNumber)
- ].
- ^ (aNumber == selection)
-!
-
positionToSelectionX:x y:y
"given a click position, return the selection lineNo"
@@ -983,24 +1165,6 @@
^ false
!
-removeFromSelection:aNumber
- "remove line, aNumber from the selection"
-
- selection isNil ifTrue:[^ self].
-
- (selection isKindOf:Collection) ifTrue:[
- (selection includes:aNumber) ifFalse:[^ self].
- selection remove:aNumber.
- (selection size == 1) ifTrue:[
- selection := selection at:1
- ]
- ] ifFalse:[
- (aNumber == selection) ifFalse:[^ self].
- selection := nil
- ].
- self redrawElement:aNumber
-!
-
scrollSelectDown
"auto scroll action; scroll and reinstall timed-block"
@@ -1155,7 +1319,7 @@
Must check, if any is in the selection and handle this case.
Otherwise draw using supers method."
- |listLine fg bg attr|
+ |listLine fg bg attr oldFont|
fg := fgColor.
bg := bgColor.
@@ -1164,17 +1328,20 @@
(self isInSelection:listLine) ifTrue:[
^ self drawVisibleLineSelected:visLineNr
].
- attr := self attributeAt:listLine.
- attr notNil ifTrue:[
- (attr == #halfIntensity
- or:[attr isSymbol not and:[attr includes:#halfIntensity]]) ifTrue:[
+ (self line:listLine hasAttribute:#halfIntensity) ifTrue:[
+ fg := halfIntensityFgColor
+ ] ifFalse:[
+ (self line:listLine hasAttribute:#disabled) ifTrue:[
fg := halfIntensityFgColor
- ].
- (attr == #disbled
- or:[attr isSymbol not and:[attr includes:#disabled]]) ifTrue:[
- fg := halfIntensityFgColor
+ ] ifFalse:[
+ (self line:listLine hasAttribute:#bold) ifTrue:[
+device setFont:(font asBold on:device) fontId in:gcId.
+ self drawVisibleLine:visLineNr with:fg and:bg.
+device setFont:(font on:device) fontId in:gcId.
+ ^ self
+ ]
]
- ].
+ ]
].
^ self drawVisibleLine:visLineNr with:fg and:bg
!
@@ -1196,6 +1363,16 @@
"/ self fillRectangleX:0 y:(self yOfVisibleLine:visLineNr)-1 width:width height:1
"/ ].
+ strikeOut ifTrue:[
+ self drawVisibleLine:visLineNr with:fgColor and:bgColor.
+ y := self yOfVisibleLine:visLineNr.
+
+ self paint:fgColor.
+ y := y + (fontHeight // 2).
+ self displayLineFromX:0 y:y toX:width y:y.
+ ^ self
+ ].
+
self drawVisibleLine:visLineNr with:fg and:bg.
y := self yOfVisibleLine:visLineNr.
@@ -1245,17 +1422,32 @@
"if there is a selection, make certain, its visible
after the sizechange"
- |first|
+ |first wasAtEnd|
+
+ wasAtEnd := (firstLineShown + nFullLinesShown) >= list size.
super sizeChanged:how.
+
shown ifTrue:[
selection notNil ifTrue:[
(selection isKindOf:Collection) ifTrue:[
- first := selection first
+ selection isEmpty ifTrue:[
+ first := 1
+ ] ifFalse:[
+ first := selection first
+ ]
] ifFalse:[
first := selection
].
self makeLineVisible:first
+ ] ifFalse:[
+ "if we where at the end before, move to the end again.
+ Still to be seen, if this is better in real life ...
+ "
+ wasAtEnd ifTrue:[
+ "at end"
+ self scrollToBottom
+ ]
]
]
!
@@ -1278,7 +1470,7 @@
keyPress:key x:x y:y
"handle keyboard input"
- |index startSearch|
+ |index startSearch backSearch searchPrefix|
(keyboardHandler notNil
and:[keyboardHandler canHandle:key]) ifTrue:[
@@ -1317,43 +1509,70 @@
doubleClickActionBlock notNil ifTrue:[
doubleClickActionBlock value:selection
].
- ^ self
- ]
+ ].
+ ^ self
].
"
alphabetic keys: search for next entry
- starting with keys character
+ starting with keys character. If shift is pressed, search backward
"
- list size > 0 ifTrue:[
- key isCharacter ifTrue:[
- key isLetter ifTrue:[
- keyActionStyle isNil ifTrue:[^ self].
- keyActionStyle == #pass ifFalse:[
- selection notNil ifTrue:[
- selection size > 0 ifTrue:[
- startSearch := selection last + 1
- ] ifFalse:[
- startSearch := selection + 1
- ]
+ (list size > 0
+ and:[key isCharacter
+ and:[key isLetter]]) ifTrue:[
+ keyActionStyle isNil ifTrue:[^ self].
+ keyActionStyle == #pass ifFalse:[
+ searchPrefix := key asLowercase asString.
+
+"/ ... isISearch... ifFalse:[
+"/ iSearchString := ''
+"/ ] ifTrue:[
+"/ iSearchString := iSearchString , searchPrefix.
+"/ searchPrefix := iSearchString
+"/ ].
+
+ backSearch := device shiftDown.
+ backSearch ifTrue:[
+ selection notNil ifTrue:[
+ selection size > 0 ifTrue:[
+ startSearch := selection first - 1
] ifFalse:[
- startSearch := 1
- ].
- startSearch > list size ifTrue:[
- startSearch := 1.
- ].
- index := startSearch.
- [true] whileTrue:[
- (((list at:index) asString at:1) asLowercase == key asLowercase) ifTrue:[
- ^ self key:key select:[self selection:index] x:x y:y
- ].
- index := index + 1.
- index > list size ifTrue:[
- index := 1
- ].
- index == startSearch ifTrue:[
- ^ self
- ]
+ startSearch := selection - 1
+ ]
+ ] ifFalse:[
+ startSearch := list size
+ ].
+ startSearch < 1 ifTrue:[
+ startSearch := list size.
+ ].
+ ] ifFalse:[
+ selection notNil ifTrue:[
+ selection size > 0 ifTrue:[
+ startSearch := selection last + 1
+ ] ifFalse:[
+ startSearch := selection + 1
]
+ ] ifFalse:[
+ startSearch := 1
+ ].
+ startSearch > list size ifTrue:[
+ startSearch := 1.
+ ].
+ ].
+ index := startSearch.
+ [true] whileTrue:[
+ (((list at:index) asString) asLowercase startsWith:searchPrefix) ifTrue:[
+ index = selection ifTrue:[^ self].
+ ^ self key:key select:[self selection:index] x:x y:y
+ ].
+ backSearch ifTrue:[
+ index := index - 1.
+ index < 1 ifTrue:[index := list size]
+ ] ifFalse:[
+ index := index + 1.
+ index > list size ifTrue:[index := 1].
+ ].
+ index == startSearch ifTrue:[
+ ^ self
]
]
].
@@ -1368,25 +1587,38 @@
enabled ifTrue:[
listLineNr := self visibleLineToListLine:(self visibleLineOfY:y).
listLineNr notNil ifTrue:[
- (self line:listLineNr hasAttribute:#disabled) ifTrue:[^ self].
+ (toggleSelect
+ and:[self isInSelection:listLineNr]) ifTrue:[
+ self removeFromSelection:listLineNr
+ ] ifFalse:[
+ (self line:listLineNr hasAttribute:#disabled) ifTrue:[^ self].
+
+ (selectConditionBlock notNil
+ and:[(selectConditionBlock value:listLineNr) not]) ifTrue:[^ self].
- (selectConditionBlock notNil
- and:[(selectConditionBlock value:listLineNr) not]) ifTrue:[^ self].
- ].
-
- oldSelection := selection.
- listLineNr notNil ifTrue: [
- self selectWithoutScroll:listLineNr
+ (toggleSelect and:[multipleSelectOk]) ifTrue:[
+ oldSelection := selection.
+ self addToSelection:listLineNr
+ ] ifFalse:[
+ oldSelection := selection.
+ self selectWithoutScroll:listLineNr.
+ ].
+ ].
+ ((ignoreReselect not and:[selection notNil])
+ or:[selection ~= oldSelection]) ifTrue:[
+ "
+ the ST/X way of doing things - perform actionBlock
+ "
+ actionBlock notNil ifTrue:[actionBlock value:selection].
+ "
+ the ST-80 way of doing things - notify model via changeSymbol
+ "
+ (model notNil and:[changeSymbol notNil]) ifTrue:[
+ model perform:changeSymbol with:(self selectionValue)
+ ]
+ ].
+ clickLine := listLineNr
].
- ((ignoreReselect not and:[selection notNil])
- or:[selection ~= oldSelection]) ifTrue:[
- actionBlock notNil ifTrue:[actionBlock value:selection].
- "the ST-80 way of doing things"
- model notNil ifTrue:[
- model perform:changeSymbol with:(self selectionValue)
- ]
- ].
- clickLine := listLineNr
]
] ifFalse:[
super buttonPress:button x:x y:y
@@ -1397,6 +1629,9 @@
|oldSelection listLineNr|
((button == 1) or:[button == #select]) ifTrue:[
+ toggleSelect ifTrue:[
+ ^ self buttonPress:button x:x y:y
+ ].
enabled ifTrue:[
listLineNr := self visibleLineToListLine:(self visibleLineOfY:y).
listLineNr notNil ifTrue:[
@@ -1449,11 +1684,18 @@
self stopAutoScroll
!
-buttonMotion:button x:x y:y
+buttonMotion:buttonMask x:x y:y
"mouse-move while button was pressed - handle selection changes"
|movedVisibleLine movedLine delta oldSelection oldSelCount|
+ "is it the select or 1-button ?"
+ (device buttonMotionMask:buttonMask includesButton:#select) ifFalse:[
+ (device buttonMotionMask:buttonMask includesButton:1) ifFalse:[
+ ^ self
+ ].
+ ].
+
clickLine isNil ifTrue:[^ self].
"if moved outside of view, start autoscroll"
--- a/SelectionInListView.st Thu Nov 17 15:34:12 1994 +0100
+++ b/SelectionInListView.st Thu Nov 17 15:38:53 1994 +0100
@@ -19,7 +19,8 @@
listAttributes multipleSelectOk clickLine
listSymbol initialSelectionSymbol printItems oneItem
hilightLevel hilightFrameColor ignoreReselect
- arrowLevel smallArrow keyActionStyle'
+ arrowLevel smallArrow keyActionStyle toggleSelect
+ strikeOut iSearchString'
classVariableNames:'RightArrowShadowForm RightArrowLightForm RightArrowForm
SmallRightArrowShadowForm SmallRightArrowLightForm
DefaultForegroundColor DefaultBackgroundColor
@@ -36,7 +37,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/SelectionInListView.st,v 1.12 1994-10-28 03:25:26 claus Exp $
+$Header: /cvs/stx/stx/libwidg/SelectionInListView.st,v 1.13 1994-11-17 14:38:36 claus Exp $
'!
!SelectionInListView class methodsFor:'documentation'!
@@ -57,7 +58,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/SelectionInListView.st,v 1.12 1994-10-28 03:25:26 claus Exp $
+$Header: /cvs/stx/stx/libwidg/SelectionInListView.st,v 1.13 1994-11-17 14:38:36 claus Exp $
"
!
@@ -66,6 +67,8 @@
this one is a ListView with a selected line (which is shown highlighted)
If multipleSelectionsOk is true, it is also allowed to shift-click multiple
entries.
+ If toggleSelect is true, clicking toggles (i.e. click on a seleted item
+ will deselect).
Whenever the selection changes, an action-block is evaluated, passing the
current selection as argument.
@@ -101,8 +104,11 @@
Currently, some limited form of line attributes are supported. These
are kept in the instance variable lineAttributes.
This may change (using mechanisms similar to MultiColListEntry), so
- be prepared. (dont use attributes, if possible - use MultiColListEntry or
- subclasses of it).
+ be prepared. (dont use the listAttributes instvar directly; if possible,
+ use MultiColListEntry or subclasses of it.
+ Although currently based on the listAttributes instVar, the implementation of
+ text attributes will be changed in the near future. However, the protocol
+ will probably be kept (i.e. use attributeAt: / attributeAt:put etc.).
InstanceVariables:
selection <misc> the current selection. nil, a number or collection of numbers
@@ -122,12 +128,19 @@
listAttributes dont use - will vanish
- multipleSelectOk <Boolean> if true, multiple selections (with shift) are ok
hilightLevel <Integer> level to draw selections (i.e. for 3D effect)
hilightFrameColor <Color> rectangle around highlighted items
+ multipleSelectOk <Boolean> if true, multiple selections (with shift) are ok.
+ default: false
+
ignoreReselect <Boolean> if true, selecting same again does not trigger action;
- if false, every select triggers it
+ if false, every select triggers it.
+ default: true
+
+ toggleSelect <Boolean> if true, click toggles;
+ if false, click selects.
+ default: false
arrowLevel <Integer> level to draw right-arrows (for submenus etc.)
smallArrow <Boolean> if true, uses a small arrow bitmap
@@ -342,9 +355,11 @@
super initialize.
fontHeight := font height + lineSpacing.
+ enabled := true.
multipleSelectOk := false.
- enabled := true.
ignoreReselect := true.
+ toggleSelect := false.
+ strikeOut := false.
keyActionStyle := #select.
!
@@ -365,7 +380,7 @@
device hasGreyscales ifTrue:[
"
- must get rid of these explicit name-checks
+ must get rid of these hard codings
"
nm := StyleSheet name asSymbol.
(nm == #next) ifTrue:[
@@ -399,7 +414,7 @@
fgColor := DefaultForegroundColor
].
DefaultBackgroundColor notNil ifTrue:[
- bgColor := DefaultBackgroundColor
+ bgColor := viewBackground := DefaultBackgroundColor
].
DefaultHilightForegroundColor notNil ifTrue:[
hilightFgColor := DefaultHilightForegroundColor
@@ -480,20 +495,36 @@
#pass -> will pass key to superclass (i.e. no special treatment)
nil -> will ignore key
+
+ the default (set in #initialize) is #select
"
keyActionStyle := aSymbol
!
-setList:aCollection
- "set the list - redefined, since setting the list implies unselecting"
+contents:aCollection
+ "set the list - redefined, since setting the list implies unselecting
+ and clearing attributes."
selection := nil.
- super setList:aCollection
+ listAttributes := nil.
+ super contents:aCollection.
+!
+
+setList:aCollection
+ "set the list - redefined, since setting the list implies unselecting
+ and clearing attributes.
+ No redraw is done - the caller should make sure to redraw afterwards
+ (or use this only before the view is visible)."
+
+ selection := nil.
+ listAttributes := nil.
+ super setList:aCollection.
!
list:aCollection
- "set the list - redefined, since setting the list implies unselecting"
+ "set the list - redefined, since setting the list implies unselecting
+ and clearing attributes."
"somewhat of a kludge: if selection is first line,
we have to remove the highlight frame by hand here"
@@ -508,17 +539,25 @@
].
selection := nil.
- super list:aCollection
+ listAttributes := nil.
+ super list:aCollection.
!
-attributes:aList
- "set the attribute list"
+setAttributes:aList
+ "set the attribute list.
+ No redraw is done - the caller should make sure to redraw afterwards
+ (or use this only before the view is visible)."
- listAttributes := attributes
+ listAttributes := aList
!
attributeAt:index
- "return the line attribute of list line index"
+ "return the line attribute of list line index.
+ currently supported are:
+ #halfIntensity
+ #disabled
+ #bold
+ "
listAttributes isNil ifFalse:[
(index > listAttributes size) ifFalse:[
@@ -529,15 +568,16 @@
!
attributeAt:index put:aSymbolOrCollectionOfSymbolsOrNil
- "set a line attribute;
+ "set a lines attribute(s);
currently supported are:
#halfIntensity
#disabled
+ #bold
"
(index > list size) ifFalse:[
listAttributes isNil ifTrue:[
- listAttributes := VariableArray new:index
+ listAttributes := (OrderedCollection new:index) grow:index
] ifFalse:[
(index > listAttributes size) ifTrue:[
listAttributes grow:index
@@ -550,11 +590,71 @@
]
!
+attributeAt:index add:aSymbolOrCollectionOfSymbols
+ "add to a lines attribute(s);
+ currently supported are:
+ #halfIntensity
+ #disabled
+ #bold
+ "
+
+ |current|
+
+ current := self attributeAt:index.
+ current isNil ifTrue:[
+ current := Set new.
+ ] ifFalse:[
+ current isSymbol ifTrue:[
+ current == aSymbolOrCollectionOfSymbols ifTrue:[^ self].
+ current := Set with:current
+ ]
+ ].
+
+ aSymbolOrCollectionOfSymbols isSymbol ifTrue:[
+ current := current add:aSymbolOrCollectionOfSymbols
+ ] ifFalse:[
+ (current includes:aSymbolOrCollectionOfSymbols) ifTrue:[^ self].
+ current addAll:aSymbolOrCollectionOfSymbols
+ ].
+ self attributeAt:index put:current
+!
+
+attributeAt:index remove:aSymbolOrCollectionOfSymbols
+ "remove a line attribute;
+ currently supported are:
+ #halfIntensity
+ #disabled
+ #bold
+ "
+
+ |current|
+
+ current := self attributeAt:index.
+ current isNil ifTrue:[^ self].
+ current isSymbol ifTrue:[
+ aSymbolOrCollectionOfSymbols isSymbol ifTrue:[
+ current == aSymbolOrCollectionOfSymbols ifTrue:[current := nil]
+ ] ifFalse:[
+ (aSymbolOrCollectionOfSymbols includes:current) ifTrue:[
+ current := nil
+ ]
+ ]
+ ] ifFalse:[
+ aSymbolOrCollectionOfSymbols isSymbol ifTrue:[
+ current := current remove:aSymbolOrCollectionOfSymbols ifAbsent:[]
+ ] ifFalse:[
+ aSymbolOrCollectionOfSymbols removeAll:aSymbolOrCollectionOfSymbols
+ ]
+ ].
+ self attributeAt:index put:current
+!
+
line:lineNr hasAttribute:aSymbol
"return true, if line nr has attribute, aSymbol;
- currently suppoerted attributes are:
+ currently supported attributes are:
#halfIntensity
#disabled
+ #bold
"
|attr|
@@ -619,6 +719,18 @@
!SelectionInListView methodsFor:'selections'!
+toggleSelect:aBoolean
+ "turn on/off toggle select"
+
+ toggleSelect := aBoolean.
+!
+
+strikeOut:aBoolean
+ "turn on/off strikeOut mode"
+
+ strikeOut := aBoolean.
+!
+
multipleSelectOk:aBoolean
"allow/disallow multiple selections"
@@ -672,8 +784,33 @@
^ 1
!
+isInSelection:aNumber
+ "return true, if line, aNumber is in the selection"
+
+ selection isNil ifTrue:[^ false].
+ (selection isKindOf:Collection) ifTrue:[
+ ^ (selection includes:aNumber)
+ ].
+ ^ (aNumber == selection)
+!
+
+valueIsInSelection:someString
+ "return true, if someString is in the selection"
+
+ |sel|
+
+ selection isNil ifTrue:[^ false].
+ sel := self selectionValue.
+ self numberOfSelections > 1 ifTrue:[
+ ^ (sel includes:someString)
+ ].
+ ^ (someString = sel)
+!
+
hasSelection
- ^ selection isNil
+ "return true, if the view has a selection"
+
+ ^ selection notNil
!
selectionValue
@@ -712,8 +849,8 @@
|lineNo|
list notNil ifTrue:[
- lineNo := list indexOf:(anObject printString) ifAbsent:[0].
- lineNo ~~ 0 ifTrue:[self selectWithoutScroll:lineNo]
+ lineNo := list indexOf:(anObject printString) ifAbsent:[].
+ lineNo notNil ifTrue:[self selectWithoutScroll:lineNo]
]
!
@@ -724,8 +861,8 @@
|lineNo|
list notNil ifTrue:[
- lineNo := list indexOf:(anObject printString) ifAbsent:[0].
- lineNo ~~ 0 ifTrue:[self selection:lineNo]
+ lineNo := list indexOf:(anObject printString) ifAbsent:[].
+ lineNo notNil ifTrue:[self selection:lineNo]
]
!
@@ -766,28 +903,42 @@
self selectWithoutScroll:aNumberOrNil.
selection notNil ifTrue:[
- shown ifTrue:[
+"/ shown ifTrue:[
self makeLineVisible:selection
- ]
+"/ ]
]
!
+selectAll
+ "select all entries."
+
+ selection := OrderedCollection withAll:(1 to:list size).
+ shown ifTrue:[self redraw]
+!
+
addElementToSelection:anObject
"add the element with the same printstring as the argument, anObject
- to the selection. No scrolling is done"
+ to the selection. The entry is searched by comparing printStrings.
+ No scrolling is done. Returns true, if ok, false if no such entry
+ was found."
+
+ |lineNo str|
- |lineNo|
-
- lineNo := list indexOf:(anObject printString) ifAbsent:[0].
- lineNo ~~ 0 ifTrue:[self addToSelection:lineNo]
+ str := anObject printString.
+ lineNo := list findFirst:[:entry | str = entry printString].
+ lineNo ~~ 0 ifTrue:[
+ self addToSelection:lineNo.
+ ^ true
+ ].
+ ^ false
!
addToSelection:aNumber
- "add line, aNumber to the selection. No scrolling is done."
+ "add entry, aNumber to the selection. No scrolling is done."
+
+ (self isValidSelection:aNumber) ifFalse:[^ self].
selection isNil ifTrue:[^ self selectWithoutScroll:aNumber].
-
- (self isValidSelection:aNumber) ifFalse:[^ self].
(selection isKindOf:Collection) ifTrue:[
(selection includes:aNumber) ifTrue:[^ self].
selection add:aNumber
@@ -798,6 +949,31 @@
self redrawElement:aNumber
!
+removeFromSelection:aNumber
+ "remove entry, aNumber from the selection."
+
+ selection isNil ifTrue:[^ self].
+
+ (selection isKindOf:Collection) ifTrue:[
+ (selection includes:aNumber) ifFalse:[^ self].
+ selection remove:aNumber
+ ] ifFalse:[
+ (aNumber == selection) ifFalse:[^ self].
+ selection := nil
+ ].
+ self redrawElement:aNumber
+!
+
+toggleSelection:aNumber
+ "toggle selection-state of entry, aNumber"
+
+ (self isInSelection:aNumber) ifTrue:[
+ self removeFromSelection:aNumber
+ ] ifFalse:[
+ self addToSelection:aNumber
+ ]
+!
+
nextAfterSelection
"return the number of the next selectable entry after the selection.
Wrap at end."
@@ -822,13 +998,6 @@
^ next
!
-selectNext
- "select next line or first visible if there is currrently no selection.
- Wrap at end."
-
- self selection:(self nextAfterSelection)
-!
-
previousBeforeSelection
"return the number of the previous selectable entry before the selection.
Wrap at beginning."
@@ -853,11 +1022,34 @@
^ prev
!
+selectNext
+ "select next line or first visible if there is currrently no selection.
+ Wrap at end."
+
+ self selection:(self nextAfterSelection)
+!
+
selectPrevious
"select previous line or previous visible if there is currently no selection.
Wrap at beginning."
self selection:(self previouseBeforeSelection).
+!
+
+selectionDo:aBlock
+ "perform aBlock for each nr in the selection.
+ For single selection, it is called once for the items nr.
+ For multiple selections, it is called for each."
+
+ |sz|
+
+ selection isNil ifTrue:[^ self].
+ sz := selection size.
+ sz > 0 ifTrue:[
+ selection do:aBlock
+ ] ifFalse:[
+ aBlock value:selection
+ ].
! !
!SelectionInListView methodsFor:'private'!
@@ -908,16 +1100,6 @@
^ (aNumber between:1 and:list size)
!
-isInSelection:aNumber
- "return true, if line, aNumber is in the selection"
-
- selection isNil ifTrue:[^ false].
- (selection isKindOf:Collection) ifTrue:[
- ^ (selection includes:aNumber)
- ].
- ^ (aNumber == selection)
-!
-
positionToSelectionX:x y:y
"given a click position, return the selection lineNo"
@@ -983,24 +1165,6 @@
^ false
!
-removeFromSelection:aNumber
- "remove line, aNumber from the selection"
-
- selection isNil ifTrue:[^ self].
-
- (selection isKindOf:Collection) ifTrue:[
- (selection includes:aNumber) ifFalse:[^ self].
- selection remove:aNumber.
- (selection size == 1) ifTrue:[
- selection := selection at:1
- ]
- ] ifFalse:[
- (aNumber == selection) ifFalse:[^ self].
- selection := nil
- ].
- self redrawElement:aNumber
-!
-
scrollSelectDown
"auto scroll action; scroll and reinstall timed-block"
@@ -1155,7 +1319,7 @@
Must check, if any is in the selection and handle this case.
Otherwise draw using supers method."
- |listLine fg bg attr|
+ |listLine fg bg attr oldFont|
fg := fgColor.
bg := bgColor.
@@ -1164,17 +1328,20 @@
(self isInSelection:listLine) ifTrue:[
^ self drawVisibleLineSelected:visLineNr
].
- attr := self attributeAt:listLine.
- attr notNil ifTrue:[
- (attr == #halfIntensity
- or:[attr isSymbol not and:[attr includes:#halfIntensity]]) ifTrue:[
+ (self line:listLine hasAttribute:#halfIntensity) ifTrue:[
+ fg := halfIntensityFgColor
+ ] ifFalse:[
+ (self line:listLine hasAttribute:#disabled) ifTrue:[
fg := halfIntensityFgColor
- ].
- (attr == #disbled
- or:[attr isSymbol not and:[attr includes:#disabled]]) ifTrue:[
- fg := halfIntensityFgColor
+ ] ifFalse:[
+ (self line:listLine hasAttribute:#bold) ifTrue:[
+device setFont:(font asBold on:device) fontId in:gcId.
+ self drawVisibleLine:visLineNr with:fg and:bg.
+device setFont:(font on:device) fontId in:gcId.
+ ^ self
+ ]
]
- ].
+ ]
].
^ self drawVisibleLine:visLineNr with:fg and:bg
!
@@ -1196,6 +1363,16 @@
"/ self fillRectangleX:0 y:(self yOfVisibleLine:visLineNr)-1 width:width height:1
"/ ].
+ strikeOut ifTrue:[
+ self drawVisibleLine:visLineNr with:fgColor and:bgColor.
+ y := self yOfVisibleLine:visLineNr.
+
+ self paint:fgColor.
+ y := y + (fontHeight // 2).
+ self displayLineFromX:0 y:y toX:width y:y.
+ ^ self
+ ].
+
self drawVisibleLine:visLineNr with:fg and:bg.
y := self yOfVisibleLine:visLineNr.
@@ -1245,17 +1422,32 @@
"if there is a selection, make certain, its visible
after the sizechange"
- |first|
+ |first wasAtEnd|
+
+ wasAtEnd := (firstLineShown + nFullLinesShown) >= list size.
super sizeChanged:how.
+
shown ifTrue:[
selection notNil ifTrue:[
(selection isKindOf:Collection) ifTrue:[
- first := selection first
+ selection isEmpty ifTrue:[
+ first := 1
+ ] ifFalse:[
+ first := selection first
+ ]
] ifFalse:[
first := selection
].
self makeLineVisible:first
+ ] ifFalse:[
+ "if we where at the end before, move to the end again.
+ Still to be seen, if this is better in real life ...
+ "
+ wasAtEnd ifTrue:[
+ "at end"
+ self scrollToBottom
+ ]
]
]
!
@@ -1278,7 +1470,7 @@
keyPress:key x:x y:y
"handle keyboard input"
- |index startSearch|
+ |index startSearch backSearch searchPrefix|
(keyboardHandler notNil
and:[keyboardHandler canHandle:key]) ifTrue:[
@@ -1317,43 +1509,70 @@
doubleClickActionBlock notNil ifTrue:[
doubleClickActionBlock value:selection
].
- ^ self
- ]
+ ].
+ ^ self
].
"
alphabetic keys: search for next entry
- starting with keys character
+ starting with keys character. If shift is pressed, search backward
"
- list size > 0 ifTrue:[
- key isCharacter ifTrue:[
- key isLetter ifTrue:[
- keyActionStyle isNil ifTrue:[^ self].
- keyActionStyle == #pass ifFalse:[
- selection notNil ifTrue:[
- selection size > 0 ifTrue:[
- startSearch := selection last + 1
- ] ifFalse:[
- startSearch := selection + 1
- ]
+ (list size > 0
+ and:[key isCharacter
+ and:[key isLetter]]) ifTrue:[
+ keyActionStyle isNil ifTrue:[^ self].
+ keyActionStyle == #pass ifFalse:[
+ searchPrefix := key asLowercase asString.
+
+"/ ... isISearch... ifFalse:[
+"/ iSearchString := ''
+"/ ] ifTrue:[
+"/ iSearchString := iSearchString , searchPrefix.
+"/ searchPrefix := iSearchString
+"/ ].
+
+ backSearch := device shiftDown.
+ backSearch ifTrue:[
+ selection notNil ifTrue:[
+ selection size > 0 ifTrue:[
+ startSearch := selection first - 1
] ifFalse:[
- startSearch := 1
- ].
- startSearch > list size ifTrue:[
- startSearch := 1.
- ].
- index := startSearch.
- [true] whileTrue:[
- (((list at:index) asString at:1) asLowercase == key asLowercase) ifTrue:[
- ^ self key:key select:[self selection:index] x:x y:y
- ].
- index := index + 1.
- index > list size ifTrue:[
- index := 1
- ].
- index == startSearch ifTrue:[
- ^ self
- ]
+ startSearch := selection - 1
+ ]
+ ] ifFalse:[
+ startSearch := list size
+ ].
+ startSearch < 1 ifTrue:[
+ startSearch := list size.
+ ].
+ ] ifFalse:[
+ selection notNil ifTrue:[
+ selection size > 0 ifTrue:[
+ startSearch := selection last + 1
+ ] ifFalse:[
+ startSearch := selection + 1
]
+ ] ifFalse:[
+ startSearch := 1
+ ].
+ startSearch > list size ifTrue:[
+ startSearch := 1.
+ ].
+ ].
+ index := startSearch.
+ [true] whileTrue:[
+ (((list at:index) asString) asLowercase startsWith:searchPrefix) ifTrue:[
+ index = selection ifTrue:[^ self].
+ ^ self key:key select:[self selection:index] x:x y:y
+ ].
+ backSearch ifTrue:[
+ index := index - 1.
+ index < 1 ifTrue:[index := list size]
+ ] ifFalse:[
+ index := index + 1.
+ index > list size ifTrue:[index := 1].
+ ].
+ index == startSearch ifTrue:[
+ ^ self
]
]
].
@@ -1368,25 +1587,38 @@
enabled ifTrue:[
listLineNr := self visibleLineToListLine:(self visibleLineOfY:y).
listLineNr notNil ifTrue:[
- (self line:listLineNr hasAttribute:#disabled) ifTrue:[^ self].
+ (toggleSelect
+ and:[self isInSelection:listLineNr]) ifTrue:[
+ self removeFromSelection:listLineNr
+ ] ifFalse:[
+ (self line:listLineNr hasAttribute:#disabled) ifTrue:[^ self].
+
+ (selectConditionBlock notNil
+ and:[(selectConditionBlock value:listLineNr) not]) ifTrue:[^ self].
- (selectConditionBlock notNil
- and:[(selectConditionBlock value:listLineNr) not]) ifTrue:[^ self].
- ].
-
- oldSelection := selection.
- listLineNr notNil ifTrue: [
- self selectWithoutScroll:listLineNr
+ (toggleSelect and:[multipleSelectOk]) ifTrue:[
+ oldSelection := selection.
+ self addToSelection:listLineNr
+ ] ifFalse:[
+ oldSelection := selection.
+ self selectWithoutScroll:listLineNr.
+ ].
+ ].
+ ((ignoreReselect not and:[selection notNil])
+ or:[selection ~= oldSelection]) ifTrue:[
+ "
+ the ST/X way of doing things - perform actionBlock
+ "
+ actionBlock notNil ifTrue:[actionBlock value:selection].
+ "
+ the ST-80 way of doing things - notify model via changeSymbol
+ "
+ (model notNil and:[changeSymbol notNil]) ifTrue:[
+ model perform:changeSymbol with:(self selectionValue)
+ ]
+ ].
+ clickLine := listLineNr
].
- ((ignoreReselect not and:[selection notNil])
- or:[selection ~= oldSelection]) ifTrue:[
- actionBlock notNil ifTrue:[actionBlock value:selection].
- "the ST-80 way of doing things"
- model notNil ifTrue:[
- model perform:changeSymbol with:(self selectionValue)
- ]
- ].
- clickLine := listLineNr
]
] ifFalse:[
super buttonPress:button x:x y:y
@@ -1397,6 +1629,9 @@
|oldSelection listLineNr|
((button == 1) or:[button == #select]) ifTrue:[
+ toggleSelect ifTrue:[
+ ^ self buttonPress:button x:x y:y
+ ].
enabled ifTrue:[
listLineNr := self visibleLineToListLine:(self visibleLineOfY:y).
listLineNr notNil ifTrue:[
@@ -1449,11 +1684,18 @@
self stopAutoScroll
!
-buttonMotion:button x:x y:y
+buttonMotion:buttonMask x:x y:y
"mouse-move while button was pressed - handle selection changes"
|movedVisibleLine movedLine delta oldSelection oldSelCount|
+ "is it the select or 1-button ?"
+ (device buttonMotionMask:buttonMask includesButton:#select) ifFalse:[
+ (device buttonMotionMask:buttonMask includesButton:1) ifFalse:[
+ ^ self
+ ].
+ ].
+
clickLine isNil ifTrue:[^ self].
"if moved outside of view, start autoscroll"
--- a/TextColl.st Thu Nov 17 15:34:12 1994 +0100
+++ b/TextColl.st Thu Nov 17 15:38:53 1994 +0100
@@ -23,7 +23,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Attic/TextColl.st,v 1.11 1994-10-28 03:25:29 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/TextColl.st,v 1.12 1994-11-17 14:38:40 claus Exp $
'!
!TextCollector class methodsFor:'documentation'!
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Attic/TextColl.st,v 1.11 1994-10-28 03:25:29 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/TextColl.st,v 1.12 1994-11-17 14:38:40 claus Exp $
"
!
@@ -96,7 +96,6 @@
|topView transcript f v fg bg cFg cBg lines cols|
topView := StandardSystemView label:'Transcript' minExtent:(100 @ 100).
- topView icon:(Form fromFile:'SmalltalkX.xbm').
v := HVScrollableView for:self miniScrollerH:true miniScrollerV:false in:topView.
v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
--- a/TextCollector.st Thu Nov 17 15:34:12 1994 +0100
+++ b/TextCollector.st Thu Nov 17 15:38:53 1994 +0100
@@ -23,7 +23,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/TextCollector.st,v 1.11 1994-10-28 03:25:29 claus Exp $
+$Header: /cvs/stx/stx/libwidg/TextCollector.st,v 1.12 1994-11-17 14:38:40 claus Exp $
'!
!TextCollector class methodsFor:'documentation'!
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/TextCollector.st,v 1.11 1994-10-28 03:25:29 claus Exp $
+$Header: /cvs/stx/stx/libwidg/TextCollector.st,v 1.12 1994-11-17 14:38:40 claus Exp $
"
!
@@ -96,7 +96,6 @@
|topView transcript f v fg bg cFg cBg lines cols|
topView := StandardSystemView label:'Transcript' minExtent:(100 @ 100).
- topView icon:(Form fromFile:'SmalltalkX.xbm').
v := HVScrollableView for:self miniScrollerH:true miniScrollerV:false in:topView.
v origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
--- a/TextView.st Thu Nov 17 15:34:12 1994 +0100
+++ b/TextView.st Thu Nov 17 15:38:53 1994 +0100
@@ -34,7 +34,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/TextView.st,v 1.11 1994-10-28 03:25:31 claus Exp $
+$Header: /cvs/stx/stx/libwidg/TextView.st,v 1.12 1994-11-17 14:38:42 claus Exp $
'!
!TextView class methodsFor:'documentation'!
@@ -55,7 +55,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/TextView.st,v 1.11 1994-10-28 03:25:31 claus Exp $
+$Header: /cvs/stx/stx/libwidg/TextView.st,v 1.12 1994-11-17 14:38:42 claus Exp $
"
!
@@ -588,9 +588,9 @@
"sent internally, whenever selection status changes to
update menu entries"
- selectionStartLine isNil ifTrue:[
+ self hasSelection ifFalse:[
self disableSelectionMenuEntries
- ] ifFalse:[
+ ] ifTrue:[
self enableSelectionMenuEntries
]
!
@@ -862,6 +862,11 @@
"show a box to enter searchpattern
- currently no regular expressions are handled."
+ "
+ cache the searchBox
+ Q: should we use one global searchBox for all textViews ?
+ (we could then preserve the last searchstring between views)
+ "
searchBox isNil ifTrue:[
searchBox :=
EnterBox2
@@ -875,9 +880,20 @@
searchPattern notNil ifTrue:[
searchBox initialText:searchPattern
].
+ self hasSelection ifTrue:[
+ selectionStartLine == selectionEndLine ifTrue:[
+ searchBox initialText:self selection
+ ]
+ ].
searchBox showAtPointer
!
+setSearchPattern:aString
+ "set the searchpattern for future searches"
+
+ searchPattern := aString withoutSeparators
+!
+
setSearchPattern
"set the searchpattern from the selection if there is one"
@@ -889,6 +905,12 @@
]
!
+searchPattern
+ "return the last search pattern"
+
+ ^ searchPattern
+!
+
showNotFound
"search not found - tell user by beeping and changing
cursor for a while (sometimes I work with a headset :-)
@@ -912,6 +934,13 @@
searchFwd
"search forward for pattern or selection"
+ selectStyle == #wordLeft ifTrue:[
+ "
+ remove the space from the selection
+ "
+ selectionStartCol := selectionStartCol + 1.
+ super redrawLine:selectionStartLine from:selectionStartCol-1 to:selectionStartCol-1.
+ ].
self setSearchPattern.
searchPattern notNil ifTrue:[
self searchFwd:searchPattern
@@ -928,7 +957,22 @@
!
searchFwd:pattern
- "do the forward search"
+ "do a forward search"
+
+ self searchFwd:pattern ifAbsent:[self showNotFound].
+ searchPattern := pattern
+!
+
+searchBwd:pattern
+ "do a backward search"
+
+ self searchBwd:pattern ifAbsent:[self showNotFound].
+ searchPattern := pattern
+
+!
+
+searchFwd:pattern ifAbsent:aBlock
+ "do a forward search"
|startLine startCol|
@@ -944,13 +988,11 @@
self selectFromLine:line col:col
toLine:line col:(col + pattern size - 1).
self makeLineVisible:line
- ] else:[
- self showNotFound
- ]
+ ] ifAbsent:aBlock
!
-searchBwd:pattern
- "do the backward search"
+searchBwd:pattern ifAbsent:aBlock
+ "do a backward search"
|startLine startCol|
@@ -966,9 +1008,7 @@
self selectFromLine:line col:col
toLine:line col:(col + pattern size - 1).
self makeLineVisible:line
- ] else:[
- self showNotFound
- ]
+ ] ifAbsent:aBlock
! !
!TextView methodsFor:'redrawing'!
@@ -1391,11 +1431,11 @@
clickLine isNil ifTrue:[^ self].
- "
- check if its a button-1 motion
- "
- ((buttonMask bitAnd:(device button1MotionMask)) ~~ 0) ifFalse:[
- ^ self
+ "is it the select or 1-button ?"
+ (device buttonMotionMask:buttonMask includesButton:#select) ifFalse:[
+ (device buttonMotionMask:buttonMask includesButton:1) ifFalse:[
+ ^ self
+ ].
].
"if moved outside of view, start autoscroll"
--- a/Toggle.st Thu Nov 17 15:34:12 1994 +0100
+++ b/Toggle.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Toggle.st,v 1.7 1994-10-10 03:03:16 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Toggle.st,v 1.8 1994-11-17 14:38:44 claus Exp $
'!
!Toggle class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Toggle.st,v 1.7 1994-10-10 03:03:16 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Toggle.st,v 1.8 1994-11-17 14:38:44 claus Exp $
"
!
@@ -68,7 +68,11 @@
lampColor <Color> color of the lamp
lampWidth <Integer> width of the lamp in pixel
lampHeight <Integer> height of the lamp in pixel
+"
+!
+examples
+"
Examples:
Try these, to see what is possible.
--- a/VPanelV.st Thu Nov 17 15:34:12 1994 +0100
+++ b/VPanelV.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Attic/VPanelV.st,v 1.5 1994-10-10 03:03:18 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/VPanelV.st,v 1.6 1994-11-17 14:38:46 claus Exp $
'!
!VerticalPanelView class methodsFor:'documentation'!
@@ -42,16 +42,45 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Attic/VPanelV.st,v 1.5 1994-10-10 03:03:18 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/VPanelV.st,v 1.6 1994-11-17 14:38:46 claus Exp $
"
!
documentation
"
a View which arranges its child-views in a vertical column.
- All real work is done in PanelView - only the layout computation is
+ All real work is done in PanelView - except the layout computation is
redefined here.
+ The layout is controlled by two instance variables.
+ The vertical layout can be any of:
+
+ #top arrange elements at the top
+ #topSpace arrange elements at the top, start with spacing
+ #bottom arrange elements at the bottom
+ #bottomSpace arrange elements at the bottom, start with spacing
+ #center arrange elements in the center
+ #spread spread elements evenly
+ #fit like spread, but resize elements for tight packing
+
+ the horizontal layout can be:
+
+ #left place element at the left
+ #leftSpace place element at the left, offset by horizontalSpace
+ #center place it horizontally centered
+ #right place it at the right
+ #rightSpace place it at the right, offset by horizontalSpace
+ #fit resize elements horizontally to fit this panel
+
+ The defaults is #centered for both directions.
+ The layout is changed by the messages #verticalLayout: and #horizontalLayout:.
+ For backward compatibility (to times, where only vLayout existed), the simple
+ #layout: does the same as #verticalLayout:. Do not use this old method.
+"
+!
+
+examples
+"
example: default layout (centered)
|v p b1 b2 b3|
@@ -66,13 +95,13 @@
v open
- example: left-layout
+ example: top-layout
|v p b1 b2 b3|
v := StandardSystemView new.
p := VerticalPanelView in:v.
- p layout:#top.
+ p verticalLayout:#top.
p origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
b1 := Button label:'button1' in:p.
b2 := Button label:'button2' in:p.
@@ -81,13 +110,13 @@
v open
- example: right-layout
+ example: bottom-layout
|v p b1 b2 b3|
v := StandardSystemView new.
p := VerticalPanelView in:v.
- p layout:#bottom.
+ p verticalLayout:#bottom.
p origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
b1 := Button label:'button1' in:p.
b2 := Button label:'button2' in:p.
@@ -102,16 +131,132 @@
v := StandardSystemView new.
p := VerticalPanelView in:v.
- p layout:#spread.
+ p verticalLayout:#spread.
+ p origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
+ b1 := Button label:'button1' in:p.
+ b2 := Button label:'button2' in:p.
+ b3 := Button label:'button3' in:p.
+ v extent:100 @ 300.
+ v open
+
+ example: from top, each at left:
+
+ |v p b1 b2 b3|
+
+ v := StandardSystemView new.
+ p := VerticalPanelView in:v.
+ p verticalLayout:#top.
+ p horizontalLayout:#left.
+ p origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
+ b1 := Button label:'button1' in:p.
+ b2 := Button label:'button2' in:p.
+ b3 := Button label:'button3' in:p.
+ v extent:100 @ 300.
+ v open
+
+ example: centered, right:
+
+ |v p b1 b2 b3|
+
+ v := StandardSystemView new.
+ p := VerticalPanelView in:v.
+ p verticalLayout:#centered.
+ p horizontalLayout:#right.
p origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
b1 := Button label:'button1' in:p.
b2 := Button label:'button2' in:p.
b3 := Button label:'button3' in:p.
v extent:100 @ 300.
v open
+
+ you should try more examples, combining spacing and different
+ verticalLayout:/horizontalLayout: combinations.
"
! !
+!VerticalPanelView methodsFor:'accessing'!
+
+horizontalLayout
+ "return the horizontal layout as symbol.
+ the returned value is one of
+ #left
+ #leftSpace
+ #center
+ #right
+ #rightSpace
+ #fit
+ the default is #centered
+ "
+
+ ^ hLayout
+!
+
+verticalLayout
+ "return the vertical layout as a symbol.
+ the returned value is one of
+ #top
+ #topSpace
+ #spread
+ #fit
+ #center
+ #bottom
+ #bottomSpace
+ the default is #centered
+ "
+
+ ^ vLayout
+!
+
+horizontalLayout:aSymbol
+ "change the horizontal layout as symbol.
+ The argument, aSymbol must be one of:
+ #left
+ #leftSpace
+ #center
+ #right
+ #rightSpace
+ #fit
+ the default (if never changed) is #centered
+ "
+
+ (hLayout ~~ aSymbol) ifTrue:[
+ hLayout := aSymbol.
+ self layoutChanged
+ ]
+!
+
+verticalLayout:aSymbol
+ "change the vertical layout as a symbol.
+ The argument, aSymbol must be one of:
+ #top
+ #topSpace
+ #spread
+ #fit
+ #center
+ #bottom
+ #bottomSpace
+ the default (if never changed) is #centered
+ "
+
+ (vLayout ~~ aSymbol) ifTrue:[
+ vLayout := aSymbol.
+ self layoutChanged
+ ]
+!
+
+layout
+ "leftover for historic reasons - do not use any more"
+
+ self verticalLayout
+!
+
+layout:aSymbol
+ "leftover for historic reasons - do not use any more"
+
+ self verticalLayout:aSymbol
+! !
+
+
!VerticalPanelView methodsFor:'queries'!
preferedExtent
@@ -127,9 +272,16 @@
maxWidth := 0.
subViews do:[:child |
- sumOfHeights := sumOfHeights + child heightIncludingBorder.
- maxWidth := maxWidth max:(child widthIncludingBorder).
- maxHeight := maxHeight max:(child heightIncludingBorder).
+ |childsPreference|
+
+ childsPreference := child preferedExtent.
+ sumOfHeights := sumOfHeights + childsPreference y.
+ maxHeight := maxHeight max:childsPreference y.
+ maxWidth := maxWidth max:childsPreference x.
+
+"/ sumOfHeights := sumOfHeights + child heightIncludingBorder.
+"/ maxWidth := maxWidth max:(child widthIncludingBorder).
+"/ maxHeight := maxHeight max:(child heightIncludingBorder).
].
borderWidth ~~ 0 ifTrue:[
sumOfHeights := sumOfHeights + (horizontalSpace * 2).
@@ -145,98 +297,137 @@
setChildPositions
"(re)compute position of every child"
- |xpos ypos space sumOfHeights numChilds l hEach|
+ |ypos space sumOfHeights numChilds l hEach|
subViews isNil ifTrue:[^ self].
space := verticalSpace.
+ numChilds := subViews size.
- numChilds := subViews size.
- layout == #fit ifTrue:[
+ vLayout == #fit ifTrue:[
"
adjust childs extents and set origins.
Be careful to avoid accumulation of rounding errors
"
hEach := (height - (margin * 2) - (numChilds + 1 * space) + borderWidth) / numChilds.
ypos := space + margin - borderWidth.
- subViews do:[:child |
- xpos := (width - child widthIncludingBorder) // 2.
- (xpos < 0) ifTrue:[xpos := 0].
+ ] ifFalse:[
+
+ "
+ compute net height needed
+ "
+ sumOfHeights := subViews inject:0 into:[:sumSoFar :child | sumSoFar + child heightIncludingBorder].
+
+ l := vLayout.
+ ((l == #center) and:[numChilds == 1]) ifTrue:[
+ l := #spread
+ ].
+
+ "
+ compute position of topmost subview and space between them;
+ if they do hardly fit, leave no space between them
+ "
+ (sumOfHeights >= (height - (margin * 2))) ifTrue:[
+ "
+ if we have not enough space for all the elements,
+ fill them tight, and show what can be shown (at least)
+ "
+ ypos := 0.
+ space := 0
+ ] ifFalse:[
+ ((l == #bottom) or:[l == #bottomSpace]) ifTrue:[
+ ypos := height - (space * numChilds) - sumOfHeights.
+ "
+ borderWidth == 0 ifTrue:[
+ ypos := ypos + space
+ ].
+ "
+ l == #bottomSpace ifTrue:[
+ ypos > space ifTrue:[
+ ypos := ypos - space
+ ]
+ ].
+ ypos < 0 ifTrue:[
+ space := space min:(height - sumOfHeights) // (numChilds + 1).
+ ypos := height - (space * numChilds) - sumOfHeights.
+ ]
+ ] ifFalse: [
+ (l == #spread) ifTrue:[
+ space := (height - sumOfHeights) // (numChilds + 1).
+ ypos := space.
+ (space == 0) ifTrue:[
+ ypos := (height - sumOfHeights) // 2
+ ]
+ ] ifFalse: [
+ ((l == #top) or:[l == #topSpace]) ifTrue:[
+ "
+ borderWidth == 0 ifTrue:[
+ ypos := 0
+ ] ifFalse:[
+ ypos := verticalSpace
+ ].
+ "
+ space := space min:(height - sumOfHeights) // (numChilds + 1).
+ l == #topSpace ifTrue:[
+ ypos := space.
+ ] ifFalse:[
+ ypos := 0
+ ]
+ ] ifFalse:[
+ "center"
+ ypos := (height - (sumOfHeights
+ + ((numChilds - 1) * space))) // 2.
+ ypos < 0 ifTrue:[
+ space := (height - sumOfHeights) // (numChilds + 1).
+ ypos := (height - (sumOfHeights
+ + ((numChilds - 1) * space))) // 2.
+ ]
+ ]
+ ]
+ ]
+ ].
+ ].
+
+ "
+ now set positions
+ "
+ subViews do:[:child |
+ |xpos|
+
+ hLayout == #left ifTrue:[
+ xpos := 0
+ ] ifFalse:[
+ hLayout == #leftSpace ifTrue:[
+ xpos := horizontalSpace
+ ] ifFalse:[
+ hLayout == #right ifTrue:[
+ xpos := width - child widthIncludingBorder
+ ] ifFalse:[
+ hLayout == #rightSpace ifTrue:[
+ xpos := width - horizontalSpace - child widthIncludingBorder.
+ ] ifFalse:[
+ hLayout == #fit ifTrue:[
+ xpos := horizontalSpace.
+ child width:(width - (horizontalSpace + child borderWidth * 2))
+ ] ifFalse:[
+ "centered"
+ xpos := (width - child widthIncludingBorder) // 2.
+ ]
+ ]
+ ]
+ ]
+ ].
+ (xpos < 0) ifTrue:[ xpos := 0 ].
+
+ vLayout == #fit ifTrue:[
child origin:(xpos @ ypos rounded)
corner:(xpos + (child width))
@ (ypos + hEach - (child borderWidth)) rounded.
ypos := ypos + hEach + "(child borderWidth * 2) +" space
- ].
- ^ self
- ].
-
- "compute net height needed"
-
- sumOfHeights := subViews inject:0 into:[:sumSoFar :child | sumSoFar + child heightIncludingBorder].
-
- l := layout.
- ((l == #center) and:[numChilds == 1]) ifTrue:[
- l := #spread
- ].
-
- "compute position of topmost subview and space between them;
- if they do hardly fit, leave no space between them "
-
- (sumOfHeights >= (height - (margin * 2))) ifTrue:[
- ypos := 0.
- space := 0
- ] ifFalse:[
- (l == #bottom) ifTrue:[
- ypos := height - (space * numChilds) - sumOfHeights.
-"
- borderWidth == 0 ifTrue:[
- ypos := ypos + space
- ].
-"
- ypos < 0 ifTrue:[
- space := space min:(height - sumOfHeights) // (numChilds + 1).
- ypos := height - (space * numChilds) - sumOfHeights.
- ]
- ] ifFalse: [
- (l == #spread) ifTrue:[
- space := (height - sumOfHeights) // (numChilds + 1).
- ypos := space.
- (space == 0) ifTrue:[
- ypos := (height - sumOfHeights) // 2
- ]
- ] ifFalse: [
- (l == #center) ifTrue:[
- ypos := (height - (sumOfHeights
- + ((numChilds - 1) * space))) // 2.
- ypos < 0 ifTrue:[
- space := (height - sumOfHeights) // (numChilds + 1).
- ypos := (height - (sumOfHeights
- + ((numChilds - 1) * space))) // 2.
- ]
- ] ifFalse:[
-"
- borderWidth == 0 ifTrue:[
- ypos := 0
- ] ifFalse:[
- ypos := verticalSpace
- ].
-"
- space := space min:(height - sumOfHeights) // (numChilds + 1).
- ypos := space.
- ]
- ]
+ ] ifFalse:[
+ child origin:(xpos@ypos).
+ ypos := ypos + (child heightIncludingBorder) + space
]
- ].
-
-
- "now set positions"
-
- subViews do:[:childView |
- xpos := (width - childView widthIncludingBorder) // 2.
- (xpos < 0) ifTrue:[ xpos := 0 ].
-
- childView origin:(xpos@ypos).
- ypos := ypos + (childView heightIncludingBorder) + space
]
! !
--- a/VarHPanel.st Thu Nov 17 15:34:12 1994 +0100
+++ b/VarHPanel.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Attic/VarHPanel.st,v 1.8 1994-10-28 03:25:33 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/VarHPanel.st,v 1.9 1994-11-17 14:38:47 claus Exp $
'!
!VariableHorizontalPanel class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Attic/VarHPanel.st,v 1.8 1994-10-28 03:25:33 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/VarHPanel.st,v 1.9 1994-11-17 14:38:47 claus Exp $
"
!
@@ -68,6 +68,11 @@
corner:1.0 @ 1.0
in:p.
+"
+!
+
+examples
+"
example:
|top p v1 v2 v3|
@@ -119,21 +124,26 @@
handleOriginsFrom:start to:stop do:aBlock
"evaluate the argument block for some handle-origins"
- |y hh|
+ |y hh vDelta|
subViews notNil ifTrue:[
shadowForm notNil ifTrue:[
hh := shadowForm height
] ifFalse:[
- hh := barHeight
+ hh := barWidth
+ ].
+ (handleStyle ~~ #normal and:[handleStyle ~~ #mswindows]) ifTrue:[
+ vDelta := barWidth // 2.
+ ] ifFalse:[
+ vDelta := 0
].
(handlePosition == #left) ifTrue:[
- y := hh * 2
+ y := vDelta
] ifFalse:[
(handlePosition == #right) ifTrue:[
- y := height - (2 * hh) - margin
+ y := height - hh - margin - vDelta
] ifFalse:[
- y := height // 2
+ y := height - barWidth // 2
]
].
(start + 1) to:stop do:[:index |
@@ -263,7 +273,7 @@
]
!
-buttonMotion:button x:bx y:by
+buttonMotion:buttonMask x:bx y:by
"mouse-button was moved while pressed;
clear prev handleBar and draw handle bar at new position"
@@ -278,8 +288,15 @@
self buttonMotionEventPending ifTrue:[^ self].
xpos := bx - start.
- limitTop := barHeight // 2.
- limitBot := self width - barHeight.
+
+ "see comment in VariableVerticalPanel>>buttonMotion:x:y:"
+
+"/ limitTop := barHeight // 2.
+"/ limitBot := self width - barHeight.
+
+ limitTop := 0.
+ limitBot := self innerWidth.
+
movedHandle > 1 ifTrue:[
limitTop := (subViews at:movedHandle) origin x + (barHeight // 2)
].
@@ -297,8 +314,15 @@
self noClipByChildren.
self xoring:[
- self fillRectangleX:prev y:0 width:barHeight height:height.
- self fillRectangleX:xpos y:0 width:barHeight height:height
+ trackLine ifTrue:[
+ self displayLineFromX:prev+(barHeight // 2) y:0
+ toX:prev+(barHeight // 2) y:height.
+ self displayLineFromX:xpos+(barHeight // 2) y:0
+ toX:xpos+(barHeight // 2) y:height.
+ ] ifFalse:[
+ self fillRectangleX:prev y:0 width:barHeight height:height.
+ self fillRectangleX:xpos y:0 width:barHeight height:height
+ ].
].
self clipByChildren.
prev := xpos
@@ -316,7 +340,12 @@
self noClipByChildren.
self xoring:[
- self fillRectangleX:prev y:0 width:barHeight height:height
+ trackLine ifTrue:[
+ self displayLineFromX:prev+(barHeight // 2) y:0
+ toX:prev+(barHeight // 2) y:height.
+ ] ifFalse:[
+ self fillRectangleX:prev y:0 width:barHeight height:height
+ ].
].
self clipByChildren.
@@ -330,9 +359,9 @@
newX := (prev + start / width) asFloat .
aboveView relativeCorner:newX @ aboveView relativeCorner y.
belowView relativeOrigin:newX @ belowView relativeOrigin y.
- self resizeSubviewsFrom:aboveIndex to:belowIndex.
+ movedHandle := nil.
- movedHandle := nil.
+ self resizeSubviewsFrom:aboveIndex to:belowIndex.
"and redraw handles"
@@ -348,7 +377,7 @@
|w x m|
shadowForm notNil ifTrue:[
- w := shadowForm height
+ w := shadowForm width
] ifFalse:[
w := barHeight - 4
].
@@ -385,7 +414,7 @@
level:2.
handleStyle == #iris ifTrue:[
- self paint:Black.
+ self paint:handleColor.
self fillDeviceRectangleX:(x + m + 2)
y:(hy - barWidth + 2)
width:w - 4
@@ -408,13 +437,13 @@
self displayLineFromX:hx" "-1" " y:height-1 toX:(hx + barHeight - 1) y:height-1.
].
] ifFalse:[
- x := hx + barHeight - 2.
+ x := hx + barHeight - 1.
self paint:handleColor.
separatingLine ifTrue:[
- self displayLineFromX:hx y:0 toX:hx y:height.
+ self displayLineFromX:hx+1 y:0 toX:hx+1 y:height.
self displayLineFromX:x y:0 toX:x y:height.
].
- self fillRectangleX:hx y:hy width:barHeight height:barHeight
+ self fillRectangleX:hx y:hy width:barHeight height:barWidth
]
!
--- a/VarVPanel.st Thu Nov 17 15:34:12 1994 +0100
+++ b/VarVPanel.st Thu Nov 17 15:38:53 1994 +0100
@@ -27,7 +27,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Attic/VarVPanel.st,v 1.9 1994-10-28 03:25:35 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/VarVPanel.st,v 1.10 1994-11-17 14:38:49 claus Exp $
'!
!VariableVerticalPanel class methodsFor:'documentation'!
@@ -48,7 +48,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Attic/VarVPanel.st,v 1.9 1994-10-28 03:25:35 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/VarVPanel.st,v 1.10 1994-11-17 14:38:49 claus Exp $
"
!
@@ -75,6 +75,11 @@
corner:1.0 @ 1.0
in:p.
+"
+!
+
+examples
+"
example:
|top p v1 v2 v3|
@@ -178,6 +183,9 @@
self barHeight:(2 * mm) rounded
].
barWidth := (2 * mm) rounded. "motif style width"
+ handleStyle == #mswindows ifTrue:[
+ barWidth := (ArrowButton new direction:#up) width + 1
+ ].
!
initCursor
@@ -343,7 +351,7 @@
height:h
level:2.
handleStyle == #iris ifTrue:[
- self paint:Black.
+ self paint:handleColor.
self fillDeviceRectangleX:(hx - barWidth + 2)
y:(y + m + 2)
width:(barWidth + barWidth - 4)
@@ -372,7 +380,7 @@
self displayLineFromX:0 y:hy+1 toX:width y:hy+1.
self displayLineFromX:0 y:y toX:width y:y.
].
- self fillRectangleX:hx y:hy width:barHeight height:barHeight
+ self fillRectangleX:hx y:hy width:barWidth height:barHeight
]
!
@@ -472,8 +480,20 @@
self buttonMotionEventPending ifTrue:[^ self].
ypos := by - start.
- limitTop := barHeight // 2.
- limitBot := self height - barHeight.
+
+ "
+ the two lines below will not allow resizing down to zero
+ (so that some is always visible)
+ "
+"/ limitTop := barHeight // 2.
+"/ limitBot := self height - barHeight.
+
+ "
+ these allow resizing to zero - which is better ?
+ "
+ limitTop := 0.
+ limitBot := self innerHeight.
+
movedHandle > 1 ifTrue:[
limitTop := (subViews at:movedHandle) origin y + (barHeight // 2)
].
@@ -508,7 +528,7 @@
buttonRelease:button x:x y:y
"end bar-move"
- |aboveView belowView aboveIndex belowIndex newY|
+ |aboveView belowView aboveIndex belowIndex newY oldY|
((button == 1) or:[button == #select]) ifTrue:[
movedHandle isNil ifTrue:[^ self].
@@ -533,12 +553,17 @@
aboveView := subViews at:aboveIndex.
belowView := subViews at:belowIndex.
+ oldY := aboveView relativeCorner y.
newY := (prev + start / height) asFloat.
aboveView relativeCorner:aboveView relativeCorner x @ newY.
belowView relativeOrigin:belowView relativeOrigin x @ newY.
- self resizeSubviewsFrom:aboveIndex to:belowIndex.
+ movedHandle := nil.
- movedHandle := nil.
+ oldY > newY ifTrue:[
+ self resizeSubviewsFrom:aboveIndex to:belowIndex.
+ ] ifFalse:[
+ self resizeSubviewsFrom:belowIndex to:aboveIndex.
+ ].
redrawLocked := true.
self redrawHandlesFrom:aboveIndex to:belowIndex.
@@ -646,21 +671,26 @@
handleOriginsFrom:start to:stop do:aBlock
"evaluate the argument block for some handle-origins"
- |x hw|
+ |x hw hDelta|
subViews notNil ifTrue:[
shadowForm notNil ifTrue:[
hw := shadowForm width
] ifFalse:[
- hw := barHeight
+ hw := barWidth
+ ].
+ (handleStyle ~~ #normal and:[handleStyle ~~ #mswindows]) ifTrue:[
+ hDelta := barWidth // 2.
+ ] ifFalse:[
+ hDelta := 0
].
(handlePosition == #left) ifTrue:[
- x := hw * 2
+ x := hDelta
] ifFalse:[
(handlePosition == #right) ifTrue:[
- x := width - (1 "2" * hw) - margin
+ x := width - (1 "2" * hw) - margin - hDelta.
] ifFalse:[
- x := width // 2
+ x := width - barWidth // 2
]
].
(start + 1) to:stop do:[:index |
--- a/VariableHorizontalPanel.st Thu Nov 17 15:34:12 1994 +0100
+++ b/VariableHorizontalPanel.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1992 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/VariableHorizontalPanel.st,v 1.8 1994-10-28 03:25:33 claus Exp $
+$Header: /cvs/stx/stx/libwidg/VariableHorizontalPanel.st,v 1.9 1994-11-17 14:38:47 claus Exp $
'!
!VariableHorizontalPanel class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/VariableHorizontalPanel.st,v 1.8 1994-10-28 03:25:33 claus Exp $
+$Header: /cvs/stx/stx/libwidg/VariableHorizontalPanel.st,v 1.9 1994-11-17 14:38:47 claus Exp $
"
!
@@ -68,6 +68,11 @@
corner:1.0 @ 1.0
in:p.
+"
+!
+
+examples
+"
example:
|top p v1 v2 v3|
@@ -119,21 +124,26 @@
handleOriginsFrom:start to:stop do:aBlock
"evaluate the argument block for some handle-origins"
- |y hh|
+ |y hh vDelta|
subViews notNil ifTrue:[
shadowForm notNil ifTrue:[
hh := shadowForm height
] ifFalse:[
- hh := barHeight
+ hh := barWidth
+ ].
+ (handleStyle ~~ #normal and:[handleStyle ~~ #mswindows]) ifTrue:[
+ vDelta := barWidth // 2.
+ ] ifFalse:[
+ vDelta := 0
].
(handlePosition == #left) ifTrue:[
- y := hh * 2
+ y := vDelta
] ifFalse:[
(handlePosition == #right) ifTrue:[
- y := height - (2 * hh) - margin
+ y := height - hh - margin - vDelta
] ifFalse:[
- y := height // 2
+ y := height - barWidth // 2
]
].
(start + 1) to:stop do:[:index |
@@ -263,7 +273,7 @@
]
!
-buttonMotion:button x:bx y:by
+buttonMotion:buttonMask x:bx y:by
"mouse-button was moved while pressed;
clear prev handleBar and draw handle bar at new position"
@@ -278,8 +288,15 @@
self buttonMotionEventPending ifTrue:[^ self].
xpos := bx - start.
- limitTop := barHeight // 2.
- limitBot := self width - barHeight.
+
+ "see comment in VariableVerticalPanel>>buttonMotion:x:y:"
+
+"/ limitTop := barHeight // 2.
+"/ limitBot := self width - barHeight.
+
+ limitTop := 0.
+ limitBot := self innerWidth.
+
movedHandle > 1 ifTrue:[
limitTop := (subViews at:movedHandle) origin x + (barHeight // 2)
].
@@ -297,8 +314,15 @@
self noClipByChildren.
self xoring:[
- self fillRectangleX:prev y:0 width:barHeight height:height.
- self fillRectangleX:xpos y:0 width:barHeight height:height
+ trackLine ifTrue:[
+ self displayLineFromX:prev+(barHeight // 2) y:0
+ toX:prev+(barHeight // 2) y:height.
+ self displayLineFromX:xpos+(barHeight // 2) y:0
+ toX:xpos+(barHeight // 2) y:height.
+ ] ifFalse:[
+ self fillRectangleX:prev y:0 width:barHeight height:height.
+ self fillRectangleX:xpos y:0 width:barHeight height:height
+ ].
].
self clipByChildren.
prev := xpos
@@ -316,7 +340,12 @@
self noClipByChildren.
self xoring:[
- self fillRectangleX:prev y:0 width:barHeight height:height
+ trackLine ifTrue:[
+ self displayLineFromX:prev+(barHeight // 2) y:0
+ toX:prev+(barHeight // 2) y:height.
+ ] ifFalse:[
+ self fillRectangleX:prev y:0 width:barHeight height:height
+ ].
].
self clipByChildren.
@@ -330,9 +359,9 @@
newX := (prev + start / width) asFloat .
aboveView relativeCorner:newX @ aboveView relativeCorner y.
belowView relativeOrigin:newX @ belowView relativeOrigin y.
- self resizeSubviewsFrom:aboveIndex to:belowIndex.
+ movedHandle := nil.
- movedHandle := nil.
+ self resizeSubviewsFrom:aboveIndex to:belowIndex.
"and redraw handles"
@@ -348,7 +377,7 @@
|w x m|
shadowForm notNil ifTrue:[
- w := shadowForm height
+ w := shadowForm width
] ifFalse:[
w := barHeight - 4
].
@@ -385,7 +414,7 @@
level:2.
handleStyle == #iris ifTrue:[
- self paint:Black.
+ self paint:handleColor.
self fillDeviceRectangleX:(x + m + 2)
y:(hy - barWidth + 2)
width:w - 4
@@ -408,13 +437,13 @@
self displayLineFromX:hx" "-1" " y:height-1 toX:(hx + barHeight - 1) y:height-1.
].
] ifFalse:[
- x := hx + barHeight - 2.
+ x := hx + barHeight - 1.
self paint:handleColor.
separatingLine ifTrue:[
- self displayLineFromX:hx y:0 toX:hx y:height.
+ self displayLineFromX:hx+1 y:0 toX:hx+1 y:height.
self displayLineFromX:x y:0 toX:x y:height.
].
- self fillRectangleX:hx y:hy width:barHeight height:barHeight
+ self fillRectangleX:hx y:hy width:barHeight height:barWidth
]
!
--- a/VariableVerticalPanel.st Thu Nov 17 15:34:12 1994 +0100
+++ b/VariableVerticalPanel.st Thu Nov 17 15:38:53 1994 +0100
@@ -27,7 +27,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/VariableVerticalPanel.st,v 1.9 1994-10-28 03:25:35 claus Exp $
+$Header: /cvs/stx/stx/libwidg/VariableVerticalPanel.st,v 1.10 1994-11-17 14:38:49 claus Exp $
'!
!VariableVerticalPanel class methodsFor:'documentation'!
@@ -48,7 +48,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/VariableVerticalPanel.st,v 1.9 1994-10-28 03:25:35 claus Exp $
+$Header: /cvs/stx/stx/libwidg/VariableVerticalPanel.st,v 1.10 1994-11-17 14:38:49 claus Exp $
"
!
@@ -75,6 +75,11 @@
corner:1.0 @ 1.0
in:p.
+"
+!
+
+examples
+"
example:
|top p v1 v2 v3|
@@ -178,6 +183,9 @@
self barHeight:(2 * mm) rounded
].
barWidth := (2 * mm) rounded. "motif style width"
+ handleStyle == #mswindows ifTrue:[
+ barWidth := (ArrowButton new direction:#up) width + 1
+ ].
!
initCursor
@@ -343,7 +351,7 @@
height:h
level:2.
handleStyle == #iris ifTrue:[
- self paint:Black.
+ self paint:handleColor.
self fillDeviceRectangleX:(hx - barWidth + 2)
y:(y + m + 2)
width:(barWidth + barWidth - 4)
@@ -372,7 +380,7 @@
self displayLineFromX:0 y:hy+1 toX:width y:hy+1.
self displayLineFromX:0 y:y toX:width y:y.
].
- self fillRectangleX:hx y:hy width:barHeight height:barHeight
+ self fillRectangleX:hx y:hy width:barWidth height:barHeight
]
!
@@ -472,8 +480,20 @@
self buttonMotionEventPending ifTrue:[^ self].
ypos := by - start.
- limitTop := barHeight // 2.
- limitBot := self height - barHeight.
+
+ "
+ the two lines below will not allow resizing down to zero
+ (so that some is always visible)
+ "
+"/ limitTop := barHeight // 2.
+"/ limitBot := self height - barHeight.
+
+ "
+ these allow resizing to zero - which is better ?
+ "
+ limitTop := 0.
+ limitBot := self innerHeight.
+
movedHandle > 1 ifTrue:[
limitTop := (subViews at:movedHandle) origin y + (barHeight // 2)
].
@@ -508,7 +528,7 @@
buttonRelease:button x:x y:y
"end bar-move"
- |aboveView belowView aboveIndex belowIndex newY|
+ |aboveView belowView aboveIndex belowIndex newY oldY|
((button == 1) or:[button == #select]) ifTrue:[
movedHandle isNil ifTrue:[^ self].
@@ -533,12 +553,17 @@
aboveView := subViews at:aboveIndex.
belowView := subViews at:belowIndex.
+ oldY := aboveView relativeCorner y.
newY := (prev + start / height) asFloat.
aboveView relativeCorner:aboveView relativeCorner x @ newY.
belowView relativeOrigin:belowView relativeOrigin x @ newY.
- self resizeSubviewsFrom:aboveIndex to:belowIndex.
+ movedHandle := nil.
- movedHandle := nil.
+ oldY > newY ifTrue:[
+ self resizeSubviewsFrom:aboveIndex to:belowIndex.
+ ] ifFalse:[
+ self resizeSubviewsFrom:belowIndex to:aboveIndex.
+ ].
redrawLocked := true.
self redrawHandlesFrom:aboveIndex to:belowIndex.
@@ -646,21 +671,26 @@
handleOriginsFrom:start to:stop do:aBlock
"evaluate the argument block for some handle-origins"
- |x hw|
+ |x hw hDelta|
subViews notNil ifTrue:[
shadowForm notNil ifTrue:[
hw := shadowForm width
] ifFalse:[
- hw := barHeight
+ hw := barWidth
+ ].
+ (handleStyle ~~ #normal and:[handleStyle ~~ #mswindows]) ifTrue:[
+ hDelta := barWidth // 2.
+ ] ifFalse:[
+ hDelta := 0
].
(handlePosition == #left) ifTrue:[
- x := hw * 2
+ x := hDelta
] ifFalse:[
(handlePosition == #right) ifTrue:[
- x := width - (1 "2" * hw) - margin
+ x := width - (1 "2" * hw) - margin - hDelta.
] ifFalse:[
- x := width // 2
+ x := width - barWidth // 2
]
].
(start + 1) to:stop do:[:index |
--- a/VerticalPanelView.st Thu Nov 17 15:34:12 1994 +0100
+++ b/VerticalPanelView.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/VerticalPanelView.st,v 1.5 1994-10-10 03:03:18 claus Exp $
+$Header: /cvs/stx/stx/libwidg/VerticalPanelView.st,v 1.6 1994-11-17 14:38:46 claus Exp $
'!
!VerticalPanelView class methodsFor:'documentation'!
@@ -42,16 +42,45 @@
version
"
-$Header: /cvs/stx/stx/libwidg/VerticalPanelView.st,v 1.5 1994-10-10 03:03:18 claus Exp $
+$Header: /cvs/stx/stx/libwidg/VerticalPanelView.st,v 1.6 1994-11-17 14:38:46 claus Exp $
"
!
documentation
"
a View which arranges its child-views in a vertical column.
- All real work is done in PanelView - only the layout computation is
+ All real work is done in PanelView - except the layout computation is
redefined here.
+ The layout is controlled by two instance variables.
+ The vertical layout can be any of:
+
+ #top arrange elements at the top
+ #topSpace arrange elements at the top, start with spacing
+ #bottom arrange elements at the bottom
+ #bottomSpace arrange elements at the bottom, start with spacing
+ #center arrange elements in the center
+ #spread spread elements evenly
+ #fit like spread, but resize elements for tight packing
+
+ the horizontal layout can be:
+
+ #left place element at the left
+ #leftSpace place element at the left, offset by horizontalSpace
+ #center place it horizontally centered
+ #right place it at the right
+ #rightSpace place it at the right, offset by horizontalSpace
+ #fit resize elements horizontally to fit this panel
+
+ The defaults is #centered for both directions.
+ The layout is changed by the messages #verticalLayout: and #horizontalLayout:.
+ For backward compatibility (to times, where only vLayout existed), the simple
+ #layout: does the same as #verticalLayout:. Do not use this old method.
+"
+!
+
+examples
+"
example: default layout (centered)
|v p b1 b2 b3|
@@ -66,13 +95,13 @@
v open
- example: left-layout
+ example: top-layout
|v p b1 b2 b3|
v := StandardSystemView new.
p := VerticalPanelView in:v.
- p layout:#top.
+ p verticalLayout:#top.
p origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
b1 := Button label:'button1' in:p.
b2 := Button label:'button2' in:p.
@@ -81,13 +110,13 @@
v open
- example: right-layout
+ example: bottom-layout
|v p b1 b2 b3|
v := StandardSystemView new.
p := VerticalPanelView in:v.
- p layout:#bottom.
+ p verticalLayout:#bottom.
p origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
b1 := Button label:'button1' in:p.
b2 := Button label:'button2' in:p.
@@ -102,16 +131,132 @@
v := StandardSystemView new.
p := VerticalPanelView in:v.
- p layout:#spread.
+ p verticalLayout:#spread.
+ p origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
+ b1 := Button label:'button1' in:p.
+ b2 := Button label:'button2' in:p.
+ b3 := Button label:'button3' in:p.
+ v extent:100 @ 300.
+ v open
+
+ example: from top, each at left:
+
+ |v p b1 b2 b3|
+
+ v := StandardSystemView new.
+ p := VerticalPanelView in:v.
+ p verticalLayout:#top.
+ p horizontalLayout:#left.
+ p origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
+ b1 := Button label:'button1' in:p.
+ b2 := Button label:'button2' in:p.
+ b3 := Button label:'button3' in:p.
+ v extent:100 @ 300.
+ v open
+
+ example: centered, right:
+
+ |v p b1 b2 b3|
+
+ v := StandardSystemView new.
+ p := VerticalPanelView in:v.
+ p verticalLayout:#centered.
+ p horizontalLayout:#right.
p origin:(0.0 @ 0.0) corner:(1.0 @ 1.0).
b1 := Button label:'button1' in:p.
b2 := Button label:'button2' in:p.
b3 := Button label:'button3' in:p.
v extent:100 @ 300.
v open
+
+ you should try more examples, combining spacing and different
+ verticalLayout:/horizontalLayout: combinations.
"
! !
+!VerticalPanelView methodsFor:'accessing'!
+
+horizontalLayout
+ "return the horizontal layout as symbol.
+ the returned value is one of
+ #left
+ #leftSpace
+ #center
+ #right
+ #rightSpace
+ #fit
+ the default is #centered
+ "
+
+ ^ hLayout
+!
+
+verticalLayout
+ "return the vertical layout as a symbol.
+ the returned value is one of
+ #top
+ #topSpace
+ #spread
+ #fit
+ #center
+ #bottom
+ #bottomSpace
+ the default is #centered
+ "
+
+ ^ vLayout
+!
+
+horizontalLayout:aSymbol
+ "change the horizontal layout as symbol.
+ The argument, aSymbol must be one of:
+ #left
+ #leftSpace
+ #center
+ #right
+ #rightSpace
+ #fit
+ the default (if never changed) is #centered
+ "
+
+ (hLayout ~~ aSymbol) ifTrue:[
+ hLayout := aSymbol.
+ self layoutChanged
+ ]
+!
+
+verticalLayout:aSymbol
+ "change the vertical layout as a symbol.
+ The argument, aSymbol must be one of:
+ #top
+ #topSpace
+ #spread
+ #fit
+ #center
+ #bottom
+ #bottomSpace
+ the default (if never changed) is #centered
+ "
+
+ (vLayout ~~ aSymbol) ifTrue:[
+ vLayout := aSymbol.
+ self layoutChanged
+ ]
+!
+
+layout
+ "leftover for historic reasons - do not use any more"
+
+ self verticalLayout
+!
+
+layout:aSymbol
+ "leftover for historic reasons - do not use any more"
+
+ self verticalLayout:aSymbol
+! !
+
+
!VerticalPanelView methodsFor:'queries'!
preferedExtent
@@ -127,9 +272,16 @@
maxWidth := 0.
subViews do:[:child |
- sumOfHeights := sumOfHeights + child heightIncludingBorder.
- maxWidth := maxWidth max:(child widthIncludingBorder).
- maxHeight := maxHeight max:(child heightIncludingBorder).
+ |childsPreference|
+
+ childsPreference := child preferedExtent.
+ sumOfHeights := sumOfHeights + childsPreference y.
+ maxHeight := maxHeight max:childsPreference y.
+ maxWidth := maxWidth max:childsPreference x.
+
+"/ sumOfHeights := sumOfHeights + child heightIncludingBorder.
+"/ maxWidth := maxWidth max:(child widthIncludingBorder).
+"/ maxHeight := maxHeight max:(child heightIncludingBorder).
].
borderWidth ~~ 0 ifTrue:[
sumOfHeights := sumOfHeights + (horizontalSpace * 2).
@@ -145,98 +297,137 @@
setChildPositions
"(re)compute position of every child"
- |xpos ypos space sumOfHeights numChilds l hEach|
+ |ypos space sumOfHeights numChilds l hEach|
subViews isNil ifTrue:[^ self].
space := verticalSpace.
+ numChilds := subViews size.
- numChilds := subViews size.
- layout == #fit ifTrue:[
+ vLayout == #fit ifTrue:[
"
adjust childs extents and set origins.
Be careful to avoid accumulation of rounding errors
"
hEach := (height - (margin * 2) - (numChilds + 1 * space) + borderWidth) / numChilds.
ypos := space + margin - borderWidth.
- subViews do:[:child |
- xpos := (width - child widthIncludingBorder) // 2.
- (xpos < 0) ifTrue:[xpos := 0].
+ ] ifFalse:[
+
+ "
+ compute net height needed
+ "
+ sumOfHeights := subViews inject:0 into:[:sumSoFar :child | sumSoFar + child heightIncludingBorder].
+
+ l := vLayout.
+ ((l == #center) and:[numChilds == 1]) ifTrue:[
+ l := #spread
+ ].
+
+ "
+ compute position of topmost subview and space between them;
+ if they do hardly fit, leave no space between them
+ "
+ (sumOfHeights >= (height - (margin * 2))) ifTrue:[
+ "
+ if we have not enough space for all the elements,
+ fill them tight, and show what can be shown (at least)
+ "
+ ypos := 0.
+ space := 0
+ ] ifFalse:[
+ ((l == #bottom) or:[l == #bottomSpace]) ifTrue:[
+ ypos := height - (space * numChilds) - sumOfHeights.
+ "
+ borderWidth == 0 ifTrue:[
+ ypos := ypos + space
+ ].
+ "
+ l == #bottomSpace ifTrue:[
+ ypos > space ifTrue:[
+ ypos := ypos - space
+ ]
+ ].
+ ypos < 0 ifTrue:[
+ space := space min:(height - sumOfHeights) // (numChilds + 1).
+ ypos := height - (space * numChilds) - sumOfHeights.
+ ]
+ ] ifFalse: [
+ (l == #spread) ifTrue:[
+ space := (height - sumOfHeights) // (numChilds + 1).
+ ypos := space.
+ (space == 0) ifTrue:[
+ ypos := (height - sumOfHeights) // 2
+ ]
+ ] ifFalse: [
+ ((l == #top) or:[l == #topSpace]) ifTrue:[
+ "
+ borderWidth == 0 ifTrue:[
+ ypos := 0
+ ] ifFalse:[
+ ypos := verticalSpace
+ ].
+ "
+ space := space min:(height - sumOfHeights) // (numChilds + 1).
+ l == #topSpace ifTrue:[
+ ypos := space.
+ ] ifFalse:[
+ ypos := 0
+ ]
+ ] ifFalse:[
+ "center"
+ ypos := (height - (sumOfHeights
+ + ((numChilds - 1) * space))) // 2.
+ ypos < 0 ifTrue:[
+ space := (height - sumOfHeights) // (numChilds + 1).
+ ypos := (height - (sumOfHeights
+ + ((numChilds - 1) * space))) // 2.
+ ]
+ ]
+ ]
+ ]
+ ].
+ ].
+
+ "
+ now set positions
+ "
+ subViews do:[:child |
+ |xpos|
+
+ hLayout == #left ifTrue:[
+ xpos := 0
+ ] ifFalse:[
+ hLayout == #leftSpace ifTrue:[
+ xpos := horizontalSpace
+ ] ifFalse:[
+ hLayout == #right ifTrue:[
+ xpos := width - child widthIncludingBorder
+ ] ifFalse:[
+ hLayout == #rightSpace ifTrue:[
+ xpos := width - horizontalSpace - child widthIncludingBorder.
+ ] ifFalse:[
+ hLayout == #fit ifTrue:[
+ xpos := horizontalSpace.
+ child width:(width - (horizontalSpace + child borderWidth * 2))
+ ] ifFalse:[
+ "centered"
+ xpos := (width - child widthIncludingBorder) // 2.
+ ]
+ ]
+ ]
+ ]
+ ].
+ (xpos < 0) ifTrue:[ xpos := 0 ].
+
+ vLayout == #fit ifTrue:[
child origin:(xpos @ ypos rounded)
corner:(xpos + (child width))
@ (ypos + hEach - (child borderWidth)) rounded.
ypos := ypos + hEach + "(child borderWidth * 2) +" space
- ].
- ^ self
- ].
-
- "compute net height needed"
-
- sumOfHeights := subViews inject:0 into:[:sumSoFar :child | sumSoFar + child heightIncludingBorder].
-
- l := layout.
- ((l == #center) and:[numChilds == 1]) ifTrue:[
- l := #spread
- ].
-
- "compute position of topmost subview and space between them;
- if they do hardly fit, leave no space between them "
-
- (sumOfHeights >= (height - (margin * 2))) ifTrue:[
- ypos := 0.
- space := 0
- ] ifFalse:[
- (l == #bottom) ifTrue:[
- ypos := height - (space * numChilds) - sumOfHeights.
-"
- borderWidth == 0 ifTrue:[
- ypos := ypos + space
- ].
-"
- ypos < 0 ifTrue:[
- space := space min:(height - sumOfHeights) // (numChilds + 1).
- ypos := height - (space * numChilds) - sumOfHeights.
- ]
- ] ifFalse: [
- (l == #spread) ifTrue:[
- space := (height - sumOfHeights) // (numChilds + 1).
- ypos := space.
- (space == 0) ifTrue:[
- ypos := (height - sumOfHeights) // 2
- ]
- ] ifFalse: [
- (l == #center) ifTrue:[
- ypos := (height - (sumOfHeights
- + ((numChilds - 1) * space))) // 2.
- ypos < 0 ifTrue:[
- space := (height - sumOfHeights) // (numChilds + 1).
- ypos := (height - (sumOfHeights
- + ((numChilds - 1) * space))) // 2.
- ]
- ] ifFalse:[
-"
- borderWidth == 0 ifTrue:[
- ypos := 0
- ] ifFalse:[
- ypos := verticalSpace
- ].
-"
- space := space min:(height - sumOfHeights) // (numChilds + 1).
- ypos := space.
- ]
- ]
+ ] ifFalse:[
+ child origin:(xpos@ypos).
+ ypos := ypos + (child heightIncludingBorder) + space
]
- ].
-
-
- "now set positions"
-
- subViews do:[:childView |
- xpos := (width - childView widthIncludingBorder) // 2.
- (xpos < 0) ifTrue:[ xpos := 0 ].
-
- childView origin:(xpos@ypos).
- ypos := ypos + (childView heightIncludingBorder) + space
]
! !
--- a/WarnBox.st Thu Nov 17 15:34:12 1994 +0100
+++ b/WarnBox.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/Attic/WarnBox.st,v 1.5 1994-10-10 03:03:26 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/WarnBox.st,v 1.6 1994-11-17 14:38:53 claus Exp $
'!
!WarningBox class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/Attic/WarnBox.st,v 1.5 1994-10-10 03:03:26 claus Exp $
+$Header: /cvs/stx/stx/libwidg/Attic/WarnBox.st,v 1.6 1994-11-17 14:38:53 claus Exp $
"
!
@@ -64,7 +64,11 @@
aBox okText:'some string'.
+"
+!
+examples
+"
Examples:
|aBox|
--- a/WarningBox.st Thu Nov 17 15:34:12 1994 +0100
+++ b/WarningBox.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1993 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/WarningBox.st,v 1.5 1994-10-10 03:03:26 claus Exp $
+$Header: /cvs/stx/stx/libwidg/WarningBox.st,v 1.6 1994-11-17 14:38:53 claus Exp $
'!
!WarningBox class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/WarningBox.st,v 1.5 1994-10-10 03:03:26 claus Exp $
+$Header: /cvs/stx/stx/libwidg/WarningBox.st,v 1.6 1994-11-17 14:38:53 claus Exp $
"
!
@@ -64,7 +64,11 @@
aBox okText:'some string'.
+"
+!
+examples
+"
Examples:
|aBox|
--- a/YesNoBox.st Thu Nov 17 15:34:12 1994 +0100
+++ b/YesNoBox.st Thu Nov 17 15:38:53 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libwidg/YesNoBox.st,v 1.7 1994-10-10 03:03:30 claus Exp $
+$Header: /cvs/stx/stx/libwidg/YesNoBox.st,v 1.8 1994-11-17 14:38:51 claus Exp $
'!
!YesNoBox class methodsFor:'documentation'!
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libwidg/YesNoBox.st,v 1.7 1994-10-10 03:03:30 claus Exp $
+$Header: /cvs/stx/stx/libwidg/YesNoBox.st,v 1.8 1994-11-17 14:38:51 claus Exp $
"
!
@@ -66,6 +66,17 @@
There is also protocol to set both button titles in one message.
Also, the action associated to the noButton can be changed.
+ For very simple yes/no queries, you can also use the much simpler confirm:.
+ Since implemented in Object, everyone understands confirm. You can pass
+ a question message (but not change the buttons labels).
+ Use is:
+ self confirm:'some question'
+ and will return true or false.
+"
+!
+
+examples
+"
Examples:
|aBox|
@@ -138,7 +149,7 @@
!YesNoBox class methodsFor:'easy startup '!
-confirm:aTitle
+XXconfirm:aTitle
^ self new confirm:aTitle
! !
@@ -153,6 +164,8 @@
initialize
super initialize.
+ buttonPanel layout:#fit. "/ looks better; should it come from the StyleSheet ?
+
textLabel label:'please Confirm'.
okButton label:(resources at:'yes').
@@ -175,7 +188,8 @@
have to be defined. The title is used as previously defined."
self yesAction:[^ true] noAction:[^ false].
- self showAtPointer
+ self showAtPointer.
+ self yesAction:nil noAction:nil. "/ clear actions for earlier release of context
"
YesNoBox new confirm
@@ -299,9 +313,11 @@
noButton width:max; fixSize.
w := (formLabel width + textLabel width) max:max * 2.
w := w + (3 * ViewSpacing) + (okButton borderWidth + noButton borderWidth * 2).
- h := (3 * ViewSpacing)
+ h := ViewSpacing
+ ((formLabel height) max:(textLabel height))
- + okButton heightIncludingBorder.
+ + (ViewSpacing * 3)
+ + okButton heightIncludingBorder
+ + ViewSpacing.
^ (w @ h).
! !