--- a/Image.st Mon Oct 10 03:30:48 1994 +0100
+++ b/Image.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,23 +11,24 @@
"
Object subclass:#Image
- instanceVariableNames:'bytes width height
- bitsPerSample samplesPerPixel
- colorMap photometric
- device deviceForm monoDeviceForm
- fullColorDeviceForm'
- classVariableNames:'Lobby
- DitherAlgorithm NumberOfDitherColors
- FileFormats'
- poolDictionaries:''
- category:'Graphics-Display Objects'
+ instanceVariableNames:'bytes width height
+ bitsPerSample samplesPerPixel
+ colorMap
+ photometric
+ device deviceForm monoDeviceForm
+ fullColorDeviceForm'
+ classVariableNames:'Lobby
+ DitherAlgorithm NumberOfDitherColors
+ FileFormats'
+ poolDictionaries:''
+ category:'Graphics-Display Objects'
!
Image comment:'
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/Image.st,v 1.13 1994-08-05 01:14:23 claus Exp $
+$Header: /cvs/stx/stx/libview/Image.st,v 1.14 1994-10-10 02:32:13 claus Exp $
'!
!Image class methodsFor:'documentation'!
@@ -35,7 +36,7 @@
copyright
"
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -48,7 +49,7 @@
version
"
-$Header: /cvs/stx/stx/libview/Image.st,v 1.13 1994-08-05 01:14:23 claus Exp $
+$Header: /cvs/stx/stx/libview/Image.st,v 1.14 1994-10-10 02:32:13 claus Exp $
"
!
@@ -88,14 +89,14 @@
DitherAlgorithm:
nil a simple threshold algorithm
- (i.e. for mono, p<0.5 -> black, p>=0.5 -> white)
+ (i.e. for mono, p<0.5 -> black, p>=0.5 -> white)
#pattern patterned dither
- (for p, take dithered color to fill pixel;
- uses dithering in color-class)
+ (for p, take dithered color to fill pixel;
+ uses dithering in color-class)
#error error diffusion dither (Floyd-Steinberg)
- planned
+ planned
File formats are handled by subclasses of ImageReader, which understand
a specific format. You can add more readers, by adding an association
@@ -104,36 +105,36 @@
instance variables:
- width <Integer> the width in pixels
- height <Integer> the height in pixels
- bytes <ByteArray> the full image information
- photometric <Symbol> #rgb, #palette, #blackIs0 or #whiteIs0
- samplesPerPixel <Integer> the number of planes
- bitsPerSample <Array> the number of bits per plane
- colorMap <Array> an Array of 3 arrays containing red,
- green and blue values (0..255 biased)
- device <Workstation> the device on which deviceForm,
- monoDeviceForm and lowResDeviceForm are
- deviceForm <Form> the device form which gives the best
- possible aproximation of the image on
- device using standard colors.
- monoDeviceForm <Form> the device form which gives a monochrome
- aproximation of the image on device.
- fullColorDeviceForm <Form> the device form which gives the best
- possible aproximation of the image on
- device using private colors.
+ width <Integer> the width in pixels
+ height <Integer> the height in pixels
+ bytes <ByteArray> the full image information
+ photometric <Symbol> #rgb, #palette, #blackIs0 or #whiteIs0
+ samplesPerPixel <Integer> the number of planes
+ bitsPerSample <Array> the number of bits per plane
+ colorMap <Array> an Array of 3 arrays containing red,
+ green and blue values (0..255 biased)
+ device <Workstation> the device on which deviceForm,
+ monoDeviceForm and lowResDeviceForm are
+ deviceForm <Form> the device form which gives the best
+ possible aproximation of the image on
+ device using standard colors.
+ monoDeviceForm <Form> the device form which gives a monochrome
+ aproximation of the image on device.
+ fullColorDeviceForm <Form> the device form which gives the best
+ possible aproximation of the image on
+ device using private colors.
class variables:
- Lobby <Registry> keeps track of known images
- DitherAlgorithm <Symbol> defines how to dither
- NumberOfDitherColors <Integer> defines, how many dither colors to use
- FileFormats <Dictionary> associates filename extensions to
- image reader classes (now set-up in startup-file)
+ Lobby <Registry> keeps track of known images
+ DitherAlgorithm <Symbol> defines how to dither
+ NumberOfDitherColors <Integer> defines, how many dither colors to use
+ FileFormats <Dictionary> associates filename extensions to
+ image reader classes (now set-up in startup-file)
todo:
- there is currently no mask stored/available in the image itself; currently masks
- have to be stored as separate bitmaps. (which is bad for image-file formats, which
- provide a mask)
+ there is currently no mask stored/available in the image itself; currently masks
+ have to be stored as separate bitmaps. (which is bad for image-file formats, which
+ provide a mask)
"
! !
@@ -153,7 +154,7 @@
numberOfDitherColors:n
"define how many colors (i.e. patterns) to use when
- doing a pattern dither (good values are:)"
+ doing a pattern dither"
NumberOfDitherColors := n
! !
@@ -165,22 +166,22 @@
"setup tracker of known pictures"
Lobby isNil ifTrue:[
- Lobby := Registry new.
- ObjectMemory addDependent:self.
+ Lobby := Registry new.
+ ObjectMemory addDependent:self.
].
"define algorithm to use for dithering - currently only nil or #pattern supported"
DitherAlgorithm := #pattern. "will be changed to error as soon as implemented"
(Display notNil and:[Display hasGreyscales]) ifFalse:[
- NumberOfDitherColors := 64
+ NumberOfDitherColors := 64
] ifTrue:[
- "as far as I remember, this is about the number of grey values, the eye can distinguish"
- NumberOfDitherColors := 100
+ "as far as I remember, this is about the number of grey values, the eye can distinguish"
+ NumberOfDitherColors := 100
].
"define reader classes"
FileFormats isNil ifTrue:[
- self initializeFileFormatTable
+ self initializeFileFormatTable
].
!
@@ -193,26 +194,33 @@
FileFormats at:'.xbm' put:XBMReader.
FileFormats at:'.tiff' put:TIFFReader.
FileFormats at:'.gif' put:GIFReader.
- FileFormats at:'.img' put:IMGReader.
- FileFormats at:'.icon' put:SunRasterReader.
+"/ FileFormats at:'.img' put:IMGReader.
+"/ FileFormats at:'.icon' put:SunRasterReader.
- "Image initializeFileFormatTable"
+ "
+ Image initializeFileFormatTable
+ "
!
fileFormats
"return the collection of supported file formats.
The returned dictionary maps file-extensions to image reader classes."
+ FileFormats isNil ifTrue:[
+ self initializeFileFormatTable
+ ].
^ FileFormats
- "Image fileFormats"
+ "
+ Image fileFormats
+ "
!
flushDeviceImages
"simply unassign all pictures from their device"
Lobby contentsDo:[:anImage |
- anImage restored
+ anImage restored
]
!
@@ -220,7 +228,7 @@
"flush all device specific stuff when restarted from a snapshot"
(something == #restarted) ifTrue:[
- self flushDeviceImages
+ self flushDeviceImages
]
! !
@@ -278,8 +286,8 @@
dev := aView device.
org := dev translatePoint:(0@0)
- from:(aView id)
- to:(DisplayRootView on:dev) id.
+ from:(aView id)
+ to:(DisplayRootView on:dev) id.
^ self fromScreen:(org extent:aView extent) on:dev
"Image fromView:(Launcher allInstances first topView)"
@@ -299,32 +307,32 @@
before trying each reader, check if file is readable
"
aFileName asFilename isReadable ifFalse:[
- ('file: ' , aFileName , ' is not existing or not readable') errorPrintNL.
- ^ nil
+ ('file: ' , aFileName , ' is not existing or not readable') errorPrintNL.
+ ^ nil
].
name := aFileName.
(name endsWith:'.Z') ifTrue:[
- name := name copyTo:(name size - 2)
+ name := name copyTo:(name size - 2)
].
FileFormats keysAndValuesDo:[:suffix :readerClass |
- (name endsWith:suffix) ifTrue:[
- readerClass notNil ifTrue:[
- image := readerClass fromFile:aFileName.
- image notNil ifTrue:[^ image].
- ]
- ]
+ (name endsWith:suffix) ifTrue:[
+ readerClass notNil ifTrue:[
+ image := readerClass fromFile:aFileName.
+ image notNil ifTrue:[^ image].
+ ]
+ ]
].
"no known extension - ask all readers if they know
this format ..."
FileFormats do:[:readerClass |
- readerClass notNil ifTrue:[
- (readerClass isValidImageFile:aFileName) ifTrue:[
- ^ readerClass fromFile:aFileName
- ]
- ]
+ readerClass notNil ifTrue:[
+ (readerClass isValidImageFile:aFileName) ifTrue:[
+ ^ readerClass fromFile:aFileName
+ ]
+ ]
].
"nope - unknown format"
@@ -361,6 +369,14 @@
^ self
! !
+!Image methodsFor:'copying'!
+
+postCopy
+ bytes := bytes copy.
+ colorMap := colorMap copy.
+ device := deviceForm := monoDeviceForm := fullColorDeviceForm := nil
+! !
+
!Image methodsFor:'instance release'!
restored
@@ -383,10 +399,10 @@
"redefined to launch an ImageInspector on the receiver
(instead of the default InspectorView)."
- ImageInspectorView isNil ifTrue:[
- super inspect
+ ImageInspectorView notNil ifTrue:[
+ ImageInspectorView openOn:self
] ifFalse:[
- ImageInspectorView openOn:self
+ super inspect
]
! !
@@ -503,7 +519,7 @@
bitsPerRow := width * (self bitsPerPixel).
bytesPerRow := bitsPerRow // 8.
((bitsPerRow \\ 8) ~~ 0) ifTrue:[
- bytesPerRow := bytesPerRow + 1
+ bytesPerRow := bytesPerRow + 1
].
^ bytesPerRow
!
@@ -647,13 +663,13 @@
aStream nextPutAll:'; photometric:('. photometric storeOn:aStream.
aStream nextPutAll:'); bitsPerSample:('. bitsPerSample storeOn:aStream.
aStream nextPutAll:'); samplesPerPixel:('. samplesPerPixel storeOn:aStream.
- aStream nextPutAll:'); bits:('. bytes storeOn:aStream. aStream nextPutAll:'); '.
+ aStream nextPutAll:'); bits:('. bytes storeOn:aStream. aStream nextPutAll:') '.
colorMap notNil ifTrue:[
- aStream nextPutAll:'; colorMap:('.
- colorMap storeOn:aStream.
- aStream nextPutAll:')'.
+ aStream nextPutAll:'; colorMap:('.
+ colorMap storeOn:aStream.
+ aStream nextPutAll:')'.
].
- aStream nextPutAll:' yourself'
+ aStream nextPutAll:'; yourself'
! !
!Image methodsFor:'screen capture'!
@@ -682,44 +698,44 @@
info bytesPerLineIn curs cid|
curs := Cursor sourceForm:(Form fromFile:'Camera.xbm')
- maskForm:(Form fromFile:'Camera_m.xbm')
- hotSpot:16@16.
+ maskForm:(Form fromFile:'Camera_m.xbm')
+ hotSpot:16@16.
curs notNil ifTrue:[
- cid := (curs on:aDevice) id
+ cid := (curs on:aDevice) id
].
"actually have to grabServer ... but thats not yet available"
ActiveGrab := DisplayRootView on:aDevice.
aDevice grabPointerIn:(DisplayRootView on:aDevice) id
- withCursor:cid pointerMode:#async keyboardMode:#sync confineTo:nil.
+ withCursor:cid pointerMode:#async keyboardMode:#sync confineTo:nil.
visType := aDevice visualType.
depth := aDevice depth.
(visType == #StaticGray) ifTrue:[
- (aDevice blackpixel == 0) ifTrue:[
- photometric := #blackIs0
- ] ifFalse:[
- photometric := #whiteIs0
- ].
- samplesPerPixel := 1.
- bitsPerPixel := depth.
- bitsPerSample := Array with:bitsPerPixel.
+ (aDevice blackpixel == 0) ifTrue:[
+ photometric := #blackIs0
+ ] ifFalse:[
+ photometric := #whiteIs0
+ ].
+ samplesPerPixel := 1.
+ bitsPerPixel := depth.
+ bitsPerSample := Array with:bitsPerPixel.
] ifFalse:[
- ((visType == #PseudoColor) or:[(visType == #StaticColor) or:[visType == #GrayScale]]) ifTrue:[
- photometric := #palette.
- samplesPerPixel := 1.
- bitsPerPixel := depth.
- bitsPerSample := Array with:bitsPerPixel.
- ] ifFalse:[
- ((visType == #TrueColor) or:[visType == #DirectColor]) ifTrue:[
- photometric := #rgb.
- samplesPerPixel := 3.
- bitsPerPixel := 24.
- bitsPerSample := #(8 8 8)
- ] ifFalse:[
- self error:'screen visual not supported'.
- ^ nil
- ]
- ]
+ ((visType == #PseudoColor) or:[(visType == #StaticColor) or:[visType == #GrayScale]]) ifTrue:[
+ photometric := #palette.
+ samplesPerPixel := 1.
+ bitsPerPixel := depth.
+ bitsPerSample := Array with:bitsPerPixel.
+ ] ifFalse:[
+ ((visType == #TrueColor) or:[visType == #DirectColor]) ifTrue:[
+ photometric := #rgb.
+ samplesPerPixel := 3.
+ bitsPerPixel := 24.
+ bitsPerSample := #(8 8 8)
+ ] ifFalse:[
+ self error:'screen visual not supported'.
+ ^ nil
+ ]
+ ]
].
"dont know yet, how display pads; assume worst case,
@@ -740,52 +756,52 @@
bytesPerLineIn := (info at:3). "what I got"
bytesPerLine := (w * bitsPerPixel + 7) // 8. "what I want"
(bytesPerLine ~~ bytesPerLineIn) ifTrue:[
- tmpData := inData.
- inData := ByteArray uninitializedNew:(bytesPerLine * height).
- srcIndex := 1.
- dstIndex := 1.
- 1 to:h do:[:hi |
- inData replaceFrom:dstIndex to:(dstIndex + bytesPerLine - 1)
- with:tmpData startingAt:srcIndex.
- dstIndex := dstIndex + bytesPerLine.
- srcIndex := srcIndex + bytesPerLineIn
- ]
+ tmpData := inData.
+ inData := ByteArray uninitializedNew:(bytesPerLine * height).
+ srcIndex := 1.
+ dstIndex := 1.
+ 1 to:h do:[:hi |
+ inData replaceFrom:dstIndex to:(dstIndex + bytesPerLine - 1)
+ with:tmpData startingAt:srcIndex.
+ dstIndex := dstIndex + bytesPerLine.
+ srcIndex := srcIndex + bytesPerLineIn
+ ]
] ifFalse:[
- (bytesPerLine * height) ~~ inData size ifTrue:[
- tmpData := inData.
- inData := ByteArray uninitializedNew:(bytesPerLine * height).
- inData replaceFrom:1 to:bytesPerLine * height with:tmpData startingAt:1
- ]
+ (bytesPerLine * height) ~~ inData size ifTrue:[
+ tmpData := inData.
+ inData := ByteArray uninitializedNew:(bytesPerLine * height).
+ inData replaceFrom:1 to:bytesPerLine * height with:tmpData startingAt:1
+ ]
].
"info printNewline. "
((visType == #StaticGray) or:[visType == #TrueColor]) ifTrue:[
- "were done, the pixel values are the rgb/grey values"
- bytes := inData.
- ^ self
+ "were done, the pixel values are the rgb/grey values"
+ bytes := inData.
+ ^ self
].
"what we have now are the color numbers - still need the r/g/b values"
"find out, which colors are in the picture"
usedColors := inData usedValues.
- nUsed := usedColors maximumValue + 1.
+ nUsed := usedColors max + 1.
"get the palette"
rMap := Array new:nUsed.
gMap := Array new:nUsed.
bMap := Array new:nUsed.
usedColors do:[:colorIndex |
- |i scale|
+ |i scale|
- i := colorIndex + 1.
- scale := 255.0 / 100.0.
- aDevice getRGBFrom:colorIndex into:[:r :g :b |
- rMap at:i put:(r * scale) rounded.
- gMap at:i put:(g * scale) rounded.
- bMap at:i put:(b * scale) rounded
- ]
+ i := colorIndex + 1.
+ scale := 255.0 / 100.0.
+ aDevice getRGBFrom:colorIndex into:[:r :g :b |
+ rMap at:i put:(r * scale) rounded.
+ gMap at:i put:(g * scale) rounded.
+ bMap at:i put:(b * scale) rounded
+ ]
].
colorMap := Array with:rMap with:gMap with:bMap.
bytes := inData.
@@ -805,9 +821,9 @@
(see ImageReader subclasses implementing save:onFile:)"
FileFormats associationsDo:[:a |
- (aFileName endsWith:(a key)) ifTrue:[
- ^ (a value) save:self onFile:aFileName
- ]
+ (aFileName endsWith:(a key)) ifTrue:[
+ ^ (a value) save:self onFile:aFileName
+ ]
].
"no known extension - could ask user for the format here.
currently default to tiff format."
@@ -828,20 +844,19 @@
!Image methodsFor:'converting'!
on:aDevice
- "make the image device dependent for aDevice"
+ "return an image with the same pixels as the receiver, but
+ associated to aDevice. If the receiver is not yet bound to
+ a device, this will be the recevier. Otherwise, a new image
+ is returned."
((aDevice == device) and:[deviceForm notNil]) ifTrue:[^ self].
+ (device notNil and:[aDevice ~~ device]) ifTrue:[
+ "oops, I am already accociated to another device
+ - need a copy ...
+ "
+ ^ self copy on:aDevice
+ ].
deviceForm := self asFormOn:aDevice.
- deviceForm notNil ifTrue:[
- device isNil ifTrue:[
- device := aDevice.
- Lobby register:self
- ] ifFalse:[
- device := aDevice.
- Lobby changed:self
- ].
- deviceForm forgetBits
- ]
!
monochromeOn:aDevice
@@ -849,61 +864,115 @@
(monochrome, even if device supports colors)"
((aDevice == device) and:[monoDeviceForm notNil]) ifTrue:[^ self].
+ (device notNil and:[aDevice ~~ device]) ifTrue:[
+ "oops, I am already accociated to another device
+ - need a copy ...
+ "
+ ^ self copy monochromeOn:aDevice
+ ].
monoDeviceForm := self asMonochromeFormOn:aDevice.
- monoDeviceForm notNil ifTrue:[
- device := aDevice.
- monoDeviceForm forgetBits
- ]
!
asFormOn:aDevice
- "get a device form, with best possible approximation"
+ "get a device form, with best possible approximation.
+ remember it in case someone asks again."
+
+ |form|
+
+ ((aDevice == device) and:[deviceForm notNil]) ifTrue:[^ deviceForm].
(photometric == #palette) ifTrue:[
- ^ self paletteImageAsFormOn:aDevice
+ form := self paletteImageAsFormOn:aDevice
+ ] ifFalse:[
+ (photometric == #rgb) ifTrue:[
+ form := self rgbImageAsFormOn:aDevice
+ ] ifFalse:[
+ form := self greyImageAsFormOn:aDevice
+ ]
].
- (photometric == #rgb) ifTrue:[
- ^ self rgbImageAsFormOn:aDevice
+ (device isNil or:[aDevice == device]) ifTrue:[
+ "remember this form in the receiver ..."
+
+ form notNil ifTrue:[
+ deviceForm := form.
+ device isNil ifTrue:[
+ device := aDevice.
+ Lobby register:self
+ ] ifFalse:[
+ Lobby changed:self
+ ].
+ "
+ can save space, by not keeping the images data-bits
+ twice (here and in the device form)
+ "
+ form forgetBits
+ ]
].
- ^ self greyImageAsFormOn:aDevice
+ ^ form
!
asMonochromeFormOn:aDevice
"get a monochrome device form"
+ |form|
+
+ ((aDevice == device) and:[monoDeviceForm notNil]) ifTrue:[^ monoDeviceForm].
+
(photometric == #palette) ifTrue:[
- ^ self paletteImageAsMonoFormOn:aDevice
+ form := self paletteImageAsMonoFormOn:aDevice
+ ] ifFalse:[
+ (photometric == #rgb) ifTrue:[
+ form := self rgbImageAsMonoFormOn:aDevice
+ ] ifFalse:[
+ form := self greyImageAsMonoFormOn:aDevice
+ ]
].
- (photometric == #rgb) ifTrue:[
- ^ self rgbImageAsMonoFormOn:aDevice
+ (device isNil or:[aDevice == device]) ifTrue:[
+ "remember this form in the receiver ..."
+
+ form notNil ifTrue:[
+ monoDeviceForm := form.
+ device isNil ifTrue:[
+ device := aDevice.
+ Lobby register:self
+ ] ifFalse:[
+ Lobby changed:self
+ ].
+ "
+ can save space, by not keeping the images data-bits
+ twice (here and in the device form)
+ "
+ form forgetBits
+ ]
].
- ^ self greyImageAsMonoFormOn:aDevice
+ ^ form
! !
!Image methodsFor:'converting rgb images'!
rgbImageAsFormOn:aDevice
- "convert am rgb image to a device form form aDevice.
- Return the device form."
+ "convert am rgb image to a device-form on aDevice.
+ Return the device-form."
|visual|
visual := aDevice visualType.
(visual == #StaticGray) ifTrue:[
- ^ self rgbImageAsGreyFormOn:aDevice
+ ^ self rgbImageAsGreyFormOn:aDevice
].
(visual == #TrueColor) ifTrue:[
- ^ self rgbImageAsTrueFormOn:aDevice
+ ^ self rgbImageAsTrueFormOn:aDevice
].
^ self rgbImageAsPseudoFormOn:aDevice
!
rgbImageAsGreyFormOn:aDevice
- "convert an rgb image to a grey image for greyscale displays"
+ "convert an rgb image to a grey device-form on aDevice
+ (for greyscale displays)"
|deviceDepth|
@@ -911,37 +980,37 @@
"I have specially tuned methods for monochrome"
(deviceDepth == 1) ifTrue:[
- DitherAlgorithm == #error ifTrue:[
- ^ self rgbImageAsErrorDitheredGreyFormOn:aDevice
- ].
- DitherAlgorithm == #pattern ifTrue:[
- ^ self rgbImageAsPatternDitheredGreyFormOn:aDevice
- ].
- ^ self rgbImageAsMonoFormOn:aDevice
+ DitherAlgorithm == #error ifTrue:[
+ ^ self rgbImageAsErrorDitheredGreyFormOn:aDevice
+ ].
+ DitherAlgorithm == #pattern ifTrue:[
+ ^ self rgbImageAsPatternDitheredGreyFormOn:aDevice
+ ].
+ ^ self rgbImageAsMonoFormOn:aDevice
].
"and for 2plane greyscale (i.e. NeXTs)"
(deviceDepth == 2) ifTrue:[
- DitherAlgorithm == #error ifTrue:[
- ^ self rgbImageAsErrorDitheredGreyFormOn:aDevice
- ].
- DitherAlgorithm == #pattern ifTrue:[
- ^ self rgbImageAsPatternDitheredGreyFormOn:aDevice
- ].
- ^ self rgbImageAs2PlaneFormOn:aDevice
+ DitherAlgorithm == #error ifTrue:[
+ ^ self rgbImageAsErrorDitheredGreyFormOn:aDevice
+ ].
+ DitherAlgorithm == #pattern ifTrue:[
+ ^ self rgbImageAsPatternDitheredGreyFormOn:aDevice
+ ].
+ ^ self rgbImageAs2PlaneFormOn:aDevice
].
(deviceDepth == 8) ifTrue:[
- ^ self rgbImageAs8BitGreyFormOn:aDevice
+ ^ self rgbImageAs8BitGreyFormOn:aDevice
].
"mhmh need another converter ...
till then we do:"
DitherAlgorithm == #error ifTrue:[
- ^ self rgbImageAsErrorDitheredGreyFormOn:aDevice
+ ^ self rgbImageAsErrorDitheredGreyFormOn:aDevice
].
DitherAlgorithm == #pattern ifTrue:[
- ^ self rgbImageAsPatternDitheredGreyFormOn:aDevice
+ ^ self rgbImageAsPatternDitheredGreyFormOn:aDevice
].
^ self rgbImageAsMonoFormOn:aDevice
!
@@ -987,50 +1056,52 @@
!Image methodsFor:'converting palette images'!
paletteImageAsFormOn:aDevice
+ "return a device-form for the palette-image receiver"
+
(aDevice visualType == #StaticGray) ifTrue:[
- (aDevice depth == 8) ifTrue:[
- ^ self paletteImageAsGreyFormOn:aDevice
- ].
+ (aDevice depth == 8) ifTrue:[
+ ^ self paletteImageAsGreyFormOn:aDevice
+ ].
- DitherAlgorithm == #pattern ifTrue:[
- ^ self paletteImageAsPatternDitheredGreyFormOn:aDevice
- ].
+ DitherAlgorithm == #pattern ifTrue:[
+ ^ self paletteImageAsPatternDitheredGreyFormOn:aDevice
+ ].
- (aDevice depth == 2) ifTrue:[
- ^ self paletteImageAs2PlaneFormOn:aDevice
- ].
+ (aDevice depth == 2) ifTrue:[
+ ^ self paletteImageAs2PlaneFormOn:aDevice
+ ].
- ^ self paletteImageAsMonoFormOn:aDevice
+ ^ self paletteImageAsMonoFormOn:aDevice
].
^ self paletteImageAsPseudoFormOn:aDevice
!
paletteImageAsMonoFormOn:aDevice
- "return a 1-bit monoForm from the palette picture"
+ "return a 1-bit mono-deviceForm from the palette image"
^ self subclassResponsibility
!
paletteImageAs2PlaneFormOn:aDevice
- "return a 2-bit greyForm from the palette picture"
+ "return a 2-bit grey-deviceForm from the palette image"
^ self subclassResponsibility
!
paletteImageAsPseudoFormOn:aDevice
- "return a pseudoForm from the palette picture."
+ "return a pseudo-deviceForm from the palette image."
^ self subclassResponsibility
!
paletteImageAsGreyFormOn:aDevice
- "return an 8-bit greyForm from the palette picture"
+ "return an 8-bit grey-deviceForm from the palette image"
^ self subclassResponsibility
!
paletteImageAsPatternDitheredGreyFormOn:aDevice
- "return a dithered greyForm from the palette picture."
+ "return a dithered grey-deviceForm from the palette image."
^ self subclassResponsibility
! !
@@ -1038,14 +1109,14 @@
!Image methodsFor:'converting greyscale images'!
greyImageAsFormOn:aDevice
- "return a thresholded greyForm from the grey picture."
+ "return a thresholded grey-deviceForm from the grey image."
|pictureDepth nPlanes f|
nPlanes := samplesPerPixel.
(nPlanes == 2) ifTrue:[
- 'alpha plane ignored' errorPrintNewline.
- nPlanes := 1
+ 'alpha plane ignored' errorPrintNewline.
+ nPlanes := 1
].
pictureDepth := bitsPerSample at:1.
@@ -1053,55 +1124,55 @@
"monochrome is very easy ..."
(pictureDepth == 1) ifTrue:[
- ^ Form width:width height:height fromArray:bytes on:aDevice
+ ^ Form width:width height:height fromArray:bytes on:aDevice
].
(aDevice visualType == #StaticGray) ifTrue:[
- (aDevice depth == pictureDepth) ifTrue:[
+ (aDevice depth == pictureDepth) ifTrue:[
- "greyscale is easy, if the depths match"
+ "greyscale is easy, if the depths match"
- f := Form width:width height:height depth:pictureDepth on:aDevice.
- f isNil ifTrue:[^ nil].
- f initGC.
+ f := Form width:width height:height depth:pictureDepth on:aDevice.
+ f isNil ifTrue:[^ nil].
+ f initGC.
- "if device has white at the opposite corner ..."
- ((aDevice blackpixel == 0) == (photometric == #blackIs0)) ifFalse:[
- "have to invert bits"
- f function:#copyInverted
- ].
- aDevice drawBits:bytes depth:pictureDepth width:width height:height
- x:0 y:0
- into:(f id)
- x:0 y:0 width:width height:height with:(f gcId).
- ^ f
- ].
+ "if device has white at the opposite corner ..."
+ ((aDevice blackpixel == 0) == (photometric == #blackIs0)) ifFalse:[
+ "have to invert bits"
+ f function:#copyInverted
+ ].
+ aDevice drawBits:bytes depth:pictureDepth width:width height:height
+ x:0 y:0
+ into:(f id)
+ x:0 y:0 width:width height:height with:(f gcId).
+ ^ f
+ ].
- "the image has more greylevels than the display - dither"
+ "the image has more greylevels than the display - dither"
"
coming soon ...
- DitherAlgorithm == #error ifTrue:[
- ^ self greyImageAsErrorDitheredGreyFormOn:aDevice
- ].
+ DitherAlgorithm == #error ifTrue:[
+ ^ self greyImageAsErrorDitheredGreyFormOn:aDevice
+ ].
"
- DitherAlgorithm == #pattern ifTrue:[
- ^ self greyImageAsPatternDitheredGreyFormOn:aDevice
- ].
+ DitherAlgorithm == #pattern ifTrue:[
+ ^ self greyImageAsPatternDitheredGreyFormOn:aDevice
+ ].
- "no dither, simply cut off information"
- (aDevice depth == 1) ifTrue:[
- "for monochrome, there is a special method to do this"
- ^ self greyImageAsMonoFormOn:aDevice
- ].
- "the general case, will take as many bits from the image
- as possible for the device"
- ^ self greyImageAsGreyFormOn:aDevice
+ "no dither, simply cut off information"
+ (aDevice depth == 1) ifTrue:[
+ "for monochrome, there is a special method to do this"
+ ^ self greyImageAsMonoFormOn:aDevice
+ ].
+ "the general case, will take as many bits from the image
+ as possible for the device"
+ ^ self greyImageAsGreyFormOn:aDevice
].
(aDevice visualType == #PseudoColor or:[aDevice visualType == #GrayScale]) ifTrue:[
- ^ self greyImageAsPseudoFormOn:aDevice
+ ^ self greyImageAsPseudoFormOn:aDevice
].
self error:'cannot convert this format'.
@@ -1109,13 +1180,13 @@
!
greyImageAsMonoFormOn:aDevice
- "return a (thresholded) monochrome Form from the picture."
+ "return a (thresholded) monochrome Form from the image."
^ self subclassResponsibility
!
greyImageAsPatternDitheredGreyFormOn:aDevice
- "return a dithered greyForm from the grey picture.
+ "return a dithered greyForm from the grey image.
Works for any source/destination depths, but very very slow
since each pixel is processed individually.
Usually redefined by subclasses for more performance"
@@ -1139,31 +1210,31 @@
f initGC.
0 to:h do:[:dstY |
- x0 := 0.
- run := 0.
- last := nil.
- self atY:dstY from:0 to:w do:[:x :srcColor |
- |dstColor|
+ x0 := 0.
+ run := 0.
+ last := nil.
+ self atY:dstY from:0 to:w do:[:x :srcColor |
+ |dstColor|
- srcColor ~~ last ifTrue:[
- (run ~~ 0) ifTrue:[
- f fillRectangleX:x0 y:dstY width:run height:1.
- ].
- run := 0.
- dstColor := Color grey:(srcColor greyIntensity).
- f paint:dstColor.
- last := srcColor.
- x0 := x
- ].
- run := run + 1
- ].
- f fillRectangleX:x0 y:dstY width:run height:1.
+ srcColor ~~ last ifTrue:[
+ (run ~~ 0) ifTrue:[
+ f fillRectangleX:x0 y:dstY width:run height:1.
+ ].
+ run := 0.
+ dstColor := Color grey:(srcColor greyIntensity).
+ f paint:dstColor.
+ last := srcColor.
+ x0 := x
+ ].
+ run := run + 1
+ ].
+ f fillRectangleX:x0 y:dstY width:run height:1.
].
^ f
!
greyImageAsGreyFormOn:aDevice
- "return an 8-bit Form from the grey picture"
+ "return an 8-bit Form from the grey image"
|wideBits pictureDepth f map nplanes ncells
inverse
@@ -1176,8 +1247,8 @@
shift4 "{ Class: SmallInteger }" |
(aDevice depth == 8) ifFalse:[
- 'non-8 plane displays not supported' errorPrintNewline.
- ^ self greyImageAsMonoFormOn:aDevice
+ 'non-8 plane displays not supported' errorPrintNewline.
+ ^ self greyImageAsMonoFormOn:aDevice
].
pictureDepth := bitsPerSample at:1.
@@ -1190,8 +1261,8 @@
nplanes := 8.
ncells := 256.
[aDevice ncells < ncells] whileTrue:[
- nplanes := nplanes - 1.
- ncells := ncells // 2
+ nplanes := nplanes - 1.
+ ncells := ncells // 2
].
"prepare translation table"
@@ -1203,38 +1274,38 @@
inverse := aDevice blackpixel ~~ 0.
photometric == #blackIs0 ifFalse:[
- inverse := inverse not
+ inverse := inverse not
].
mapSize := map size.
1 to:mapSize do:[:index |
- oldValue := index - 1.
- newValue := oldValue bitShift:shift.
- newValue := newValue bitOr:(oldValue bitShift:shift2).
- newValue := newValue bitOr:(oldValue bitShift:shift3).
- newValue := newValue bitOr:(oldValue bitShift:shift4).
- inverse ifTrue:[
- map at:(map size - index + 1) put:newValue
- ] ifFalse:[
- map at:index put:newValue
- ]
+ oldValue := index - 1.
+ newValue := oldValue bitShift:shift.
+ newValue := newValue bitOr:(oldValue bitShift:shift2).
+ newValue := newValue bitOr:(oldValue bitShift:shift3).
+ newValue := newValue bitOr:(oldValue bitShift:shift4).
+ inverse ifTrue:[
+ map at:(map size - index + 1) put:newValue
+ ] ifFalse:[
+ map at:index put:newValue
+ ]
].
bytes expandPixels:pictureDepth
- width:width
- height:height
- into:wideBits
- mapping:map.
+ width:width
+ height:height
+ into:wideBits
+ mapping:map.
f := Form width:width height:height depth:8 on:aDevice.
f isNil ifTrue:[^ nil].
f initGC.
aDevice drawBits:wideBits depth:8 width:width height:height
- x:0 y:0
- into:(f id) x:0 y:0 width:width height:height with:(f gcId).
+ x:0 y:0
+ into:(f id) x:0 y:0 width:width height:height with:(f gcId).
^ f
!
greyImageAsPseudoFormOn:aDevice
- "return an 8-bit pseudo Form from the grey picture"
+ "return an 8-bit pseudo Form from the grey image"
|wideBits pictureDepth f map
colorMap usedColors nUsed aColor
@@ -1244,42 +1315,42 @@
pictureDepth := bitsPerSample at:1.
(#(2 4 8) includes:pictureDepth) ifFalse:[
- self error:'currently only depth-2, 4 or 8 supported'.
- ^ nil
+ self error:'currently only depth-2, 4 or 8 supported'.
+ ^ nil
].
wideBits := ByteArray uninitializedNew:(width * height).
(pictureDepth == 8) ifTrue:[
- "for 8bits, we scan for used colors first;
- to avoid allocating too many colors"
+ "for 8bits, we scan for used colors first;
+ to avoid allocating too many colors"
- usedColors := bytes usedValues.
- nUsed := usedColors maximumValue + 1.
+ usedColors := bytes usedValues.
+ nUsed := usedColors max + 1.
- colorMap := Array new:nUsed.
- photometric == #blackIs0 ifTrue:[
- usedColors do:[:grey |
- colorMap at:(grey + 1) put:(Color grey:(100.0 / 256.0 * grey))
- ]
- ] ifFalse:[
- usedColors do:[:grey |
- colorMap at:(grey + 1) put:(Color grey:(100 - (100.0 / 256.0 * grey)))
- ]
- ]
+ colorMap := Array new:nUsed.
+ photometric == #blackIs0 ifTrue:[
+ usedColors do:[:grey |
+ colorMap at:(grey + 1) put:(Color grey:(100.0 / 256.0 * grey))
+ ]
+ ] ifFalse:[
+ usedColors do:[:grey |
+ colorMap at:(grey + 1) put:(Color grey:(100 - (100.0 / 256.0 * grey)))
+ ]
+ ]
] ifFalse:[
- nColors := (1 bitShift:pictureDepth).
- colorMap := Array new:nColors.
- range := 100 / (nColors - 1) asFloat.
- photometric == #blackIs0 ifTrue:[
- 1 to:nColors do:[:i |
- colorMap at:i put:(Color grey:(i - 1) * range).
- ].
- ] ifFalse:[
- 1 to:nColors do:[:i |
- colorMap at:(nColors - i + 1) put:(Color grey:(i - 1) * range).
- ].
- ].
+ nColors := (1 bitShift:pictureDepth).
+ colorMap := Array new:nColors.
+ range := 100 / (nColors - 1) asFloat.
+ photometric == #blackIs0 ifTrue:[
+ 1 to:nColors do:[:i |
+ colorMap at:i put:(Color grey:(i - 1) * range).
+ ].
+ ] ifFalse:[
+ 1 to:nColors do:[:i |
+ colorMap at:(nColors - i + 1) put:(Color grey:(i - 1) * range).
+ ].
+ ].
].
"XXX should reduce 8->6->4->2 planes, if not all colors could be allocated"
@@ -1288,33 +1359,33 @@
map := ByteArray uninitializedNew:256.
nColors := colorMap size.
1 to:nColors do:[:i |
- aColor := colorMap at:i.
- aColor notNil ifTrue:[
- aColor := aColor on:aDevice.
- colorMap at:i put:aColor.
- id := aColor colorId.
- id notNil ifTrue:[
- map at:i put:id
- ] ifFalse:[
- map at:i put:0
- ]
- ]
+ aColor := colorMap at:i.
+ aColor notNil ifTrue:[
+ aColor := aColor on:aDevice.
+ colorMap at:i put:aColor.
+ id := aColor colorId.
+ id notNil ifTrue:[
+ map at:i put:id
+ ] ifFalse:[
+ map at:i put:0
+ ]
+ ]
].
"expand & translate"
bytes expandPixels:pictureDepth
- width:width
- height:height
- into:wideBits
- mapping:map.
+ width:width
+ height:height
+ into:wideBits
+ mapping:map.
f := Form width:width height:height depth:8 on:aDevice.
f isNil ifTrue:[^ nil].
f colorMap:colorMap.
f initGC.
aDevice drawBits:wideBits depth:8 width:width height:height
- x:0 y:0
- into:(f id) x:0 y:0 width:width height:height with:(f gcId).
+ x:0 y:0
+ into:(f id) x:0 y:0 width:width height:height with:(f gcId).
^ f
! !
@@ -1336,7 +1407,8 @@
magnifyBy:extent
"return a new image magnified by extent, aPoint.
- If non-integral magnify is asked for, pass the work on to 'hardMagnifyBy:'"
+ If non-integral magnify is asked for, pass the work on to 'hardMagnifyBy:'
+ while simple (integral) magnifications are handled here."
|mX mY
magX "{ Class: SmallInteger }" "new version of stc can find this out itself..."
@@ -1354,7 +1426,7 @@
((mX = 1) and:[mY = 1]) ifTrue:[^ self].
((mX isMemberOf:SmallInteger) and:[mY isMemberOf:SmallInteger]) ifFalse:[
- ^ self hardMagnifyBy:extent
+ ^ self hardMagnifyBy:extent
].
bitsPerPixel := self depth.
@@ -1380,45 +1452,45 @@
newImage colorMap:colorMap copy.
mX = 1 ifTrue:[
- "expand rows only"
- srcOffset := 1.
- dstOffset := 1.
+ "expand rows only"
+ srcOffset := 1.
+ dstOffset := 1.
- 1 to:h do:[:row |
- 1 to:mY do:[:i |
- newBits replaceFrom:dstOffset
- to:(dstOffset + oldBytesPerRow - 1)
- with:bytes
- startingAt:srcOffset.
- dstOffset := dstOffset + newBytesPerRow
- ].
- srcOffset := srcOffset + oldBytesPerRow.
- ].
+ 1 to:h do:[:row |
+ 1 to:mY do:[:i |
+ newBits replaceFrom:dstOffset
+ to:(dstOffset + oldBytesPerRow - 1)
+ with:bytes
+ startingAt:srcOffset.
+ dstOffset := dstOffset + newBytesPerRow
+ ].
+ srcOffset := srcOffset + oldBytesPerRow.
+ ].
] ifFalse:[
- "expand cols"
- (mX > 1) ifTrue:[
- dstOffset := 1.
- srcOffset := 1.
- 1 to:h do:[:row |
- self magnifyRowFrom:bytes
- offset:srcOffset
- into:newBits
- offset:dstOffset
- factor:mX.
+ "expand cols"
+ (mX > 1) ifTrue:[
+ dstOffset := 1.
+ srcOffset := 1.
+ 1 to:h do:[:row |
+ self magnifyRowFrom:bytes
+ offset:srcOffset
+ into:newBits
+ offset:dstOffset
+ factor:mX.
- first := dstOffset.
- dstOffset := dstOffset + newBytesPerRow.
- " and copy for row expansion "
- 2 to:mY do:[:i |
- newBits replaceFrom:dstOffset
- to:(dstOffset + newBytesPerRow - 1)
- with:newBits
- startingAt:first.
- dstOffset := dstOffset + newBytesPerRow
- ].
- srcOffset := srcOffset + oldBytesPerRow.
- ].
- ]
+ first := dstOffset.
+ dstOffset := dstOffset + newBytesPerRow.
+ " and copy for row expansion "
+ 2 to:mY do:[:i |
+ newBits replaceFrom:dstOffset
+ to:(dstOffset + newBytesPerRow - 1)
+ with:newBits
+ startingAt:first.
+ dstOffset := dstOffset + newBytesPerRow
+ ].
+ srcOffset := srcOffset + oldBytesPerRow.
+ ].
+ ]
].
^ newImage
@@ -1427,7 +1499,8 @@
hardMagnifyBy:extent
"return a new image magnified by extent, aPoint.
- This is the general magnification method, handling non-integral values"
+ This is the general magnification method, handling non-integral values.
+ It is slower than the integral magnification method."
|mX
mY
@@ -1465,11 +1538,11 @@
h := newHeight - 1.
0 to:h do:[:row |
- srcRow := (row // mY).
- 0 to:w do:[:col |
- value := self valueAtX:(col // mX) y:srcRow.
- newImage atX:col y:row putValue:value.
- ]
+ srcRow := (row // mY).
+ 0 to:w do:[:col |
+ value := self valueAtX:(col // mX) y:srcRow.
+ newImage atX:col y:row putValue:value.
+ ]
].
^ newImage
@@ -1489,13 +1562,13 @@
h := height - 1.
0 to:h do:[:row |
- c2 := w.
- 0 to:(w // 2) do:[:col |
- value := self valueAtX:col y:row.
- self atX:col y:row putValue:(self valueAtX:c2 y:row).
- self atX:c2 y:row putValue:value.
- c2 := c2 - 1.
- ]
+ c2 := w.
+ 0 to:(w // 2) do:[:col |
+ value := self valueAtX:col y:row.
+ self atX:col y:row putValue:(self valueAtX:c2 y:row).
+ self atX:c2 y:row putValue:value.
+ c2 := c2 - 1.
+ ]
].
"flush device info"
self restored
@@ -1519,11 +1592,11 @@
indexHi := bytesPerRow * h + 1.
0 to:(h // 2) do:[:row |
- buffer replaceFrom:1 to:bytesPerRow with:bytes startingAt:indexLow.
- bytes replaceFrom:indexLow to:(indexLow + bytesPerRow - 1) with:bytes startingAt:indexHi.
- bytes replaceFrom:indexHi to:(indexHi + bytesPerRow - 1) with:buffer startingAt:1.
- indexLow := indexLow + bytesPerRow.
- indexHi := indexHi - bytesPerRow.
+ buffer replaceFrom:1 to:bytesPerRow with:bytes startingAt:indexLow.
+ bytes replaceFrom:indexLow to:(indexLow + bytesPerRow - 1) with:bytes startingAt:indexHi.
+ bytes replaceFrom:indexHi to:(indexHi + bytesPerRow - 1) with:buffer startingAt:1.
+ indexLow := indexLow + bytesPerRow.
+ indexHi := indexHi - bytesPerRow.
].
"flush device info"
self restored
@@ -1545,7 +1618,7 @@
d := d truncated.
d == 0 ifTrue:[^ self].
((d ~~ 90) and:[(d ~~ 270) and:[d ~~ 180]]) ifTrue:[
- ^ self hardRotated:d
+ ^ self hardRotated:d
].
newBytesPerRow := ((height * self depth) + 7) // 8.
@@ -1564,26 +1637,26 @@
h := height - 1.
d == 90 ifTrue:[
- 0 to:h do:[:row |
- c2 := h-row.
- 0 to:w do:[:col |
- newImage atX:c2 y:col putValue:(self valueAtX:col y:row).
- ]
- ]
+ 0 to:h do:[:row |
+ c2 := h-row.
+ 0 to:w do:[:col |
+ newImage atX:c2 y:col putValue:(self valueAtX:col y:row).
+ ]
+ ]
].
d == 180 ifTrue:[
- 0 to:h do:[:row |
- 0 to:w do:[:col |
- newImage atX:(h-row) y:(w-col) putValue:(self valueAtX:col y:row).
- ]
- ]
+ 0 to:h do:[:row |
+ 0 to:w do:[:col |
+ newImage atX:(h-row) y:(w-col) putValue:(self valueAtX:col y:row).
+ ]
+ ]
].
d == 270 ifTrue:[
- 0 to:h do:[:row |
- 0 to:w do:[:col |
- newImage atX:row y:(w-col) putValue:(self valueAtX:col y:row).
- ]
- ]
+ 0 to:h do:[:row |
+ 0 to:w do:[:col |
+ newImage atX:row y:(w-col) putValue:(self valueAtX:col y:row).
+ ]
+ ]
].
^ newImage
!
@@ -1604,7 +1677,7 @@
!Image methodsFor:'private'!
magnifyRowFrom:srcBytes offset:srcStart pixels:oldPixels
- into:dstBytes offset:dstStart factor:mX
+ into:dstBytes offset:dstStart factor:mX
"magnify a single pixel row - can only magnify by integer factors,
can only magnify 1,2,4,8 and 24 bit-per-pixel images. But this is done fast."
@@ -1615,7 +1688,8 @@
!Image methodsFor: 'binary storage'!
readBinaryContentsFrom: stream manager: manager
- "tell the newly restored Image about restoration"
+ "read a binary representation of an image from stream.
+ Redefined to fLush any device data."
super readBinaryContentsFrom: stream manager: manager.
device := nil.
--- a/ImageRdr.st Mon Oct 10 03:30:48 1994 +0100
+++ b/ImageRdr.st Mon Oct 10 03:34:45 1994 +0100
@@ -23,7 +23,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libview/Attic/ImageRdr.st,v 1.8 1994-08-05 01:14:28 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/ImageRdr.st,v 1.9 1994-10-10 02:32:26 claus Exp $
'!
!ImageReader class methodsFor:'documentation'!
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libview/Attic/ImageRdr.st,v 1.8 1994-08-05 01:14:28 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/ImageRdr.st,v 1.9 1994-10-10 02:32:26 claus Exp $
"
!
@@ -208,7 +208,7 @@
readShort
"return the next 2-byte short, honoring the byte-order"
- ^ inStream nextShortMSB:(byteOrder ~~ #lsb)
+ ^ inStream nextUnsignedShortMSB:(byteOrder ~~ #lsb)
!
readShortLong
--- a/ImageReader.st Mon Oct 10 03:30:48 1994 +0100
+++ b/ImageReader.st Mon Oct 10 03:34:45 1994 +0100
@@ -23,7 +23,7 @@
COPYRIGHT (c) 1991 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libview/ImageReader.st,v 1.8 1994-08-05 01:14:28 claus Exp $
+$Header: /cvs/stx/stx/libview/ImageReader.st,v 1.9 1994-10-10 02:32:26 claus Exp $
'!
!ImageReader class methodsFor:'documentation'!
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libview/ImageReader.st,v 1.8 1994-08-05 01:14:28 claus Exp $
+$Header: /cvs/stx/stx/libview/ImageReader.st,v 1.9 1994-10-10 02:32:26 claus Exp $
"
!
@@ -208,7 +208,7 @@
readShort
"return the next 2-byte short, honoring the byte-order"
- ^ inStream nextShortMSB:(byteOrder ~~ #lsb)
+ ^ inStream nextUnsignedShortMSB:(byteOrder ~~ #lsb)
!
readShortLong
--- a/KeybdMap.st Mon Oct 10 03:30:48 1994 +0100
+++ b/KeybdMap.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
KeyboardMap comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/Attic/KeybdMap.st,v 1.4 1994-08-05 01:14:32 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/KeybdMap.st,v 1.5 1994-10-10 02:32:37 claus Exp $
'!
!KeyboardMap class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libview/Attic/KeybdMap.st,v 1.4 1994-08-05 01:14:32 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/KeybdMap.st,v 1.5 1994-10-10 02:32:37 claus Exp $
"
!
@@ -67,8 +67,8 @@
submap := self at:key1.
submap isNil ifTrue:[
- submap := KeyboardMap new.
- self at:key1 put:submap.
+ submap := KeyboardMap new.
+ self at:key1 put:submap.
].
submap at:key2 put:anObject
!
@@ -78,10 +78,10 @@
where := current notNil ifTrue:[current] ifFalse:[self].
- value := where at:aKey ifAbsent:[aKey].
+ value := where at:aKey ifAbsent:aKey.
(value isMemberOf:KeyboardMap) ifTrue:[
- current := value.
- ^ nil.
+ current := value.
+ ^ nil.
].
current := nil.
^ value
--- a/KeyboardMap.st Mon Oct 10 03:30:48 1994 +0100
+++ b/KeyboardMap.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
KeyboardMap comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/KeyboardMap.st,v 1.4 1994-08-05 01:14:32 claus Exp $
+$Header: /cvs/stx/stx/libview/KeyboardMap.st,v 1.5 1994-10-10 02:32:37 claus Exp $
'!
!KeyboardMap class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libview/KeyboardMap.st,v 1.4 1994-08-05 01:14:32 claus Exp $
+$Header: /cvs/stx/stx/libview/KeyboardMap.st,v 1.5 1994-10-10 02:32:37 claus Exp $
"
!
@@ -67,8 +67,8 @@
submap := self at:key1.
submap isNil ifTrue:[
- submap := KeyboardMap new.
- self at:key1 put:submap.
+ submap := KeyboardMap new.
+ self at:key1 put:submap.
].
submap at:key2 put:anObject
!
@@ -78,10 +78,10 @@
where := current notNil ifTrue:[current] ifFalse:[self].
- value := where at:aKey ifAbsent:[aKey].
+ value := where at:aKey ifAbsent:aKey.
(value isMemberOf:KeyboardMap) ifTrue:[
- current := value.
- ^ nil.
+ current := value.
+ ^ nil.
].
current := nil.
^ value
--- a/Make.proto Mon Oct 10 03:30:48 1994 +0100
+++ b/Make.proto Mon Oct 10 03:34:45 1994 +0100
@@ -10,7 +10,7 @@
LOCALDEFS=-I$(XINCLUDE)
-all:: abbrev.stc objs classList.stc $(OBJTARGET)
+all:: abbrev.stc objs classList.stc $(OBJTARGET) $(LIBVIEW_MORE)
#
# although all files are compiled here,
@@ -21,6 +21,19 @@
| grep -v $(WORKSTAT2).$(O) \
| grep -v libviewInit.o`
+#
+# less frequently used/needed
+#
+moreObjs= \
+ SunReader.$(O) \
+ WinIconRdr.$(O) \
+ PCXReader.$(O) \
+ FaceReader.$(O)
+
+# if you want them included, uncomment the next line
+# MOREOBJS=$(moreObjs)
+#
+
objs:: \
DevWorkst.$(O) \
$(WORKSTAT1).$(O) \
@@ -52,6 +65,7 @@
WGroup.$(O) \
KeybdMap.$(O) \
RsrcPack.$(O) \
+ ViewStyle.$(O) \
Image.$(O) \
Depth1Image.$(O) \
Depth2Image.$(O) \
@@ -62,9 +76,7 @@
TIFFRdr.$(O) \
GIFReader.$(O) \
XBMReader.$(O) \
- SunReader.$(O) \
- WinIconRdr.$(O) \
- FaceReader.$(O)
+ $(MOREOBJS)
smalllib: $(SMALLOBJTARGET)
@@ -130,57 +142,60 @@
IMAGE=$(I)/Image.H $(OBJECT)
IMAGERDR=$(I)/ImageRdr.H $(OBJECT)
-Workstat.o: Workstat.st $(OBJECT)
-DevWorkst.o: DevWorkst.st $(OBJECT)
-XWorkstat.o: XWorkstat.st $(I)/DevWorkst.H $(OBJECT)
-NXWorkst.o: NXWorkst.st $(I)/DevWorkst.H $(OBJECT)
-NTWorkst.o: NTWorkst.st $(I)/DevWorkst.H $(OBJECT)
-MacWorkst.o: MacWorkst.st $(I)/DevWorkst.H $(OBJECT)
-GLXWorkstat.o: GLXWorkstat.st $(I)/XWorkstat.H $(I)/DevWorkst.H $(OBJECT)
-# VGLWorkstat.o: VGLWorkstat.st $(I)/XWorkstat.H $(I)/DevWorkst.H $(OBJECT)
+Workstat.$(O): Workstat.st $(OBJECT)
+DevWorkst.$(O): DevWorkst.st $(OBJECT)
+XWorkstat.$(O): XWorkstat.st $(I)/DevWorkst.H $(OBJECT)
+NXWorkst.$(O): NXWorkst.st $(I)/DevWorkst.H $(OBJECT)
+NTWorkst.$(O): NTWorkst.st $(I)/DevWorkst.H $(OBJECT)
+MacWorkst.$(O): MacWorkst.st $(I)/DevWorkst.H $(OBJECT)
+GLXWorkstat.$(O): GLXWorkstat.st $(I)/XWorkstat.H $(I)/DevWorkst.H $(OBJECT)
+# VGLWorkstat.$(O): VGLWorkstat.st $(I)/XWorkstat.H $(I)/DevWorkst.H $(OBJECT)
-Color.o: Color.st $(OBJECT)
-WSensor.o: WSensor.st $(OBJECT)
-WGroup.o: WGroup.st $(OBJECT)
-WEvent.o: WEvent.st $(OBJECT)
-KeybdMap.o: KeybdMap.st $(I)/IdDict.H $(OBJECT)
-Model.o: Model.st $(OBJECT)
-Controll.o: Controll.st $(OBJECT)
-StdSysC.o: StdSysC.st $(I)/Controll.H $(OBJECT)
-WTrans.o: WTrans.st $(OBJECT)
-RsrcPack.o: RsrcPack.st $(I)/Dict.H $(OBJECT)
-ImageRdr.o: ImageRdr.st $(OBJECT)
-Font.o: Font.st $(OBJECT)
-Cursor.o: Cursor.st $(OBJECT)
-DObject.o: DObject.st $(OBJECT)
+Color.$(O): Color.st $(OBJECT)
+WSensor.$(O): WSensor.st $(OBJECT)
+WGroup.$(O): WGroup.st $(OBJECT)
+WEvent.$(O): WEvent.st $(OBJECT)
+KeybdMap.$(O): KeybdMap.st $(I)/IdDict.H $(OBJECT)
+Model.$(O): Model.st $(OBJECT)
+Controll.$(O): Controll.st $(OBJECT)
+StdSysC.$(O): StdSysC.st $(I)/Controll.H $(OBJECT)
+WTrans.$(O): WTrans.st $(OBJECT)
+RsrcPack.$(O): RsrcPack.st $(I)/Dict.H $(OBJECT)
+ViewStyle.$(O): ViewStyle.st $(I)/RsrcPack.H $(I)/Dict.H $(OBJECT)
+ImageRdr.$(O): ImageRdr.st $(OBJECT)
+Font.$(O): Font.st $(OBJECT)
+Cursor.$(O): Cursor.st $(OBJECT)
+DObject.$(O): DObject.st $(OBJECT)
-GC.o: GC.st $(OBJECT)
-DMedium.o: DMedium.st $(GRAPHICSCONTEXT)
-DevDraw.o: DevDraw.st $(DISPLAYMEDIUM)
-Form.o: Form.st $(DEVDRAWABLE)
-# OpqForm.o: OpqForm.st $(DEVDRAWABLE)
-PseudoV.o: PseudoV.st $(DEVDRAWABLE)
-View.o: View.st $(PSEUDOVIEW)
-DRootView.o: DRootView.st $(PSEUDOVIEW)
-InputView.o: InputView.st $(VIEW)
-PopUpView.o: PopUpView.st $(VIEW)
-ShadowV.o: ShadowV.st $(VIEW)
-StdSysV.o: StdSysV.st $(VIEW)
-ModalBox.o: ModalBox.st $(STDSYSVIEW)
+GC.$(O): GC.st $(OBJECT)
+DMedium.$(O): DMedium.st $(GRAPHICSCONTEXT)
+DevDraw.$(O): DevDraw.st $(DISPLAYMEDIUM)
+Form.$(O): Form.st $(DEVDRAWABLE)
+# OpqForm.$(O): OpqForm.st $(DEVDRAWABLE)
+PseudoV.$(O): PseudoV.st $(DEVDRAWABLE)
+View.$(O): View.st $(PSEUDOVIEW)
+DRootView.$(O): DRootView.st $(PSEUDOVIEW)
+InputView.$(O): InputView.st $(VIEW)
+PopUpView.$(O): PopUpView.st $(VIEW)
+ShadowV.$(O): ShadowV.st $(VIEW)
+StdSysV.$(O): StdSysV.st $(VIEW)
+ModalBox.$(O): ModalBox.st $(STDSYSVIEW)
-Image.o: Image.st $(OBJECT)
-Depth1Image.o: Depth1Image.st $(IMAGE)
-Depth2Image.o: Depth2Image.st $(IMAGE)
-Depth4Image.o: Depth4Image.st $(IMAGE)
-Depth8Image.o: Depth8Image.st $(IMAGE)
-Depth24Image.o: Depth24Image.st $(IMAGE)
+Image.$(O): Image.st $(OBJECT)
+Depth1Image.$(O): Depth1Image.st $(IMAGE)
+Depth2Image.$(O): Depth2Image.st $(IMAGE)
+Depth4Image.$(O): Depth4Image.st $(IMAGE)
+Depth8Image.$(O): Depth8Image.st $(IMAGE)
+Depth24Image.$(O): Depth24Image.st $(IMAGE)
-TIFFRdr.o: TIFFRdr.st $(IMAGERDR)
-GIFReader.o: GIFReader.st $(IMAGERDR)
-XBMReader.o: XBMReader.st $(IMAGERDR)
-SunReader.o: SunReader.st $(IMAGERDR)
-FaceReader.o: FaceReader.st $(IMAGERDR)
-WinIconRdr.o: WinIconRdr.st $(IMAGERDR)
-JPEGReader.o: JPEGReader.st $(IMAGERDR)
-PBMReader.o: PBMReader.st $(IMAGERDR)
-FontDescr.o: FontDescr.st $(OBJECT)
+TIFFRdr.$(O): TIFFRdr.st $(IMAGERDR)
+GIFReader.$(O): GIFReader.st $(IMAGERDR)
+XBMReader.$(O): XBMReader.st $(IMAGERDR)
+SunReader.$(O): SunReader.st $(IMAGERDR)
+FaceReader.$(O): FaceReader.st $(IMAGERDR)
+WinIconRdr.$(O): WinIconRdr.st $(IMAGERDR)
+JPEGReader.$(O): JPEGReader.st $(IMAGERDR)
+PBMReader.$(O): PBMReader.st $(IMAGERDR)
+PCXReader.$(O): PCXReader.st $(IMAGERDR)
+
+FontDescr.$(O): FontDescr.st $(OBJECT)
--- a/ModalBox.st Mon Oct 10 03:30:48 1994 +0100
+++ b/ModalBox.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1990 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -12,16 +12,16 @@
StandardSystemView subclass:#ModalBox
instanceVariableNames:'haveControl shadowView exclusiveKeyboard '
- classVariableNames:'PopShadow'
+ classVariableNames:'UseTransientViews'
poolDictionaries:''
category:'Views-Basic'
!
ModalBox comment:'
COPYRIGHT (c) 1990 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/ModalBox.st,v 1.11 1994-08-22 13:17:08 claus Exp $
+$Header: /cvs/stx/stx/libview/ModalBox.st,v 1.12 1994-10-10 02:32:40 claus Exp $
'!
!ModalBox class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1990 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libview/ModalBox.st,v 1.11 1994-08-22 13:17:08 claus Exp $
+$Header: /cvs/stx/stx/libview/ModalBox.st,v 1.12 1994-10-10 02:32:40 claus Exp $
"
!
@@ -52,20 +52,13 @@
others, in that they take complete control over the display, until
all processing is done (i.e. other views will not get any events
while the box is active).
-
- class variables:
-
- PopShadow <Boolean> if true, modalBoxes will show a shadow
"
! !
!ModalBox class methodsFor:'initialization'!
initialize
- super initialize.
- Display notNil ifTrue:[
- PopShadow := self classResources name:'POPUP_SHADOW' default:false
- ]
+ UseTransient := false.
! !
!ModalBox methodsFor:'initialize / release'!
@@ -75,20 +68,32 @@
haveControl := false.
exclusiveKeyboard := false.
+ label := ' '.
- PopShadow ifTrue:[
- shadowView := (ShadowView on:device) for:self
+ UseTransient ifFalse:[
+ (StyleSheet at:#popupShadow default:false) ifTrue:[
+ shadowView := (ShadowView on:device) for:self
+ ]
]
!
+initEvents
+ self enableEvent:#visibilityChange
+!
+
initStyle
super initStyle.
((style ~~ #normal) and:[style ~~ #mswindows]) ifTrue:[
- borderWidth := 0.
- self level:2
+ borderWidth := 0.
+ self level:2
]
!
+reinitialize
+ super reinitialize.
+ self unrealize.
+!
+
addToCurrentProject
"ignored here"
@@ -97,8 +102,8 @@
destroy
shadowView notNil ifTrue:[
- shadowView destroy.
- shadowView := nil
+ shadowView destroy.
+ shadowView := nil
].
self leaveControl. "just to make sure"
super destroy.
@@ -106,13 +111,13 @@
create
super create.
- PopShadow ifFalse:[
- self saveUnder:true
+ shadowView notNil ifTrue:[
+ self saveUnder:true
]
!
createOnTop
- ^ true
+ ^ UseTransient not
! !
!ModalBox methodsFor:'accessing'!
@@ -138,15 +143,15 @@
"take it away from any popup menu possibly still active"
ActiveGrab notNil ifTrue:[
- device ungrabKeyboard.
- ActiveGrab := nil.
+ device ungrabKeyboard.
+ ActiveGrab := nil.
].
"
if I am a super-modal box, take the keyboard
"
exclusiveKeyboard ifTrue:[
- device grabKeyboardIn:drawableId.
+ device grabKeyboardIn:drawableId.
].
"
@@ -157,8 +162,9 @@
!
fixPosition:aPoint
- "make sure, that the box is visible by shifting it
- into the visible screen area if nescessary"
+ "set origin to aPoint, but make sure, that the box is fully visible
+ by shifting it into the visible screen area if nescessary.
+ This prevents invisible modalBoxes (which you could never close)."
self origin:aPoint.
self makeFullyVisible
@@ -166,45 +172,96 @@
positionOffset
"return the delta, by which the box should be
- displaced from the mouse pointer. Usually redefined in
- subclasses to have some ok-button appear under
- the pointer."
+ displaced from the mouse pointer.
+ Usually redefined in subclasses to have the most convenient
+ ok-button appear under the pointer."
^ (width // 2) @ (height // 2)
!
open
- "default for modalboxes is to come up modal"
+ "default for modalboxes is to come up modal at the pointer position"
- ^ self openModal
+ ^ self showAtPointer
!
-openModal
+openModal:aBlock
"open the box modal;
In addition to the basic (inherited) modalloop, change
- the current maingroups cursors to the busy-stop cursor, show
+ the current active windowgroups cursors to the busy-stop cursor, show
a shadow, and raise the box."
- |g|
+ |mainGroup mainView useTransient|
+
+ useTransient := UseTransient.
+
+ "
+ show a stop-cursor in the current group
+ "
+ mainGroup := WindowGroup activeGroup.
+ mainGroup notNil ifTrue:[
+ mainGroup := mainGroup mainGroup.
+ mainGroup notNil ifTrue:[
+ mainGroup showCursor:(Cursor stop).
+ ]
+ ].
+
+ mainGroup isNil ifTrue:[
+ useTransient := false
+ ].
+
+ useTransient ifTrue:[
+ mainGroup topViews notNil ifTrue:[
+ mainView := mainGroup topViews first.
+ ].
+ mainView isNil ifTrue:[
+ useTransient := false.
+ ]
+ ].
- g := WindowGroup activeGroup.
- g notNil ifTrue:[
- g := g mainGroup.
- g notNil ifTrue:[
- g showCursor:(Cursor stop)
- ]
+ useTransient ifTrue:[
+ shadowView := nil.
+ ] ifFalse:[
+ shadowView notNil ifTrue:[shadowView realize].
].
- shadowView notNil ifTrue:[shadowView realize].
self raise.
+
haveControl := true.
- super openModal.
+ mainGroup notNil ifTrue:[
+ "
+ flush pending key & mouse events.
+ this avoids pre-characters
+ to be put into the view ...
+ "
+"/ mainGroup sensor flushUserEvents.
+ ].
+
+ useTransient ifTrue:[
+ device setTransient:drawableId for:(mainView id).
+ ].
+ super openModal:aBlock.
+ mainGroup notNil ifTrue:[
+ "
+ flush any key & mouse events which arrived
+ while the box was open (avoids stray input).
+ "
+ mainGroup sensor flushUserEvents.
+ ].
!
show
- "make myself visible (at the last position) and take control"
+ "make myself visible (at the last or default position) and take control"
self fixSize.
+ self makeFullyVisible.
self openModal
+
+ "
+ |b|
+
+ b := InfoBox title:'hello'.
+ b show.
+ "
!
showAt:aPoint
@@ -214,14 +271,90 @@
self fixSize.
self fixPosition:aPoint.
self openModal
+
+ "
+ |b|
+
+ b := InfoBox title:'hello'.
+ b showAt:(0 @ 0).
+ b showAt:(400 @ 400).
+ "
+!
+
+showAt:aPoint center:center
+ "make myself visible at aPoint. center specifies
+ if the view should show up centered around aPoint."
+
+ self showAt:aPoint centerX:center centerY:center
+
+ "
+ |b|
+
+ b := InfoBox title:'hello'.
+ b showAt:(100 @ 100) center:true.
+ b showAt:(100 @ 100) center:false.
+ "
+!
+
+showAt:aPoint centerX:centerX centerY:centerY
+ "make myself visible at aPoint. centerX/centerY specify
+ if the view should show up centered around aPoint.
+ Fix position to make box fully visible"
+
+ |dx dy|
+
+ self fixSize.
+ centerX ifTrue:[
+ dx := self width // 2.
+ ] ifFalse:[
+ dx := 0
+ ].
+ centerY ifTrue:[
+ dy := self height // 2.
+ ] ifFalse:[
+ dy := 0
+ ].
+ self origin:(aPoint - (dx @ dy)).
+ self makeFullyVisible.
+ self openModal
+
+ "
+ |b|
+
+ b := InfoBox title:'hello'.
+ b showAt:(100 @ 100).
+ b showAt:(100 @ 100) centerX:true centerY:false.
+ "
!
showAtCenter
"make myself visible at the screen center."
- self fixSize.
- self fixPosition:(device center - (self extent / 2)).
- self openModal
+ self showAt:(device center) center:true
+
+ "
+ |b|
+
+ b := InfoBox title:'hello'.
+ b showAtCenter.
+ "
+!
+
+showCenteredIn:aView
+ "make myself visible at the screen center."
+
+ |top|
+
+ top := aView topView.
+ top raise.
+ self showAt:(top center + (aView originRelativeTo:top)) center:true
+
+ "
+ |b|
+
+ b := InfoBox title:'hello'.
+ b showCenteredIn:Transcript.
+ "
!
showAtPointer
@@ -233,6 +366,13 @@
self fixSize.
self fixPosition:(device pointerPosition - self positionOffset).
self openModal
+
+ "
+ |b|
+
+ b := InfoBox title:'hello'.
+ b showAtPointer.
+ "
!
showAtPointerNotCovering:aView
@@ -246,30 +386,30 @@
pos := device pointerPosition - self positionOffset.
((Rectangle origin:pos extent:self extent)
- intersects: (aView origin corner: aView corner))
+ intersects: (aView origin corner: aView corner))
ifTrue:[
- "
- try to the right of the untouchable view
- "
- newX := (aView origin x + aView width).
- newX + width > device width ifTrue:[
- newX := device width - width
- ].
- pos x:newX.
+ "
+ try to the right of the untouchable view
+ "
+ newX := (aView origin x + aView width).
+ newX + width > device width ifTrue:[
+ newX := device width - width
+ ].
+ pos x:newX.
- ((Rectangle origin:pos extent:self extent)
- intersects: (aView origin corner: aView corner))
- ifTrue:[
- "
- try to the left of the untouchable view
- "
- newX := aView origin x - width.
- "
- should look for vertical possibilities too ...
- "
- pos x:newX.
- ]
+ ((Rectangle origin:pos extent:self extent)
+ intersects: (aView origin corner: aView corner))
+ ifTrue:[
+ "
+ try to the left of the untouchable view
+ "
+ newX := aView origin x - width.
+ "
+ should look for vertical possibilities too ...
+ "
+ pos x:newX.
+ ]
].
self showAt:pos
@@ -285,14 +425,16 @@
device synchronizeOutput.
(windowGroup notNil and:[(p := windowGroup previousGroup) notNil]) ifTrue:[
- "
- this is a kludge for IRIS which does not provide backingstore:
- when we hide a modalbox (such as a searchbox) which covered
- a scrollbar, the scrollbars bitblt-method will copy from the
- not-yet redrawn area - effectively clearing the scroller
- "
- (Delay forSeconds:0.1) wait.
- p processExposeEvents
+ "
+ this is a kludge for IRIS which does not provide backingstore:
+ when we hide a modalbox (such as a searchbox) which covered
+ a scrollbar, the scrollbars bitblt-method will copy from the
+ not-yet redrawn area - effectively clearing the scroller.
+ We need a short delay here, since at this sime, the expose event has
+ not yet arrived.
+ "
+ (Delay forSeconds:0.1) wait.
+ p processExposeEvents
].
self leaveControl.
!
@@ -300,14 +442,17 @@
autoHideAfter:seconds with:anAction
"install a background process, which hides the box
after some time. Also, if non-nil, anAction will be
- evaluated then."
+ evaluated then. The action will not be evaluated if
+ the box is closed by the user pressing a button."
+ "the implementation is simple: just fork of a process
+ to hide me."
[
- (Delay forSeconds:seconds) wait.
- self shown ifTrue:[
- self hide.
- anAction notNil ifTrue:[anAction value]
- ]
+ (Delay forSeconds:seconds) wait.
+ self shown ifTrue:[
+ self hide.
+ anAction notNil ifTrue:[anAction value]
+ ]
] forkAt:4.
"
@@ -321,6 +466,55 @@
!ModalBox methodsFor:'events'!
+visibilityChange:how
+ "raise when covered - this should not be needed, since we
+ have been created as override-redirect window (which should
+ stay on top - but some window managers (fvwm) seem to ignore
+ this ..."
+
+ "code below is not good, since it will lead to
+ oscillating raises when two modalBoxes are going to cover
+ each other - see coveredBy:-handling ..."
+
+"/ how ~~ #fullyVisible ifTrue:[
+"/ self raise
+"/ ]
+!
+
+coveredBy:aView
+ "the receiver has been covered by another view.
+ If the other view is a non-modal one, raise"
+
+ |mainGroup topViews|
+
+ "
+ if the other view is not a modal- (or shadow-, or popup-) -view,
+ bring myself to the front again.
+ "
+ aView createOnTop ifFalse:[
+ "
+ if I have a mainGroup,
+ only raise if its one of my maingroup-views
+ "
+ windowGroup notNil ifTrue:[
+ mainGroup := windowGroup mainGroup.
+ mainGroup notNil ifTrue:[
+ topViews := mainGroup topViews.
+ topViews notNil ifTrue:[
+ topViews do:[:aTopView |
+ aView == aTopView ifTrue:[
+ self raise.
+ ^ self
+ ]
+ ]
+ ].
+ ^ self
+ ]
+ ].
+ self raise
+ ]
+!
+
pointerEnter:state x:x y:y
"
mhmh: this seems to be a special X kludge;
@@ -337,13 +531,13 @@
|g|
windowGroup notNil ifTrue:[
- g := windowGroup mainGroup.
- g notNil ifTrue:[
- g restoreCursors
- ]
+ g := windowGroup mainGroup.
+ g notNil ifTrue:[
+ g restoreCursors
+ ]
].
haveControl := false.
exclusiveKeyboard ifTrue:[
- device ungrabKeyboard
+ device ungrabKeyboard
]
! !
--- a/PopUpView.st Mon Oct 10 03:30:48 1994 +0100
+++ b/PopUpView.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -19,9 +19,9 @@
PopUpView comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/PopUpView.st,v 1.7 1994-08-05 01:14:53 claus Exp $
+$Header: /cvs/stx/stx/libview/PopUpView.st,v 1.8 1994-10-10 02:32:53 claus Exp $
'!
Smalltalk at:#ActiveGrab put:nil!
@@ -31,7 +31,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -44,7 +44,7 @@
version
"
-$Header: /cvs/stx/stx/libview/PopUpView.st,v 1.7 1994-08-05 01:14:53 claus Exp $
+$Header: /cvs/stx/stx/libview/PopUpView.st,v 1.8 1994-10-10 02:32:53 claus Exp $
"
!
@@ -56,7 +56,7 @@
class variables:
- PopShadow <Boolean> if true, popupviews show a shadow
+ PopShadow <Boolean> if true, popupviews show a shadow
"
! !
@@ -71,7 +71,7 @@
initialize
super initialize.
Display notNil ifTrue:[
- PopShadow := self classResources name:'POPUP_SHADOW' default:false
+ PopShadow := self classResources name:'POPUP_SHADOW' default:false
]
! !
@@ -85,17 +85,14 @@
left := c x - (width // 2).
top := c y - (height // 2).
((style ~~ #normal) and:[style ~~ #mswindows]) ifTrue:[
- borderWidth := 0.
- self level:2
+ borderWidth := 0.
+ self level:2
] ifFalse:[
- borderWidth := 1
+ borderWidth := 1
].
- (resources name:'POPUP_SHADOW' default:false) ifTrue:[
- shadowView := (ShadowView on:device) for:self.
- device hasGreyscales ifTrue:[
- shadowView paint:(Color darkGrey)
- ]
+ (StyleSheet at:#popupShadow default:false) ifTrue:[
+ shadowView := (ShadowView on:device) for:self.
].
haveControl := false
!
@@ -109,7 +106,7 @@
create
super create.
shadowView isNil ifTrue:[
- self saveUnder:true
+ self saveUnder:true
]
! !
@@ -147,8 +144,8 @@
super mapped.
ActiveGrab notNil ifTrue:[
- device ungrabPointer.
- ActiveGrab := nil
+ device ungrabPointer.
+ ActiveGrab := nil
].
device grabPointerIn:drawableId.
ActiveGrab := self.
@@ -164,8 +161,8 @@
unrealize
haveControl := false.
ActiveGrab == self ifTrue:[
- device ungrabPointer.
- ActiveGrab := nil.
+ device ungrabPointer.
+ ActiveGrab := nil.
].
super unrealize.
shadowView notNil ifTrue:[shadowView unrealize].
--- a/PseudoV.st Mon Oct 10 03:30:48 1994 +0100
+++ b/PseudoV.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -12,11 +12,11 @@
DeviceDrawable subclass:#PseudoView
instanceVariableNames:'viewBackground
- cursor eventMask
- middleButtonMenu
- keyCommands
- gotExpose exposePending
- backed saveUnder delegate'
+ cursor eventMask
+ middleButtonMenu
+ keyCommands
+ gotExpose exposePending
+ backed saveUnder delegate'
classVariableNames:''
poolDictionaries:''
category:'Views-Basic'
@@ -24,9 +24,9 @@
PseudoView comment:'
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/Attic/PseudoV.st,v 1.16 1994-08-11 23:43:43 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/PseudoV.st,v 1.17 1994-10-10 02:32:55 claus Exp $
'!
!PseudoView class methodsFor:'documentation'!
@@ -34,7 +34,7 @@
copyright
"
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -47,7 +47,7 @@
version
"
-$Header: /cvs/stx/stx/libview/Attic/PseudoV.st,v 1.16 1994-08-11 23:43:43 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/PseudoV.st,v 1.17 1994-10-10 02:32:55 claus Exp $
"
!
@@ -64,28 +64,28 @@
instance variables:
- viewBackground <Color|Form|Image> the views background
+ viewBackground <Color|Form|Image> the views background
- cursor <Cursor> the cursor
+ cursor <Cursor> the cursor
- eventMask mask specifying the enabled
+ eventMask mask specifying the enabled
events.
- middleButtonMenu a popup menu for the middle
+ middleButtonMenu a popup menu for the middle
button.
- keyCommands not yet supported
+ keyCommands not yet supported
- gotExpose for exposure handling after
- exposePending after a scroll
+ gotExpose for exposure handling after
+ exposePending after a scroll
- backed true if backing store for that
+ backed true if backing store for that
view is enabled
- saveUnder true if saveunder store for
+ saveUnder true if saveunder store for
that view is enabled
- delegate for event delegation
+ delegate for event delegation
"
! !
@@ -125,7 +125,7 @@
"recreate (i.e. tell X about me) after a snapin"
viewBackground isColor ifTrue:[
- viewBackground := viewBackground on:device
+ viewBackground := viewBackground on:device
].
super recreate.
"/ viewBackground isColor ifTrue:[
@@ -141,17 +141,17 @@
then the view is physically destroyed."
middleButtonMenu notNil ifTrue:[
- middleButtonMenu destroy.
- middleButtonMenu := nil
+ middleButtonMenu destroy.
+ middleButtonMenu := nil
].
keyCommands := nil.
gcId notNil ifTrue:[
- device destroyGC:gcId.
- gcId := nil
+ device destroyGC:gcId.
+ gcId := nil
].
drawableId notNil ifTrue:[
- device destroyView:self withId:drawableId.
- drawableId := nil
+ device destroyView:self withId:drawableId.
+ drawableId := nil
]
!
@@ -159,9 +159,9 @@
"view has been destroyed by someone else"
drawableId notNil ifTrue:[
- device removeKnownView:self.
- drawableId := nil.
- realized := false.
+ device removeKnownView:self.
+ drawableId := nil.
+ realized := false.
].
self destroy
!
@@ -205,10 +205,10 @@
"set the viewBackground to something, a color, image or form"
viewBackground ~~ something ifTrue:[
- viewBackground := something.
- drawableId notNil ifTrue:[
- self setViewBackground
- ]
+ viewBackground := something.
+ drawableId notNil ifTrue:[
+ self setViewBackground
+ ]
]
!
@@ -218,83 +218,83 @@
|id devBgPixmap bgPixmap w h colors|
drawableId notNil ifTrue:[
- viewBackground isColor ifTrue:[
- viewBackground := viewBackground on:device.
- id := viewBackground colorId.
- "
- a real color (i.e. one supported by the device) ?
- "
- id notNil ifTrue:[
- device setWindowBackground:id in:drawableId.
- ^ self
- ].
- "
- no, a dithered one - must have a dither-pattern
- (which is ready for the device, since viewBackground
- is already assigned to the device)
- "
- bgPixmap := viewBackground ditherForm.
- ] ifFalse:[
- "
- assume, it can convert itself to a form
- "
- bgPixmap := viewBackground asFormOn:device
- ].
+ viewBackground isColor ifTrue:[
+ viewBackground := viewBackground on:device.
+ id := viewBackground colorId.
+ "
+ a real color (i.e. one supported by the device) ?
+ "
+ id notNil ifTrue:[
+ device setWindowBackground:id in:drawableId.
+ ^ self
+ ].
+ "
+ no, a dithered one - must have a dither-pattern
+ (which is ready for the device, since viewBackground
+ is already assigned to the device)
+ "
+ bgPixmap := viewBackground ditherForm.
+ ] ifFalse:[
+ "
+ assume, it can convert itself to a form
+ "
+ bgPixmap := viewBackground asFormOn:device
+ ].
- "
- must now have:
- a dithered color or bitmap or pixmap
- "
- bgPixmap isNil ifTrue:[
- 'background not convertable - ignored' errorPrintNewline.
- ^ self
- ].
+ "
+ must now have:
+ a dithered color or bitmap or pixmap
+ "
+ bgPixmap isNil ifTrue:[
+ 'background not convertable - ignored' errorPrintNewline.
+ ^ self
+ ].
- w := bgPixmap width.
- h := bgPixmap height.
+ w := bgPixmap width.
+ h := bgPixmap height.
- (bgPixmap depth ~~ device depth) ifTrue:[
- (bgPixmap depth ~~ 1) ifTrue:[
- self error:'bad dither depth'.
- ^ self
- ].
- "
- convert it into a deep form
- "
- colors := bgPixmap colorMap.
- devBgPixmap := Form width:w height:h depth:(device depth) on:device.
- devBgPixmap paint:(colors at:1).
- devBgPixmap fillRectangleX:0 y:0 width:w height:h.
- devBgPixmap foreground:(colors at:2) background:(colors at:1).
- devBgPixmap copyPlaneFrom:bgPixmap x:0 y:0 toX:0 y:0 width:w height:h.
- bgPixmap := devBgPixmap.
- ] ifFalse:[
- (bgPixmap depth == 1) ifTrue:[
- "
- although depth matches,
- values in the dither are to be interpreted via the ditherForms
- colormap, which is not always the same as blackpixel/whitepixel ...
- "
- (bgPixmap colorMap at:1) colorId == device whitepixel ifTrue:[
- (bgPixmap colorMap at:2) colorId == device blackpixel ifTrue:[
- "
- ok, can use it
- "
- device setWindowBackgroundPixmap:(bgPixmap id) in:drawableId.
- ^ self
- ]
- ].
+ (bgPixmap depth ~~ device depth) ifTrue:[
+ (bgPixmap depth ~~ 1) ifTrue:[
+ self error:'bad dither depth'.
+ ^ self
+ ].
+ "
+ convert it into a deep form
+ "
+ colors := bgPixmap colorMap.
+ devBgPixmap := Form width:w height:h depth:(device depth) on:device.
+ devBgPixmap paint:(colors at:1).
+ devBgPixmap fillRectangleX:0 y:0 width:w height:h.
+ devBgPixmap foreground:(colors at:2) background:(colors at:1).
+ devBgPixmap copyPlaneFrom:bgPixmap x:0 y:0 toX:0 y:0 width:w height:h.
+ bgPixmap := devBgPixmap.
+ ] ifFalse:[
+ (bgPixmap depth == 1) ifTrue:[
+ "
+ although depth matches,
+ values in the dither are to be interpreted via the ditherForms
+ colormap, which is not always the same as blackpixel/whitepixel ...
+ "
+ (bgPixmap colorMap at:1) colorId == device whitepixel ifTrue:[
+ (bgPixmap colorMap at:2) colorId == device blackpixel ifTrue:[
+ "
+ ok, can use it
+ "
+ device setWindowBackgroundPixmap:(bgPixmap id) in:drawableId.
+ ^ self
+ ]
+ ].
- "
- no, must invert it
- "
- devBgPixmap := Form width:w height:h depth:(device depth) on:device.
- devBgPixmap paint:(bgPixmap colorMap at:2) on:(bgPixmap colorMap at:1).
- devBgPixmap copyPlaneFrom:bgPixmap x:0 y:0 toX:0 y:0 width:w height:h.
- bgPixmap := devBgPixmap.
- ]
- ].
- device setWindowBackgroundPixmap:(bgPixmap id) in:drawableId.
+ "
+ no, must invert it
+ "
+ devBgPixmap := Form width:w height:h depth:(device depth) on:device.
+ devBgPixmap paint:(bgPixmap colorMap at:2) on:(bgPixmap colorMap at:1).
+ devBgPixmap copyPlaneFrom:bgPixmap x:0 y:0 toX:0 y:0 width:w height:h.
+ bgPixmap := devBgPixmap.
+ ]
+ ].
+ device setWindowBackgroundPixmap:(bgPixmap id) in:drawableId.
]
!
@@ -319,22 +319,22 @@
|id|
aCursor notNil ifTrue:[
- (aCursor ~~ cursor) ifTrue:[
- cursor := aCursor.
- drawableId notNil ifTrue:[
- cursor := cursor on:device.
- id := cursor id.
- id isNil ifTrue:[
- 'nil cursorId shape=' errorPrint. cursor shape errorPrintNewline.
- ^ self
- ].
- device setCursor:id in:drawableId.
- realized ifTrue:[
- "flush, to make cursor immediately visible"
- device synchronizeOutput
- ]
- ]
- ]
+ (aCursor ~~ cursor) ifTrue:[
+ cursor := aCursor.
+ drawableId notNil ifTrue:[
+ cursor := cursor on:device.
+ id := cursor id.
+ id isNil ifTrue:[
+ 'nil cursorId shape=' errorPrint. cursor shape errorPrintNewline.
+ ^ self
+ ].
+ device setCursor:id in:drawableId.
+ realized ifTrue:[
+ "flush, to make cursor immediately visible"
+ device synchronizeOutput
+ ]
+ ]
+ ]
]
!
@@ -345,8 +345,7 @@
savedCursor := cursor.
self cursor:aCursor.
- aBlock value.
- self cursor:savedCursor
+ aBlock valueNowOrOnUnwindDo:[self cursor:savedCursor]
! !
!PseudoView methodsFor:'accessing-hierarchy'!
@@ -537,7 +536,7 @@
"drawing shall be done into my view only (default)"
gcId isNil ifTrue:[
- self initGC
+ self initGC
].
device setClipByChildren:true in:gcId
!
@@ -546,7 +545,7 @@
"drawing shall also be done into subviews"
gcId isNil ifTrue:[
- self initGC
+ self initGC
].
device setClipByChildren:false in:gcId
!
@@ -557,7 +556,7 @@
saveUnder := aBoolean.
drawableId notNil ifTrue:[
- device setSaveUnder:aBoolean in:drawableId
+ device setSaveUnder:aBoolean in:drawableId
]
!
@@ -566,10 +565,10 @@
how may true/false, but also #always, #whenMapped or #never."
how ~~ backed ifTrue:[
- backed := how.
- drawableId notNil ifTrue:[
- device setBackingStore:how in:drawableId
- ]
+ backed := how.
+ drawableId notNil ifTrue:[
+ device setBackingStore:how in:drawableId
+ ]
]
!
@@ -597,43 +596,25 @@
^ self
!
-clear
- "clear window to viewBackground -
- redefined here since DisplayMedium clears with background
- - not viewBackground"
-
- viewBackground isColor ifFalse:[
- self setMaskOriginX:0 y:0
- ].
- self fillRectangleX:0 y:0
- width:width height:height
- with:viewBackground
-!
-
-clearRectangle:aRectangle
- "clear a rectangular area to viewBackground -
- redefined here since DisplayMedium clears with background
- - not viewBackground"
-
- viewBackground isColor ifFalse:[
- self setMaskOriginX:0 y:0
- ].
- self fillRectangleX:(aRectangle left)
- y:(aRectangle top)
- width:(aRectangle width)
- height:(aRectangle height)
- with:viewBackground
-!
-
clearRectangleX:x y:y width:w height:h
"clear a rectangular area to viewBackground -
redefined since DisplayMedium fills with background
- - not viewBackground"
+ - not viewBackground as we want here."
+
+ |oldPaint|
+
+ oldPaint := paint.
+ self paint:viewBackground.
viewBackground isColor ifFalse:[
- self setMaskOriginX:0 y:0
+"/ self setMaskOriginX:0 y:0
+ self setMaskOriginX:self viewOrigin x negated y:self viewOrigin y negated
].
- self fillRectangleX:x y:y width:w height:h with:viewBackground
+ "
+ fill in device coordinates - not logical coordinates
+ "
+ self fillDeviceRectangleX:x y:y width:w height:h "with:viewBackground".
+ self paint:oldPaint
! !
!PseudoView methodsFor:'keyboard commands'!
@@ -642,14 +623,14 @@
"define a keyboard command function"
keyCommands isNil ifTrue:[
- keyCommands := IdentityDictionary new
+ keyCommands := IdentityDictionary new
].
keyCommands at:aKey put:aBlock
!
removeActionForKey:aKey
keyCommands notNil ifTrue:[
- keyCommands removeKey:aKey ifAbsent:[]
+ keyCommands removeKey:aKey ifAbsent:[]
]
! !
@@ -665,7 +646,7 @@
"associate aMenu with the middle mouse button"
middleButtonMenu notNil ifTrue:[
- middleButtonMenu destroy
+ middleButtonMenu destroy
].
middleButtonMenu := aMenu.
self enableButtonEvents
@@ -688,7 +669,7 @@
eventMask := eventMask bitOr:(device eventMaskFor:anEventSymbol).
drawableId notNil ifTrue:[
- device setEventMask:eventMask in:drawableId
+ device setEventMask:eventMask in:drawableId
]
!
@@ -698,9 +679,9 @@
for a list of allowed event symbols see Workstation class"
eventMask := eventMask bitAnd:
- (device eventMaskFor:anEventSymbol) bitInvert.
+ (device eventMaskFor:anEventSymbol) bitInvert.
drawableId notNil ifTrue:[
- device setEventMask:eventMask in:drawableId
+ device setEventMask:eventMask in:drawableId
]
!
@@ -874,13 +855,13 @@
gotExpose := false.
wg := self windowGroup.
wg notNil ifTrue:[
- "
- must process eny pending expose events, since
- usually the origin is changed soon so that previous
- expose events coordinates are invalid
- "
- wg processExposeEvents.
- wg sensor catchExpose
+ "
+ must process eny pending expose events, since
+ usually the origin is changed soon so that previous
+ expose events coordinates are invalid
+ "
+ wg processExposeEvents.
+ wg sensor catchExpose
]
!
@@ -891,19 +872,19 @@
wg := self windowGroup.
wg notNil ifTrue:[
- "
- a normal (suspendable) view.
- wait by doing a real wait
- "
- wg waitForExposeFor:self
+ "
+ a normal (suspendable) view.
+ wait by doing a real wait
+ "
+ wg waitForExposeFor:self
] ifFalse:[
- "
- a pure event driven view.
- wait by doing a direct dispatch loop until the event arrives.
- "
- [gotExpose] whileFalse:[
- device dispatchExposeEventFor:drawableId
- ].
+ "
+ a pure event driven view.
+ wait by doing a direct dispatch loop until the event arrives.
+ "
+ [gotExpose] whileFalse:[
+ device dispatchExposeEventFor:drawableId
+ ].
]
!
@@ -934,10 +915,10 @@
|action|
keyCommands notNil ifTrue:[
- action := keyCommands at:key ifAbsent:[nil].
- action notNil ifTrue:[
- action value
- ]
+ action := keyCommands at:key ifAbsent:[nil].
+ action notNil ifTrue:[
+ action value
+ ]
]
!
@@ -958,9 +939,9 @@
show it."
((button == 2) or:[button == #menu]) ifTrue:[
- middleButtonMenu notNil ifTrue:[
- middleButtonMenu showAtPointer
- ]
+ middleButtonMenu notNil ifTrue:[
+ middleButtonMenu showAtPointer
+ ]
]
!
@@ -1022,7 +1003,7 @@
drawableId := nil.
self recreate.
realized ifTrue:[
- self rerealize
+ self rerealize
]
"
--- a/ResourcePack.st Mon Oct 10 03:30:48 1994 +0100
+++ b/ResourcePack.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,17 @@
"
Dictionary subclass:#ResourcePack
- instanceVariableNames:'elements dependents packsClassName'
- classVariableNames:'Packs'
- poolDictionaries:''
- category:'System-Support'
+ instanceVariableNames:'elements dependents packsClassName'
+ classVariableNames:'Packs'
+ poolDictionaries:''
+ category:'System-Support'
!
ResourcePack comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/ResourcePack.st,v 1.8 1994-08-05 01:14:58 claus Exp $
+$Header: /cvs/stx/stx/libview/ResourcePack.st,v 1.9 1994-10-10 02:33:00 claus Exp $
'!
!ResourcePack class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libview/ResourcePack.st,v 1.8 1994-08-05 01:14:58 claus Exp $
+$Header: /cvs/stx/stx/libview/ResourcePack.st,v 1.9 1994-10-10 02:33:00 claus Exp $
"
!
@@ -59,23 +59,23 @@
The resourcePack initializes itself from a file found in 'resources/<className>.rs',
where 'className' is built by the usual abbreviation mechanism (see abbrev-files).
Conditional mappings are possible, by including lines as:
- #if <expression>
- #endif
+ #if <expression>
+ #endif
in the resourcefile. Example:
file 'foo.rs':
- #if Language == #german
- 'abort' 'Abbruch'
- #endif
- #if Language == #french
- 'abort' 'canceller'
- #endif
+ #if Language == #german
+ 'abort' 'Abbruch'
+ #endif
+ #if Language == #french
+ 'abort' 'canceller'
+ #endif
the corresponding resource-strings are accessed using:
- resource string:'abort'
+ resource string:'abort'
returning the mapped string (i.e. 'Abbruch' if the global Language is set
to #german)..
If no corresponding entry is found in the resources, the key is returned.
Translations can also include arguments, such as:
- resources string:'really delete %1' with:fileName
+ resources string:'really delete %1' with:fileName
"
! !
@@ -83,19 +83,19 @@
initialize
Packs isNil ifTrue:[
- Packs := WeakArray new:30
+ Packs := WeakArray new:30
].
"ResourcePack initialize"
!
-flushResources
+flushCachedResourcePacks
"forget all cached resources - needed after a style change"
Packs := nil.
self initialize
- "ResourcePack flushResources"
+ "ResourcePack flushCachedResourcePacks"
! !
!ResourcePack class methodsFor:'private'!
@@ -105,11 +105,11 @@
idx := Packs identityIndexOf:nil.
idx == 0 ifTrue:[
- "
- throw away oldest
- "
- idx := Packs size.
- Packs replaceFrom:1 to:idx-1 with:Packs startingAt:2.
+ "
+ throw away oldest
+ "
+ idx := Packs size.
+ Packs replaceFrom:1 to:idx-1 with:Packs startingAt:2.
].
Packs at:idx put:aPack
!
@@ -118,25 +118,25 @@
|sz|
Packs isNil ifTrue:[
- self initialize.
- ^ nil
+ self initialize.
+ ^ nil
].
sz := Packs size.
1 to:sz do:[:idx |
- |aPack|
+ |aPack|
- aPack := Packs at:idx.
- aPack notNil ifTrue:[
- aPack packsClassName = aClassname ifTrue:[
- "
- bring to end for LRU
- "
- Packs replaceFrom:idx to:sz-1 with:Packs startingAt:idx+1.
- Packs at:sz put:aPack.
- ^ aPack
- ]
- ]
+ aPack := Packs at:idx.
+ aPack notNil ifTrue:[
+ aClassname = aPack packsClassName ifTrue:[
+ "
+ bring to end for LRU
+ "
+ Packs replaceFrom:idx to:sz-1 with:Packs startingAt:idx+1.
+ Packs at:sz put:aPack.
+ ^ aPack
+ ]
+ ]
].
^ nil
! !
@@ -147,20 +147,10 @@
"get the resource definitions from a file in a directory.
Uncached low-level entry."
- |inStream newPack|
+ |newPack|
newPack := self new.
- inStream := Smalltalk systemFileStreamFor:('resources/' , aFileName).
- inStream isNil ifTrue:[
- "
- an empty pack
- "
- ^ newPack
- ].
- newPack readFromResourceStream:inStream.
- inStream close.
-
- self addToCache:newPack.
+ newPack readFromFile:aFileName directory:dirName.
^ newPack
!
@@ -189,8 +179,8 @@
pack := self fromFile:(Smalltalk fileNameForClass:nm) , '.rs'.
aClass == Object ifFalse:[
- superPack := self for:(aClass superclass).
- pack := pack merge:superPack
+ superPack := self for:(aClass superclass).
+ pack := pack merge:superPack
].
pack packsClassName:nm.
self addToCache:pack.
@@ -201,9 +191,9 @@
merge:anotherPack
anotherPack keysAndValuesDo:[:key :value |
- (self includesKey:key) ifFalse:[
- self at:key put:value
- ]
+ (self includesKey:key) ifFalse:[
+ self at:key put:value
+ ]
]
! !
@@ -226,19 +216,19 @@
!
at:aKey
- ^ self at:aKey ifAbsent:[aKey]
+ ^ self at:aKey ifAbsent:aKey
!
at:aKey default:default
- ^ self at:aKey ifAbsent:[default]
+ ^ self at:aKey ifAbsent:default
!
name:aKey
- ^ self at:aKey ifAbsent:[aKey]
+ ^ self at:aKey ifAbsent:aKey
!
name:aKey default:default
- ^ self at:aKey ifAbsent:[default]
+ ^ self at:aKey ifAbsent:default
!
array:anArray
@@ -246,7 +236,7 @@
!
string:s
- ^ self at:s ifAbsent:[s]
+ ^ self at:s ifAbsent:s
!
string:s with:arg
@@ -265,84 +255,125 @@
stop := template size.
start := 1.
[start < stop] whileTrue:[
- idx := template indexOf:$% startingAt:start.
- idx == 0 ifTrue:[
- ^ expandedString , (template copyFrom:start to:stop)
- ].
- "found a %"
- expandedString := expandedString , (template copyFrom:start to:(idx - 1)).
- next := template at:(idx + 1).
- (next == $%) ifTrue:[
- expandedString := expandedString , '%'
- ] ifFalse:[
- expandedString := expandedString , (argArray at:(next digitValue)) printString
- ].
- start := idx + 2
+ idx := template indexOf:$% startingAt:start.
+ idx == 0 ifTrue:[
+ ^ expandedString , (template copyFrom:start to:stop)
+ ].
+ "found a %"
+ expandedString := expandedString , (template copyFrom:start to:(idx - 1)).
+ next := template at:(idx + 1).
+ (next == $%) ifTrue:[
+ expandedString := expandedString , '%'
+ ] ifFalse:[
+ expandedString := expandedString , (argArray at:(next digitValue)) printString
+ ].
+ start := idx + 2
].
^ expandedString
! !
!ResourcePack methodsFor:'file reading'!
-readFromResourceStream:inStream
- |lineString rest value ifLevel skipping l name first|
+readFromFile:fileName directory:dirName
+ |inStream|
+
+ inStream := Smalltalk systemFileStreamFor:(dirName , '/' , fileName).
+ inStream isNil ifTrue:[
+ "
+ an empty pack
+ "
+ ^ nil
+ ].
+ self readFromResourceStream:inStream in:dirName.
+ inStream close.
+!
+
+readFromResourceStream:inStream in:dirName
+ |lineString rest value ifLevel skipping l name first str macroName|
ifLevel := 0.
skipping := false.
[inStream atEnd] whileFalse:[
- lineString := inStream nextLine.
- (lineString notNil and:[lineString isEmpty not]) ifTrue:[
- first := lineString at:1.
- first == $; ifFalse:[
- first == $# ifTrue:[
- (lineString startsWith:'#if') ifTrue:[
- skipping ifFalse:[
- rest := lineString copyFrom:4.
- value := Compiler evaluate:rest.
- (value == #Error) ifTrue:[
- Transcript show:('error in resource:' , lineString).
- ].
- (value == false) ifTrue:[
- skipping := true
- ]
- ].
- ifLevel := ifLevel + 1
- ] ifFalse:[
- (lineString startsWith:'#endif') ifTrue:[
- ifLevel := ifLevel - 1.
- ifLevel == 0 ifTrue:[
- skipping := false
- ]
- ].
- ].
- ] ifFalse:[
- skipping ifFalse:[
- lineString := lineString withoutSeparators.
- name := nil.
- (lineString at:1) == $' ifTrue:[
- l := lineString indexOf:$' startingAt:2.
- l ~~ 0 ifTrue:[
- name := (lineString copyFrom:2 to:l-1).
- l := l + 1
- ]
- ] ifFalse:[
- l := lineString indexOfSeparatorStartingAt:1.
- l ~~ 0 ifTrue:[
- name := lineString copyFrom:1 to:l-1.
- ]
- ].
- name notNil ifTrue:[
- rest := lineString copyFrom:l.
- value := Compiler evaluate:rest.
- (value == #Error) ifTrue:[
- Transcript show:('error in resource:' , name).
- ].
- self at:name put:value.
- ]
- ]
- ]
- ]
- ]
+ lineString := inStream nextLine.
+ (lineString notNil and:[lineString isEmpty not]) ifTrue:[
+ first := lineString at:1.
+ first == $; ifFalse:[
+ first == $# ifTrue:[
+ lineString := (lineString copyFrom:2) withoutSpaces.
+
+ (lineString startsWith:'if') ifTrue:[
+ skipping ifFalse:[
+ rest := lineString copyFrom:3.
+ value := Compiler evaluate:rest.
+ (value == #Error) ifTrue:[
+ Transcript show:('error in resource:' , lineString).
+ ].
+ (value == false) ifTrue:[
+ skipping := true
+ ]
+ ].
+ ifLevel := ifLevel + 1
+ ] ifFalse:[
+ (lineString startsWith:'endif') ifTrue:[
+ ifLevel := ifLevel - 1.
+ ifLevel == 0 ifTrue:[
+ skipping := false
+ ]
+ ] ifFalse:[
+ (lineString startsWith:'else') ifTrue:[
+ skipping := skipping not
+ ] ifFalse:[
+ (lineString startsWith:'include') ifTrue:[
+ rest := lineString copyFrom:8.
+ value := Compiler evaluate:rest.
+ self readFromFile:value directory:dirName
+ ]
+ ]
+ ]
+ ].
+ ] ifFalse:[
+ skipping ifFalse:[
+ lineString := lineString withoutSeparators.
+ name := nil.
+ (lineString at:1) == $' ifTrue:[
+ str := ReadStream on:lineString.
+ name := String readFrom:str.
+ l := str position.
+
+"/ l := lineString indexOf:$' startingAt:2.
+"/ l ~~ 0 ifTrue:[
+"/ name := (lineString copyFrom:2 to:l-1).
+"/ l := l + 1
+"/ ]
+ ] ifFalse:[
+ l := lineString indexOfSeparatorStartingAt:1.
+ l ~~ 0 ifTrue:[
+ name := lineString copyFrom:1 to:l-1.
+ ]
+ ].
+ name notNil ifTrue:[
+ rest := (lineString copyFrom:l) withoutSeparators.
+ (rest startsWith:'=') ifTrue:[
+ rest := rest copyFrom:2.
+ str := ReadStream on:rest.
+ macroName := str nextWord.
+ rest := str upToEnd.
+ value := self at:macroName.
+ value := Compiler evaluate:('self ' , rest)
+ receiver:value
+ notifying:nil.
+ ] ifFalse:[
+ value := Compiler evaluate:rest.
+ (value == #Error) ifTrue:[
+ Transcript show:('error in resource:' , name).
+ ]
+ ].
+ self at:name put:value.
+ ]
+ ]
+ ]
+ ]
+ ]
].
! !
--- a/RsrcPack.st Mon Oct 10 03:30:48 1994 +0100
+++ b/RsrcPack.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,17 @@
"
Dictionary subclass:#ResourcePack
- instanceVariableNames:'elements dependents packsClassName'
- classVariableNames:'Packs'
- poolDictionaries:''
- category:'System-Support'
+ instanceVariableNames:'elements dependents packsClassName'
+ classVariableNames:'Packs'
+ poolDictionaries:''
+ category:'System-Support'
!
ResourcePack comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/Attic/RsrcPack.st,v 1.8 1994-08-05 01:14:58 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/RsrcPack.st,v 1.9 1994-10-10 02:33:00 claus Exp $
'!
!ResourcePack class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libview/Attic/RsrcPack.st,v 1.8 1994-08-05 01:14:58 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/RsrcPack.st,v 1.9 1994-10-10 02:33:00 claus Exp $
"
!
@@ -59,23 +59,23 @@
The resourcePack initializes itself from a file found in 'resources/<className>.rs',
where 'className' is built by the usual abbreviation mechanism (see abbrev-files).
Conditional mappings are possible, by including lines as:
- #if <expression>
- #endif
+ #if <expression>
+ #endif
in the resourcefile. Example:
file 'foo.rs':
- #if Language == #german
- 'abort' 'Abbruch'
- #endif
- #if Language == #french
- 'abort' 'canceller'
- #endif
+ #if Language == #german
+ 'abort' 'Abbruch'
+ #endif
+ #if Language == #french
+ 'abort' 'canceller'
+ #endif
the corresponding resource-strings are accessed using:
- resource string:'abort'
+ resource string:'abort'
returning the mapped string (i.e. 'Abbruch' if the global Language is set
to #german)..
If no corresponding entry is found in the resources, the key is returned.
Translations can also include arguments, such as:
- resources string:'really delete %1' with:fileName
+ resources string:'really delete %1' with:fileName
"
! !
@@ -83,19 +83,19 @@
initialize
Packs isNil ifTrue:[
- Packs := WeakArray new:30
+ Packs := WeakArray new:30
].
"ResourcePack initialize"
!
-flushResources
+flushCachedResourcePacks
"forget all cached resources - needed after a style change"
Packs := nil.
self initialize
- "ResourcePack flushResources"
+ "ResourcePack flushCachedResourcePacks"
! !
!ResourcePack class methodsFor:'private'!
@@ -105,11 +105,11 @@
idx := Packs identityIndexOf:nil.
idx == 0 ifTrue:[
- "
- throw away oldest
- "
- idx := Packs size.
- Packs replaceFrom:1 to:idx-1 with:Packs startingAt:2.
+ "
+ throw away oldest
+ "
+ idx := Packs size.
+ Packs replaceFrom:1 to:idx-1 with:Packs startingAt:2.
].
Packs at:idx put:aPack
!
@@ -118,25 +118,25 @@
|sz|
Packs isNil ifTrue:[
- self initialize.
- ^ nil
+ self initialize.
+ ^ nil
].
sz := Packs size.
1 to:sz do:[:idx |
- |aPack|
+ |aPack|
- aPack := Packs at:idx.
- aPack notNil ifTrue:[
- aPack packsClassName = aClassname ifTrue:[
- "
- bring to end for LRU
- "
- Packs replaceFrom:idx to:sz-1 with:Packs startingAt:idx+1.
- Packs at:sz put:aPack.
- ^ aPack
- ]
- ]
+ aPack := Packs at:idx.
+ aPack notNil ifTrue:[
+ aClassname = aPack packsClassName ifTrue:[
+ "
+ bring to end for LRU
+ "
+ Packs replaceFrom:idx to:sz-1 with:Packs startingAt:idx+1.
+ Packs at:sz put:aPack.
+ ^ aPack
+ ]
+ ]
].
^ nil
! !
@@ -147,20 +147,10 @@
"get the resource definitions from a file in a directory.
Uncached low-level entry."
- |inStream newPack|
+ |newPack|
newPack := self new.
- inStream := Smalltalk systemFileStreamFor:('resources/' , aFileName).
- inStream isNil ifTrue:[
- "
- an empty pack
- "
- ^ newPack
- ].
- newPack readFromResourceStream:inStream.
- inStream close.
-
- self addToCache:newPack.
+ newPack readFromFile:aFileName directory:dirName.
^ newPack
!
@@ -189,8 +179,8 @@
pack := self fromFile:(Smalltalk fileNameForClass:nm) , '.rs'.
aClass == Object ifFalse:[
- superPack := self for:(aClass superclass).
- pack := pack merge:superPack
+ superPack := self for:(aClass superclass).
+ pack := pack merge:superPack
].
pack packsClassName:nm.
self addToCache:pack.
@@ -201,9 +191,9 @@
merge:anotherPack
anotherPack keysAndValuesDo:[:key :value |
- (self includesKey:key) ifFalse:[
- self at:key put:value
- ]
+ (self includesKey:key) ifFalse:[
+ self at:key put:value
+ ]
]
! !
@@ -226,19 +216,19 @@
!
at:aKey
- ^ self at:aKey ifAbsent:[aKey]
+ ^ self at:aKey ifAbsent:aKey
!
at:aKey default:default
- ^ self at:aKey ifAbsent:[default]
+ ^ self at:aKey ifAbsent:default
!
name:aKey
- ^ self at:aKey ifAbsent:[aKey]
+ ^ self at:aKey ifAbsent:aKey
!
name:aKey default:default
- ^ self at:aKey ifAbsent:[default]
+ ^ self at:aKey ifAbsent:default
!
array:anArray
@@ -246,7 +236,7 @@
!
string:s
- ^ self at:s ifAbsent:[s]
+ ^ self at:s ifAbsent:s
!
string:s with:arg
@@ -265,84 +255,125 @@
stop := template size.
start := 1.
[start < stop] whileTrue:[
- idx := template indexOf:$% startingAt:start.
- idx == 0 ifTrue:[
- ^ expandedString , (template copyFrom:start to:stop)
- ].
- "found a %"
- expandedString := expandedString , (template copyFrom:start to:(idx - 1)).
- next := template at:(idx + 1).
- (next == $%) ifTrue:[
- expandedString := expandedString , '%'
- ] ifFalse:[
- expandedString := expandedString , (argArray at:(next digitValue)) printString
- ].
- start := idx + 2
+ idx := template indexOf:$% startingAt:start.
+ idx == 0 ifTrue:[
+ ^ expandedString , (template copyFrom:start to:stop)
+ ].
+ "found a %"
+ expandedString := expandedString , (template copyFrom:start to:(idx - 1)).
+ next := template at:(idx + 1).
+ (next == $%) ifTrue:[
+ expandedString := expandedString , '%'
+ ] ifFalse:[
+ expandedString := expandedString , (argArray at:(next digitValue)) printString
+ ].
+ start := idx + 2
].
^ expandedString
! !
!ResourcePack methodsFor:'file reading'!
-readFromResourceStream:inStream
- |lineString rest value ifLevel skipping l name first|
+readFromFile:fileName directory:dirName
+ |inStream|
+
+ inStream := Smalltalk systemFileStreamFor:(dirName , '/' , fileName).
+ inStream isNil ifTrue:[
+ "
+ an empty pack
+ "
+ ^ nil
+ ].
+ self readFromResourceStream:inStream in:dirName.
+ inStream close.
+!
+
+readFromResourceStream:inStream in:dirName
+ |lineString rest value ifLevel skipping l name first str macroName|
ifLevel := 0.
skipping := false.
[inStream atEnd] whileFalse:[
- lineString := inStream nextLine.
- (lineString notNil and:[lineString isEmpty not]) ifTrue:[
- first := lineString at:1.
- first == $; ifFalse:[
- first == $# ifTrue:[
- (lineString startsWith:'#if') ifTrue:[
- skipping ifFalse:[
- rest := lineString copyFrom:4.
- value := Compiler evaluate:rest.
- (value == #Error) ifTrue:[
- Transcript show:('error in resource:' , lineString).
- ].
- (value == false) ifTrue:[
- skipping := true
- ]
- ].
- ifLevel := ifLevel + 1
- ] ifFalse:[
- (lineString startsWith:'#endif') ifTrue:[
- ifLevel := ifLevel - 1.
- ifLevel == 0 ifTrue:[
- skipping := false
- ]
- ].
- ].
- ] ifFalse:[
- skipping ifFalse:[
- lineString := lineString withoutSeparators.
- name := nil.
- (lineString at:1) == $' ifTrue:[
- l := lineString indexOf:$' startingAt:2.
- l ~~ 0 ifTrue:[
- name := (lineString copyFrom:2 to:l-1).
- l := l + 1
- ]
- ] ifFalse:[
- l := lineString indexOfSeparatorStartingAt:1.
- l ~~ 0 ifTrue:[
- name := lineString copyFrom:1 to:l-1.
- ]
- ].
- name notNil ifTrue:[
- rest := lineString copyFrom:l.
- value := Compiler evaluate:rest.
- (value == #Error) ifTrue:[
- Transcript show:('error in resource:' , name).
- ].
- self at:name put:value.
- ]
- ]
- ]
- ]
- ]
+ lineString := inStream nextLine.
+ (lineString notNil and:[lineString isEmpty not]) ifTrue:[
+ first := lineString at:1.
+ first == $; ifFalse:[
+ first == $# ifTrue:[
+ lineString := (lineString copyFrom:2) withoutSpaces.
+
+ (lineString startsWith:'if') ifTrue:[
+ skipping ifFalse:[
+ rest := lineString copyFrom:3.
+ value := Compiler evaluate:rest.
+ (value == #Error) ifTrue:[
+ Transcript show:('error in resource:' , lineString).
+ ].
+ (value == false) ifTrue:[
+ skipping := true
+ ]
+ ].
+ ifLevel := ifLevel + 1
+ ] ifFalse:[
+ (lineString startsWith:'endif') ifTrue:[
+ ifLevel := ifLevel - 1.
+ ifLevel == 0 ifTrue:[
+ skipping := false
+ ]
+ ] ifFalse:[
+ (lineString startsWith:'else') ifTrue:[
+ skipping := skipping not
+ ] ifFalse:[
+ (lineString startsWith:'include') ifTrue:[
+ rest := lineString copyFrom:8.
+ value := Compiler evaluate:rest.
+ self readFromFile:value directory:dirName
+ ]
+ ]
+ ]
+ ].
+ ] ifFalse:[
+ skipping ifFalse:[
+ lineString := lineString withoutSeparators.
+ name := nil.
+ (lineString at:1) == $' ifTrue:[
+ str := ReadStream on:lineString.
+ name := String readFrom:str.
+ l := str position.
+
+"/ l := lineString indexOf:$' startingAt:2.
+"/ l ~~ 0 ifTrue:[
+"/ name := (lineString copyFrom:2 to:l-1).
+"/ l := l + 1
+"/ ]
+ ] ifFalse:[
+ l := lineString indexOfSeparatorStartingAt:1.
+ l ~~ 0 ifTrue:[
+ name := lineString copyFrom:1 to:l-1.
+ ]
+ ].
+ name notNil ifTrue:[
+ rest := (lineString copyFrom:l) withoutSeparators.
+ (rest startsWith:'=') ifTrue:[
+ rest := rest copyFrom:2.
+ str := ReadStream on:rest.
+ macroName := str nextWord.
+ rest := str upToEnd.
+ value := self at:macroName.
+ value := Compiler evaluate:('self ' , rest)
+ receiver:value
+ notifying:nil.
+ ] ifFalse:[
+ value := Compiler evaluate:rest.
+ (value == #Error) ifTrue:[
+ Transcript show:('error in resource:' , name).
+ ]
+ ].
+ self at:name put:value.
+ ]
+ ]
+ ]
+ ]
+ ]
].
! !
--- a/ShadowV.st Mon Oct 10 03:30:48 1994 +0100
+++ b/ShadowV.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,7 +11,7 @@
"
View subclass:#ShadowView
- instanceVariableNames:'myView shadowLength shadow imageUnderShadow'
+ instanceVariableNames:'myView shadowLength shadowClr imageUnderShadow'
classVariableNames:''
poolDictionaries:''
category:'Views-Basic'
@@ -19,9 +19,9 @@
ShadowView comment:'
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/Attic/ShadowV.st,v 1.7 1994-08-05 01:15:02 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/ShadowV.st,v 1.8 1994-10-10 02:33:07 claus Exp $
'!
!ShadowView class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,31 +42,29 @@
version
"
-$Header: /cvs/stx/stx/libview/Attic/ShadowV.st,v 1.7 1994-08-05 01:15:02 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/ShadowV.st,v 1.8 1994-10-10 02:33:07 claus Exp $
"
!
documentation
"
just to give PopUps and ModalBoxes a shadow.
- A ShadowView gets the screen-contents under itself before, and
- uses a greyed version of these for its background.
- The instance variable myView is the view, the shadow is for.
+ If shadowClr is nil, the shadowView reads the screen-contents under
+ itself before realization, and uses a greyed version of these pixels
+ for its background. If shadowClr is non-nil, that color is used
+ as shadow (can be used for solid-black shadows).
+
+ The instance variable myView is the view, for which the shadow is for.
"
! !
-!ShadowView class methodsFor:'defaults'!
-
-solidShadow
- ^ false
-! !
-
!ShadowView methodsFor:'initialization'!
initialize
super initialize.
borderWidth := 0.
- shadow := Black.
+
+ shadowClr := StyleSheet at:#shadowColor.
"the length of the shadow from myView"
shadowLength := (device pixelPerMillimeter * 1.0) rounded
@@ -76,70 +74,72 @@
"realize the shadowView some distance away from myView,
get the pixels under the shadow from the screen"
- |root shW shH right bot kludge|
+ |root shW shH right bot kludge clr1 clr0 org blackIs0|
myView notNil ifTrue:[
- self origin:(myView origin + (myView borderWidth * 2) + shadowLength)
- extent:(myView extent).
+ self origin:(myView origin + (myView borderWidth * 2) + shadowLength)
+ extent:(myView extent).
- self class solidShadow ifFalse:[
- "
- get the pixels under the shadow
- (copy from root-view into the 'imageUnderShadow'-form)
- "
- imageUnderShadow := Form width:width height:height depth:device depth on:device.
- imageUnderShadow initGC.
- device setClipByChildren:false in:imageUnderShadow gcId.
+ shadowClr isNil ifTrue:[
+ "
+ get the pixels under the shadow
+ (copy from root-view into the 'imageUnderShadow'-form)
+ "
+ imageUnderShadow := Form width:width height:height depth:device depth on:device.
+ imageUnderShadow initGC.
+ device setClipByChildren:false in:imageUnderShadow gcId.
- shW := shadowLength x.
- shH := shadowLength y.
- right := width - shW.
- bot := height - shH.
+ shW := shadowLength x.
+ shH := shadowLength y.
+ right := width - shW.
+ bot := height - shH.
- root := DisplayRootView new.
+ root := DisplayRootView new.
- kludge := root device depth == 1.
- (kludge and:[root device blackpixel == 0]) ifTrue:[
- imageUnderShadow foreground:(Color colorId:0)
- background:(Color colorId:1).
- ].
+ clr0 := Color colorId:0.
+ clr1 := Color colorId:1.
- imageUnderShadow copyFrom:root x:(self origin x + right) y:(self origin y)
- toX:right y:0 width:shW height:height.
+ kludge := root device depth == 1.
+ blackIs0 := (root device blackpixel == 0).
+ (kludge and:[blackIs0]) ifTrue:[
+ imageUnderShadow foreground:clr0 background:clr1.
+ ].
- imageUnderShadow copyFrom:root x:(self origin x) y:(self origin y + bot)
- toX:0 y:bot width:width height:shH.
+ org := self origin.
- "
- grey out the image (by oring-in a grey pattern)
- (sometimes we are lucky, and can do it with one raster-op)
- "
- (kludge and:[root device blackpixel == 0]) ifFalse:[
- imageUnderShadow foreground:(Color colorId:0) background:(Color colorId:-1).
- imageUnderShadow mask:(Form mediumGreyFormOn:device).
- imageUnderShadow function:#and.
-"/ imageUnderShadow fillRectangleX:0 y:0 width:width height:height.
- imageUnderShadow fillRectangleX:right y:0 width:shW height:height.
- imageUnderShadow fillRectangleX:0 y:bot width:width height:shH.
+ imageUnderShadow copyFrom:root x:(org x + right) y:org y
+ toX:right y:0 width:shW height:height.
+
+ imageUnderShadow copyFrom:root x:org x y:(org y + bot)
+ toX:0 y:bot width:width height:shH.
+
+ "
+ grey out the image (by oring-in a grey pattern)
+ (sometimes we are lucky, and can do it with one raster-op)
+ "
+ (kludge and:[blackIs0]) ifFalse:[
+ imageUnderShadow foreground:clr0 background:(Color colorId:-1).
+ imageUnderShadow mask:(Form mediumGreyFormOn:device).
+ imageUnderShadow function:#and.
+ imageUnderShadow fillRectangleX:right y:0 width:shW height:height.
+ imageUnderShadow fillRectangleX:0 y:bot width:width height:shH.
- (Color black on:device) colorId == 0 ifFalse:[
- imageUnderShadow foreground:(Color black on:device) background:(Color colorId:0).
- imageUnderShadow function:#or.
-"/ imageUnderShadow fillRectangleX:0 y:0 width:width height:height.
- imageUnderShadow fillRectangleX:right y:0 width:shW height:height.
- imageUnderShadow fillRectangleX:0 y:bot width:width height:shH.
- ]
- ] ifTrue:[
- imageUnderShadow foreground:(Color colorId:1) background:(Color colorId:0).
- imageUnderShadow mask:(Form mediumGreyFormOn:device).
- imageUnderShadow function:#or.
-"/ imageUnderShadow fillRectangleX:0 y:0 width:width height:height.
- imageUnderShadow fillRectangleX:right y:0 width:shW height:height.
- imageUnderShadow fillRectangleX:0 y:bot width:width height:shH.
- ].
- ].
- super realize.
- self raise
+ blackIs0 ifFalse:[
+ imageUnderShadow foreground:(Color black on:device) background:clr0.
+ imageUnderShadow function:#or.
+ imageUnderShadow fillRectangleX:right y:0 width:shW height:height.
+ imageUnderShadow fillRectangleX:0 y:bot width:width height:shH.
+ ]
+ ] ifTrue:[
+ imageUnderShadow foreground:clr1 background:clr0.
+ imageUnderShadow mask:(Form mediumGreyFormOn:device).
+ imageUnderShadow function:#or.
+ imageUnderShadow fillRectangleX:right y:0 width:shW height:height.
+ imageUnderShadow fillRectangleX:0 y:bot width:width height:shH.
+ ].
+ ].
+ super realize.
+ self raise
]
!
@@ -155,7 +155,9 @@
!
recreate
- shadow := Black.
+ shadowClr notNil ifTrue:[
+ shadowClr := shadowClr on:device
+ ].
"the length of the shadow from myView"
shadowLength := (device pixelPerMillimeter * 1.0) rounded.
@@ -170,21 +172,27 @@
redraw
"fill all of myself with black"
- self class solidShadow ifFalse:[
- imageUnderShadow isNil ifTrue:[^ self].
+ |ws hs|
+
+ shadowClr isNil ifTrue:[
+ imageUnderShadow isNil ifTrue:[^ self].
"
- self foreground:(Color colorId:-1) background:(Color colorId:0).
- self function:#copy.
+ self foreground:(Color colorId:-1) background:(Color colorId:0).
+ self function:#copy.
"
- self copyFrom:imageUnderShadow x:(width - shadowLength x) y:0
- toX:(width - shadowLength x) y:0 width:shadowLength x height:height.
- self copyFrom:imageUnderShadow x:0 y:(height - shadowLength y)
- toX:0 y:(height - shadowLength y) width:width height:shadowLength y.
+ ws := shadowLength x.
+ hs := shadowLength y.
+ self copyFrom:imageUnderShadow x:(width - ws) y:0
+ toX:(width - ws) y:0
+ width:ws height:height.
+ self copyFrom:imageUnderShadow x:0 y:(height - hs)
+ toX:0 y:(height - hs)
+ width:width height:hs.
- ] ifTrue:[
- self paint:shadow.
- self fillRectangleX:0 y:0 width:width height:height
+ ] ifFalse:[
+ self paint:shadowClr.
+ self fillRectangleX:(width - ws) y:0 width:ws height:height
]
! !
@@ -193,7 +201,7 @@
shadowColor:aColor
"to set the shadow color"
- shadow := aColor
+ shadowClr := aColor
!
for:aView
--- a/ShadowView.st Mon Oct 10 03:30:48 1994 +0100
+++ b/ShadowView.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,7 +11,7 @@
"
View subclass:#ShadowView
- instanceVariableNames:'myView shadowLength shadow imageUnderShadow'
+ instanceVariableNames:'myView shadowLength shadowClr imageUnderShadow'
classVariableNames:''
poolDictionaries:''
category:'Views-Basic'
@@ -19,9 +19,9 @@
ShadowView comment:'
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/ShadowView.st,v 1.7 1994-08-05 01:15:02 claus Exp $
+$Header: /cvs/stx/stx/libview/ShadowView.st,v 1.8 1994-10-10 02:33:07 claus Exp $
'!
!ShadowView class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1991 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,31 +42,29 @@
version
"
-$Header: /cvs/stx/stx/libview/ShadowView.st,v 1.7 1994-08-05 01:15:02 claus Exp $
+$Header: /cvs/stx/stx/libview/ShadowView.st,v 1.8 1994-10-10 02:33:07 claus Exp $
"
!
documentation
"
just to give PopUps and ModalBoxes a shadow.
- A ShadowView gets the screen-contents under itself before, and
- uses a greyed version of these for its background.
- The instance variable myView is the view, the shadow is for.
+ If shadowClr is nil, the shadowView reads the screen-contents under
+ itself before realization, and uses a greyed version of these pixels
+ for its background. If shadowClr is non-nil, that color is used
+ as shadow (can be used for solid-black shadows).
+
+ The instance variable myView is the view, for which the shadow is for.
"
! !
-!ShadowView class methodsFor:'defaults'!
-
-solidShadow
- ^ false
-! !
-
!ShadowView methodsFor:'initialization'!
initialize
super initialize.
borderWidth := 0.
- shadow := Black.
+
+ shadowClr := StyleSheet at:#shadowColor.
"the length of the shadow from myView"
shadowLength := (device pixelPerMillimeter * 1.0) rounded
@@ -76,70 +74,72 @@
"realize the shadowView some distance away from myView,
get the pixels under the shadow from the screen"
- |root shW shH right bot kludge|
+ |root shW shH right bot kludge clr1 clr0 org blackIs0|
myView notNil ifTrue:[
- self origin:(myView origin + (myView borderWidth * 2) + shadowLength)
- extent:(myView extent).
+ self origin:(myView origin + (myView borderWidth * 2) + shadowLength)
+ extent:(myView extent).
- self class solidShadow ifFalse:[
- "
- get the pixels under the shadow
- (copy from root-view into the 'imageUnderShadow'-form)
- "
- imageUnderShadow := Form width:width height:height depth:device depth on:device.
- imageUnderShadow initGC.
- device setClipByChildren:false in:imageUnderShadow gcId.
+ shadowClr isNil ifTrue:[
+ "
+ get the pixels under the shadow
+ (copy from root-view into the 'imageUnderShadow'-form)
+ "
+ imageUnderShadow := Form width:width height:height depth:device depth on:device.
+ imageUnderShadow initGC.
+ device setClipByChildren:false in:imageUnderShadow gcId.
- shW := shadowLength x.
- shH := shadowLength y.
- right := width - shW.
- bot := height - shH.
+ shW := shadowLength x.
+ shH := shadowLength y.
+ right := width - shW.
+ bot := height - shH.
- root := DisplayRootView new.
+ root := DisplayRootView new.
- kludge := root device depth == 1.
- (kludge and:[root device blackpixel == 0]) ifTrue:[
- imageUnderShadow foreground:(Color colorId:0)
- background:(Color colorId:1).
- ].
+ clr0 := Color colorId:0.
+ clr1 := Color colorId:1.
- imageUnderShadow copyFrom:root x:(self origin x + right) y:(self origin y)
- toX:right y:0 width:shW height:height.
+ kludge := root device depth == 1.
+ blackIs0 := (root device blackpixel == 0).
+ (kludge and:[blackIs0]) ifTrue:[
+ imageUnderShadow foreground:clr0 background:clr1.
+ ].
- imageUnderShadow copyFrom:root x:(self origin x) y:(self origin y + bot)
- toX:0 y:bot width:width height:shH.
+ org := self origin.
- "
- grey out the image (by oring-in a grey pattern)
- (sometimes we are lucky, and can do it with one raster-op)
- "
- (kludge and:[root device blackpixel == 0]) ifFalse:[
- imageUnderShadow foreground:(Color colorId:0) background:(Color colorId:-1).
- imageUnderShadow mask:(Form mediumGreyFormOn:device).
- imageUnderShadow function:#and.
-"/ imageUnderShadow fillRectangleX:0 y:0 width:width height:height.
- imageUnderShadow fillRectangleX:right y:0 width:shW height:height.
- imageUnderShadow fillRectangleX:0 y:bot width:width height:shH.
+ imageUnderShadow copyFrom:root x:(org x + right) y:org y
+ toX:right y:0 width:shW height:height.
+
+ imageUnderShadow copyFrom:root x:org x y:(org y + bot)
+ toX:0 y:bot width:width height:shH.
+
+ "
+ grey out the image (by oring-in a grey pattern)
+ (sometimes we are lucky, and can do it with one raster-op)
+ "
+ (kludge and:[blackIs0]) ifFalse:[
+ imageUnderShadow foreground:clr0 background:(Color colorId:-1).
+ imageUnderShadow mask:(Form mediumGreyFormOn:device).
+ imageUnderShadow function:#and.
+ imageUnderShadow fillRectangleX:right y:0 width:shW height:height.
+ imageUnderShadow fillRectangleX:0 y:bot width:width height:shH.
- (Color black on:device) colorId == 0 ifFalse:[
- imageUnderShadow foreground:(Color black on:device) background:(Color colorId:0).
- imageUnderShadow function:#or.
-"/ imageUnderShadow fillRectangleX:0 y:0 width:width height:height.
- imageUnderShadow fillRectangleX:right y:0 width:shW height:height.
- imageUnderShadow fillRectangleX:0 y:bot width:width height:shH.
- ]
- ] ifTrue:[
- imageUnderShadow foreground:(Color colorId:1) background:(Color colorId:0).
- imageUnderShadow mask:(Form mediumGreyFormOn:device).
- imageUnderShadow function:#or.
-"/ imageUnderShadow fillRectangleX:0 y:0 width:width height:height.
- imageUnderShadow fillRectangleX:right y:0 width:shW height:height.
- imageUnderShadow fillRectangleX:0 y:bot width:width height:shH.
- ].
- ].
- super realize.
- self raise
+ blackIs0 ifFalse:[
+ imageUnderShadow foreground:(Color black on:device) background:clr0.
+ imageUnderShadow function:#or.
+ imageUnderShadow fillRectangleX:right y:0 width:shW height:height.
+ imageUnderShadow fillRectangleX:0 y:bot width:width height:shH.
+ ]
+ ] ifTrue:[
+ imageUnderShadow foreground:clr1 background:clr0.
+ imageUnderShadow mask:(Form mediumGreyFormOn:device).
+ imageUnderShadow function:#or.
+ imageUnderShadow fillRectangleX:right y:0 width:shW height:height.
+ imageUnderShadow fillRectangleX:0 y:bot width:width height:shH.
+ ].
+ ].
+ super realize.
+ self raise
]
!
@@ -155,7 +155,9 @@
!
recreate
- shadow := Black.
+ shadowClr notNil ifTrue:[
+ shadowClr := shadowClr on:device
+ ].
"the length of the shadow from myView"
shadowLength := (device pixelPerMillimeter * 1.0) rounded.
@@ -170,21 +172,27 @@
redraw
"fill all of myself with black"
- self class solidShadow ifFalse:[
- imageUnderShadow isNil ifTrue:[^ self].
+ |ws hs|
+
+ shadowClr isNil ifTrue:[
+ imageUnderShadow isNil ifTrue:[^ self].
"
- self foreground:(Color colorId:-1) background:(Color colorId:0).
- self function:#copy.
+ self foreground:(Color colorId:-1) background:(Color colorId:0).
+ self function:#copy.
"
- self copyFrom:imageUnderShadow x:(width - shadowLength x) y:0
- toX:(width - shadowLength x) y:0 width:shadowLength x height:height.
- self copyFrom:imageUnderShadow x:0 y:(height - shadowLength y)
- toX:0 y:(height - shadowLength y) width:width height:shadowLength y.
+ ws := shadowLength x.
+ hs := shadowLength y.
+ self copyFrom:imageUnderShadow x:(width - ws) y:0
+ toX:(width - ws) y:0
+ width:ws height:height.
+ self copyFrom:imageUnderShadow x:0 y:(height - hs)
+ toX:0 y:(height - hs)
+ width:width height:hs.
- ] ifTrue:[
- self paint:shadow.
- self fillRectangleX:0 y:0 width:width height:height
+ ] ifFalse:[
+ self paint:shadowClr.
+ self fillRectangleX:(width - ws) y:0 width:ws height:height
]
! !
@@ -193,7 +201,7 @@
shadowColor:aColor
"to set the shadow color"
- shadow := aColor
+ shadowClr := aColor
!
for:aView
--- a/StandardSystemView.st Mon Oct 10 03:30:48 1994 +0100
+++ b/StandardSystemView.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -12,7 +12,7 @@
View subclass:#StandardSystemView
instanceVariableNames:'label icon iconView iconLabel
- minExtent maxExtent'
+ minExtent maxExtent'
classVariableNames: ''
poolDictionaries:''
category:'Views-Basic'
@@ -20,9 +20,9 @@
StandardSystemView comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/StandardSystemView.st,v 1.10 1994-08-23 23:34:43 claus Exp $
+$Header: /cvs/stx/stx/libview/StandardSystemView.st,v 1.11 1994-10-10 02:33:15 claus Exp $
'!
!StandardSystemView class methodsFor:'documentation'!
@@ -30,7 +30,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -43,14 +43,15 @@
version
"
-$Header: /cvs/stx/stx/libview/StandardSystemView.st,v 1.10 1994-08-23 23:34:43 claus Exp $
+$Header: /cvs/stx/stx/libview/StandardSystemView.st,v 1.11 1994-10-10 02:33:15 claus Exp $
"
!
documentation
"
I represent topViews i.e. those views which have a title-label,
- an icon etc.
+ an icon etc. Usually StandardSystemViews are subclassed for
+ special views.
"
! !
@@ -84,11 +85,11 @@
|newView|
newView := self origin:nil
- extent:minExtent
- label:aLabel
- icon:nil
- minExtent:minExtent
- maxExtent:nil.
+ extent:minExtent
+ label:aLabel
+ icon:nil
+ minExtent:minExtent
+ maxExtent:nil.
newView model:aModel.
newView controller:(self defaultController new view:newView).
^ newView
@@ -98,72 +99,72 @@
"create a new topView and define its label"
^ self origin:nil extent:nil
- label:aLabel icon:nil
- minExtent:nil maxExtent:nil
+ label:aLabel icon:nil
+ minExtent:nil maxExtent:nil
!
label:aLabel minExtent:anExtent
^ self origin:nil extent:nil
- label:aLabel icon:nil
- minExtent:anExtent maxExtent:nil
+ label:aLabel icon:nil
+ minExtent:anExtent maxExtent:nil
!
label:aLabel icon:aForm
^ self origin:nil extent:nil
- label:aLabel icon:aForm
- minExtent:nil maxExtent:nil
+ label:aLabel icon:aForm
+ minExtent:nil maxExtent:nil
!
label:aLabel icon:aForm minExtent:anExtent
^ self origin:nil extent:nil
- label:aLabel icon:aForm
- minExtent:anExtent maxExtent:nil
+ label:aLabel icon:aForm
+ minExtent:anExtent maxExtent:nil
!
label:aLabel icon:aForm minExtent:minExtent maxExtent:maxExtent
^ self origin:nil extent:nil
- label:aLabel icon:aForm
- minExtent:minExtent maxExtent:maxExtent
+ label:aLabel icon:aForm
+ minExtent:minExtent maxExtent:maxExtent
!
origin:anOrigin extent:anExtent label:aLabel
^ self origin:anOrigin extent:anExtent
- label:aLabel icon:nil
- minExtent:nil maxExtent:nil
+ label:aLabel icon:nil
+ minExtent:nil maxExtent:nil
!
origin:anOrigin label:aLabel icon:aForm
- minExtent:minExtent maxExtent:maxExtent
+ minExtent:minExtent maxExtent:maxExtent
^ self origin:anOrigin extent:nil
- label:aLabel icon:aForm
- minExtent:minExtent maxExtent:maxExtent
+ label:aLabel icon:aForm
+ minExtent:minExtent maxExtent:maxExtent
!
extent:anExtent label:aLabel
- minExtent:minExtent
+ minExtent:minExtent
^ self origin:nil extent:anExtent
- label:aLabel icon:nil
- minExtent:minExtent maxExtent:nil
+ label:aLabel icon:nil
+ minExtent:minExtent maxExtent:nil
!
extent:anExtent label:aLabel icon:aForm
^ self origin:nil extent:anExtent
- label:aLabel icon:aForm
- minExtent:nil maxExtent:nil
+ label:aLabel icon:aForm
+ minExtent:nil maxExtent:nil
!
extent:anExtent label:aLabel icon:aForm
- minExtent:minExtent
+ minExtent:minExtent
^ self origin:nil extent:anExtent
- label:aLabel icon:aForm
- minExtent:minExtent maxExtent:nil
+ label:aLabel icon:aForm
+ minExtent:minExtent maxExtent:nil
!
extent:anExtent label:aLabel icon:aForm
- minExtent:minExtent maxExtent:maxExtent
+ minExtent:minExtent maxExtent:maxExtent
^ self origin:nil extent:anExtent
- label:aLabel icon:aForm
- minExtent:minExtent maxExtent:maxExtent
+ label:aLabel icon:aForm
+ minExtent:minExtent maxExtent:maxExtent
! !
!StandardSystemView methodsFor:'initialization'!
@@ -194,14 +195,14 @@
"add the receiver (a topview) to the current projects set-of-views.
(If there is a current project)"
- |project p|
+ |p|
"
- avoid introducing a new global here
+ the following check allows systems
+ without projects and changeSets
"
- project := Smalltalk at:#Project ifAbsent:[].
- (project notNil and:[(p := project current) notNil]) ifTrue:[
- p addView: self
+ (Project notNil and:[(p := Project current) notNil]) ifTrue:[
+ p addView: self
]
!
@@ -209,28 +210,28 @@
"remove the receiver (a topview) from the current projects set-of-views.
(If there is a current project)"
- |project p|
+ |p|
"
- avoid introducing a new global here
+ the following check allows systems
+ without projects and changeSets
"
- project := Smalltalk at:#Project ifAbsent:[].
- (project notNil and:[(p := project current) notNil]) ifTrue:[
- p removeView:self
+ (Project notNil and:[(p := Project current) notNil]) ifTrue:[
+ p removeView:self
]
!
reinitialize
"reopen the receiver if if was visible before.
This is called right after snapIn; Notice, that all instance variables
- (such as shown, realized etc.) are left-over from the time the snapout
+ (such as shown, realized etc.) are left-overs from the time the snapout
was done. Remap the receiver, if it was mapped at snapout time"
|myController|
"if I have already been reinited - return"
drawableId notNil ifTrue:[
- ^ self
+ ^ self
].
"have to kludge with the controller
@@ -244,19 +245,19 @@
"if I was mapped, do it again"
realized ifTrue:[
- "if it was iconified, try to remap iconified"
- shown ifFalse:[
- device mapView:self id:drawableId iconified:true
- atX:left y:top width:width height:height
- ] ifTrue:[
- device mapView:self id:drawableId iconified:false
- atX:left y:top width:width height:height
- ].
+ "if it was iconified, try to remap iconified"
+ shown ifFalse:[
+ device mapView:self id:drawableId iconified:true
+ atX:left y:top width:width height:height
+ ] ifTrue:[
+ device mapView:self id:drawableId iconified:false
+ atX:left y:top width:width height:height
+ ].
- "and restart the window-group process"
- windowGroup notNil ifTrue:[
- windowGroup restart
- ]
+ "and restart the window-group process"
+ windowGroup notNil ifTrue:[
+ windowGroup restart
+ ]
].
"restore controller"
@@ -270,16 +271,16 @@
super recreate.
iconView notNil ifTrue:[
- iconView create.
- device setWindowIconWindow:iconView in:drawableId
+ iconView create.
+ device setWindowIconWindow:iconView in:drawableId
] ifFalse:[
- (icon notNil and:[icon id notNil]) ifTrue:[
- device setWindowIcon:icon in:drawableId
- ].
+ (icon notNil and:[icon id notNil]) ifTrue:[
+ device setWindowIcon:icon in:drawableId
+ ].
].
iconLabel notNil ifTrue:[
- device setIconName:iconLabel in:drawableId
+ device setIconName:iconLabel in:drawableId
]
!
@@ -294,8 +295,8 @@
((self left > (device width - dX)) or:[
self top > (device height - dY)]) ifTrue:[
- 'moving view into visible area' errorPrintNewline.
- self origin:(device width - dX) @ (device height - dY)
+ 'moving view into visible area' errorPrintNewline.
+ self origin:(device width - dX) @ (device height - dY)
]
! !
@@ -310,21 +311,21 @@
convertedIcon
"make certain, that the icon is a b&w bitmap;
- do so by converting if appropriate.
+ do so by converting if required.
Will add a device supportsDeepIcons and only convert when needed;
- for now (since there are only Xdisplays) we always have to convert."
+ for now, we always have to convert (since there are only Xdisplays)."
|deviceIcon|
icon isNil ifTrue:[^ nil].
icon depth ~~ 1 ifTrue:[
- deviceIcon := icon asMonochromeFormOn:device.
+ deviceIcon := icon asMonochromeFormOn:device.
] ifFalse:[
- deviceIcon := icon
+ deviceIcon := icon
].
deviceIcon notNil ifTrue:[
- deviceIcon := deviceIcon on:device
+ deviceIcon := deviceIcon on:device
].
^ deviceIcon
! !
@@ -334,42 +335,56 @@
physicalCreate
"common code for create & recreate"
- "associate cursor/colors to device"
-
+ "get device specific representations of borderColor"
+"
borderColor notNil ifTrue:[
- borderColor := borderColor on:device.
+ borderColor := borderColor on:device.
].
+"
drawableId := device
- createWindowFor:self
- origin:(left @ top)
- extent:(width @ height)
- minExtent:minExtent
- maxExtent:maxExtent
- borderWidth:borderWidth
- borderColor:borderColor
- subViewOf:nil
- onTop:(self createOnTop)
- inputOnly:(self inputOnly)
- label:label
- cursor:cursor
- icon:icon
- iconView:iconView.
+ createWindowFor:self
+ origin:(left @ top)
+ extent:(width @ height)
+ minExtent:minExtent
+ maxExtent:maxExtent
+ borderWidth:borderWidth
+"/ borderColor:borderColor
+ subViewOf:nil
+ onTop:(self createOnTop)
+ inputOnly:(self inputOnly)
+ label:label
+ cursor:cursor
+ icon:icon
+ iconView:iconView.
extentChanged := false.
originChanged := false.
+ borderColor notNil ifTrue:[
+ borderColor ~~ Black ifTrue:[
+ borderColor := borderColor on:device.
+ self setBorderColor
+ ]
+ ].
+ (viewGravity notNil and:[viewGravity ~~ #NorthWest]) ifTrue:[
+ device setWindowGravity:viewGravity in:drawableId
+ ].
+ (bitGravity notNil and:[bitGravity ~~ #NorthWest]) ifTrue:[
+ device setBitGravity:bitGravity in:drawableId
+ ].
+
borderShape notNil ifTrue:[
- device setWindowBorderShape:(borderShape id) in:drawableId
+ device setWindowBorderShape:(borderShape id) in:drawableId
].
viewShape notNil ifTrue:[
- device setWindowShape:(viewShape id) in:drawableId
+ device setWindowShape:(viewShape id) in:drawableId
].
(backed notNil and:[backed ~~ false]) ifTrue:[
- device setBackingStore:backed in:drawableId
+ device setBackingStore:backed in:drawableId
].
saveUnder ifTrue:[
- device setSaveUnder:true in:drawableId
+ device setSaveUnder:true in:drawableId
].
!
@@ -380,11 +395,11 @@
super create.
iconView notNil ifTrue:[
- iconView create.
- device setWindowIconWindow:iconView in:drawableId
+ iconView create.
+ device setWindowIconWindow:iconView in:drawableId
].
iconLabel notNil ifTrue:[
- device setIconName:iconLabel in:drawableId
+ device setIconName:iconLabel in:drawableId
]
!
@@ -406,7 +421,23 @@
withCursor:aCursor do:aBlock
"evaluate aBlock while showing aCursor in all my views"
- windowGroup withCursor:aCursor do:aBlock
+ windowGroup notNil ifTrue:[
+ windowGroup withCursor:aCursor do:aBlock
+ ]
+! !
+
+!StandardSystemView methodsFor:'printing & storing'!
+
+displayString
+ "just for your convenience in inspectors ..."
+
+ |s|
+
+ s := super displayString.
+ label isNil ifTrue:[
+ s := s , '(' , label , ')'
+ ].
+ ^ s
! !
!StandardSystemView methodsFor:'accessing'!
@@ -434,11 +465,11 @@
label := aString.
drawableId notNil ifTrue: [
- device setWindowName:aString in:drawableId.
- "
- unbuffered - to make it visible right NOW
- "
- device synchronizeOutput.
+ device setWindowName:aString in:drawableId.
+ "
+ unbuffered - to make it visible right NOW
+ "
+ device synchronizeOutput.
]
!
@@ -453,11 +484,11 @@
iconLabel := aString.
drawableId notNil ifTrue:[
- device setIconName:aString in:drawableId.
- "
- unbuffered - to make it visible right NOW
- "
- device synchronizeOutput.
+ device setIconName:aString in:drawableId.
+ "
+ unbuffered - to make it visible right NOW
+ "
+ device synchronizeOutput.
]
!
@@ -480,27 +511,27 @@
icon := aForm.
icon notNil ifTrue:[
- drawableId notNil ifTrue:[
- icon depth ~~ 1 ifTrue:[
- icon := icon asMonochromeFormOn:device.
- ].
- "icons assume 1s as black - invert icon if the device thinks different"
- (device depth == 1 and:[device whitepixel ~~ 0]) ifTrue:[
- i := icon on:device.
- i notNil ifTrue:[
- invertedIcon := Form width:icon width height:icon height on:device.
- invertedIcon function:#copy.
- invertedIcon foreground:Color noColor background:Color allColor.
- invertedIcon copyFrom:i x:0 y:0 toX:0 y:0 width:icon width height:icon height.
- i := invertedIcon.
- ]
- ] ifFalse:[
- i := icon on:device.
- ].
- (i notNil and:[i id notNil]) ifTrue:[
- device setWindowIcon:i in:drawableId
- ]
- ]
+ drawableId notNil ifTrue:[
+ icon depth ~~ 1 ifTrue:[
+ icon := icon asMonochromeFormOn:device.
+ ].
+ "icons assume 1s as black - invert icon if the device thinks different"
+ (device depth == 1 and:[device whitepixel ~~ 0]) ifTrue:[
+ i := icon on:device.
+ i notNil ifTrue:[
+ invertedIcon := Form width:icon width height:icon height on:device.
+ invertedIcon function:#copy.
+ invertedIcon foreground:Color noColor background:Color allColor.
+ invertedIcon copyFrom:i x:0 y:0 toX:0 y:0 width:icon width height:icon height.
+ i := invertedIcon.
+ ]
+ ] ifFalse:[
+ i := icon on:device.
+ ].
+ (i notNil and:[i id notNil]) ifTrue:[
+ device setWindowIcon:i in:drawableId
+ ]
+ ]
]
!
@@ -515,8 +546,8 @@
iconView := aView.
drawableId notNil ifTrue:[
- aView create.
- device setWindowIconWindow:aView in:drawableId
+ aView create.
+ device setWindowIconWindow:aView in:drawableId
]
!
@@ -550,10 +581,10 @@
minExtent := min.
(width notNil and:[height notNil]) ifTrue:[
- ((width < (minExtent x)) or:
- [height < (minExtent y)]) ifTrue: [
- self extent:minExtent
- ]
+ ((width < (minExtent x)) or:
+ [height < (minExtent y)]) ifTrue: [
+ self extent:minExtent
+ ]
]
!
@@ -569,9 +600,9 @@
maxExtent := max.
(width notNil and:[height notNil]) ifTrue:[
- ((width > (maxExtent x)) or:
- [height > (maxExtent y)]) ifTrue: [
- self extent:maxExtent
- ]
+ ((width > (maxExtent x)) or:
+ [height > (maxExtent y)]) ifTrue: [
+ self extent:maxExtent
+ ]
]
! !
--- a/StdSysV.st Mon Oct 10 03:30:48 1994 +0100
+++ b/StdSysV.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -12,7 +12,7 @@
View subclass:#StandardSystemView
instanceVariableNames:'label icon iconView iconLabel
- minExtent maxExtent'
+ minExtent maxExtent'
classVariableNames: ''
poolDictionaries:''
category:'Views-Basic'
@@ -20,9 +20,9 @@
StandardSystemView comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/Attic/StdSysV.st,v 1.10 1994-08-23 23:34:43 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/StdSysV.st,v 1.11 1994-10-10 02:33:15 claus Exp $
'!
!StandardSystemView class methodsFor:'documentation'!
@@ -30,7 +30,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -43,14 +43,15 @@
version
"
-$Header: /cvs/stx/stx/libview/Attic/StdSysV.st,v 1.10 1994-08-23 23:34:43 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/StdSysV.st,v 1.11 1994-10-10 02:33:15 claus Exp $
"
!
documentation
"
I represent topViews i.e. those views which have a title-label,
- an icon etc.
+ an icon etc. Usually StandardSystemViews are subclassed for
+ special views.
"
! !
@@ -84,11 +85,11 @@
|newView|
newView := self origin:nil
- extent:minExtent
- label:aLabel
- icon:nil
- minExtent:minExtent
- maxExtent:nil.
+ extent:minExtent
+ label:aLabel
+ icon:nil
+ minExtent:minExtent
+ maxExtent:nil.
newView model:aModel.
newView controller:(self defaultController new view:newView).
^ newView
@@ -98,72 +99,72 @@
"create a new topView and define its label"
^ self origin:nil extent:nil
- label:aLabel icon:nil
- minExtent:nil maxExtent:nil
+ label:aLabel icon:nil
+ minExtent:nil maxExtent:nil
!
label:aLabel minExtent:anExtent
^ self origin:nil extent:nil
- label:aLabel icon:nil
- minExtent:anExtent maxExtent:nil
+ label:aLabel icon:nil
+ minExtent:anExtent maxExtent:nil
!
label:aLabel icon:aForm
^ self origin:nil extent:nil
- label:aLabel icon:aForm
- minExtent:nil maxExtent:nil
+ label:aLabel icon:aForm
+ minExtent:nil maxExtent:nil
!
label:aLabel icon:aForm minExtent:anExtent
^ self origin:nil extent:nil
- label:aLabel icon:aForm
- minExtent:anExtent maxExtent:nil
+ label:aLabel icon:aForm
+ minExtent:anExtent maxExtent:nil
!
label:aLabel icon:aForm minExtent:minExtent maxExtent:maxExtent
^ self origin:nil extent:nil
- label:aLabel icon:aForm
- minExtent:minExtent maxExtent:maxExtent
+ label:aLabel icon:aForm
+ minExtent:minExtent maxExtent:maxExtent
!
origin:anOrigin extent:anExtent label:aLabel
^ self origin:anOrigin extent:anExtent
- label:aLabel icon:nil
- minExtent:nil maxExtent:nil
+ label:aLabel icon:nil
+ minExtent:nil maxExtent:nil
!
origin:anOrigin label:aLabel icon:aForm
- minExtent:minExtent maxExtent:maxExtent
+ minExtent:minExtent maxExtent:maxExtent
^ self origin:anOrigin extent:nil
- label:aLabel icon:aForm
- minExtent:minExtent maxExtent:maxExtent
+ label:aLabel icon:aForm
+ minExtent:minExtent maxExtent:maxExtent
!
extent:anExtent label:aLabel
- minExtent:minExtent
+ minExtent:minExtent
^ self origin:nil extent:anExtent
- label:aLabel icon:nil
- minExtent:minExtent maxExtent:nil
+ label:aLabel icon:nil
+ minExtent:minExtent maxExtent:nil
!
extent:anExtent label:aLabel icon:aForm
^ self origin:nil extent:anExtent
- label:aLabel icon:aForm
- minExtent:nil maxExtent:nil
+ label:aLabel icon:aForm
+ minExtent:nil maxExtent:nil
!
extent:anExtent label:aLabel icon:aForm
- minExtent:minExtent
+ minExtent:minExtent
^ self origin:nil extent:anExtent
- label:aLabel icon:aForm
- minExtent:minExtent maxExtent:nil
+ label:aLabel icon:aForm
+ minExtent:minExtent maxExtent:nil
!
extent:anExtent label:aLabel icon:aForm
- minExtent:minExtent maxExtent:maxExtent
+ minExtent:minExtent maxExtent:maxExtent
^ self origin:nil extent:anExtent
- label:aLabel icon:aForm
- minExtent:minExtent maxExtent:maxExtent
+ label:aLabel icon:aForm
+ minExtent:minExtent maxExtent:maxExtent
! !
!StandardSystemView methodsFor:'initialization'!
@@ -194,14 +195,14 @@
"add the receiver (a topview) to the current projects set-of-views.
(If there is a current project)"
- |project p|
+ |p|
"
- avoid introducing a new global here
+ the following check allows systems
+ without projects and changeSets
"
- project := Smalltalk at:#Project ifAbsent:[].
- (project notNil and:[(p := project current) notNil]) ifTrue:[
- p addView: self
+ (Project notNil and:[(p := Project current) notNil]) ifTrue:[
+ p addView: self
]
!
@@ -209,28 +210,28 @@
"remove the receiver (a topview) from the current projects set-of-views.
(If there is a current project)"
- |project p|
+ |p|
"
- avoid introducing a new global here
+ the following check allows systems
+ without projects and changeSets
"
- project := Smalltalk at:#Project ifAbsent:[].
- (project notNil and:[(p := project current) notNil]) ifTrue:[
- p removeView:self
+ (Project notNil and:[(p := Project current) notNil]) ifTrue:[
+ p removeView:self
]
!
reinitialize
"reopen the receiver if if was visible before.
This is called right after snapIn; Notice, that all instance variables
- (such as shown, realized etc.) are left-over from the time the snapout
+ (such as shown, realized etc.) are left-overs from the time the snapout
was done. Remap the receiver, if it was mapped at snapout time"
|myController|
"if I have already been reinited - return"
drawableId notNil ifTrue:[
- ^ self
+ ^ self
].
"have to kludge with the controller
@@ -244,19 +245,19 @@
"if I was mapped, do it again"
realized ifTrue:[
- "if it was iconified, try to remap iconified"
- shown ifFalse:[
- device mapView:self id:drawableId iconified:true
- atX:left y:top width:width height:height
- ] ifTrue:[
- device mapView:self id:drawableId iconified:false
- atX:left y:top width:width height:height
- ].
+ "if it was iconified, try to remap iconified"
+ shown ifFalse:[
+ device mapView:self id:drawableId iconified:true
+ atX:left y:top width:width height:height
+ ] ifTrue:[
+ device mapView:self id:drawableId iconified:false
+ atX:left y:top width:width height:height
+ ].
- "and restart the window-group process"
- windowGroup notNil ifTrue:[
- windowGroup restart
- ]
+ "and restart the window-group process"
+ windowGroup notNil ifTrue:[
+ windowGroup restart
+ ]
].
"restore controller"
@@ -270,16 +271,16 @@
super recreate.
iconView notNil ifTrue:[
- iconView create.
- device setWindowIconWindow:iconView in:drawableId
+ iconView create.
+ device setWindowIconWindow:iconView in:drawableId
] ifFalse:[
- (icon notNil and:[icon id notNil]) ifTrue:[
- device setWindowIcon:icon in:drawableId
- ].
+ (icon notNil and:[icon id notNil]) ifTrue:[
+ device setWindowIcon:icon in:drawableId
+ ].
].
iconLabel notNil ifTrue:[
- device setIconName:iconLabel in:drawableId
+ device setIconName:iconLabel in:drawableId
]
!
@@ -294,8 +295,8 @@
((self left > (device width - dX)) or:[
self top > (device height - dY)]) ifTrue:[
- 'moving view into visible area' errorPrintNewline.
- self origin:(device width - dX) @ (device height - dY)
+ 'moving view into visible area' errorPrintNewline.
+ self origin:(device width - dX) @ (device height - dY)
]
! !
@@ -310,21 +311,21 @@
convertedIcon
"make certain, that the icon is a b&w bitmap;
- do so by converting if appropriate.
+ do so by converting if required.
Will add a device supportsDeepIcons and only convert when needed;
- for now (since there are only Xdisplays) we always have to convert."
+ for now, we always have to convert (since there are only Xdisplays)."
|deviceIcon|
icon isNil ifTrue:[^ nil].
icon depth ~~ 1 ifTrue:[
- deviceIcon := icon asMonochromeFormOn:device.
+ deviceIcon := icon asMonochromeFormOn:device.
] ifFalse:[
- deviceIcon := icon
+ deviceIcon := icon
].
deviceIcon notNil ifTrue:[
- deviceIcon := deviceIcon on:device
+ deviceIcon := deviceIcon on:device
].
^ deviceIcon
! !
@@ -334,42 +335,56 @@
physicalCreate
"common code for create & recreate"
- "associate cursor/colors to device"
-
+ "get device specific representations of borderColor"
+"
borderColor notNil ifTrue:[
- borderColor := borderColor on:device.
+ borderColor := borderColor on:device.
].
+"
drawableId := device
- createWindowFor:self
- origin:(left @ top)
- extent:(width @ height)
- minExtent:minExtent
- maxExtent:maxExtent
- borderWidth:borderWidth
- borderColor:borderColor
- subViewOf:nil
- onTop:(self createOnTop)
- inputOnly:(self inputOnly)
- label:label
- cursor:cursor
- icon:icon
- iconView:iconView.
+ createWindowFor:self
+ origin:(left @ top)
+ extent:(width @ height)
+ minExtent:minExtent
+ maxExtent:maxExtent
+ borderWidth:borderWidth
+"/ borderColor:borderColor
+ subViewOf:nil
+ onTop:(self createOnTop)
+ inputOnly:(self inputOnly)
+ label:label
+ cursor:cursor
+ icon:icon
+ iconView:iconView.
extentChanged := false.
originChanged := false.
+ borderColor notNil ifTrue:[
+ borderColor ~~ Black ifTrue:[
+ borderColor := borderColor on:device.
+ self setBorderColor
+ ]
+ ].
+ (viewGravity notNil and:[viewGravity ~~ #NorthWest]) ifTrue:[
+ device setWindowGravity:viewGravity in:drawableId
+ ].
+ (bitGravity notNil and:[bitGravity ~~ #NorthWest]) ifTrue:[
+ device setBitGravity:bitGravity in:drawableId
+ ].
+
borderShape notNil ifTrue:[
- device setWindowBorderShape:(borderShape id) in:drawableId
+ device setWindowBorderShape:(borderShape id) in:drawableId
].
viewShape notNil ifTrue:[
- device setWindowShape:(viewShape id) in:drawableId
+ device setWindowShape:(viewShape id) in:drawableId
].
(backed notNil and:[backed ~~ false]) ifTrue:[
- device setBackingStore:backed in:drawableId
+ device setBackingStore:backed in:drawableId
].
saveUnder ifTrue:[
- device setSaveUnder:true in:drawableId
+ device setSaveUnder:true in:drawableId
].
!
@@ -380,11 +395,11 @@
super create.
iconView notNil ifTrue:[
- iconView create.
- device setWindowIconWindow:iconView in:drawableId
+ iconView create.
+ device setWindowIconWindow:iconView in:drawableId
].
iconLabel notNil ifTrue:[
- device setIconName:iconLabel in:drawableId
+ device setIconName:iconLabel in:drawableId
]
!
@@ -406,7 +421,23 @@
withCursor:aCursor do:aBlock
"evaluate aBlock while showing aCursor in all my views"
- windowGroup withCursor:aCursor do:aBlock
+ windowGroup notNil ifTrue:[
+ windowGroup withCursor:aCursor do:aBlock
+ ]
+! !
+
+!StandardSystemView methodsFor:'printing & storing'!
+
+displayString
+ "just for your convenience in inspectors ..."
+
+ |s|
+
+ s := super displayString.
+ label isNil ifTrue:[
+ s := s , '(' , label , ')'
+ ].
+ ^ s
! !
!StandardSystemView methodsFor:'accessing'!
@@ -434,11 +465,11 @@
label := aString.
drawableId notNil ifTrue: [
- device setWindowName:aString in:drawableId.
- "
- unbuffered - to make it visible right NOW
- "
- device synchronizeOutput.
+ device setWindowName:aString in:drawableId.
+ "
+ unbuffered - to make it visible right NOW
+ "
+ device synchronizeOutput.
]
!
@@ -453,11 +484,11 @@
iconLabel := aString.
drawableId notNil ifTrue:[
- device setIconName:aString in:drawableId.
- "
- unbuffered - to make it visible right NOW
- "
- device synchronizeOutput.
+ device setIconName:aString in:drawableId.
+ "
+ unbuffered - to make it visible right NOW
+ "
+ device synchronizeOutput.
]
!
@@ -480,27 +511,27 @@
icon := aForm.
icon notNil ifTrue:[
- drawableId notNil ifTrue:[
- icon depth ~~ 1 ifTrue:[
- icon := icon asMonochromeFormOn:device.
- ].
- "icons assume 1s as black - invert icon if the device thinks different"
- (device depth == 1 and:[device whitepixel ~~ 0]) ifTrue:[
- i := icon on:device.
- i notNil ifTrue:[
- invertedIcon := Form width:icon width height:icon height on:device.
- invertedIcon function:#copy.
- invertedIcon foreground:Color noColor background:Color allColor.
- invertedIcon copyFrom:i x:0 y:0 toX:0 y:0 width:icon width height:icon height.
- i := invertedIcon.
- ]
- ] ifFalse:[
- i := icon on:device.
- ].
- (i notNil and:[i id notNil]) ifTrue:[
- device setWindowIcon:i in:drawableId
- ]
- ]
+ drawableId notNil ifTrue:[
+ icon depth ~~ 1 ifTrue:[
+ icon := icon asMonochromeFormOn:device.
+ ].
+ "icons assume 1s as black - invert icon if the device thinks different"
+ (device depth == 1 and:[device whitepixel ~~ 0]) ifTrue:[
+ i := icon on:device.
+ i notNil ifTrue:[
+ invertedIcon := Form width:icon width height:icon height on:device.
+ invertedIcon function:#copy.
+ invertedIcon foreground:Color noColor background:Color allColor.
+ invertedIcon copyFrom:i x:0 y:0 toX:0 y:0 width:icon width height:icon height.
+ i := invertedIcon.
+ ]
+ ] ifFalse:[
+ i := icon on:device.
+ ].
+ (i notNil and:[i id notNil]) ifTrue:[
+ device setWindowIcon:i in:drawableId
+ ]
+ ]
]
!
@@ -515,8 +546,8 @@
iconView := aView.
drawableId notNil ifTrue:[
- aView create.
- device setWindowIconWindow:aView in:drawableId
+ aView create.
+ device setWindowIconWindow:aView in:drawableId
]
!
@@ -550,10 +581,10 @@
minExtent := min.
(width notNil and:[height notNil]) ifTrue:[
- ((width < (minExtent x)) or:
- [height < (minExtent y)]) ifTrue: [
- self extent:minExtent
- ]
+ ((width < (minExtent x)) or:
+ [height < (minExtent y)]) ifTrue: [
+ self extent:minExtent
+ ]
]
!
@@ -569,9 +600,9 @@
maxExtent := max.
(width notNil and:[height notNil]) ifTrue:[
- ((width > (maxExtent x)) or:
- [height > (maxExtent y)]) ifTrue: [
- self extent:maxExtent
- ]
+ ((width > (maxExtent x)) or:
+ [height > (maxExtent y)]) ifTrue: [
+ self extent:maxExtent
+ ]
]
! !
--- a/View.st Mon Oct 10 03:30:48 1994 +0100
+++ b/View.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -12,30 +12,30 @@
PseudoView subclass:#View
instanceVariableNames:'superView subViews
- components style resources
- transformation viewport
- borderColor borderWidth borderShape viewShape
- top left
- extentChanged originChanged cornerChanged
- relativeOrigin relativeExtent relativeCorner
- originRule extentRule cornerRule
- topInset leftInset bottomInset rightInset
- shown hidden name
- level softEdge margin innerClipRect
- shadowColor lightColor
- halfShadowColor halfLightColor
- viewOrigin
- contentsChangeAction originChangeAction
- bitGravity viewGravity
- keyboardHandler model controller windowGroup
- aspectSymbol changeSymbol menuSymbol'
- classVariableNames: 'Grey ZeroPoint CentPoint
- ViewSpacing DefaultStyle
- StyleSheet
- DefaultViewBackgroundColor DefaultBorderColor
- DefaultLightColor DefaultShadowColor
- DefaultHalfShadowColor DefaultHalfLightColor
- DefaultBorderWidth'
+ components style resources
+ viewport
+ borderColor borderWidth borderShape viewShape
+ top left
+ extentChanged originChanged cornerChanged
+ relativeOrigin relativeExtent relativeCorner
+ originRule extentRule cornerRule
+ topInset leftInset bottomInset rightInset
+ shown hidden name
+ level softEdge margin innerClipRect
+ shadowColor lightColor
+ halfShadowColor halfLightColor
+ viewOrigin
+ contentsChangeAction originChangeAction
+ bitGravity viewGravity
+ keyboardHandler model controller windowGroup
+ aspectSymbol changeSymbol menuSymbol'
+ classVariableNames: 'Grey CentPoint
+ ViewSpacing
+ DefaultStyle StyleSheet
+ DefaultViewBackgroundColor DefaultBorderColor
+ DefaultLightColor DefaultShadowColor
+ DefaultHalfShadowColor DefaultHalfLightColor
+ DefaultBorderWidth DefaultFont'
poolDictionaries: ''
category:'Views-Basic'
!
@@ -44,9 +44,9 @@
View comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
-
-$Header: /cvs/stx/stx/libview/View.st,v 1.18 1994-08-11 23:43:58 claus Exp $
+ All Rights Reserved
+
+$Header: /cvs/stx/stx/libview/View.st,v 1.19 1994-10-10 02:33:27 claus Exp $
'!
"this flag controls (globally) how views look"
@@ -58,7 +58,7 @@
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -71,7 +71,7 @@
version
"
-$Header: /cvs/stx/stx/libview/View.st,v 1.18 1994-08-11 23:43:58 claus Exp $
+$Header: /cvs/stx/stx/libview/View.st,v 1.19 1994-10-10 02:33:27 claus Exp $
"
!
@@ -85,7 +85,6 @@
superView <aView> my superview i.e. the view I am in
subViews <aCollection> the collection of subviews
- transformation <WindowingTransformation>
window <Rectangle> my window i.e. local coordinate-system
viewport <Rectangle> my Rectangle in superviews coordinates
borderColor <Color> color of border
@@ -120,9 +119,8 @@
Class variables:
Grey <Color> the color grey - its used so often
- ViewSpacing <Number> the number of pixels in a millimeter (prefered
- spacing between views)
- ZeroPoint <Point> 0 @ 0 - its used so often
+ ViewSpacing <Number> prefered spacing between views; 1mm
+
CentPoint <Point> 100 @ 100 - its used so often
StyleSheet <ResourcePack> contains all view-style specifics
@@ -148,44 +146,35 @@
^ CentPoint
!
-defaultStyle
- "return the default view style"
-
- ^ DefaultStyle
-
- "View defaultStyle"
-!
-
-defaultStyle:aStyle
- "set the default view style"
-
- aStyle ~~ DefaultStyle ifTrue:[
- Grey := nil.
- DefaultStyle := aStyle.
- ViewStyle notNil ifTrue:[
- StyleSheet := ViewStyle fromFile:aStyle.
- ].
- ResourcePack flushResources.
- DefaultViewBackgroundColor := nil. "to force redefinition"
- View withAllSubclasses do:[:aClass |
- aClass updateClassResources
- ]
+flushAllClassResources
+ "flush all classes resource translations.
+ Needed after a resource file has changed."
+
+ ResourcePack flushCachedResourcePacks.
+ self flushClassResources.
+ self allSubclassesDo:[:aClass |
+ (aClass class implements:#flushClassResources) ifTrue:[aClass flushClassResources].
]
"
- View defaultStyle:#next. SystemBrowser start
- View defaultStyle:#motif. SystemBrowser start
- View defaultStyle:#iris. SystemBrowser start
+ View flushAllClassResources
"
+ "to change the language:
+ Language := #english.
+ Smalltalk changed:#Language.
+ View flushAllClassResources
+ or:
+ Language := #german.
+ Smalltalk changed:#Language.
+ View flushAllClassResources
+ "
!
-updateClassResources
- "if resources have been loaded, reload them - needed
- after a style change"
-
- ClassResources notNil ifTrue:[
- ClassResources := ResourcePack for:self.
- ]
+flushClassResources
+ "flush classes resource string translations.
+ Needed whenever a resource file has changed"
+
+ ClassResources := nil.
!
classResources
@@ -193,7 +182,7 @@
and return it"
ClassResources isNil ifTrue:[
- ClassResources := ResourcePack for:self.
+ ClassResources := ResourcePack for:self.
].
^ ClassResources
!
@@ -202,6 +191,137 @@
"allow setting of the classResources"
ClassResources := aResourcePack
+!
+
+defaultStyle
+ "return the default view style"
+
+ ^ DefaultStyle
+
+ "
+ View defaultStyle
+ "
+!
+
+styleSheet:aViewStyle
+ "set the view style from a style-sheet"
+
+ StyleSheet := aViewStyle.
+ DefaultStyle := (StyleSheet at:'name' ifAbsent:'unknown') asSymbol.
+ self updateAllStyleCaches.
+!
+
+defaultStyle:aStyle
+ "set the view style for new views"
+
+ aStyle ~~ DefaultStyle ifTrue:[
+ DefaultStyle := aStyle.
+ self updateAllStyleCaches.
+ ]
+
+ "
+ View defaultStyle:#next. SystemBrowser start
+ View defaultStyle:#motif. SystemBrowser start
+ View defaultStyle:#iris. SystemBrowser start
+ View defaultStyle:#st80. SystemBrowser start
+ View defaultStyle:#normal. SystemBrowser start
+ "
+!
+
+updateAllStyleCaches
+ "reload all style caches in all view classes.
+ Needed after a style change or when a style file has been changed"
+
+ StyleSheet := ViewStyle fromFile:(DefaultStyle , '.style').
+ StyleSheet fileReadFailed ifTrue:[
+ ('***** WARNING: no styleSheet for ' , DefaultStyle , '-style.') errorPrintNL.
+ DefaultStyle := #normal.
+ StyleSheet := ViewStyle fromFile:(DefaultStyle , '.style').
+ StyleSheet fileReadFailed ifTrue:[
+ '***** FATAL: not even a styleSheet for normal-style.' errorPrintNL.
+ ]
+ ].
+
+ "
+ tell all view classes to flush any
+ cached style-data
+ "
+ self changed:#style.
+ self updateStyleCache.
+ self allSubclassesDo:[:aClass |
+ (aClass class implements:#updateStyleCache) ifTrue:[aClass updateStyleCache].
+ ]
+
+ "
+ View updateAllStyleCaches
+ "
+!
+
+updateStyleCache
+ "this method gets some heavily used style stuff and keeps
+ it in class-variables for faster access.
+ Subclasses should redefine this to load any cached style-values
+ into faster class variables as well. These should NOT do a
+ super updateStyleCache, since this method is called for all view-classes
+ anyway."
+
+ |bgGrey|
+
+ "
+ when coming here the first time, we read the styleSheet
+ and keep the values in fast class variables
+ "
+ StyleSheet isNil ifTrue:[
+ DefaultStyle := #normal.
+ StyleSheet := ViewStyle fromFile:'normal.style'.
+ ].
+
+ Grey := StyleSheet viewGrey.
+ Grey isNil ifTrue:[
+ Grey := Color grey
+ ].
+ Grey := Grey on:Display.
+ Display hasGreyscales ifTrue:[
+ bgGrey := Grey
+ ] ifFalse:[
+ bgGrey := White on:Display
+ ].
+
+ ViewSpacing := StyleSheet at:'viewSpacing'.
+ ViewSpacing isNil ifTrue:[
+ ViewSpacing := Display verticalPixelPerMillimeter rounded.
+ ].
+
+ DefaultBorderWidth := StyleSheet at:'borderWidth' default:0.
+ DefaultBorderColor := StyleSheet at:'borderColor' default:Black.
+ DefaultViewBackgroundColor := StyleSheet at:'viewBackground' default:bgGrey.
+ DefaultShadowColor := StyleSheet at:'shadowColor'.
+ DefaultLightColor := StyleSheet at:'lightColor'.
+ DefaultHalfShadowColor := StyleSheet at:'halfShadowColor'.
+ DefaultHalfLightColor := StyleSheet at:'halfLightColor'.
+ DefaultFont := StyleSheet at:'font'.
+ DefaultFont isNil ifTrue:[
+ DefaultFont := Font family:'courier' face:'medium' style:'roman' size:12.
+ ].
+
+ "
+ get device colors - avoid repeated device conversions later
+ "
+ DefaultViewBackgroundColor := DefaultViewBackgroundColor on:Display.
+ DefaultLightColor notNil ifTrue:[
+ DefaultLightColor := DefaultLightColor on:Display.
+ ].
+ DefaultShadowColor notNil ifTrue:[
+ DefaultShadowColor := DefaultShadowColor on:Display.
+ ].
+ DefaultHalfShadowColor notNil ifTrue:[
+ DefaultHalfShadowColor := DefaultHalfShadowColor on:Display.
+ ].
+ DefaultLightShadowColor notNil ifTrue:[
+ DefaultHalfLightColor := DefaultHalfLightColor on:Display.
+ ].
+ DefaultBorderColor := DefaultBorderColor on:Display.
+ DefaultFont := DefaultFont on:Display.
! !
!View class methodsFor:'instance creation'!
@@ -218,10 +338,10 @@
newView := self basicNew.
aView notNil ifTrue:[
- newView device:(aView device).
- newView superView:(aView).
+ newView device:(aView device).
+ newView superView:(aView).
] ifFalse:[
- newView device:Display
+ newView device:Display
].
newView initialize.
aView notNil ifTrue:[aView addSubView:newView].
@@ -232,35 +352,35 @@
"create a new view as a subview of aView with given extent"
^ self origin:nil extent:extent borderWidth:nil
- font:nil label:nil in:aView
+ font:nil label:nil in:aView
!
origin:origin in:aView
"create a new view as a subview of aView with given origin"
^ self origin:origin extent:nil borderWidth:nil
- font:nil label:nil in:aView
+ font:nil label:nil in:aView
!
extent:extent
"create a new view with given extent"
^ self origin:nil extent:extent borderWidth:nil
- font:nil label:nil in:nil
+ font:nil label:nil in:nil
!
origin:origin extent:extent
"create a new view with given origin and extent"
^ self origin:origin extent:extent borderWidth:nil
- font:nil label:nil in:nil
+ font:nil label:nil in:nil
!
origin:origin extent:extent in:aView
"create a new view as a subview of aView with given origin and extent"
^ self origin:origin extent:extent borderWidth:nil
- font:nil label:nil in:aView
+ font:nil label:nil in:aView
!
origin:origin extent:extent borderWidth:bw in:aView
@@ -268,57 +388,57 @@
and borderWidth"
^ self origin:origin extent:extent borderWidth:bw
- font:nil label:nil in:aView
+ font:nil label:nil in:aView
!
origin:origin extent:extent borderWidth:bw
"create a new view with given origin, extent and borderWidth"
^ self origin:origin extent:extent borderWidth:bw
- font:nil label:nil in:nil
+ font:nil label:nil in:nil
!
label:label
"create a new view with given label"
^ self origin:nil extent:nil borderWidth:nil
- font:nil label:label in:nil
+ font:nil label:label in:nil
!
label:label in:aView
"create a new view as subview of aView with given label"
^ self origin:nil extent:nil borderWidth:nil
- font:nil label:label in:aView
+ font:nil label:label in:aView
!
extent:extent label:label
"create a new view with given extent and label"
^ self origin:nil extent:extent borderWidth:nil
- font:nil label:label in:nil
+ font:nil label:label in:nil
!
origin:origin extent:extent label:label
"create a new view with given origin, extent and label"
^ self origin:origin extent:extent borderWidth:nil
- font:nil label:label in:nil
+ font:nil label:label in:nil
!
origin:origin extent:extent font:aFont label:label
^ self origin:origin extent:extent borderWidth:nil
- font:nil label:label in:nil
+ font:nil label:label in:nil
!
origin:origin extent:extent font:aFont label:label in:aView
^ self origin:origin extent:extent borderWidth:nil
- font:aFont label:label in:aView
+ font:aFont label:label in:aView
!
origin:anOrigin extent:anExtent
- label:aLabel icon:aForm
- minExtent:minExtent maxExtent:maxExtent
+ label:aLabel icon:aForm
+ minExtent:minExtent maxExtent:maxExtent
|newView|
newView := self on:Display.
@@ -332,16 +452,16 @@
!
origin:anOrigin extent:anExtent borderWidth:bw
- font:aFont label:aLabel in:aView
+ font:aFont label:aLabel in:aView
|newView|
aView notNil ifTrue:[
- newView := self basicNew.
- newView device:(aView device).
- aView addSubView:newView.
- newView initialize
+ newView := self basicNew.
+ newView device:(aView device).
+ aView addSubView:newView.
+ newView initialize
] ifFalse:[
- newView := self on:Display
+ newView := self on:Display
].
bw notNil ifTrue:[newView borderWidth:bw].
anExtent notNil ifTrue:[newView extent:anExtent].
@@ -355,34 +475,34 @@
"create a new view with given origin and extent"
^ self origin:origin corner:corner borderWidth:nil
- font:nil label:nil in:nil
+ font:nil label:nil in:nil
!
origin:origin corner:corner in:aView
"create a new view as a subview of aView with given origin and extent"
^ self origin:origin corner:corner borderWidth:nil
- font:nil label:nil in:aView
+ font:nil label:nil in:aView
!
origin:origin corner:corner borderWidth:bw in:aView
"create a new view as a subview of aView with given origin and extent"
^ self origin:origin corner:corner borderWidth:bw
- font:nil label:nil in:aView
+ font:nil label:nil in:aView
!
origin:anOrigin corner:aCorner borderWidth:bw
- font:aFont label:aLabel in:aView
+ font:aFont label:aLabel in:aView
|newView|
aView notNil ifTrue:[
- newView := self basicNew.
- newView device:(aView device).
- aView addSubView:newView.
- newView initialize
+ newView := self basicNew.
+ newView device:(aView device).
+ aView addSubView:newView.
+ newView initialize
] ifFalse:[
- newView := self on:Display
+ newView := self on:Display
].
bw notNil ifTrue:[newView borderWidth:bw].
anOrigin notNil ifTrue:[newView origin:anOrigin].
@@ -397,9 +517,9 @@
and access selectors for aspect, change and menu"
^ self new on:anObject
- aspect:aspectMsg
- change:changeMsg
- menu:menuMsg
+ aspect:aspectMsg
+ change:changeMsg
+ menu:menuMsg
!
model:aModel
@@ -416,12 +536,16 @@
locals - and not forget the others.
View setup is separated into two parts, the general setup done here
and the style specific setup in initStyle. Each view should be prepared
- for a style change by being sent another initStyle with a new style value"
+ for a stylechange by being sent another initStyle with a new style value.
+ (in this case, it should set all of its style-dependent things, but
+ leave the state and contents as-is)"
|ext|
super initialize.
+ font := DefaultFont.
+
shown := false.
hidden := false.
realized := false.
@@ -449,11 +573,7 @@
rightInset := 0.
bottomInset := 0.
- ZeroPoint isNil ifTrue:[ZeroPoint := 0 @ 0].
- viewOrigin := ZeroPoint.
- ViewSpacing isNil ifTrue:[
- ViewSpacing := Display verticalPixelPerMillimeter rounded
- ].
+ viewOrigin := 0 @ 0.
originChanged := false.
extentChanged := false.
bitGravity := nil.
@@ -473,84 +593,50 @@
"this method sets up all style dependent things"
"
- when coming here the first time, we read the resources
- and keep them in fast class variables
+ when coming here the first time, we read the styleSheet
+ and keep the values in fast class variables
"
- DefaultStyle isNil ifTrue:[
- DefaultStyle := resources name:'VIEW_STYLE'
- default:(View3D ifTrue:[#view3D]
- ifFalse:[#normal])
+ StyleSheet isNil ifTrue:[
+ self class updateStyleCache
].
style := DefaultStyle.
- Grey isNil ifTrue:[
- style == #openwin ifTrue:[
- Grey := Color grey:80. "lightGrey "
- ].
- style == #st80 ifTrue:[
- Grey := Color grey:80. "lightGrey "
- ].
- style == #motif ifTrue:[
- Grey := Color grey:50
- ].
- style == #next ifTrue:[
- Grey := Color grey:67
- ].
- style == #iris ifTrue:[
- Grey := Color grey:67
- ].
- Grey isNil ifTrue:[
- Grey := Color grey
- ].
-"
- Grey := resources name:'VIEW_GREY' default:Color grey.
-"
- Grey := Grey on:Display
+ borderWidth := DefaultBorderWidth.
+ borderWidth isNil ifTrue:[borderWidth := 1].
+
+ viewBackground := DefaultViewBackgroundColor on:device.
+ DefaultLightColor notNil ifTrue:[
+ lightColor := DefaultLightColor on:device.
+ ] ifFalse:[
+ device hasGreyscales ifTrue:[
+ lightColor := viewBackground lightened on:device
+ ] ifFalse:[
+ "
+ this seems strange: on B&W light color is darker than
+ normal viewBackground (White) to make the boundary of
+ the view visible
+ "
+ lightColor := Color grey:50
+ ]
].
-
- DefaultViewBackgroundColor isNil ifTrue:[
- DefaultBorderWidth := self is3D ifTrue:[0] ifFalse:[1].
- DefaultBorderColor := resources name:'VIEW_BORDER_COLOR' default:Black.
- DefaultShadowColor := resources name:'VIEW_SHADOW_COLOR' default:Black.
- (self is3D and:[device hasGreyscales]) ifTrue:[
- DefaultViewBackgroundColor := resources name:'VIEW_BACKGROUND' default:Grey.
- style == #motif ifTrue:[
- DefaultLightColor := resources name:'VIEW_LIGHT_COLOR' default:(Grey lightened) "Color lightGrey"
- ] ifFalse:[
- DefaultLightColor := resources name:'VIEW_LIGHT_COLOR' default:White.
- ].
- DefaultHalfShadowColor := resources name:'VIEW_HSHADOW_COLOR' default:Grey darkened "Color darkGrey".
- DefaultHalfLightColor := resources name:'VIEW_HLIGHT_COLOR' default:White.
- ] ifFalse:[
- DefaultViewBackgroundColor := resources name:'VIEW_BACKGROUND' default:White.
- DefaultLightColor := resources name:'VIEW_LIGHT_COLOR' default:Color grey
- "or White"
- "or Color lightGrey".
- "cant say which is better ..."
- DefaultHalfShadowColor := resources name:'VIEW_HSHADOW_COLOR' default:Grey "Color grey".
- DefaultHalfLightColor := resources name:'VIEW_HLIGHT_COLOR' default:White.
- ].
- DefaultViewBackgroundColor := DefaultViewBackgroundColor on:Display.
- DefaultLightColor := DefaultLightColor on:Display.
- DefaultShadowColor := DefaultShadowColor on:Display.
- DefaultHalfShadowColor := DefaultHalfShadowColor on:Display.
- DefaultHalfLightColor := DefaultHalfLightColor on:Display.
- DefaultBorderColor := DefaultBorderColor on:Display.
+ DefaultShadowColor notNil ifTrue:[
+ shadowColor := DefaultShadowColor on:device.
+ ] ifFalse:[
+ shadowColor := Black on:device
].
-
- borderWidth := DefaultBorderWidth.
- viewBackground := DefaultViewBackgroundColor.
- lightColor := DefaultLightColor.
- shadowColor := DefaultShadowColor.
- halfShadowColor := DefaultHalfShadowColor.
- halfLightColor := DefaultHalfLightColor.
- borderColor := DefaultBorderColor.
- "
- DefaultViewBackgroundColor := (Color red:50 greep:50 blue:90) on:Display
- DefaultViewBackgroundColor := (Image fromFile:'bitmaps/granite.tiff') asFormOn:Display
- DefaultViewBackgroundColor := (Image fromFile:'bitmaps/woodV.tiff') asFormOn:Display
- "
+ DefaultHalfShadowColor notNil ifTrue:[
+ halfShadowColor := DefaultHalfShadowColor on:device.
+ ] ifFalse:[
+ halfShadowColor := viewBackground darkened on:device
+ ].
+ DefaultHalfLightColor notNil ifTrue:[
+ halfLightColor := DefaultHalfLightColor on:device.
+ ] ifFalse:[
+ halfLightColor := White on:device
+ ].
+ borderColor := DefaultBorderColor on:device.
+ font := DefaultFont on:device.
!
initEvents
@@ -563,7 +649,7 @@
prepareForReinit
super prepareForReinit.
windowGroup notNil ifTrue:[
- windowGroup reinitialize
+ windowGroup reinitialize
]
!
@@ -574,16 +660,16 @@
"if I have already been reinited - return"
drawableId notNil ifTrue:[
- ^ self
+ ^ self
].
"
superView must be there, first
"
superView notNil ifTrue:[
- superView id isNil ifTrue:[
- superView reinitialize
- ]
+ superView id isNil ifTrue:[
+ superView reinitialize
+ ]
].
myController := controller.
@@ -592,14 +678,14 @@
"if I was mapped, do it again"
realized ifTrue:[
- "only remap if I have a superview - otherwise, I might be
- a hidden iconView or menu ..."
- superView notNil ifTrue:[
- shown ifTrue:[
- device mapView:self id:drawableId iconified:false
- atX:left y:top width:width height:height
- ].
- ].
+ "only remap if I have a superview - otherwise, I might be
+ a hidden iconView or menu ..."
+ superView notNil ifTrue:[
+ shown ifTrue:[
+ device mapView:self id:drawableId iconified:false
+ atX:left y:top width:width height:height
+ ].
+ ].
"/ "if it was iconified, try to remap iconified"
"/ shown ifFalse:[
@@ -625,20 +711,13 @@
|t|
-"
- Grey := nil.
-"
-"
- DefaultStyle := nil.
-"
self initStyle.
-
drawableId notNil ifTrue:[
- "force a change"
- t := borderWidth. borderWidth := nil. self borderWidth:t.
- t := viewBackground. viewBackground := nil. self viewBackground:t.
- self clear.
- self redraw
+ "force a change"
+ t := borderWidth. borderWidth := nil. self borderWidth:t.
+ t := viewBackground. viewBackground := nil. self viewBackground:t.
+ self clear.
+ self redraw
].
! !
@@ -681,14 +760,14 @@
"set the model"
model notNil ifTrue:[
- model removeDependent:self
+ model removeDependent:self
].
model := aModel.
model notNil ifTrue:[
- aModel addDependent:self
+ aModel addDependent:self
].
controller notNil ifTrue:[
- controller model:aModel
+ controller model:aModel
]
!
@@ -755,56 +834,68 @@
!
innerWidth
- "return the width of the view minus any shadow-borders"
+ "return the width of the view minus any 3D-shadow-borders"
(level == 0) ifTrue:[^ width].
^ width - (2 * margin)
!
innerHeight
- "return the height of the view minus any shadow-borders"
+ "return the height of the view minus any 3D-shadow-borders"
(margin == 0) ifTrue:[^ height].
^ height - (2 * margin)
!
leftInset:aNumber
+ "set the inset of the left edge; positive is to the right,
+ negative to the left"
+
leftInset := aNumber.
"force recomputation"
drawableId isNil ifTrue:[
- originChanged := true
+ originChanged := true
] ifFalse:[
- self superViewChangedSize
+ self superViewChangedSize
]
!
topInset:aNumber
+ "set the inset of the top edge; positive is to the bottom,
+ negative to the top"
+
topInset := aNumber.
"force recomputation"
drawableId isNil ifTrue:[
- originChanged := true
+ originChanged := true
] ifFalse:[
- self superViewChangedSize
+ self superViewChangedSize
]
!
rightInset:aNumber
+ "set the inset of the right edge; positive is to the left,
+ negative to the right"
+
rightInset := aNumber.
"force recomputation"
drawableId isNil ifTrue:[
- originChanged := true
+ originChanged := true
] ifFalse:[
- self superViewChangedSize
+ self superViewChangedSize
]
!
bottomInset:aNumber
+ "set the inset of the bottom edge; positive is to the top,
+ negative to the bottom"
+
bottomInset := aNumber.
"force recomputation"
drawableId isNil ifTrue:[
- originChanged := true
+ originChanged := true
] ifFalse:[
- self superViewChangedSize
+ self superViewChangedSize
]
!
@@ -817,26 +908,26 @@
|w h e|
extent isBlock ifTrue:[
- extentRule := extent.
- "shown " drawableId notNil " " ifTrue:[ "23-feb-93"
- self pixelExtent:(extent value)
- ] ifFalse:[
- extentChanged := true
- ]
+ extentRule := extent.
+ "shown " drawableId notNil " " ifTrue:[ "23-feb-93"
+ self pixelExtent:(extent value)
+ ] ifFalse:[
+ extentChanged := true
+ ]
] ifFalse:[
- w := extent x.
- h := extent y.
- ((w isMemberOf:Float) or:[h isMemberOf:Float]) ifTrue:[
- relativeExtent := extent.
- e := self extentFromRelativeExtent.
- e isNil ifTrue:[
- extentChanged := true
- ] ifFalse:[
- self pixelExtent:e
- ]
- ] ifFalse:[
- self pixelExtent:extent
- ]
+ w := extent x.
+ h := extent y.
+ ((w isMemberOf:Float) or:[h isMemberOf:Float]) ifTrue:[
+ relativeExtent := extent.
+ e := self extentFromRelativeExtent.
+ e isNil ifTrue:[
+ extentChanged := true
+ ] ifFalse:[
+ self pixelExtent:e
+ ]
+ ] ifFalse:[
+ self pixelExtent:extent
+ ]
]
!
@@ -849,26 +940,26 @@
|newLeft newTop o|
origin isBlock ifTrue:[
- originRule := origin.
- drawableId notNil ifTrue:[
- self pixelOrigin:(origin value)
- ] ifFalse:[
- originChanged := true
- ]
+ originRule := origin.
+ drawableId notNil ifTrue:[
+ self pixelOrigin:(origin value)
+ ] ifFalse:[
+ originChanged := true
+ ]
] ifFalse:[
- newLeft := origin x.
- newTop := origin y.
- ((newLeft isMemberOf:Float) or:[newTop isMemberOf:Float]) ifTrue:[
- relativeOrigin := origin.
- o := self originFromRelativeOrigin.
- o isNil ifTrue:[
- originChanged := true
- ] ifFalse:[
- self pixelOrigin:o
- ]
- ] ifFalse:[
- self pixelOrigin:origin
- ]
+ newLeft := origin x.
+ newTop := origin y.
+ ((newLeft isMemberOf:Float) or:[newTop isMemberOf:Float]) ifTrue:[
+ relativeOrigin := origin.
+ o := self originFromRelativeOrigin.
+ o isNil ifTrue:[
+ originChanged := true
+ ] ifFalse:[
+ self pixelOrigin:o
+ ]
+ ] ifFalse:[
+ self pixelOrigin:origin
+ ]
]
!
@@ -880,21 +971,21 @@
"do it as one operation if possible"
origin isBlock ifFalse:[
- corner isBlock ifFalse:[
- newLeft := origin x.
- (newLeft isMemberOf:Float) ifFalse:[
- newTop := origin y.
- (newTop isMemberOf:Float) ifFalse:[
- newRight := corner x.
- (newRight isMemberOf:Float) ifFalse:[
- newBot := corner y.
- (newBot isMemberOf:Float) ifFalse:[
- self pixelOrigin:origin corner:corner
- ]
- ]
- ]
- ]
- ]
+ corner isBlock ifFalse:[
+ newLeft := origin x.
+ (newLeft isMemberOf:Float) ifFalse:[
+ newTop := origin y.
+ (newTop isMemberOf:Float) ifFalse:[
+ newRight := corner x.
+ (newRight isMemberOf:Float) ifFalse:[
+ newBot := corner y.
+ (newBot isMemberOf:Float) ifFalse:[
+ self pixelOrigin:origin corner:corner
+ ]
+ ]
+ ]
+ ]
+ ]
].
self origin:origin.
self corner:corner
@@ -908,21 +999,21 @@
"do it as one operation if possible"
origin isBlock ifFalse:[
- extent isBlock ifFalse:[
- newLeft := origin x.
- (newLeft isMemberOf:Float) ifFalse:[
- newTop := origin y.
- (newTop isMemberOf:Float) ifFalse:[
- newWidth := extent x.
- (newWidth isMemberOf:Float) ifFalse:[
- newHeight := extent y.
- (newHeight isMemberOf:Float) ifFalse:[
- self pixelOrigin:origin extent:extent
- ]
- ]
- ]
- ]
- ]
+ extent isBlock ifFalse:[
+ newLeft := origin x.
+ (newLeft isMemberOf:Float) ifFalse:[
+ newTop := origin y.
+ (newTop isMemberOf:Float) ifFalse:[
+ newWidth := extent x.
+ (newWidth isMemberOf:Float) ifFalse:[
+ newHeight := extent y.
+ (newHeight isMemberOf:Float) ifFalse:[
+ self pixelOrigin:origin extent:extent
+ ]
+ ]
+ ]
+ ]
+ ]
].
self extent:extent.
self origin:origin
@@ -939,16 +1030,16 @@
into the visible screen area if nescessary"
((top + height) > (device height)) ifTrue:[
- self top:(device height - height)
+ self top:(device height - height)
].
((left + width) > (device width)) ifTrue:[
- self left:(device width - width)
+ self left:(device width - width)
].
(top < 0) ifTrue:[
- self top:0
+ self top:0
].
(left < 0) ifTrue:[
- self left:0
+ self left:0
].
!
@@ -1018,13 +1109,13 @@
sumX := 0.
sumY := 0.
[currentView notNil] whileTrue:[
- (currentView == aView) ifTrue:[
- ^ (sumX @ sumY)
- ].
- org := currentView origin.
- sumX := sumX + org x.
- sumY := sumY + org y.
- currentView := currentView superView
+ (currentView == aView) ifTrue:[
+ ^ (sumX @ sumY)
+ ].
+ org := currentView origin.
+ sumX := sumX + org x.
+ sumY := sumY + org y.
+ currentView := currentView superView
].
^ nil
!
@@ -1068,54 +1159,85 @@
|x y c|
corner isBlock ifTrue:[
- cornerRule := corner.
- drawableId notNil ifTrue:[
- self pixelCorner:(corner value)
- ] ifFalse:[
- extentChanged := true
- ]
+ cornerRule := corner.
+ drawableId notNil ifTrue:[
+ self pixelCorner:(corner value)
+ ] ifFalse:[
+ extentChanged := true
+ ]
] ifFalse:[
- x := corner x.
- y := corner y.
- ((x isMemberOf:Float) or:[y isMemberOf:Float]) ifTrue:[
- relativeCorner := corner.
- c := self cornerFromRelativeCorner.
- c isNil ifTrue:[
- extentChanged := true
- ] ifFalse:[
- self pixelCorner:c
- ]
- ] ifFalse:[
- self pixelCorner:corner
- ]
+ x := corner x.
+ y := corner y.
+ ((x isMemberOf:Float) or:[y isMemberOf:Float]) ifTrue:[
+ relativeCorner := corner.
+ c := self cornerFromRelativeCorner.
+ c isNil ifTrue:[
+ extentChanged := true
+ ] ifFalse:[
+ self pixelCorner:c
+ ]
+ ] ifFalse:[
+ self pixelCorner:corner
+ ]
]
! !
!View methodsFor:'accessing-transformation'!
window
+ "return my window (i.e. logical coordinate space).
+ If there is no window, return the extent."
+
+ window isNil ifTrue:[^ width @ height].
^ window
!
window:aRectangle
+ "define my window (i.e. logical coordinate space)"
+
window := aRectangle.
subViews notNil ifTrue:[
- subViews do:[:s |
- s superViewChangedSize
- ]
+ subViews do:[:s |
+ s superViewChangedSize
+ ]
]
"
viewport isNil ifTrue:[
- viewport := aRectangle.
+ viewport := aRectangle.
].
"
"
superView notNil ifTrue:[
- self superViewChangedSize
+ self superViewChangedSize
] ifFalse:[
- originChanged := true.
- extentChanged := true
+ originChanged := true.
+ extentChanged := true
+ ]
+"
+!
+
+viewport:aRectangle
+ "define my extend in my superviews coordinate-system."
+
+ |relW relH relX relY winW winH|
+
+ viewport := aRectangle.
+ self dimensionFromViewport
+"
+ superView notNil ifTrue:[
+ superView window isNil ifTrue:[
+ winW := 1.
+ winH := 1
+ ] ifFalse:[
+ winW := superView window width.
+ winH := superView window height
+ ].
+ relW := (aRectangle width / winW) asFloat.
+ relH := (aRectangle height / winH) asFloat.
+ relX := (aRectangle left / winW) asFloat.
+ relY := (aRectangle top / winH) asFloat.
+ self origin:(relX @ relY) extent:(relW @ relH)
]
"
!
@@ -1124,24 +1246,28 @@
window := aRectangle.
self viewport:vRect.
subViews notNil ifTrue:[
- subViews do:[:s |
- s superViewChangedSize
- ]
+ subViews do:[:s |
+ s superViewChangedSize
+ ]
]
!
transformation
+ "return the transformation"
+
transformation isNil ifTrue:[
- superView isNil ifTrue:[
- transformation := WindowingTransformation window:window
- viewport:(0@0 extent:self extent)
- ] ifFalse:[
- window isNil ifTrue:[
- window := (0 @ 0) corner:(1 @ 1)
- ].
- transformation := WindowingTransformation window:window
- viewport:(self origin extent:self extent)
- ]
+ superView isNil ifTrue:[
+ transformation := WindowingTransformation
+ window:window
+ viewport:(0@0 extent:self extent)
+ ] ifFalse:[
+ window isNil ifTrue:[
+ window := (0 @ 0) corner:(1 @ 1)
+ ].
+ transformation := WindowingTransformation
+ window:window
+ viewport:(self origin extent:self extent)
+ ]
].
^ transformation
!
@@ -1153,58 +1279,41 @@
!
displayTransform:aPoint
- "given a point in window coordinate, make pixel coordinate"
+ "given a point in logical coordinate space, return corresponding
+ point in device coordinates"
|nx ny|
+ transformation notNil ifTrue:[
+ ^ transformation applyTo:aPoint x
+ ].
nx := aPoint x - window left * width / window width.
ny := aPoint y - window top * height / window height.
^ nx @ ny
!
inverseDisplayTransform:aPoint
- "given a pixel coordinate, make window coordinate"
+ "given a point in device coordinates (such as a button-press-point),
+ return corresponding point in logical coordinates"
|nx ny|
+ transformation notNil ifTrue:[
+ ^ transformation applyInverseTo:aPoint x
+ ].
window isNil ifTrue:[^ aPoint].
nx := aPoint x * window width / width + window left.
ny := aPoint y * window height / height + window top.
^ nx @ ny
!
-viewport:aRectangle
- "define my extend in my superviews coordinate-system."
-
- |relW relH relX relY winW winH|
-
- viewport := aRectangle.
- self dimensionFromViewport
-"
- superView notNil ifTrue:[
- superView window isNil ifTrue:[
- winW := 1.
- winH := 1
- ] ifFalse:[
- winW := superView window width.
- winH := superView window height
- ].
- relW := (aRectangle width / winW) asFloat.
- relH := (aRectangle height / winH) asFloat.
- relX := (aRectangle left / winW) asFloat.
- relY := (aRectangle top / winH) asFloat.
- self origin:(relX @ relY) extent:(relW @ relH)
- ]
-"
-!
-
viewRectangle
"return the inside area"
|m2|
innerClipRect notNil ifTrue:[
- ^ innerClipRect
+ ^ innerClipRect
].
m2 := margin + margin.
@@ -1260,8 +1369,8 @@
v := self.
[v notNil] whileTrue:[
- v superView isNil ifTrue:[^ v].
- v := v superView
+ v superView isNil ifTrue:[^ v].
+ v := v superView
].
^ nil
@@ -1278,9 +1387,9 @@
subViews := aListOfViews.
subViews notNil ifTrue:[
- subViews do:[:view |
- view superView:self
- ]
+ subViews do:[:view |
+ view superView:self
+ ]
]
! !
@@ -1305,9 +1414,9 @@
"evaluate aBlock for all subviews (recursively)"
(subViews isNil or:[subViews isEmpty]) ifFalse:[
- subViews do:[:aSubview |
- aSubview withAllSubViewsDo:aBlock
- ]
+ subViews do:[:aSubview |
+ aSubview withAllSubViewsDo:aBlock
+ ]
]
!
@@ -1331,7 +1440,12 @@
"set the viewGravity - thats the direction where the view will move
when the superView is resized."
- viewGravity := gravity
+ viewGravity ~~ gravity ifTrue:[
+ viewGravity := gravity.
+ drawableId notNil ifTrue:[
+ device setWindowGravity:gravity in:drawableId
+ ]
+ ]
!
bitGravity
@@ -1341,6 +1455,18 @@
^ bitGravity
!
+bitGravity:gravity
+ "set the bitGravity - thats the direction where the contents will move
+ when the view is resized."
+
+ bitGravity ~~ gravity ifTrue:[
+ bitGravity := gravity.
+ drawableId notNil ifTrue:[
+ device setBitGravity:gravity in:drawableId
+ ]
+ ]
+!
+
inputOnly
"return true, if this view is an input-only view;
input only views are transparent and can be layed on top of a view to
@@ -1367,13 +1493,7 @@
is3D
"return true, if my style is some kind of 3D style - will change"
- style == #next ifTrue:[^true].
- style == #iris ifTrue:[^true].
- style == #openwin ifTrue:[^true].
- style == #view3D ifTrue:[^true].
- style == #motif ifTrue:[^true].
- style == #st80 ifTrue:[^true].
- ^ false
+ ^ StyleSheet is3D
!
shown
@@ -1425,10 +1545,10 @@
edges."
something isColor ifTrue:[
- device hasGreyscales ifTrue:[
- shadowColor := something darkened.
- lightColor := something lightened
- ]
+ device hasGreyscales ifTrue:[
+ shadowColor := something darkened.
+ lightColor := something lightened
+ ]
].
super viewBackground:something
!
@@ -1442,24 +1562,11 @@
borderColor:aColor
"set my borderColor"
- |id dither|
-
(aColor ~~ borderColor) ifTrue:[
- borderColor := aColor.
- drawableId notNil ifTrue:[
- borderColor := borderColor on:device.
- id := borderColor colorId.
- id notNil ifTrue:[
- device setWindowBorderColor:id in:drawableId
- ] ifFalse:[
- dither := borderColor ditherForm.
- dither notNil ifTrue:[
- device setWindowBorderPixmap:(dither id) in:drawableId
- ] ifFalse:[
- 'bad borderColor' errorPrintNewline
- ]
- ]
- ]
+ borderColor := aColor.
+ drawableId notNil ifTrue:[
+ self setBorderColor
+ ]
]
!
@@ -1473,10 +1580,10 @@
"set my borderWidth"
(aNumber ~~ borderWidth) ifTrue:[
- borderWidth := aNumber.
- drawableId notNil ifTrue:[
- device setWindowBorderWidth:aNumber in:drawableId
- ]
+ borderWidth := aNumber.
+ drawableId notNil ifTrue:[
+ device setWindowBorderWidth:aNumber in:drawableId
+ ]
]
!
@@ -1485,7 +1592,7 @@
borderShape := aForm.
drawableId notNil ifTrue:[
- device setWindowBorderShape:(aForm id) in:drawableId
+ device setWindowBorderShape:(aForm id) in:drawableId
]
!
@@ -1494,7 +1601,7 @@
viewShape := aForm.
drawableId notNil ifTrue:[
- device setWindowShape:(aForm id) in:drawableId
+ device setWindowShape:(aForm id) in:drawableId
]
!
@@ -1508,7 +1615,7 @@
"return my full name to be used for resource-access"
superView notNil ifTrue:[
- ^ superView fullName , '.' , name
+ ^ superView fullName , '.' , name
].
^ name
!
@@ -1537,24 +1644,24 @@
|oldMargin how|
(aNumber ~~ level) ifTrue:[
- self is3D ifTrue:[
- level := aNumber.
- oldMargin := margin.
- margin := level abs.
-
- realized ifTrue:[
- (margin > oldMargin) ifTrue:[
- how := #smaller
- ] ifFalse:[
- how := #larger
- ].
- self sizeChanged:how.
- self computeInnerClip.
- shown ifTrue:[
- self redrawEdges
- ]
- ]
- ]
+ self is3D ifTrue:[
+ level := aNumber.
+ oldMargin := margin.
+ margin := level abs.
+
+ realized ifTrue:[
+ (margin > oldMargin) ifTrue:[
+ how := #smaller
+ ] ifFalse:[
+ how := #larger
+ ].
+ self sizeChanged:how.
+ self computeInnerClip.
+ shown ifTrue:[
+ self redrawEdges
+ ]
+ ]
+ ]
]
!
@@ -1581,7 +1688,7 @@
addComponent:aComponent
components isNil ifTrue:[
- components := IdentitySet new
+ components := IdentitySet new
].
components add:aComponent
!
@@ -1596,10 +1703,10 @@
aView superView:self.
(aView device ~~ device) ifTrue:[
- 'warning subview (' errorPrint. aView class name errorPrint.
- ') has different device than me (' errorPrint.
- self class name errorPrint. ').' errorPrintNewline.
- aView device:device
+ 'warning subview (' errorPrint. aView class name errorPrint.
+ ') has different device than me (' errorPrint.
+ self class name errorPrint. ').' errorPrintNewline.
+ aView device:device
]
!
@@ -1607,9 +1714,9 @@
"add a view to the collection of subviews"
subViews isNil ifTrue:[
- subViews := OrderedCollection with:newView
+ subViews := OrderedCollection with:newView
] ifFalse:[
- subViews add:newView.
+ subViews add:newView.
].
self setParentViewIn:newView.
!
@@ -1620,9 +1727,9 @@
element at some defined place."
subViews isNil ifTrue:[
- subViews := OrderedCollection with:newView
+ subViews := OrderedCollection with:newView
] ifFalse:[
- subViews add:newView after:aView.
+ subViews add:newView after:aView.
].
self setParentViewIn:newView.
!
@@ -1633,9 +1740,9 @@
element at some defined place."
subViews isNil ifTrue:[
- subViews := OrderedCollection with:newView
+ subViews := OrderedCollection with:newView
] ifFalse:[
- subViews add:newView before:aView.
+ subViews add:newView before:aView.
].
self setParentViewIn:newView.
!
@@ -1645,7 +1752,7 @@
aView borderWidth:bw.
aView origin:(bounds origin x asFloat) @ (bounds origin y asFloat)
- extent:(bounds extent x asFloat) @ (bounds extent y asFloat).
+ extent:(bounds extent x asFloat) @ (bounds extent y asFloat).
self addSubView:aView
!
@@ -1653,7 +1760,7 @@
"for ST-80 compatibility"
aView origin:(bounds origin x asFloat) @ (bounds origin y asFloat)
- extent:(bounds extent x asFloat) @ (bounds extent y asFloat).
+ extent:(bounds extent x asFloat) @ (bounds extent y asFloat).
self addSubView:aView
!
@@ -1678,10 +1785,10 @@
"remove a view from the collection of subviews"
subViews notNil ifTrue:[
- subViews remove:aView ifAbsent:[nil].
- (subViews size == 0) ifTrue:[
- subViews := nil
- ]
+ subViews remove:aView ifAbsent:[nil].
+ (subViews size == 0) ifTrue:[
+ subViews := nil
+ ]
]
! !
@@ -1700,7 +1807,7 @@
"return the views sensor"
windowGroup notNil ifTrue:[
- ^ windowGroup sensor.
+ ^ windowGroup sensor.
].
^ nil
!
@@ -1718,8 +1825,11 @@
update:aspect with:anObject
"an update request - should be redefined in subclasses"
+ "
+ this is a leftover for ST-80 supprto; may vanish
+ "
aspect == #rectangle ifTrue:[
- ^ self update:#all
+ ^ self update:#all
].
^ self update:aspect
! !
@@ -1775,7 +1885,7 @@
"scroll to a position given in percent of total"
self scrollVerticalTo:
- ((((self heightOfContents * percent) / 100.0) + 0.5) asInteger)
+ ((((self heightOfContents * percent) / 100.0) + 0.5) asInteger)
!
scrollVerticalTo:aPixelOffset
@@ -1786,11 +1896,11 @@
orgY := viewOrigin y.
(aPixelOffset < orgY) ifTrue:[
- self scrollUp:(orgY - aPixelOffset)
+ self scrollUp:(orgY - aPixelOffset)
] ifFalse:[
- (aPixelOffset > orgY) ifTrue:[
- self scrollDown:(aPixelOffset - orgY)
- ]
+ (aPixelOffset > orgY) ifTrue:[
+ self scrollDown:(aPixelOffset - orgY)
+ ]
]
!
@@ -1798,7 +1908,7 @@
"scroll to a position given in percent of total"
self scrollHorizontalTo:
- ((((self widthOfContents * percent) / 100.0) + 0.5) asInteger)
+ ((((self widthOfContents * percent) / 100.0) + 0.5) asInteger)
!
scrollHorizontalTo:aPixelOffset
@@ -1809,11 +1919,11 @@
orgX := viewOrigin x.
(aPixelOffset < orgX) ifTrue:[
- self scrollLeft:(orgX - aPixelOffset)
+ self scrollLeft:(orgX - aPixelOffset)
] ifFalse:[
- (aPixelOffset > orgX) ifTrue:[
- self scrollRight:(aPixelOffset - orgX)
- ]
+ (aPixelOffset > orgX) ifTrue:[
+ self scrollRight:(aPixelOffset - orgX)
+ ]
]
!
@@ -1845,7 +1955,7 @@
count := nPixels.
(count > viewOrigin y) ifTrue:[
- count := viewOrigin y
+ count := viewOrigin y
].
(count <= 0) ifTrue:[^ self].
@@ -1853,25 +1963,25 @@
viewOrigin := viewOrigin x @ (viewOrigin y - count).
(count >= self innerHeight) ifTrue:[
- self redraw.
- self originChanged:(0 @ count negated)
+ self redraw.
+ self originChanged:(0 @ count negated)
] ifFalse:[
- w := self widthForScrollBetween:(viewOrigin y)
- and:(viewOrigin y + count).
- m2 := margin * 2.
- w := w min:(width - m2).
-
- self catchExpose.
- self copyFrom:self x:margin y:margin
- toX:margin y:(count + margin)
- width:w
- height:(height - m2 - count).
- self redrawX:margin y:margin
- width:(width - m2)
- height:count.
-
- self waitForExpose.
- self originChanged:(0 @ count negated).
+ w := self widthForScrollBetween:(viewOrigin y)
+ and:(viewOrigin y + count).
+ m2 := margin * 2.
+ w := w min:(width - m2).
+
+ self catchExpose.
+ self copyFrom:self x:margin y:margin
+ toX:margin y:(count + margin)
+ width:w
+ height:(height - m2 - count).
+ self redrawX:margin y:margin
+ width:(width - m2)
+ height:count.
+
+ self waitForExpose.
+ self originChanged:(0 @ count negated).
]
!
@@ -1896,7 +2006,7 @@
ih := self innerHeight.
((viewOrigin y + nPixels + ih) > hCont) ifTrue:[
- count := hCont - viewOrigin y - ih
+ count := hCont - viewOrigin y - ih
].
(count <= 0) ifTrue:[^ self].
@@ -1904,25 +2014,25 @@
viewOrigin := viewOrigin x @ (viewOrigin y + count).
(count >= ih) ifTrue:[
- self redraw.
- self originChanged:(0 @ count)
+ self redraw.
+ self originChanged:(0 @ count)
] ifFalse:[
- m2 := margin * 2.
- w := self widthForScrollBetween:(viewOrigin y)
- and:(viewOrigin y + count).
- w := w min:(width - m2).
-
- self catchExpose.
- self copyFrom:self x:margin y:(count + margin)
- toX:margin y:margin
- width:w
- height:(height - m2 - count).
-
- self redrawX:margin y:(height - margin - count)
- width:(width - m2) height:count.
-
- self waitForExpose.
- self originChanged:(0 @ count).
+ m2 := margin * 2.
+ w := self widthForScrollBetween:(viewOrigin y)
+ and:(viewOrigin y + count).
+ w := w min:(width - m2).
+
+ self catchExpose.
+ self copyFrom:self x:margin y:(count + margin)
+ toX:margin y:margin
+ width:w
+ height:(height - m2 - count).
+
+ self redrawX:margin y:(height - margin - count)
+ width:(width - m2) height:count.
+
+ self waitForExpose.
+ self originChanged:(0 @ count).
]
!
@@ -1942,7 +2052,7 @@
count := nPixels.
(count > viewOrigin x) ifTrue:[
- count := viewOrigin x
+ count := viewOrigin x
].
(count <= 0) ifTrue:[^ self].
@@ -1950,24 +2060,24 @@
viewOrigin := (viewOrigin x - count) @ viewOrigin y.
(count >= self innerWidth) ifTrue:[
- self redraw.
- self originChanged:(count negated @ 0)
+ self redraw.
+ self originChanged:(count negated @ 0)
] ifFalse:[
- m2 := margin * 2.
- h := (height - m2).
-
- self catchExpose.
- self copyFrom:self x:margin y:margin
- toX:(count + margin) y:margin
- width:(width - m2 - count)
- height:h.
-
- self redrawX:margin y:margin
- width:count
- height:(height - m2).
-
- self waitForExpose.
- self originChanged:(count negated @ 0).
+ m2 := margin * 2.
+ h := (height - m2).
+
+ self catchExpose.
+ self copyFrom:self x:margin y:margin
+ toX:(count + margin) y:margin
+ width:(width - m2 - count)
+ height:h.
+
+ self redrawX:margin y:margin
+ width:count
+ height:(height - m2).
+
+ self waitForExpose.
+ self originChanged:(count negated @ 0).
]
!
@@ -1992,7 +2102,7 @@
iw := self innerWidth.
((viewOrigin x + nPixels + iw) > wCont) ifTrue:[
- count := wCont - viewOrigin x - iw
+ count := wCont - viewOrigin x - iw
].
(count <= 0) ifTrue:[^ self].
@@ -2000,23 +2110,23 @@
viewOrigin := (viewOrigin x + count) @ viewOrigin y.
(count >= iw) ifTrue:[
- self redraw.
- self originChanged:(count @ 0)
+ self redraw.
+ self originChanged:(count @ 0)
] ifFalse:[
- m2 := margin * 2.
- h := (height - m2).
-
- self catchExpose.
- self copyFrom:self x:(count + margin) y:margin
- toX:margin y:margin
- width:(width - m2 - count)
- height:h.
-
- self redrawX:(width - margin - count) y:margin
- width:count height:(height - m2).
-
- self waitForExpose.
- self originChanged:(count @ 0).
+ m2 := margin * 2.
+ h := (height - m2).
+
+ self catchExpose.
+ self copyFrom:self x:(count + margin) y:margin
+ toX:margin y:margin
+ width:(width - m2 - count)
+ height:h.
+
+ self redrawX:(width - margin - count) y:margin
+ width:count height:(height - m2).
+
+ self waitForExpose.
+ self originChanged:(count @ 0).
]
!
@@ -2043,15 +2153,15 @@
newLeft := origin x.
newTop := origin y.
((newTop ~~ top) or:[newLeft ~~ left]) ifTrue:[
- top := newTop.
- left := newLeft.
- drawableId notNil ifTrue:[
- "have to tell X, when origin of view is changed"
- device moveWindow:drawableId x:left y:top
- ].
- realized ifFalse:[
- originChanged := true
- ]
+ top := newTop.
+ left := newLeft.
+ drawableId notNil ifTrue:[
+ "have to tell X, when origin of view is changed"
+ device moveWindow:drawableId x:left y:top
+ ].
+ realized ifFalse:[
+ originChanged := true
+ ]
]
!
@@ -2089,8 +2199,8 @@
newWidth := extent x.
newHeight := extent y.
((newWidth == width) and:[newHeight == height]) ifTrue:[
- sameOrigin ifTrue:[^ self].
- ^ self pixelOrigin:origin
+ sameOrigin ifTrue:[^ self].
+ ^ self pixelOrigin:origin
].
top := newTop.
left := newLeft.
@@ -2099,114 +2209,181 @@
mustRedrawRightEdge := (level ~~ 0) and:[newWidth < width].
((newHeight <= height) and:[newWidth <= width]) ifTrue:[
- how := #smaller
+ how := #smaller
].
"shown " drawableId notNil "" ifTrue:[ "23-feb-93"
- mustRepaintRight := false.
- mustRepaintBottom := false.
- (level ~~ 0) ifTrue:[
- "clear the old edges"
-
- newWidth > width ifTrue:[
- self clipRect:nil.
- self paint:viewBackground.
- self fillRectangleX:(width - margin)
- y:0
- width:margin
- height:height.
- mustRepaintRight := true.
- oldWidth := width
- ].
- newHeight > height ifTrue:[
- self clipRect:nil.
- self paint:viewBackground.
- self fillRectangleX:0
- y:(height - margin)
- width:width
- height:margin.
- mustRepaintBottom := true.
- oldHeight := height
- ]
- ].
-
- width := newWidth.
- height := newHeight.
-
- self setInnerClip.
-
- "if view becomes smaller, send sizeChanged first"
- (how == #smaller) ifTrue:[
- self sizeChanged:how
- ].
-
- "have to tell X, when extent of view is changed"
- sameOrigin ifTrue:[
- device resizeWindow:drawableId width:width height:height.
- ] ifFalse:[
- "claus: some xservers seem to do better when resizing
- first ...."
+ mustRepaintRight := false.
+ mustRepaintBottom := false.
+ (level ~~ 0) ifTrue:[
+ "clear the old edges"
+
+ newWidth > width ifTrue:[
+ self clipRect:nil.
+ self paint:viewBackground.
+ self fillRectangleX:(width - margin)
+ y:0
+ width:margin
+ height:height.
+ mustRepaintRight := true.
+ oldWidth := width
+ ].
+ newHeight > height ifTrue:[
+ self clipRect:nil.
+ self paint:viewBackground.
+ self fillRectangleX:0
+ y:(height - margin)
+ width:width
+ height:margin.
+ mustRepaintBottom := true.
+ oldHeight := height
+ ]
+ ].
+
+ width := newWidth.
+ height := newHeight.
+
+ self setInnerClip.
+
+ "if view becomes smaller, send sizeChanged first"
+ (how == #smaller) ifTrue:[
+ self sizeChanged:how
+ ].
+
+ "have to tell X, when extent of view is changed"
+ sameOrigin ifTrue:[
+ device resizeWindow:drawableId width:width height:height.
+ ] ifFalse:[
+ "claus: some xservers seem to do better when resizing
+ first ...."
+"
+ (how == #smaller) ifTrue:[
+ device resizeWindow:drawableId width:width height:height.
+ device moveWindow:drawableId x:left y:top
+ ] ifFalse:[
+ device moveResizeWindow:drawableId x:left y:top width:width height:height
+ ].
"
- (how == #smaller) ifTrue:[
- device resizeWindow:drawableId width:width height:height.
- device moveWindow:drawableId x:left y:top
- ] ifFalse:[
- device moveResizeWindow:drawableId x:left y:top width:width height:height
- ].
-"
- device moveResizeWindow:drawableId x:left y:top
- width:width height:height.
+ device moveResizeWindow:drawableId x:left y:top
+ width:width height:height.
" "
- ].
-
- "if view becomes bigger, send sizeChanged after"
- (how ~~ #smaller) ifTrue:[
- self sizeChanged:how
- ].
-
- (mustRedrawBottomEdge or:[mustRedrawRightEdge]) ifTrue:[
- self clipRect:nil.
- mustRedrawBottomEdge ifTrue:[
- self drawBottomEdge
- ].
- mustRedrawRightEdge ifTrue:[
- self drawRightEdge
- ].
- self clipRect:innerClipRect
- ].
- mustRepaintRight ifTrue:[
- self redrawX:(oldWidth - margin)
- y:0
- width:margin
- height:height.
- ].
- mustRepaintBottom ifTrue:[
- self redrawX:0
- y:(oldHeight - margin)
- width:width
- height:margin.
- ].
+ ].
+
+ "if view becomes bigger, send sizeChanged after"
+ (how ~~ #smaller) ifTrue:[
+ self sizeChanged:how
+ ].
+
+ (mustRedrawBottomEdge or:[mustRedrawRightEdge]) ifTrue:[
+ self clipRect:nil.
+ mustRedrawBottomEdge ifTrue:[
+ self drawBottomEdge
+ ].
+ mustRedrawRightEdge ifTrue:[
+ self drawRightEdge
+ ].
+ self clipRect:innerClipRect
+ ].
+ mustRepaintRight ifTrue:[
+ self redrawX:(oldWidth - margin)
+ y:0
+ width:margin
+ height:height.
+ ].
+ mustRepaintBottom ifTrue:[
+ self redrawX:0
+ y:(oldHeight - margin)
+ width:width
+ height:margin.
+ ].
] ifFalse:[
- "otherwise memorize the need for a sizeChanged message"
-
- width := newWidth.
- height := newHeight.
- sameOrigin ifFalse:[
- originChanged := true.
- ].
- extentChanged := true
+ "otherwise memorize the need for a sizeChanged message"
+
+ width := newWidth.
+ height := newHeight.
+ sameOrigin ifFalse:[
+ originChanged := true.
+ ].
+ extentChanged := true
]
!
+pointFromRelative:p
+ "compute absolute coordinate from p"
+
+ |newX newY rel inRect bw superWidth superHeight superLeft superTop |
+
+ bw := borderWidth.
+
+ superView isNil ifTrue:[
+ superWidth := device width.
+ superHeight := device height.
+ superLeft := superTop := 0.
+ ] ifFalse:[
+ inRect := superView viewRectangle.
+ superWidth := inRect width - bw.
+ superHeight := inRect height - bw.
+ superLeft := inRect left.
+ superTop := inRect top.
+ ].
+
+ rel := p x.
+ rel isInteger ifTrue:[
+ newX := rel
+ ] ifFalse:[
+ newX := (rel * (superWidth + bw)) asInteger + superLeft.
+ (bw ~~ 0) ifTrue:[
+ rel ~= 1.0 ifTrue:[
+ newX := newX - bw
+ ]
+ ]
+ ].
+
+ rel := p y.
+ rel isInteger ifTrue:[
+ newY := rel
+ ] ifFalse:[
+ newY := (rel * (superHeight + bw)) asInteger + superTop.
+ (bw ~~ 0) ifTrue:[
+ rel ~= 1.0 ifTrue:[
+ newY := newY - bw
+ ]
+ ]
+ ].
+ ^ newX @ newY
+!
+
originFromRelativeOrigin
"compute pixel origin from relativeOrigin"
+ |newX newY p l t|
+
+ p := self pointFromRelative:relativeOrigin.
+
+ l := t := 0.
+ leftInset notNil ifTrue:[
+ l := leftInset
+ ].
+ topInset notNil ifTrue:[
+ t := topInset
+ ].
+ ((l ~~ 0) or:[t ~~ 0]) ifTrue:[
+ newX := p x.
+ newY := p y.
+ ^ (newX + l) @ (newY + t)
+ ].
+ ^ p
+!
+
+XXoriginFromRelativeOrigin
+ "compute pixel origin from relativeOrigin"
+
|newX newY rel inRect "bw2"|
superView isNil ifTrue:[
- inRect := 0@0 extent:device extent
+ inRect := 0@0 extent:device extent
] ifFalse:[
- inRect := superView viewRectangle.
+ inRect := superView viewRectangle.
].
"
@@ -2214,29 +2391,29 @@
"
rel := relativeOrigin x.
(rel isMemberOf:Float) ifTrue:[
- newX := (rel * (inRect width + borderWidth "bw2")) asInteger + inRect left.
- (borderWidth ~~ 0) ifTrue:[
- newX := newX - borderWidth
- ]
+ newX := (rel * (inRect width + borderWidth "bw2")) asInteger + inRect left.
+ (borderWidth ~~ 0) ifTrue:[
+ newX := newX - borderWidth
+ ]
] ifFalse:[
- newX := rel
+ newX := rel
].
rel := relativeOrigin y.
(rel isMemberOf:Float) ifTrue:[
- newY := (rel * (inRect height + borderWidth "bw2")) asInteger + inRect top.
- (borderWidth ~~ 0) ifTrue:[
- newY := newY - borderWidth
- ]
+ newY := (rel * (inRect height + borderWidth "bw2")) asInteger + inRect top.
+ (borderWidth ~~ 0) ifTrue:[
+ newY := newY - borderWidth
+ ]
] ifFalse:[
- newY := rel
+ newY := rel
].
(leftInset notNil and:[leftInset ~~ 0]) ifTrue:[
- newX := newX + leftInset
+ newX := newX + leftInset
].
(topInset notNil and:[topInset ~~ 0]) ifTrue:[
- newY := newY + topInset
+ newY := newY + topInset
].
^ newX @ newY
!
@@ -2244,12 +2421,35 @@
cornerFromRelativeCorner
"compute pixel corner from relativeCorner"
+ |newX newY p r b bw|
+
+ p := self pointFromRelative:relativeCorner.
+
+ bw := borderWidth.
+ r := b := bw.
+ rightInset notNil ifTrue:[
+ r := rightInset + bw
+ ].
+ bottomInset notNil ifTrue:[
+ b := bottomInset + bw
+ ].
+ ((r ~~ 0) or:[b ~~ 0]) ifTrue:[
+ newX := p x.
+ newY := p y.
+ ^ (newX - r) @ (newY - b)
+ ].
+ ^ p
+!
+
+XXcornerFromRelativeCorner
+ "compute pixel corner from relativeCorner"
+
|rel newX newY inRect "bw2"|
superView isNil ifTrue:[
- inRect := 0@0 extent:device extent
+ inRect := 0@0 extent:device extent
] ifFalse:[
- inRect := superView viewRectangle.
+ inRect := superView viewRectangle.
].
"
@@ -2257,29 +2457,29 @@
"
rel := relativeCorner x.
(rel isMemberOf:Float) ifTrue:[
- newX := (rel * (inRect width" + bw2")) asInteger "+ inRect left".
- (borderWidth ~~ 0) ifTrue:[
- newX := newX - borderWidth
- ]
+ newX := (rel * (inRect width" + bw2")) asInteger "+ inRect left".
+ (borderWidth ~~ 0) ifTrue:[
+ newX := newX - borderWidth
+ ]
] ifFalse:[
- newX := rel
+ newX := rel
].
rel := relativeCorner y.
(rel isMemberOf:Float) ifTrue:[
- newY := (rel * (inRect height" + bw2")) asInteger "+ inRect top".
- (borderWidth ~~ 0) ifTrue:[
- newY := newY - borderWidth
- ]
+ newY := (rel * (inRect height" + bw2")) asInteger "+ inRect top".
+ (borderWidth ~~ 0) ifTrue:[
+ newY := newY - borderWidth
+ ]
] ifFalse:[
- newY := rel
+ newY := rel
].
(rightInset notNil and:[rightInset ~~ 0]) ifTrue:[
- newX := newX - rightInset
+ newX := newX - rightInset
].
(bottomInset notNil and:[bottomInset ~~ 0]) ifTrue:[
- newY := newY - bottomInset
+ newY := newY - bottomInset
].
^ newX @ newY
!
@@ -2290,38 +2490,38 @@
|rel newX newY inRect bw2|
superView isNil ifTrue:[
- inRect := 0@0 extent:device extent
+ inRect := 0@0 extent:device extent
] ifFalse:[
- inRect := superView viewRectangle.
+ inRect := superView viewRectangle.
].
bw2 := borderWidth * 2.
rel := relativeExtent x.
(rel isMemberOf:Float) ifTrue:[
- newX := (rel * (inRect width + bw2)) asInteger + inRect left.
- (borderWidth ~~ 0) ifTrue:[
- newX := newX - borderWidth
- ].
+ newX := (rel * (inRect width + bw2)) asInteger + inRect left.
+ (borderWidth ~~ 0) ifTrue:[
+ newX := newX - borderWidth
+ ].
] ifFalse:[
- newX := rel
+ newX := rel
].
rel := relativeExtent y.
(rel isMemberOf:Float) ifTrue:[
- newY := (rel * (inRect height + bw2)) asInteger + inRect top.
- (borderWidth ~~ 0) ifTrue:[
- newY := newY - borderWidth
- ].
+ newY := (rel * (inRect height + bw2)) asInteger + inRect top.
+ (borderWidth ~~ 0) ifTrue:[
+ newY := newY - borderWidth
+ ].
] ifFalse:[
- newY := rel
+ newY := rel
].
(rightInset notNil and:[rightInset ~~ 0]) ifTrue:[
- newX := newX - rightInset
+ newX := newX - rightInset
].
(bottomInset notNil and:[bottomInset ~~ 0]) ifTrue:[
- newY := newY - bottomInset
+ newY := newY - bottomInset
].
^ newX @ newY
!
@@ -2332,42 +2532,42 @@
|relW relH relX relY winW winH org ext|
superView notNil ifTrue:[
- superView window isNil ifTrue:[
+ superView window isNil ifTrue:[
"
- v := superView.
- (v notNil and:[v window isNil]) whileTrue:[
- v := v superview
- ].
- v notNil ifTrue:[
- w := v window
- ].
+ v := superView.
+ (v notNil and:[v window isNil]) whileTrue:[
+ v := v superview
+ ].
+ v notNil ifTrue:[
+ w := v window
+ ].
"
"
- winW := 1.
- winH := 1
+ winW := 1.
+ winH := 1
"
- winW := superView width.
- winH := superView height.
-
- ] ifFalse:[
- winW := superView window width.
- winH := superView window height
- ].
- relW := (viewport width / winW) asFloat.
- relH := (viewport height / winH) asFloat.
- relX := (viewport left / winW) asFloat.
- relY := (viewport top / winH) asFloat.
- "bad coding style ... misuse other method"
- relativeOrigin := (relX @ relY).
- org := self originFromRelativeOrigin.
- relativeOrigin := nil.
-
- "bad coding style ...misuse other method"
- relativeExtent := (relW @ relH).
- ext := self extentFromRelativeExtent.
- relativeExtent := nil.
-
- self pixelOrigin:org extent:ext.
+ winW := superView width.
+ winH := superView height.
+
+ ] ifFalse:[
+ winW := superView window width.
+ winH := superView window height
+ ].
+ relW := (viewport width / winW) asFloat.
+ relH := (viewport height / winH) asFloat.
+ relX := (viewport left / winW) asFloat.
+ relY := (viewport top / winH) asFloat.
+ "bad coding style ... misuse other method"
+ relativeOrigin := (relX @ relY).
+ org := self originFromRelativeOrigin.
+ relativeOrigin := nil.
+
+ "bad coding style ...misuse other method"
+ relativeExtent := (relW @ relH).
+ ext := self extentFromRelativeExtent.
+ relativeExtent := nil.
+
+ self pixelOrigin:org extent:ext.
]
!
@@ -2377,14 +2577,14 @@
|m2|
(margin ~~ 0) ifTrue:[
- m2 := margin + margin.
- innerClipRect := Rectangle
- left:margin
- top:margin
- width:(width - m2)
- height:(height - m2)
+ m2 := margin + margin.
+ innerClipRect := Rectangle
+ left:margin
+ top:margin
+ width:(width - m2)
+ height:(height - m2)
] ifFalse:[
- innerClipRect := nil
+ innerClipRect := nil
]
!
@@ -2393,6 +2593,27 @@
self computeInnerClip.
self clipRect:innerClipRect
+!
+
+setBorderColor
+ "set my borderColor"
+
+ |id dither|
+
+ drawableId notNil ifTrue:[
+ borderColor := borderColor on:device.
+ id := borderColor colorId.
+ id notNil ifTrue:[
+ device setWindowBorderColor:id in:drawableId
+ ] ifFalse:[
+ dither := borderColor ditherForm.
+ dither notNil ifTrue:[
+ device setWindowBorderPixmap:(dither id) in:drawableId
+ ] ifFalse:[
+ 'bad borderColor' errorPrintNewline
+ ]
+ ]
+ ]
! !
!View methodsFor:'realization'!
@@ -2402,57 +2623,53 @@
"associate colors to device"
- borderColor notNil ifTrue:[
- borderColor := borderColor on:device.
- ].
-"/
-"/ not needed - will be done with 1st draw operation
-"/
-"/ shadowColor notNil ifTrue:[
-"/ shadowColor := shadowColor on:device.
-"/ ].
-"/ lightColor notNil ifTrue:[
-"/ lightColor := lightColor on:device.
-"/ ].
-"/ halfShadowColor notNil ifTrue:[
-"/ halfShadowColor := halfShadowColor on:device.
-"/ ].
-"/ halfLightColor notNil ifTrue:[
-"/ halfLightColor := halfLightColor on:device.
+"/ borderColor notNil ifTrue:[
+"/ borderColor := borderColor on:device.
"/ ].
drawableId := device
- createWindowFor:self
- origin:(left @ top)
- extent:(width @ height)
- minExtent:nil
- maxExtent:nil
- borderWidth:borderWidth
- borderColor:borderColor
- subViewOf:superView
- onTop:(self createOnTop)
- inputOnly:(self inputOnly)
- label:nil
- cursor:cursor
- icon:nil
- iconView:nil.
+ createWindowFor:self
+ origin:(left @ top)
+ extent:(width @ height)
+ minExtent:nil
+ maxExtent:nil
+ borderWidth:borderWidth
+"/ borderColor:borderColor
+ subViewOf:superView
+ onTop:(self createOnTop)
+ inputOnly:(self inputOnly)
+ label:nil
+ cursor:cursor
+ icon:nil
+ iconView:nil.
extentChanged := false.
originChanged := false.
+ borderColor notNil ifTrue:[
+ borderColor ~~ Black ifTrue:[
+ borderColor := borderColor on:device.
+ self setBorderColor
+ ]
+ ].
+ (viewGravity notNil and:[viewGravity ~~ #NorthWest]) ifTrue:[
+ device setWindowGravity:viewGravity in:drawableId
+ ].
+ (bitGravity notNil and:[bitGravity ~~ #NorthWest]) ifTrue:[
+ device setBitGravity:bitGravity in:drawableId
+ ].
borderShape notNil ifTrue:[
- device setWindowBorderShape:(borderShape id) in:drawableId
+ device setWindowBorderShape:(borderShape id) in:drawableId
].
viewShape notNil ifTrue:[
- device setWindowShape:(viewShape id) in:drawableId
+ device setWindowShape:(viewShape id) in:drawableId
].
(backed notNil and:[backed ~~ false]) ifTrue:[
- device setBackingStore:backed in:drawableId
+ device setBackingStore:backed in:drawableId
].
saveUnder ifTrue:[
- device setSaveUnder:true in:drawableId
+ device setSaveUnder:true in:drawableId
].
-"/ font := font on:device.
!
create
@@ -2461,12 +2678,12 @@
realizing means XMapWindow"
drawableId isNil ifTrue:[
- "
- make certain that superview is created also
- "
- superView notNil ifTrue:[
+ "
+ make certain that superview is created also
+ "
+ superView notNil ifTrue:[
"/ superView id isNil ifTrue:[
- superView create.
+ superView create.
"/ ].
"/ "and put my controller into the superviews controller list"
@@ -2475,18 +2692,25 @@
"/ controller manager:(superView controller manager)
"/ ]
"/ ]
- ].
-
- cursor := cursor on:device.
-
- self physicalCreate.
-
- viewBackground notNil ifTrue:[
- self setViewBackground
- ].
-
- self initializeMiddleButtonMenu.
- self initEvents.
+ ].
+
+ cursor := cursor on:device.
+
+ self physicalCreate.
+
+ viewBackground notNil ifTrue:[
+ self setViewBackground
+ ].
+
+ self initializeMiddleButtonMenu.
+ self initEvents.
+
+ "
+ this is the first create,
+ force sizechange messages to be sent to the view
+ "
+ extentChanged := true.
+ originChanged := true
]
!
@@ -2494,19 +2718,19 @@
"recreate (i.e. tell X about me) after a snapin"
drawableId isNil ifTrue:[
- super recreate.
- self physicalCreate.
-
- viewBackground notNil ifTrue:[
- self setViewBackground
- ].
-
- "
- XXX has to be changed: eventmasks are device specific -
- XXX will not allow restart on another Workstation-type.
- XXX event masks must become symbolic
- "
- device setEventMask:eventMask in:drawableId
+ super recreate.
+ self physicalCreate.
+
+ viewBackground notNil ifTrue:[
+ self setViewBackground
+ ].
+
+ "
+ XXX has to be changed: eventmasks are device specific -
+ XXX will not allow restart on another Workstation-type.
+ XXX event masks must become symbolic
+ "
+ device setEventMask:eventMask in:drawableId
]
!
@@ -2515,7 +2739,7 @@
drawableId isNil ifTrue:[self create].
subViews notNil ifTrue:[
- subViews do:[:subView | subView createWithAllSubViews]
+ subViews do:[:subView | subView createWithAllSubViews]
]
!
@@ -2531,24 +2755,24 @@
block extent; also set origin"
window notNil ifTrue:[
- ^ self superViewChangedSize
+ ^ self superViewChangedSize
].
"if the extent is not the one we created the window with ..."
extentChanged ifTrue:[
- self sizeChanged:nil.
- extentChanged := false
+ self sizeChanged:nil.
+ extentChanged := false
].
originChanged ifTrue:[
- originRule notNil ifTrue:[
- self pixelOrigin:(originRule value)
- ] ifFalse:[
- relativeOrigin notNil ifTrue:[
- self originFromRelativeOrigin
- ]
- ].
- originChanged := false
+ originRule notNil ifTrue:[
+ self pixelOrigin:(originRule value)
+ ] ifFalse:[
+ relativeOrigin notNil ifTrue:[
+ self originFromRelativeOrigin
+ ]
+ ].
+ originChanged := false
]
!
@@ -2560,57 +2784,51 @@
|superGroup groupChange|
drawableId isNil ifTrue:[
- self create.
-
- "
- this is the first realize (which means a create),
- force sizechange messages to be sent to the view
- "
- extentChanged := true.
- originChanged := true
+ self create.
].
"
put myself into superviews windowgroup if there is a superview
"
+ groupChange := false.
superView notNil ifTrue:[
- windowGroup notNil ifTrue:[
+ windowGroup notNil ifTrue:[
"/ 'oops - wgroup change on realize' printNewline.
- windowGroup removeView:self.
- windowGroup := nil
- ].
- superGroup := superView windowGroup.
- superGroup ~~ windowGroup ifTrue:[
- groupChange := true.
- windowGroup := superGroup.
- windowGroup notNil ifTrue:[
- windowGroup addView:self.
- ]
- ]
+ windowGroup removeView:self.
+ windowGroup := nil
+ ].
+ superGroup := superView windowGroup.
+ superGroup ~~ windowGroup ifTrue:[
+ groupChange := true.
+ windowGroup := superGroup.
+ windowGroup notNil ifTrue:[
+ windowGroup addView:self.
+ ]
+ ]
].
hidden ifTrue:[
- ^ self
+ ^ self
].
"/ realized ifFalse:[
(originChanged or:[extentChanged]) ifTrue:[self fixSize].
(realized not or:[groupChange]) ifTrue:[
- subViews notNil ifTrue:[
- subViews do:[:subView |
- subView realize
- ]
- ].
+ subViews notNil ifTrue:[
+ subViews do:[:subView |
+ subView realize
+ ]
+ ].
].
self setInnerClip.
realized ifFalse:[
- "
- now, make the view visible
- "
- device mapWindow:drawableId.
- realized := true
+ "
+ now, make the view visible
+ "
+ device mapWindow:drawableId.
+ realized := true
]
!
@@ -2620,38 +2838,31 @@
|superGroup groupChange|
drawableId isNil ifTrue:[
- self create.
-
- "
- this is the first realize (which means a create),
- force sizechange messages to be sent to the view
- "
- extentChanged := true.
- originChanged := true
+ self create.
].
hidden ifTrue:[
- ^ self
+ ^ self
].
"/ realized ifFalse:[
(originChanged or:[extentChanged]) ifTrue:[self fixSize].
(realized not) ifTrue:[
- subViews notNil ifTrue:[
- subViews do:[:subView |
- subView realize
- ]
- ].
+ subViews notNil ifTrue:[
+ subViews do:[:subView |
+ subView realize
+ ]
+ ].
].
self setInnerClip.
realized ifFalse:[
- "
- now, make the view visible
- "
- device mapWindow:drawableId.
- realized := true
+ "
+ now, make the view visible
+ "
+ device mapWindow:drawableId.
+ realized := true
]
!
@@ -2659,13 +2870,13 @@
"rerealize at old position"
drawableId notNil ifTrue:[
- subViews notNil ifTrue:[
- subViews do:[:aView |
- aView realize
- ]
- ].
- device mapView:self id:drawableId iconified:false
- atX:left y:top width:width height:height
+ subViews notNil ifTrue:[
+ subViews do:[:aView |
+ aView realize
+ ]
+ ].
+ device mapView:self id:drawableId iconified:false
+ atX:left y:top width:width height:height
]
!
@@ -2676,38 +2887,38 @@
|subs|
realized ifTrue:[
- self unrealize.
- "make it go away immediately
- - also, this hides the subview killing"
+ self unrealize.
+ "make it go away immediately
+ - also, this hides the subview killing"
"
- device synchronizeOutput.
+ device synchronizeOutput.
"
].
model notNil ifTrue:[
- model removeDependent:self
+ model removeDependent:self
].
controller := nil.
subs := subViews.
subs notNil ifTrue:[
- "stupid: destroy removes itself from the subview list
- - therefore we have to loop over a copy here"
-
- subViews := nil.
- subs do:[:aView |
- aView notNil ifTrue:[aView destroy]
- ]
+ "stupid: destroy removes itself from the subview list
+ - therefore we have to loop over a copy here"
+
+ subViews := nil.
+ subs do:[:aView |
+ aView notNil ifTrue:[aView destroy]
+ ]
].
superView notNil ifTrue:[
- superView removeSubView:self.
- superView := nil
+ superView removeSubView:self.
+ superView := nil
].
super destroy.
windowGroup notNil ifTrue:[
- windowGroup removeView:self.
- windowGroup := nil
+ windowGroup removeView:self.
+ windowGroup := nil
].
!
@@ -2715,11 +2926,11 @@
"hide me"
realized ifTrue:[
- drawableId notNil ifTrue:[
- device unmapWindow:drawableId
- ].
- realized := false.
- shown := false
+ drawableId notNil ifTrue:[
+ device unmapWindow:drawableId
+ ].
+ realized := false.
+ shown := false
]
!
@@ -2739,13 +2950,13 @@
parallel."
ProcessorScheduler isPureEventDriven ifFalse:[
- windowGroup isNil ifTrue:[
- windowGroup := WindowGroup new.
- windowGroup addTopView:self.
- ].
- windowGroup startup.
+ windowGroup isNil ifTrue:[
+ windowGroup := WindowGroup new.
+ windowGroup addTopView:self.
+ ].
+ windowGroup startup.
] ifTrue:[
- self realize
+ self realize
]
!
@@ -2766,22 +2977,22 @@
however, other views (in their groups) still work."
(Processor activePriority > Processor userSchedulingPriority) ifFalse:[
- "
- create a new window group and put myself into it
- "
- windowGroup := WindowGroup new.
- windowGroup addTopView:self.
- "
- go dispatch events in this new group
- (thus current windowgroup is blocked from interaction)
- "
- (Object abortSignal catch:[
- windowGroup startupModal:[realized and:aBlock]
- ]) ifTrue:[
- self hide
- ].
+ "
+ create a new window group and put myself into it
+ "
+ windowGroup := WindowGroup new.
+ windowGroup addTopView:self.
+ "
+ go dispatch events in this new group
+ (thus current windowgroup is blocked from interaction)
+ "
+ (Object abortSignal catch:[
+ windowGroup startupModal:[realized and:aBlock]
+ ]) ifTrue:[
+ self hide
+ ].
] ifTrue:[
- self realize
+ self realize
]
!
@@ -2789,26 +3000,43 @@
"create and schedule a new windowgroup for me and open the view.
The view will be handled by its own process, effectively running in
parallel. This entry is for non-topviews, which want to be served
- autonomous from the topview."
+ autonomous from the topview. (see the fileBrowsers kill-button
+ when executing unix commands as an example)"
|wg|
ProcessorScheduler isPureEventDriven ifFalse:[
- wg := WindowGroup new.
- self windowGroup:wg.
- wg addView:self.
- wg startup.
- self realizeInGroup.
+ wg := WindowGroup new.
+ self windowGroup:wg.
+ wg addView:self.
+ wg startup.
+ self realizeInGroup.
] ifTrue:[
- self realize
+ self realize
]
! !
+!View methodsFor:'user notification'!
+
+warn:aString
+ "like Objects warn, but translates the string via the
+ resourcePack, thus giving a translated string automatically"
+
+ super warn:(resources string:aString)
+!
+
+warn:aString with:argument
+ "like Objects warn, but translates the string via the
+ resourcePack, thus giving a translated string automatically"
+
+ super warn:(resources string:aString with:argument)
+! !
+
!View methodsFor:'drawing'!
drawEdgesForX:x y:y width:w height:h level:l
- shadow:shadowColor light:lightColor
- halfShadow:halfShadowColor halfLight:halfLightColor
+ shadow:shadowColor light:lightColor
+ halfShadow:halfShadowColor halfLight:halfLightColor
"draw 3D edges into a rectangle"
|topLeftFg botRightFg topLeftHalfFg botRightHalfFg
@@ -2820,17 +3048,17 @@
run |
(l < 0) ifTrue:[
- topLeftFg := shadowColor.
- botRightFg := lightColor.
- topLeftHalfFg := halfShadowColor.
- botRightHalfFg := halfLightColor.
- count := l negated
+ topLeftFg := shadowColor.
+ botRightFg := lightColor.
+ topLeftHalfFg := halfShadowColor.
+ botRightHalfFg := halfLightColor.
+ count := l negated
] ifFalse:[
- topLeftFg := lightColor.
- botRightFg := shadowColor.
- topLeftHalfFg := halfLightColor.
- botRightHalfFg := halfShadowColor.
- count := l
+ topLeftFg := lightColor.
+ botRightFg := shadowColor.
+ topLeftHalfFg := halfLightColor.
+ botRightHalfFg := halfShadowColor.
+ count := l
].
r := x + w - 1. "right"
b := y + h - 1. "bottom"
@@ -2839,50 +3067,55 @@
"top and left edges"
(softEdge and:[l > 0]) ifTrue:[
- super paint:topLeftHalfFg
+ super paint:topLeftHalfFg
] ifFalse:[
- super paint:topLeftFg
+ super paint:topLeftFg
].
0 to:(count - 1) do:[:i |
- run := y + i.
- super displayLineFromX:x y:run toX:r y:run. "top"
- run := x + i.
- super displayLineFromX:run y:y toX:run y:b "left"
+ run := y + i.
+ super displayLineFromX:x y:run toX:r y:run. "top"
+ run := x + i.
+ super displayLineFromX:run y:y toX:run y:b "left"
].
softEdge ifTrue:[
"
- super paint:topLeftFg.
- super displayLineFromX:x y:y toX:r y:y.
- super displayLineFromX:x y:y toX:x y:b
+ super paint:topLeftFg.
+ super displayLineFromX:x y:y toX:r y:y.
+ super displayLineFromX:x y:y toX:x y:b
"
- (l > 2) ifTrue:[
- super paint:Black.
- super displayLineFromX:x y:y toX:r y:y.
- super displayLineFromX:x y:y toX:x y:b.
- ]
+ (l > 2) ifTrue:[
+ super paint:Black.
+ super displayLineFromX:x y:y toX:r y:y.
+ super displayLineFromX:x y:y toX:x y:b.
+ ]
].
xi := x + 1.
yi := y + 1.
+"/ does not look good
+"/ style == #st80 iftrue:[
+"/ yi := yi + 1
+"/ ].
+
"bottom and right edges"
(softEdge) ifTrue:[
- super paint:botRightHalfFg
+ super paint:botRightHalfFg
] ifFalse:[
- super paint:botRightFg
+ super paint:botRightFg
].
0 to:(count - 1) do:[:i |
- run := b - i.
- super displayLineFromX:xi-1 y:run toX:r y:run. "bottom"
- run := r - i.
- super displayLineFromX:run y:yi-1 toX:run y:b. "right"
- xi := xi + 1.
- yi := yi + 1
+ run := b - i.
+ super displayLineFromX:xi-1 y:run toX:r y:run. "bottom"
+ run := r - i.
+ super displayLineFromX:run y:yi-1 toX:run y:b. "right"
+ xi := xi + 1.
+ yi := yi + 1
].
(softEdge and:[l > 1]) ifTrue:[
- super paint:Black "shadowColor".
- super displayLineFromX:(x + 1-1) y:b toX:r y:b.
- super displayLineFromX:r y:(y + 1 - 1) toX:r y:b
+ super paint:Black "shadowColor".
+ super displayLineFromX:(x + 1-1) y:b toX:r y:b.
+ super displayLineFromX:r y:(y + 1 - 1) toX:r y:b
]
!
@@ -2890,8 +3123,8 @@
"draw 3D edges into a rectangle"
self drawEdgesForX:x y:y width:w height:h level:l
- shadow:shadowColor light:lightColor
- halfShadow:halfShadowColor halfLight:halfLightColor
+ shadow:shadowColor light:lightColor
+ halfShadow:halfShadowColor halfLight:halfLightColor
!
drawLeftEdge
@@ -2901,27 +3134,27 @@
count "{ Class: SmallInteger }" |
(level < 0) ifTrue:[
- leftFg := shadowColor.
- leftHalfFg := halfShadowColor.
- count := level negated
+ leftFg := shadowColor.
+ leftHalfFg := halfShadowColor.
+ count := level negated
] ifFalse:[
- leftFg := lightColor.
- leftHalfFg := halfLightColor.
- count := level
+ leftFg := lightColor.
+ leftHalfFg := halfLightColor.
+ count := level
].
super lineWidth:0.
(softEdge and:[level > 0]) ifTrue:[
- super paint:leftHalfFg
+ super paint:leftHalfFg
] ifFalse:[
- super paint:leftFg
+ super paint:leftFg
].
0 to:(count - 1) do:[:i |
- super displayLineFromX:i y:i toX:i y:(height - 1 - i)
+ super displayLineFromX:i y:i toX:i y:(height - 1 - i)
].
(softEdge and:[level > 2]) ifTrue:[
- super paint:Black.
- super displayLineFromX:0 y:0 toX:0 y:height-1.
+ super paint:Black.
+ super displayLineFromX:0 y:0 toX:0 y:height-1.
]
!
@@ -2933,26 +3166,26 @@
r|
(level < 0) ifTrue:[
- rightFg := lightColor.
- count := level negated
+ rightFg := lightColor.
+ count := level negated
] ifFalse:[
- (softEdge and:[level > 1]) ifTrue:[
- rightFg := halfShadowColor
- ] ifFalse:[
- rightFg := shadowColor
- ].
- count := level
+ (softEdge and:[level > 1]) ifTrue:[
+ rightFg := halfShadowColor
+ ] ifFalse:[
+ rightFg := shadowColor
+ ].
+ count := level
].
super lineWidth:0.
super paint:rightFg.
0 to:(count - 1) do:[:i |
- r := width - 1 - i.
- super displayLineFromX:r y:i toX:r y:(height - 1 - i)
+ r := width - 1 - i.
+ super displayLineFromX:r y:i toX:r y:(height - 1 - i)
].
(softEdge and:[level > 1]) ifTrue:[
- super paint:shadowColor.
- super displayLineFromX:width-1 y:1 toX:width-1 y:height-1.
+ super paint:shadowColor.
+ super displayLineFromX:width-1 y:1 toX:width-1 y:height-1.
]
!
@@ -2963,27 +3196,27 @@
count "{ Class: SmallInteger }" |
(level < 0) ifTrue:[
- topFg := shadowColor.
- topHalfFg := halfShadowColor.
- count := level negated
+ topFg := shadowColor.
+ topHalfFg := halfShadowColor.
+ count := level negated
] ifFalse:[
- topFg := lightColor.
- topHalfFg := halfLightColor.
- count := level
+ topFg := lightColor.
+ topHalfFg := halfLightColor.
+ count := level
].
super lineWidth:0.
(softEdge and:[level > 0]) ifTrue:[
- super paint:topHalfFg
+ super paint:topHalfFg
] ifFalse:[
- super paint:topFg
+ super paint:topFg
].
0 to:(count - 1) do:[:i |
- super displayLineFromX:i y:i toX:(width - 1 - i) y:i
+ super displayLineFromX:i y:i toX:(width - 1 - i) y:i
].
(softEdge and:[level > 2]) ifTrue:[
- super paint:Black.
- super displayLineFromX:0 y:0 toX:width-1 y:0.
+ super paint:Black.
+ super displayLineFromX:0 y:0 toX:width-1 y:0.
]
!
@@ -2995,26 +3228,26 @@
b|
(level < 0) ifTrue:[
- botFg := lightColor.
- count := level negated
+ botFg := lightColor.
+ count := level negated
] ifFalse:[
- (softEdge and:[level > 1]) ifTrue:[
- botFg := halfShadowColor
- ] ifFalse:[
- botFg := shadowColor
- ].
- count := level
+ (softEdge and:[level > 1]) ifTrue:[
+ botFg := halfShadowColor
+ ] ifFalse:[
+ botFg := shadowColor
+ ].
+ count := level
].
super lineWidth:0.
super paint:botFg.
0 to:(count - 1) do:[:i |
- b := height - 1 - i.
- super displayLineFromX:i y:b toX:(width "- 1" - i) y:b
+ b := height - 1 - i.
+ super displayLineFromX:i y:b toX:(width "- 1" - i) y:b
].
(softEdge and:[level > 1]) ifTrue:[
- super paint:shadowColor.
- super displayLineFromX:1 y:height-1 toX:width-1 y:height-1.
+ super paint:shadowColor.
+ super displayLineFromX:1 y:height-1 toX:width-1 y:height-1.
]
!
@@ -3022,13 +3255,13 @@
"redraw my edges if 3D"
" self is3D ifTrue:[ "
- (level ~~ 0) ifTrue:[
- self clipRect:nil.
- self drawEdgesForX:0 y:0
- width:width height:height
- level:level.
- self clipRect:innerClipRect
- ]
+ (level ~~ 0) ifTrue:[
+ self clipRect:nil.
+ self drawEdgesForX:0 y:0
+ width:width height:height
+ level:level.
+ self clipRect:innerClipRect
+ ]
" ] "
!
@@ -3038,7 +3271,7 @@
otherwise we cannot do much here - has to be redefined in subclasses"
model notNil ifTrue:[
- model update:self
+ model update:self
]
!
@@ -3050,20 +3283,20 @@
area := Rectangle left:x top:y width:w height:h.
self clippedTo:area do:[
- controller notNil ifTrue:[
- "ST-80 updating"
- self update:#rectangle with:area
- ] ifFalse:[
- components notNil ifTrue:[
- components do:[:aComponent |
- (aComponent frame intersects:area) ifTrue:[
- aComponent drawIn:self offset:0@0
- ]
- ]
- ] ifFalse:[
- self redraw
- ]
- ]
+ controller notNil ifTrue:[
+ "ST-80 updating"
+ self update:#rectangle with:area
+ ] ifFalse:[
+ components notNil ifTrue:[
+ components do:[:aComponent |
+ (aComponent frame intersects:area) ifTrue:[
+ aComponent drawIn:self offset:0@0
+ ]
+ ]
+ ] ifFalse:[
+ self redraw
+ ]
+ ]
]
! !
@@ -3101,22 +3334,24 @@
How is either #smaller, #larger or nil, and controls the order,
in which subviews are notified (possibly reducing redraw activity)"
- transformation := nil. "transformation becomes void"
+ window notNil ifTrue:[
+ "compute new transformation"
+ ].
subViews notNil ifTrue:[
- (how isNil or:[how == #smaller]) ifTrue:[
- subViews do:[:view |
- view superViewChangedSize
- ]
- ] ifFalse:[
- "doing it reverse speeds up resizing - usually subviews
- are created from top-left to bottom-right; therefore
- bottom-right views will be moved/resized first, then top-left ones;
- this avoids multiple redraws of subviews"
-
- subViews reverseDo:[:view |
- view superViewChangedSize
- ]
- ]
+ (how isNil or:[how == #smaller]) ifTrue:[
+ subViews do:[:view |
+ view superViewChangedSize
+ ]
+ ] ifFalse:[
+ "doing it reverse speeds up resizing - usually subviews
+ are created from top-left to bottom-right; therefore
+ bottom-right views will be moved/resized first, then top-left ones;
+ this avoids multiple redraws of subviews"
+
+ subViews reverseDo:[:view |
+ view superViewChangedSize
+ ]
+ ]
]
!
@@ -3134,88 +3369,90 @@
oldLeft := left.
viewport notNil ifTrue:[
- "if this view has a viewPort, resize a la st-80"
- superView isNil ifTrue:[^ self].
- winSuper := superView window.
- winSuper isNil ifTrue:[
- "take pixel size as window"
- winSuper := 0@0 extent:(superView width@superView height)
- ].
-
- superWidth := superView width.
- superHeight := superView height.
- superWinWidth := winSuper width.
- superWinHeight := winSuper height.
- newLeft := (viewport left - winSuper left) * superWidth // superWinWidth.
- newTop := (viewport top - winSuper top) * superHeight // superWinHeight.
- newWidth := superWidth * viewport width // superWinWidth.
- newHeight := superHeight * viewport height // superWinHeight.
- self pixelOrigin:(newLeft @ newTop).
- self pixelExtent:(newWidth @ newHeight).
- ^ self
+ "
+ if this view has a viewPort, resize a la st-80
+ "
+ superView isNil ifTrue:[^ self].
+ winSuper := superView window.
+ winSuper isNil ifTrue:[
+ "take pixel size as window"
+ winSuper := 0@0 extent:(superView width@superView height)
+ ].
+
+ superWidth := superView width.
+ superHeight := superView height.
+ superWinWidth := winSuper width.
+ superWinHeight := winSuper height.
+ newLeft := (viewport left - winSuper left) * superWidth // superWinWidth.
+ newTop := (viewport top - winSuper top) * superHeight // superWinHeight.
+ newWidth := superWidth * viewport width // superWinWidth.
+ newHeight := superHeight * viewport height // superWinHeight.
+ self pixelOrigin:(newLeft @ newTop).
+ self pixelExtent:(newWidth @ newHeight).
+ ^ self
].
(originRule notNil) ifTrue:[
- newOrg := originRule value
+ newOrg := originRule value
] ifFalse:[
- (relativeOrigin notNil) ifTrue:[
- newOrg := self originFromRelativeOrigin.
- ]
+ (relativeOrigin notNil) ifTrue:[
+ newOrg := self originFromRelativeOrigin.
+ ]
].
(cornerRule notNil) ifTrue:[
- newCorner := cornerRule value
+ newCorner := cornerRule value
] ifFalse:[
- (relativeCorner notNil) ifTrue:[
- newCorner := self cornerFromRelativeCorner
- ] ifFalse:[
- (extentRule notNil) ifTrue:[
- newExt := extentRule value
- ] ifFalse:[
- (relativeExtent notNil) ifTrue:[
- newExt := self extentFromRelativeExtent
- ]
- ].
- ]
+ (relativeCorner notNil) ifTrue:[
+ newCorner := self cornerFromRelativeCorner
+ ] ifFalse:[
+ (extentRule notNil) ifTrue:[
+ newExt := extentRule value
+ ] ifFalse:[
+ (relativeExtent notNil) ifTrue:[
+ newExt := self extentFromRelativeExtent
+ ]
+ ].
+ ]
].
newOrg notNil ifTrue:[
- ((newOrg x == oldLeft) and:[newOrg y == oldTop]) ifTrue:[
- newOrg := nil
- ]
+ ((newOrg x == oldLeft) and:[newOrg y == oldTop]) ifTrue:[
+ newOrg := nil
+ ]
].
newCorner notNil ifTrue:[
- (newCorner = self corner) ifTrue:[
- newCorner := nil
- ] ifFalse:[
- self corner isNil ifTrue:[
- newExt notNil ifTrue:[
- ((newExt x == oldWidth) and:[newExt y == oldHeight]) ifTrue:[
- newExt := nil
- ]
- ].
- ]
- ]
+ (newCorner = self corner) ifTrue:[
+ newCorner := nil
+ ] ifFalse:[
+ self corner isNil ifTrue:[
+ newExt notNil ifTrue:[
+ ((newExt x == oldWidth) and:[newExt y == oldHeight]) ifTrue:[
+ newExt := nil
+ ]
+ ].
+ ]
+ ]
].
newCorner isNil ifTrue:[
- newExt isNil ifTrue:[
- newOrg notNil ifTrue:[
- self pixelOrigin:newOrg
- ]
- ] ifFalse:[
- newOrg isNil ifTrue:[
- self pixelExtent:newExt
- ] ifFalse:[
- self pixelOrigin:newOrg extent:newExt
- ]
- ]
+ newExt isNil ifTrue:[
+ newOrg notNil ifTrue:[
+ self pixelOrigin:newOrg
+ ]
+ ] ifFalse:[
+ newOrg isNil ifTrue:[
+ self pixelExtent:newExt
+ ] ifFalse:[
+ self pixelOrigin:newOrg extent:newExt
+ ]
+ ]
] ifFalse:[
- newOrg isNil ifTrue:[
- self pixelCorner:newCorner
- ] ifFalse:[
- self pixelOrigin:newOrg corner:newCorner
- ]
+ newOrg isNil ifTrue:[
+ self pixelCorner:newCorner
+ ] ifFalse:[
+ self pixelOrigin:newOrg corner:newCorner
+ ]
]
!
@@ -3227,46 +3464,51 @@
left := x.
top := y.
((width ~~ newWidth) or:[height ~~ newHeight]) ifTrue:[
- realized ifFalse:[
- width := newWidth.
- height := newHeight.
- extentChanged := true.
- ^ self
- ].
-
- ((newWidth <= width) and:[newHeight <= height]) ifTrue:[
- how := #smaller
- ].
-
- level ~~ 0 "self is3D" ifTrue:[
- mustRedrawBottomEdge := newHeight < height.
- mustRedrawRightEdge := newWidth < width.
- anyEdge := mustRedrawBottomEdge or:[mustRedrawRightEdge]
- ] ifFalse:[
- anyEdge := false
- ].
-
- width := newWidth.
- height := newHeight.
-
- "recompute inner-clip if needed"
- self setInnerClip.
-
- self sizeChanged:how.
-
- (anyEdge and:[shown]) ifTrue:[
- self clipRect:nil.
- mustRedrawBottomEdge ifTrue:[
- self drawBottomEdge
- ].
- mustRedrawRightEdge ifTrue:[
- self drawRightEdge
- ].
- self clipRect:innerClipRect
- ]
+ realized ifFalse:[
+ width := newWidth.
+ height := newHeight.
+ extentChanged := true.
+ ^ self
+ ].
+
+ ((newWidth <= width) and:[newHeight <= height]) ifTrue:[
+ how := #smaller
+ ].
+
+ level ~~ 0 "self is3D" ifTrue:[
+ mustRedrawBottomEdge := newHeight < height.
+ mustRedrawRightEdge := newWidth < width.
+ anyEdge := mustRedrawBottomEdge or:[mustRedrawRightEdge]
+ ] ifFalse:[
+ anyEdge := false
+ ].
+
+ width := newWidth.
+ height := newHeight.
+
+ "recompute inner-clip if needed"
+ self setInnerClip.
+
+ self sizeChanged:how.
+
+ (anyEdge and:[shown]) ifTrue:[
+ self clipRect:nil.
+ mustRedrawBottomEdge ifTrue:[
+ self drawBottomEdge
+ ].
+ mustRedrawRightEdge ifTrue:[
+ self drawRightEdge
+ ].
+ self clipRect:innerClipRect
+ ]
]
!
+coveredBy:aView
+ "the receiver has been covered by another view;
+ we are not interrested in tha here (but see modalBox for more)."
+!
+
mapped
"the view has been mapped (by some outside
action - i.e. window manager de-iconified me)"
@@ -3277,7 +3519,7 @@
to force a redraw here to get things drawn into
backing store"
backed ifTrue:[
- self redraw
+ self redraw
]
!
@@ -3288,6 +3530,18 @@
shown := false
!
+visibilityChange:how
+ "the visibility of the view has changed (by some outside
+ action - i.e. window manager rearranged things).
+ Using this knowledge avoids useless redraw in obsucred views."
+
+ how == #fullyObscured ifTrue:[
+ shown := false
+ ] ifFalse:[
+ shown := true.
+ ]
+!
+
reparented
"the view has changed its parent by some outside
action - i.e. window manager has added a frame.
@@ -3312,32 +3566,32 @@
"check if there is a need to draw an edge"
(margin ~~ 0) ifTrue:[
- leftEdge := false.
- topEdge := false.
- rightEdge := false.
- botEdge := false.
- (x < margin) ifTrue:[
- nx := margin.
- nw := nw - (nx - x).
- leftEdge := true.
- anyEdge := true
- ].
- ((x + w - 1) >= (width - margin)) ifTrue:[
- nw := (width - margin - nx).
- rightEdge := true.
- anyEdge := true
- ].
- (y < margin) ifTrue:[
- ny := margin.
- nh := nh - (ny - y).
- topEdge := true.
- anyEdge := true
- ].
- ((y + h - 1) >= (height - margin)) ifTrue:[
- nh := (height - margin - ny).
- botEdge := true.
- anyEdge := true
- ]
+ leftEdge := false.
+ topEdge := false.
+ rightEdge := false.
+ botEdge := false.
+ (x < margin) ifTrue:[
+ nx := margin.
+ nw := nw - (nx - x).
+ leftEdge := true.
+ anyEdge := true
+ ].
+ ((x + w - 1) >= (width - margin)) ifTrue:[
+ nw := (width - margin - nx).
+ rightEdge := true.
+ anyEdge := true
+ ].
+ (y < margin) ifTrue:[
+ ny := margin.
+ nh := nh - (ny - y).
+ topEdge := true.
+ anyEdge := true
+ ].
+ ((y + h - 1) >= (height - margin)) ifTrue:[
+ nh := (height - margin - ny).
+ botEdge := true.
+ anyEdge := true
+ ]
].
"redraw inside area"
@@ -3347,26 +3601,26 @@
"redraw edge(s)"
anyEdge ifTrue:[
- self clipRect:nil.
- (topEdge and:[leftEdge and:[botEdge and:[rightEdge]]]) ifTrue:[
- self drawEdgesForX:0 y:0
- width:width height:height
- level:level
- ] ifFalse:[
- topEdge ifTrue:[
- self drawTopEdge
- ].
- leftEdge ifTrue:[
- self drawLeftEdge
- ].
- botEdge ifTrue:[
- self drawBottomEdge
- ].
- rightEdge ifTrue:[
- self drawRightEdge
- ]
- ].
- self clipRect:innerClipRect
+ self clipRect:nil.
+ (topEdge and:[leftEdge and:[botEdge and:[rightEdge]]]) ifTrue:[
+ self drawEdgesForX:0 y:0
+ width:width height:height
+ level:level
+ ] ifFalse:[
+ topEdge ifTrue:[
+ self drawTopEdge
+ ].
+ leftEdge ifTrue:[
+ self drawLeftEdge
+ ].
+ botEdge ifTrue:[
+ self drawBottomEdge
+ ].
+ rightEdge ifTrue:[
+ self drawRightEdge
+ ]
+ ].
+ self clipRect:innerClipRect
]
!
@@ -3379,7 +3633,7 @@
allow forwarding events to the keyboardhandler
"
keyboardHandler notNil ifTrue:[
- ^ keyboardHandler keyPress:key x:x y:y
+ ^ keyboardHandler keyPress:key x:x y:y
].
"
@@ -3396,9 +3650,9 @@
thisContext isRecursive ifTrue:[^ self].
superView notNil ifTrue:[
- superView keyPress:key x:x y:y
+ superView keyPress:key x:x y:y
] ifFalse:[
- super keyPress:key x:x y:y
+ super keyPress:key x:x y:y
]
!
@@ -3408,21 +3662,21 @@
|menu menuSelector|
((button == 2) or:[button == #menu]) ifTrue:[
- "
- try ST-80 style menus first:
- if there is a model, and a menuSymbol is defined,
- ask model for the menu and launch that if non-nil.
- "
- (model notNil and:[menuSymbol notNil]) ifTrue:[
- menu := model perform:menuSymbol.
- menu notNil ifTrue:[
- menuSelector := menu startUp.
- menuSelector ~~ 0 ifTrue:[
- model perform:menuSelector
- ]
- ].
- ^ self
- ]
+ "
+ try ST-80 style menus first:
+ if there is a model, and a menuSymbol is defined,
+ ask model for the menu and launch that if non-nil.
+ "
+ (model notNil and:[menuSymbol notNil]) ifTrue:[
+ menu := model perform:menuSymbol.
+ menu notNil ifTrue:[
+ menuSelector := menu startUp.
+ menuSelector ~~ 0 ifTrue:[
+ model perform:menuSelector
+ ]
+ ].
+ ^ self
+ ]
].
super buttonPress:button x:x y:y
! !
@@ -3446,49 +3700,49 @@
ok := ProcessorScheduler isPureEventDriven not.
ok ifTrue:[
- ok := (OperatingSystem getSystemType = 'linux') not.
- ok ifTrue:[
- bitmaps := #('wheel1' 'wheel2' 'wheel3' 'wheel4')
- collect:[:name |
- |f|
-
- f := Form fromFile:(name , '.xbm').
- f isNil ifTrue:[ok := false].
- f
- ].
-
- mask := Form fromFile:'wheelm.xbm'.
- mask isNil ifTrue:[ok := false].
- ].
+ ok := (OperatingSystem getSystemType = 'linux') not.
+ ok ifTrue:[
+ bitmaps := #('wheel1' 'wheel2' 'wheel3' 'wheel4')
+ collect:[:name |
+ |f|
+
+ f := Form fromFile:(name , '.xbm').
+ f isNil ifTrue:[ok := false].
+ f
+ ].
+
+ mask := Form fromFile:'wheelm.xbm'.
+ mask isNil ifTrue:[ok := false].
+ ].
].
ok ifFalse:[
- self cursor:Cursor wait.
- aBlock valueNowOrOnUnwindDo:[
- self cursor:oldCursor
- ]
+ self cursor:Cursor wait.
+ aBlock valueNowOrOnUnwindDo:[
+ self cursor:oldCursor
+ ]
] ifTrue:[
- cursors := bitmaps collect:[:form | (Cursor sourceForm:form
- maskForm:mask
- hotX:8
- hotY:8) on:device].
-
- process := [
- (Delay forSeconds:0.25) wait.
- [true] whileTrue:[
- cursors do:[:curs |
- self cursor:curs.
- (Delay forSeconds:0.05) wait
- ]
- ]
- ] fork.
-
- Processor activeProcess priority:7.
- aBlock valueNowOrOnUnwindDo:[
- Processor activeProcess priority:8.
- process terminate.
- self cursor:oldCursor
- ]
+ cursors := bitmaps collect:[:form | (Cursor sourceForm:form
+ maskForm:mask
+ hotX:8
+ hotY:8) on:device].
+
+ process := [
+ (Delay forSeconds:0.25) wait.
+ [true] whileTrue:[
+ cursors do:[:curs |
+ self cursor:curs.
+ (Delay forSeconds:0.05) wait
+ ]
+ ]
+ ] fork.
+
+ Processor activeProcess priority:7.
+ aBlock valueNowOrOnUnwindDo:[
+ Processor activeProcess priority:8.
+ process terminate.
+ self cursor:oldCursor
+ ]
].
"View new realize showBusyWhile:[700 factorial]"
--- a/ViewStyle.st Mon Oct 10 03:30:48 1994 +0100
+++ b/ViewStyle.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,17 @@
"
ResourcePack subclass:#ViewStyle
- instanceVariableNames:'bgColor fgColor borderWidth'
- classVariableNames:''
- poolDictionaries:''
- category:'System-Support'
+ instanceVariableNames:'name is3D'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Views-Support'
!
ViewStyle comment:'
COPYRIGHT (c) 1994 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/ViewStyle.st,v 1.1 1994-08-05 01:15:24 claus Exp $
+$Header: /cvs/stx/stx/libview/ViewStyle.st,v 1.2 1994-10-10 02:33:46 claus Exp $
'!
!ViewStyle class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,15 +42,17 @@
version
"
-$Header: /cvs/stx/stx/libview/ViewStyle.st,v 1.1 1994-08-05 01:15:24 claus Exp $
+$Header: /cvs/stx/stx/libview/ViewStyle.st,v 1.2 1994-10-10 02:33:46 claus Exp $
"
!
documentation
"
instances of this class keep all view-style specific information.
- For better performance, they cache some heavily used values in extra
- instance variables (basically, they are dictionaries).
+ The current viewStyle is kept in Views-classvariable called 'StyleSheet'
+ and is instantiated with 'View defaultStyle:aStyleSymbol', which reads
+ a stylesheet from a file '<aStyleSymbol>.style' (usually in the 'resources'
+ directory.
"
! !
@@ -61,40 +63,46 @@
|prefs|
- prefs := super fromFile:aFileName directory:'styles'.
+ prefs := self new.
+ (aFileName endsWith:'.style') ifTrue:[
+ prefs at:#name put:(aFileName copyTo:aFileName size - 6)
+ ] ifFalse:[
+ prefs at:#name put:aFileName
+ ].
+ (prefs readFromFile:aFileName directory:'resources') isNil ifTrue:[
+ prefs at:#fileReadFailed put:true
+ ] ifFalse:[
+ prefs at:#fileReadFailed put:false
+ ].
^ prefs
- "ViewStyle fromFile:'motif.style'"
- "ViewStyle fromFile:'normal.style'"
- "ViewStyle fromFile:'iris.style'"
+ "
+ ViewStyle fromFile:'motif.style'
+ ViewStyle fromFile:'normal.style'
+ ViewStyle fromFile:'iris.style'
+ "
! !
!ViewStyle methodsFor:'accessing'!
-backgroundColor
- bgColor notNil ifTrue:[
- ^ bgColor
- ].
- ^ self at:#backgroundColor ifAbsent:[nil]
+at:aKey
+ ^ self at:aKey default:nil
!
-foregroundColor
- fgColor notNil ifTrue:[
- ^ fgColor
+is3D
+ is3D isNil ifTrue:[
+ is3D := self at:#is3D default:false.
].
- ^ self at:#foregroundColor ifAbsent:[nil]
+ ^ is3D
!
-borderWidth
- borderWidth notNil ifTrue:[
- ^ borderWidth
+name
+ name isNil ifTrue:[
+ name := self at:#name default:'noname'.
].
- ^ self at:#borderWidth ifAbsent:[nil]
+ ^ name
!
doesNotUnderstand:aMessage
- ^ self at:(aMessage selector) ifAbsent:[nil]
+ ^ self at:(aMessage selector) default:nil
! !
-
-
-
--- a/WEvent.st Mon Oct 10 03:30:48 1994 +0100
+++ b/WEvent.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,17 @@
"
Object subclass:#WindowEvent
- instanceVariableNames:'view type arguments'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Support'
+ instanceVariableNames:'view type arguments'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Support'
!
WindowEvent comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/Attic/WEvent.st,v 1.6 1994-08-05 01:16:15 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/WEvent.st,v 1.7 1994-10-10 02:33:48 claus Exp $
'!
!WindowEvent class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,15 +42,16 @@
version
"
-$Header: /cvs/stx/stx/libview/Attic/WEvent.st,v 1.6 1994-08-05 01:16:15 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/WEvent.st,v 1.7 1994-10-10 02:33:48 claus Exp $
"
!
documentation
"
Instances of WindowEvent are created for every event coming from
- the graphics device, to be handled by a windowGroup. Usually, they
- are queued by a sensor, and processed in some ebent loop in the window group.
+ the graphics device, to be handled by a windowGroup.
+ Usually, they are queued by a sensor, and processed in some event loop
+ in the window group.
"
! !
@@ -63,6 +64,13 @@
^ (self new) for:aView type:aSymbol arguments:argArray
!
+for:aView type:aSymbol
+ "create and return a new windowEvent for sending
+ aSymbol-message with no arguments to aView"
+
+ ^ (self new) for:aView type:aSymbol arguments:#()
+!
+
damageFor:aView rectangle:aRectangle
"create and return a new damage Event for aRectangle
in aView"
@@ -71,6 +79,20 @@
! !
+!WindowEvent methodsFor:'queries'!
+
+isKeyEvent
+ "return true, if this event is a keyboard event"
+
+ ^ (type == #keyPress:x:y) or:[type == #keyRelease:x:y]
+!
+
+isDamage
+ "return true, if this is a damage event"
+
+ ^ type == #damage
+! !
+
!WindowEvent methodsFor:'accessing'!
view
@@ -79,18 +101,18 @@
^ view
!
+view:aView
+ "set the view, for which the event is for"
+
+ view := aView
+!
+
type
"return the type of the event"
^ type
!
-isDamage
- "return true, if this is a damage event"
-
- ^ type == #damage
-!
-
arguments
"return the arguments of the event"
@@ -118,33 +140,33 @@
|delegate selector|
"/ type == #keyPress:x:y: ifTrue:[
- "/
- "/ send it via the device, which does the key-mapping
- "/
+ "/
+ "/ send it via the device, which does the key-mapping
+ "/
"/ view device sendKeyPress:(arguments at:1)
"/ x:(arguments at:2)
"/ y:(arguments at:3)
"/ to:view
"/ ] ifFalse:[
- delegate := view delegate.
- delegate notNil ifTrue:[
- "what a kludge - sending to delegate needs another
- selector and an additional argument.
- have to edit the selector ..."
+ delegate := view delegate.
+ delegate notNil ifTrue:[
+ "what a kludge - sending to delegate needs another
+ selector and an additional argument.
+ have to edit the selector ..."
- (type endsWith:':') ifTrue:[
- selector := (type , 'view:') asSymbol.
- ] ifFalse:[
- selector := (type , 'View:') asSymbol.
- ].
- arguments isNil ifTrue:[
- delegate perform:selector with:view
- ] ifFalse:[
- delegate perform:selector withArguments:(arguments copyWith:view)
- ]
- ] ifFalse:[
- view perform:type withArguments:arguments
- ]
+ (type endsWith:':') ifTrue:[
+ selector := (type , 'view:') asSymbol.
+ ] ifFalse:[
+ selector := (type , 'View:') asSymbol.
+ ].
+ arguments isNil ifTrue:[
+ delegate perform:selector with:view
+ ] ifFalse:[
+ delegate perform:selector withArguments:(arguments copyWith:view)
+ ]
+ ] ifFalse:[
+ view perform:type withArguments:arguments
+ ]
"/ ]
! !
--- a/WGroup.st Mon Oct 10 03:30:48 1994 +0100
+++ b/WGroup.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,17 @@
"
Object subclass:#WindowGroup
- instanceVariableNames:'views topViews myProcess mySensor isModal previousGroup'
- classVariableNames:'ActiveGroup ScheduledWindowGroups LeaveSignal'
- poolDictionaries:''
- category:'Interface-Support'
+ instanceVariableNames:'views topViews myProcess mySensor isModal previousGroup'
+ classVariableNames:'ActiveGroup ScheduledWindowGroups LeaveSignal'
+ poolDictionaries:''
+ category:'Interface-Support'
!
WindowGroup comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/Attic/WGroup.st,v 1.11 1994-08-22 13:15:31 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/WGroup.st,v 1.12 1994-10-10 02:33:56 claus Exp $
'!
!WindowGroup class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libview/Attic/WGroup.st,v 1.11 1994-08-22 13:15:31 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/WGroup.st,v 1.12 1994-10-10 02:33:56 claus Exp $
"
!
@@ -55,14 +55,21 @@
initialize
LeaveSignal isNil ifTrue:[
- LeaveSignal := (Signal new) mayProceed:true.
- LeaveSignal notifierString:'unhandled leave signal'.
- ScheduledWindowGroups := IdentitySet new.
+ LeaveSignal := (Signal new) mayProceed:true.
+ LeaveSignal nameClass:self message:#leaveSignal.
+ LeaveSignal notifierString:'unhandled leave signal'.
+ "/ ScheduledWindowGroups := IdentitySet new.
].
"WindowGroup initialize"
! !
+!WindowGroup class methodsFor:'signal access'!
+
+leaveSignal
+ ^ LeaveSignal
+! !
+
!WindowGroup class methodsFor:'instance creation'!
new
@@ -95,7 +102,7 @@
"add aView to the windowGroup"
views isNil ifTrue:[
- views := OrderedCollection new.
+ views := OrderedCollection new.
].
views add:aView
!
@@ -104,7 +111,7 @@
"add a topview to the group"
topViews isNil ifTrue:[
- topViews := OrderedCollection new.
+ topViews := OrderedCollection new.
].
topViews add:aView
!
@@ -115,16 +122,16 @@
also shut down the corresponding process"
views notNil ifTrue:[
- views remove:aView ifAbsent:[].
- views isEmpty ifTrue:[
- views := nil
- ]
+ views remove:aView ifAbsent:[].
+ views isEmpty ifTrue:[
+ views := nil
+ ]
].
topViews notNil ifTrue:[
- topViews remove:aView ifAbsent:[].
- topViews isEmpty ifTrue:[
- topViews := nil
- ]
+ topViews remove:aView ifAbsent:[].
+ topViews isEmpty ifTrue:[
+ topViews := nil
+ ]
].
"
wakeup my process to look if last view has been
@@ -170,7 +177,7 @@
g := self.
[g notNil and:[g isModal]] whileTrue:[
- g := g previousGroup
+ g := g previousGroup
].
^ g
!
@@ -194,9 +201,9 @@
"evaluate aBlock for all topviews except aView in this group"
topViews notNil ifTrue:[
- topViews do:[:v |
- v ~~ aView ifTrue:[aBlock value:v]
- ]
+ topViews do:[:v |
+ v ~~ aView ifTrue:[aBlock value:v]
+ ]
].
! !
@@ -209,8 +216,8 @@
c := aCursor.
self allViewsDo:[:aView |
- c := c on:(aView device).
- aView device setCursor:c id in:aView id.
+ c := c on:(aView device).
+ aView device setCursor:c id in:aView id.
].
!
@@ -220,8 +227,8 @@
|c|
self allViewsDo:[:aView |
- c := aView cursor on:(aView device).
- aView device setCursor:(c id) in:(aView id).
+ c := aView cursor on:(aView device).
+ aView device setCursor:(c id) in:(aView id).
].
!
@@ -231,16 +238,22 @@
|oldCursors|
+ "
+ get mapping of view->cursor for all of my subviews
+ "
oldCursors := IdentityDictionary new.
self allViewsDo:[:aView |
- oldCursors at:aView put:(aView cursor).
- aView cursor:aCursor
+ oldCursors at:aView put:(aView cursor).
+ aView cursor:aCursor
].
aBlock valueNowOrOnUnwindDo:[
- oldCursors keysAndValuesDo:[:view :cursor |
- view cursor:cursor
- ]
+ "
+ restore cursors
+ "
+ oldCursors keysAndValuesDo:[:view :cursor |
+ view cursor:cursor
+ ]
]
! !
@@ -250,23 +263,15 @@
"process a single event from either the damage- or user input queues.
Debugger abort brings us back here."
- |event oldActive|
+ |event|
- oldActive := ActiveGroup.
- Object abortSignal handle:[:ex |
- ex return
- ] do:[
- self processExposeEvents.
- [mySensor hasEvents] whileTrue:[
- event := mySensor nextEvent.
- (views isNil and:[topViews isNil]) ifFalse:[
- ActiveGroup := self.
- event sendEvent.
- ActiveGroup := oldActive
- ].
- ].
- ].
- ActiveGroup := oldActive
+ self processExposeEvents.
+ [mySensor hasEvents] whileTrue:[
+ event := mySensor nextEvent.
+ (views isNil and:[topViews isNil]) ifFalse:[
+ event sendEvent.
+ ].
+ ]
!
processExposeEvents
@@ -277,18 +282,18 @@
oldActive := ActiveGroup.
ActiveGroup := self.
[mySensor hasDamage] whileTrue:[
- event := mySensor nextDamage.
- (views isNil and:[topViews isNil]) ifFalse:[
- event isDamage ifTrue:[
- view := event view.
- rect := event rectangle.
- view shown ifTrue:[
- view exposeX:(rect left) y:(rect top) width:(rect width) height:(rect height)
- ]
- ] ifFalse:[
- event sendEvent.
- ]
- ]
+ event := mySensor nextDamage.
+ (views isNil and:[topViews isNil]) ifFalse:[
+ event isDamage ifTrue:[
+ view := event view.
+ rect := event rectangle.
+ view shown ifTrue:[
+ view exposeX:(rect left) y:(rect top) width:(rect width) height:(rect height)
+ ]
+ ] ifFalse:[
+ event sendEvent.
+ ]
+ ]
].
ActiveGroup := oldActive
!
@@ -303,41 +308,60 @@
eventLoopWhile:aBlock
"wait-for and process events while aBlock evaluates to true."
- ScheduledWindowGroups add:self.
- LeaveSignal handle:[:ex |
- ex return
+ "/ ScheduledWindowGroups add:self.
+"/ LeaveSignal
+ (SignalSet with:LeaveSignal with:(Object abortSignal))
+ handle:[:ex |
+ ex return
] do:[
- |p g|
+ |p g oldActive|
- aBlock whileTrue:[
- (views isNil and:[topViews isNil]) ifTrue:[
- ScheduledWindowGroups remove:self ifAbsent:[].
- myProcess notNil ifTrue:[
- p := myProcess.
- myProcess := nil.
- p terminate.
- "not reached - there is no life after death"
- ].
- "
- this is the end of a modal loop
- (not having a private process ...)
- "
- ^ self
- ].
- mySensor eventSemaphore wait.
- self processEvent
- "
- if modal, also check for redraw events in my maingroup
- (this is a kludge, since it only handles exposures there
- when events arrive for myself)
- "
- isModal ifTrue:[
- g := self mainGroup.
- g notNil ifTrue:[g processExposeEvents].
- ]
- ]
+ aBlock whileTrue:[
+ (views isNil and:[topViews isNil]) ifTrue:[
+ "/ ScheduledWindowGroups remove:self ifAbsent:[].
+ myProcess notNil ifTrue:[
+ p := myProcess.
+ myProcess := nil.
+ p terminate.
+ "not reached - there is no life after death"
+ ].
+ "
+ this is the end of a modal loop
+ (not having a private process ...)
+ "
+ ^ self
+ ].
+ Object abortSignal handle:[:ex |
+ ex return
+ ] do:[
+ "
+ if modal, break out of the wait after some time
+ to allow servicing update-events of the blocked
+ windowgroup.
+ "
+ isModal ifTrue:[
+ mySensor eventSemaphore waitWithTimeout:0.2.
+ ] ifFalse:[
+ mySensor eventSemaphore wait.
+ ].
+ oldActive := ActiveGroup.
+ ActiveGroup := self.
+ self processEvent
+ ].
+ ActiveGroup := oldActive.
+
+ "
+ if modal, also check for redraw events in my maingroup
+ (this is a kludge, since it only handles exposures there
+ when events arrive for myself - but at least updates sometimes)
+ "
+ isModal ifTrue:[
+ g := self mainGroup.
+ g notNil ifTrue:[g processExposeEvents].
+ ]
+ ]
].
- ScheduledWindowGroups remove:self ifAbsent:[].
+ "/ ScheduledWindowGroups remove:self ifAbsent:[].
!
waitForExposeFor:aView
@@ -358,12 +382,14 @@
"restart after a snapin."
topViews notNil ifTrue:[
- "
- need a new semaphore, since obsolete processes
- (from out previous live) may still sit on the current semaphore
- "
- mySensor eventSemaphore:Semaphore new.
- self startup
+ "
+ need a new semaphore, since obsolete processes
+ (from our previous live) may still sit on the current semaphore
+ "
+ mySensor eventSemaphore:Semaphore new.
+ isModal ifFalse:[
+ self startup
+ ]
]
!
@@ -376,32 +402,32 @@
previousGroup := nil.
myProcess isNil ifTrue:[
- isModal := false.
- ScheduledWindowGroups add:self.
- myProcess := [
- topViews notNil ifTrue:[
- topViews do:[:aView |
- aView realize
- ].
- ].
- self eventLoopWhile:[true]
- ] forkAt:Processor userSchedulingPriority.
+ isModal := false.
+ "/ ScheduledWindowGroups add:self.
+ myProcess := [
+ topViews notNil ifTrue:[
+ topViews do:[:aView |
+ aView realize
+ ].
+ ].
+ self eventLoopWhile:[true]
+ ] forkAt:Processor userSchedulingPriority.
- (topViews notNil and:[topViews isEmpty not]) ifTrue:[
- "give the handler process a user friendly name"
- nm := topViews first name.
- nm isNil ifTrue:[
- nm := topViews first label.
- ].
- myProcess name:(topViews first name)
- ] ifFalse:[
- myProcess name:'window handler'.
- ].
+ (topViews notNil and:[topViews isEmpty not]) ifTrue:[
+ "give the handler process a user friendly name"
+ nm := topViews first name.
+ nm isNil ifTrue:[
+ nm := topViews first label.
+ ].
+ myProcess name:(topViews first name)
+ ] ifFalse:[
+ myProcess name:'window handler'.
+ ].
- "when the process dies, we have to close-down
- the views as well
- "
- myProcess exitAction:[self closeDownViews]
+ "when the process dies, we have to close-down
+ the views as well
+ "
+ myProcess exitAction:[self closeDownViews]
]
!
@@ -416,7 +442,7 @@
previousGroup := WindowGroup activeGroup.
isModal := true.
topViews do:[:aView |
- aView realize.
+ aView realize.
].
self eventLoopWhile:checkBlock.
!
@@ -425,11 +451,11 @@
"destroy all views associated to this window group"
topViews notNil ifTrue:[
- topViews do:[:aTopView | aTopView destroy]
+ topViews do:[:aTopView | aTopView destroy]
].
views := nil.
topViews := nil.
- ScheduledWindowGroups remove:self ifAbsent:[].
+ "/ ScheduledWindowGroups remove:self ifAbsent:[].
!
shutdown
@@ -440,21 +466,29 @@
self closeDownViews.
myProcess notNil ifTrue:[
- p := myProcess.
- myProcess := nil.
- ScheduledWindowGroups remove:self ifAbsent:[].
- p terminate.
+ p := myProcess.
+ myProcess := nil.
+ "/ ScheduledWindowGroups remove:self ifAbsent:[].
+ p terminate.
]
! !
!WindowGroup methodsFor:'initialization'!
reinitialize
+ "reinitialize the windowgroup after an image restart"
+
"throw away old (zombie) process"
- myProcess := nil.
+ myProcess notNil ifTrue:[
+ "careful: the old processes exitaction must be cleared
+ otherwise, it might do destroy or other actions when it
+ gets finalized ...
+ "
+ myProcess exitAction:nil.
+ myProcess := nil.
+ ].
"throw away old events"
-"/ self initialize
mySensor reinitialize
!
@@ -463,7 +497,8 @@
and an event semaphore"
mySensor := WindowSensor new.
- mySensor eventSemaphore:Semaphore new
+ mySensor eventSemaphore:Semaphore new.
+ isModal := false.
! !
!WindowGroup methodsFor:'printing'!
--- a/WSensor.st Mon Oct 10 03:30:48 1994 +0100
+++ b/WSensor.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,21 +11,21 @@
"
Object subclass:#WindowSensor
- instanceVariableNames:'eventSemaphore damage mouseAndKeyboard
- compressMotionEvents ignoreUserInput
- buttonState exposeEventSemaphore
- catchExpose gotExpose gotOtherEvent
- '
- classVariableNames:'ControlCEnabled'
- poolDictionaries:''
- category:'Interface-Support'
+ instanceVariableNames:'eventSemaphore damage mouseAndKeyboard
+ compressMotionEvents ignoreUserInput
+ buttonState exposeEventSemaphore
+ catchExpose gotExpose gotOtherEvent
+ '
+ classVariableNames:'ControlCEnabled'
+ poolDictionaries:''
+ category:'Interface-Support'
!
WindowSensor comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/Attic/WSensor.st,v 1.11 1994-08-22 13:16:44 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/WSensor.st,v 1.12 1994-10-10 02:34:01 claus Exp $
'!
!WindowSensor class methodsFor:'documentation'!
@@ -33,7 +33,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -46,53 +46,56 @@
version
"
-$Header: /cvs/stx/stx/libview/Attic/WSensor.st,v 1.11 1994-08-22 13:16:44 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/WSensor.st,v 1.12 1994-10-10 02:34:01 claus Exp $
"
!
documentation
"
- Instances of this class keep track of events and damage areas for a group of views.
- All incoming expose rectangles and events (from Workstation) are collected here, until someone
- gets a chance to handle them.
- When adding an expose rectangle, WindowSensor tries to merge the rectangle with the list of
- existing damages to minimize redrawing.
+ Instances of this class keep track of events and damage areas for a group of
+ views. All incoming expose rectangles and events (from Workstation) are
+ collected here, until someone gets a chance to handle them.
+ When adding an expose rectangle, WindowSensor tries to merge the rectangle
+ with the list of existing damages to minimize redrawing.
instance variables:
- eventSemaphore <Semaphore> the semaphore to be signalled when an event
- (or damage) arrives
+ eventSemaphore <Semaphore> the semaphore to be signalled when an event
+ (or damage) arrives
- damage <Collection> collection of damage events
+ damage <Collection> collection of damage events
- mouseAndKeyboard <Collection> collection of user events
+ mouseAndKeyboard <Collection> collection of user events
- compressMotionEvents <Boolean> if true, multiple motion events are
- compressed to one event. If false, each
- event is handled individual.
- (should be set to false when doing free-hand drawing)
+ compressMotionEvents <Boolean> if true, multiple motion events are
+ compressed to one event. If false, each
+ event is handled individual.
+ (should be set to false when doing free-hand drawing)
- ignoreUserInput <Boolean> if true, key & button events are ignored
- (usually set to true by WindowGroup, while a
- modalbox covers a view)
+ ignoreUserInput <Boolean> if true, key & button events are ignored
+ (usually set to true by WindowGroup, while a
+ modalbox covers a view)
- buttonState the current state
+ buttonState the current state (currently unused)
+
+ exposeEventSemaphore <Semaphore> X-special: semaphore to be signalled when
+ expose event arrives after a copyArea.
- exposeEventSemaphore <Semaphore> X-special: semaphore to be signalled when
- expose event arrives after a copyArea.
+ catchExpose <Boolean> true, while waiting for an expose event
+ (after a copyArea)
- catchExpose <Boolean> true, while waiting for an expose event
- (after a copyArea)
+ gotExpose <Boolean> set to true, when an expose event arrives
+ (after a copyarea)
- gotExpose set to true, when an expose event arrives
- (after a copyarea)
+ gotOtherEvent <Boolean> set to true if other events arrive while
+ waiting for expose (after a copyarea).
class variables:
- ControlCEnabled <Boolean> if true (which is the default) Control-C
- will interrupt the process handling the
- view.
- For secure stand-alone applications,
- this can be set to false, in which case
- Control-C does NOT interrupt the process.
+ ControlCEnabled <Boolean> if true (which is the default) Control-C
+ will interrupt the process handling the
+ view.
+ For secure stand-alone applications,
+ this can be set to false, in which case
+ Control-C does NOT interrupt the process.
"
! !
@@ -103,10 +106,9 @@
!
disableControlC
- "
- disable Control-C processing. If enabled,
+ "disable Control-C processing. If enabled,
pressing CNTL-C in a view will interrupt it and bring
- its process into the debugger.
+ its process into the debugger (actually raising signal).
Otherwise, CNTL-C is sent to the view like any other key.
"
@@ -114,10 +116,9 @@
!
enableControlC
- "
- enable Control-C processing. If enabled,
+ "enable Control-C processing. If enabled,
pressing CNTL-C in a view will interrupt it and bring
- its process into the debugger.
+ its process into the debugger (actually raising signal).
Otherwise, CNTL-C is sent to the view like any other key.
"
@@ -144,9 +145,9 @@
sz := damage size.
sz == 0 ifTrue: [
- newEvent := WindowEvent damageFor:aView rectangle:aRectangle.
- damage := OrderedCollection with:newEvent.
- ^ self
+ newEvent := WindowEvent damageFor:aView rectangle:aRectangle.
+ damage := OrderedCollection with:newEvent.
+ ^ self
].
"
@@ -154,13 +155,13 @@
if so, dont add to queue
"
damage do: [:aDamage |
- aDamage notNil ifTrue:[
- aDamage isDamage ifTrue:[
- aDamage view == aView ifTrue:[
- ((aDamage rectangle) contains:aRectangle) ifTrue: [^self]
- ]
- ]
- ].
+ aDamage notNil ifTrue:[
+ aDamage isDamage ifTrue:[
+ aDamage view == aView ifTrue:[
+ ((aDamage rectangle) contains:aRectangle) ifTrue: [^self]
+ ]
+ ]
+ ].
].
"
@@ -169,30 +170,30 @@
"
count := 0.
1 to:sz do:[:i |
- |aDamage|
+ |aDamage|
- aDamage := damage at:i.
- aDamage notNil ifTrue:[
- aDamage isDamage ifTrue:[
- (aDamage view) == aView ifTrue:[
- (aRectangle contains:(aDamage rectangle)) ifTrue: [
- damage at:i put:nil.
- count := count + 1
- ]
- ]
- ]
- ]
+ aDamage := damage at:i.
+ aDamage notNil ifTrue:[
+ aDamage isDamage ifTrue:[
+ (aDamage view) == aView ifTrue:[
+ (aRectangle contains:(aDamage rectangle)) ifTrue: [
+ damage at:i put:nil.
+ count := count + 1
+ ]
+ ]
+ ]
+ ]
].
count > 10 ifTrue: [
- temp := OrderedCollection new:(sz - count + 1).
- index := 1.
- damage do:[:aDamage |
- aDamage notNil ifTrue: [
- temp add: aDamage.
- ]
- ].
- damage := temp
+ temp := OrderedCollection new:(sz - count + 1).
+ index := 1.
+ damage do:[:aDamage |
+ aDamage notNil ifTrue: [
+ temp add: aDamage.
+ ]
+ ].
+ damage := temp
].
newEvent := WindowEvent damageFor:aView rectangle:aRectangle.
damage add:newEvent.
@@ -204,8 +205,8 @@
|d|
[d isNil] whileTrue:[
- damage size == 0 ifTrue:[^ nil].
- d := damage removeFirst.
+ damage size == 0 ifTrue:[^ nil].
+ d := damage removeFirst.
].
^ d
!
@@ -216,8 +217,8 @@
|e|
[e isNil] whileTrue:[
- mouseAndKeyboard size == 0 ifTrue:[^ nil].
- e := mouseAndKeyboard removeFirst.
+ mouseAndKeyboard size == 0 ifTrue:[^ nil].
+ e := mouseAndKeyboard removeFirst.
].
^ e
! !
@@ -241,22 +242,33 @@
"/ aView device synchronizeOutput.
Processor activePriority < Processor userInterruptPriority ifTrue:[
- [gotExpose] whileFalse:[
- exposeEventSemaphore wait
- ].
+ [gotExpose] whileFalse:[
+ "
+ just in case we have (network or software) a problem ...
+ "
+ (exposeEventSemaphore waitWithTimeout:5) ifFalse:[
+ 'oops: lost expose event' printNL.
+ aView device synchronizeOutput.
+ (exposeEventSemaphore waitWithTimeout:10) ifFalse:[
+ 'oops: lost expose event again - ignore' printNL.
+ ].
+ gotExpose := true.
+ ^ self
+ ]
+ ].
- "
- other incoming events have been ignored during the wait.
- Now handle those ...
- "
- gotOtherEvent ifTrue:[
- eventSemaphore signal
- ].
+ "
+ other incoming events have been ignored during the wait.
+ Now handle those ...
+ "
+ gotOtherEvent ifTrue:[
+ eventSemaphore signal
+ ].
] ifFalse:[
- [gotExpose] whileFalse:[
- aView device dispatchExposeEventFor:aView id.
- Processor yield.
- ]
+ [gotExpose] whileFalse:[
+ aView device dispatchExposeEventFor:aView id.
+ Processor yield.
+ ]
].
catchExpose := false
!
@@ -265,31 +277,33 @@
"throw away all events for aView"
1 to: damage size do:[:i |
- |aDamage|
+ |aDamage|
- aDamage := damage at:i.
- aDamage notNil ifTrue:[
- aDamage view == aView ifTrue:[
- damage at:i put:nil
- ]
- ]
+ aDamage := damage at:i.
+ aDamage notNil ifTrue:[
+ aDamage view == aView ifTrue:[
+ damage at:i put:nil
+ ]
+ ]
].
1 to: mouseAndKeyboard size do:[:i |
- |anEvent|
+ |anEvent|
- anEvent := mouseAndKeyboard at:i.
- anEvent notNil ifTrue:[
- anEvent view == aView ifTrue:[
- mouseAndKeyboard at:i put:nil
- ]
- ]
+ anEvent := mouseAndKeyboard at:i.
+ anEvent notNil ifTrue:[
+ anEvent view == aView ifTrue:[
+ mouseAndKeyboard at:i put:nil
+ ]
+ ]
].
!
flushUserEvents
"throw away all pending user events"
- mouseAndKeyboard := OrderedCollection new.
+ (mouseAndKeyboard isNil or:[mouseAndKeyboard size > 0]) ifTrue:[
+ mouseAndKeyboard := OrderedCollection new
+ ].
!
flushExposeEvents
@@ -297,7 +311,60 @@
can be done after a full redraw (or in views, which are
doing full redraws anly)"
- damage := OrderedCollection new.
+ (damage isNil or:[damage size > 0]) ifTrue:[
+ damage := OrderedCollection new
+ ].
+!
+
+pushUserEvent:anEvent
+ "manually put an event into the queue - this allows
+ simulation of events (implementation of recorders & playback)."
+
+ mouseAndKeyboard addLast:anEvent.
+ self notifyEventArrival
+!
+
+pushUserEvent:aSelector for:aView withArguments:arguments
+ "manually put an event into the queue - this allows
+ simulation of events (implementation of recorders & playback)."
+
+ self pushEvent:(WindowEvent
+ for:aView
+ type:aSelector
+ arguments:arguments).
+
+ "
+ |b|
+ b := Button label:'test'.
+ b open.
+ (Delay forSeconds:5) wait.
+ b sensor pushEvent:#pointerEnter:x:y: for:b withArguments:#(0 1 1).
+ (Delay forSeconds:1) wait.
+ b sensor pushEvent:#buttonPress:x:y: for:b withArguments:#(1 1 1).
+ (Delay forSeconds:2) wait.
+ b sensor pushEvent:#buttonRelease:x:y: for:b withArguments:#(1 1 1).
+ (Delay forSeconds:1) wait.
+ b sensor pushEvent:#pointerLeave: for:b withArguments:#(0).
+ "
+!
+
+forwardKeyEventsTo:aView
+ "remove all keyboard events and send them to aSensor instead"
+
+"/ 'fwd' printNL.
+ 1 to:mouseAndKeyboard size do:[:i |
+ |anEvent|
+
+ anEvent := mouseAndKeyboard at:i.
+ anEvent notNil ifTrue:[
+ anEvent isKeyEvent ifTrue:[
+ anEvent view:aView.
+ aView sensor pushUserEvent:anEvent.
+"/ anEvent type printNL.
+ mouseAndKeyboard at:i put:nil
+ ]
+ ]
+ ].
! !
!WindowSensor methodsFor:'event processing'!
@@ -307,14 +374,15 @@
signal it, to wake up any controller process"
catchExpose == true ifTrue:[
- "
- dont wake up, if we are currently waiting for an expose
- "
- gotOtherEvent := true.
- ^ self
+ "
+ dont wake up, if we are currently waiting for an expose
+ but remember arrival of something.
+ "
+ gotOtherEvent := true.
+ ^ self
].
eventSemaphore notNil ifTrue:[
- eventSemaphore signal
+ eventSemaphore signal
]
!
@@ -351,7 +419,7 @@
"/ catchExpose := false.
exposeEventSemaphore notNil ifTrue:[
- exposeEventSemaphore signal
+ exposeEventSemaphore signal
]
!
@@ -365,30 +433,30 @@
|args|
ignoreUserInput == true ifTrue:[
- ^ self
+ ^ self
].
args := Array with:state with:x with:y.
compressMotionEvents ifTrue:[
- "
- merge with last motion
- "
- mouseAndKeyboard reverseDo:[:ev |
- ev notNil ifTrue:[
- ((ev type == #buttonMotion:x:y:)
- and:[(ev view == aView)
- and:[(ev arguments at:1) == state]]) ifTrue:[
- ev arguments:args.
- ^ self
- ]
- ]
- ]
+ "
+ merge with last motion
+ "
+ mouseAndKeyboard reverseDo:[:ev |
+ ev notNil ifTrue:[
+ ((ev type == #buttonMotion:x:y:)
+ and:[(ev view == aView)
+ and:[(ev arguments at:1) == state]]) ifTrue:[
+ ev arguments:args.
+ ^ self
+ ]
+ ]
+ ]
].
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#buttonMotion:x:y:
- arguments:args).
+ addLast:(WindowEvent
+ for:aView
+ type:#buttonMotion:x:y:
+ arguments:args).
self notifyEventArrival
!
@@ -396,13 +464,13 @@
"mouse button was pressed - this is sent from the device (Display)"
ignoreUserInput == true ifTrue:[
- ^ self
+ ^ self
].
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#buttonPress:x:y:
- arguments:(Array with:button with:x with:y)).
+ addLast:(WindowEvent
+ for:aView
+ type:#buttonPress:x:y:
+ arguments:(Array with:button with:x with:y)).
self notifyEventArrival
!
@@ -410,13 +478,13 @@
"mouse button was released- this is sent from the device (Display)"
ignoreUserInput == true ifTrue:[
- ^ self
+ ^ self
].
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#buttonRelease:x:y:
- arguments:(Array with:button with:x with:y)).
+ addLast:(WindowEvent
+ for:aView
+ type:#buttonRelease:x:y:
+ arguments:(Array with:button with:x with:y)).
self notifyEventArrival
!
@@ -424,13 +492,13 @@
"mouse button was pressed - this is sent from the device (Display)"
ignoreUserInput == true ifTrue:[
- ^ self
+ ^ self
].
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#buttonMultiPress:x:y:
- arguments:(Array with:button with:x with:y)).
+ addLast:(WindowEvent
+ for:aView
+ type:#buttonMultiPress:x:y:
+ arguments:(Array with:button with:x with:y)).
self notifyEventArrival
!
@@ -438,47 +506,53 @@
"mouse button was pressed - this is sent from the device (Display)"
ignoreUserInput == true ifTrue:[
- ^ self
+ ^ self
].
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#buttonShiftPress:x:y:
- arguments:(Array with:button with:x with:y)).
+ addLast:(WindowEvent
+ for:aView
+ type:#buttonShiftPress:x:y:
+ arguments:(Array with:button with:x with:y)).
self notifyEventArrival
!
keyPress:key x:x y:y view:aView
- "key was pressed - this is sent from the device (Display)"
+ "key was pressed - this is sent from the device (Display).
+ beside the keyboard translation, CntlC processing is done here."
|xlatedKey group process|
xlatedKey := aView device translateKey:key.
((xlatedKey == #Ctrlc) and:[ControlCEnabled]) ifTrue:[
- "
- Special handling for Cntl-C: interrupt the underlying process.
+ "
+ Special handling for Cntl-C: interrupt the underlying process.
- cannot halt here (this would stop the event-dispatcher),
- but instead interrupt the underlying process and have it
- perform the userInterrupt in the interrupt-method.
- "
- group := aView windowGroup.
- group notNil ifTrue:[
- process := group process.
- process notNil ifTrue:[
- process interruptWith:[process userInterrupt]
- ]
- ].
- ^ self
+ cannot halt here (this would stop the event-dispatcher),
+ but instead interrupt the underlying process and have it
+ perform the userInterrupt in the interrupt-method.
+ "
+ group := aView windowGroup.
+ group notNil ifTrue:[
+ process := group process.
+ process notNil ifTrue:[
+ process interruptWith:[process userInterrupt]
+ ]
+ ].
+ ^ self
].
+ (xlatedKey == #CtrlV) ifTrue:[
+ 'Smalltalk/X ' print. Smalltalk versionString printNL.
+ Smalltalk copyrightString printNL.
+ ].
+
ignoreUserInput == true ifTrue:[
- ^ self
+ ^ self
].
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#keyPress:x:y:
- arguments:(Array with:xlatedKey with:x with:y)).
+ addLast:(WindowEvent
+ for:aView
+ type:#keyPress:x:y:
+ arguments:(Array with:xlatedKey with:x with:y)).
self notifyEventArrival
!
@@ -488,14 +562,14 @@
|xlatedKey|
ignoreUserInput == true ifTrue:[
- ^ self
+ ^ self
].
xlatedKey := aView device translateKey:key.
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#keyRelease:x:y:
- arguments:(Array with:xlatedKey with:x with:y)).
+ addLast:(WindowEvent
+ for:aView
+ type:#keyRelease:x:y:
+ arguments:(Array with:xlatedKey with:x with:y)).
self notifyEventArrival
!
@@ -503,10 +577,10 @@
"mouse cursor was moved into the view - this is sent from the device (Display)"
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#pointerEnter:x:y:
- arguments:(Array with:state with:x with:y)).
+ addLast:(WindowEvent
+ for:aView
+ type:#pointerEnter:x:y:
+ arguments:(Array with:state with:x with:y)).
self notifyEventArrival
!
@@ -514,19 +588,30 @@
"mouse cursor was moved out of the view - this is sent from the device (Display)"
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#pointerLeave:
- arguments:(Array with:state)).
+ addLast:(WindowEvent
+ for:aView
+ type:#pointerLeave:
+ arguments:(Array with:state)).
self notifyEventArrival
!
configureX:x y:y width:w height:h view:aView
damage
- addLast:(WindowEvent
- for:aView
- type:#configureX:y:width:height:
- arguments:(Array with:x with:y with:w with:h)).
+ addLast:(WindowEvent
+ for:aView
+ type:#configureX:y:width:height:
+ arguments:(Array with:x with:y with:w with:h)).
+ self notifyEventArrival
+!
+
+coveredBy:sibling view:aView
+ "aView was covered by one of its siblings"
+
+ damage
+ addLast:(WindowEvent
+ for:aView
+ type:#coveredBy:
+ arguments:(Array with:sibling)).
self notifyEventArrival
!
@@ -534,10 +619,9 @@
"view got input focus - this is sent from the device (Display)"
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#focusIn
- arguments:#()).
+ addLast:(WindowEvent
+ for:aView
+ type:#focusIn).
self notifyEventArrival
!
@@ -545,10 +629,9 @@
"view lost input focus - this is sent from the device (Display)"
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#focusOut
- arguments:#()).
+ addLast:(WindowEvent
+ for:aView
+ type:#focusOut).
self notifyEventArrival
!
@@ -556,10 +639,9 @@
"view was mapped (from window manager)"
damage
- addLast:(WindowEvent
- for:aView
- type:#mapped
- arguments:#()).
+ addLast:(WindowEvent
+ for:aView
+ type:#mapped).
self notifyEventArrival
!
@@ -567,10 +649,9 @@
"view was unmapped (from window manager)"
damage
- addLast:(WindowEvent
- for:aView
- type:#unmapped
- arguments:#()).
+ addLast:(WindowEvent
+ for:aView
+ type:#unmapped).
self notifyEventArrival
!
@@ -579,10 +660,9 @@
self flushEventsFor:aView.
damage
- addLast:(WindowEvent
- for:aView
- type:#terminate
- arguments:#()).
+ addLast:(WindowEvent
+ for:aView
+ type:#terminate).
self notifyEventArrival
!
@@ -591,10 +671,9 @@
self flushEventsFor:aView.
damage
- addLast:(WindowEvent
- for:aView
- type:#saveAndTerminate
- arguments:#()).
+ addLast:(WindowEvent
+ for:aView
+ type:#saveAndTerminate).
self notifyEventArrival
!
@@ -606,10 +685,9 @@
self flushEventsFor:aView.
damage
- addLast:(WindowEvent
- for:aView
- type:#destroyed
- arguments:#()).
+ addLast:(WindowEvent
+ for:aView
+ type:#destroyed).
self notifyEventArrival
! !
@@ -629,8 +707,8 @@
reinitialize
"reinitialize the event queues to empty; leave other setup as-is"
- damage := OrderedCollection new.
- mouseAndKeyboard := OrderedCollection new.
+ self flushUserEvents.
+ self flushExposeEvents.
gotExpose := true.
catchExpose := false.
! !
--- a/WTrans.st Mon Oct 10 03:30:48 1994 +0100
+++ b/WTrans.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -10,25 +10,108 @@
hereby transferred.
"
-Object subclass: #WindowingTransformation
- instanceVariableNames: 'scale translation'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Graphics-Support'!
+'From Smalltalk/X, Version:2.10.3 on 20-sep-1994 at 0:15:56'!
+
+Object subclass:#WindowingTransformation
+ instanceVariableNames:'scale translation'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Graphics-Support'
+!
WindowingTransformation comment:'
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/Attic/WTrans.st,v 1.5 1994-08-05 01:16:22 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/WTrans.st,v 1.6 1994-10-10 02:34:07 claus Exp $
'!
-!WindowingTransformation class methodsFor: 'documentation'!
+!WindowingTransformation class methodsFor:'instance creation'!
+
+unit:unitSymbol on:device
+ "returns a windowing transformation with scaling
+ for unitSymbol and no translation (0@0).
+ With such a transformation, you can draw in your preferred
+ units.
+ UnitSymbol may be #mm, #cm, #inch, #point, #twip or #pixel (default).
+ Twip is 1/20th of a point, point is 1/72th of an inch
+ (i.e. the print-unit which is also used for font sizes etc.)
+ - not to confuse with device pixels."
+
+ |pixelPerUnitV pixelPerUnitH|
+
+ unitSymbol == #mm ifTrue:[
+ pixelPerUnitV := device verticalPixelPerMillimeter.
+ pixelPerUnitH := device horizontalPixelPerMillimeter
+ ] ifFalse:[
+ unitSymbol == #cm ifTrue:[
+ pixelPerUnitV := device verticalPixelPerMillimeter * 10.
+ pixelPerUnitH := device horizontalPixelPerMillimeter * 10
+ ] ifFalse:[
+ unitSymbol == #twip ifTrue:[
+ pixelPerUnitV := device verticalPixelPerInch / 1440.
+ pixelPerUnitH := device horizontalPixelPerInch / 1440
+ ] ifFalse:[
+ unitSymbol == #point ifTrue:[
+ pixelPerUnitV := device verticalPixelPerInch / 72.
+ pixelPerUnitH := device horizontalPixelPerInch / 72
+ ] ifFalse:[
+ unitSymbol == #inch ifTrue:[
+ pixelPerUnitV := device verticalPixelPerInch.
+ pixelPerUnitH := device horizontalPixelPerInch
+ ] ifFalse:[
+ "sorry: unknown unit is taken as pixel"
+ ^ self new scale:nil translation:(0 @ 0)
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ self new scale:(pixelPerUnitH @ pixelPerUnitV) translation:0
+!
+
+scale:aScale translation:aTranslation
+ "returns a windowing transformation with a scale factor of
+ aScale and a translation offset of aTranslation."
+
+ ^ self new scale:aScale translation:aTranslation
+!
+
+window:sourceRectangle viewport:destinationRectangle
+ "returns a windowing transformation with a scale and
+ translation computed from sourceRectangle and destinationRectangle.
+ The scale and transformation are computed such that sourceRectangle
+ is transformed to destinationRectangle. Typically sourceRectangle
+ represents the logical coordinateSpace while destinationRectangle
+ represents the device coordinateSpace."
+
+ |sX sY tX tY newScale|
+
+ sX := destinationRectangle width / sourceRectangle width.
+ sY := destinationRectangle height / sourceRectangle height.
+ tX := destinationRectangle left - sourceRectangle left.
+ tY := destinationRectangle top - sourceRectangle top.
+ ((sX = 1.0) and:[sY = 1.0]) ifTrue:[
+ newScale := 1 @ 1
+ ] ifFalse:[
+ newScale := sX @ sY
+ ].
+ ^ self new scale:newScale translation:(tX @ tY)
+!
+
+identity
+ "returns a windowing transformation with no scaling (nil)
+ and no translation (0@0)."
+
+ ^ self new scale:1 translation:0
+! !
+
+!WindowingTransformation class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -41,7 +124,7 @@
version
"
-$Header: /cvs/stx/stx/libview/Attic/WTrans.st,v 1.5 1994-08-05 01:16:22 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/WTrans.st,v 1.6 1994-10-10 02:34:07 claus Exp $
"
!
@@ -50,8 +133,8 @@
I represent the ability to perform transformations in 2-D space.
Instance variables are:
- scale <Number> or <Point> representing a linear scaling factor.
- translation <Number> or <Point> representing a translation in 2-D.
+ scale <Number> or <Point> representing a linear scaling factor.
+ translation <Number> or <Point> representing a translation in 2-D.
All 2-D objects are supposed to be able to be transformed using
instances of me. Instances of me can also be combined to form a
@@ -59,67 +142,62 @@
"
! !
-!WindowingTransformation methodsFor: 'accessing'!
-
-scale
- "return a copy of the Point that represents the
- current scale of the receiver."
+!WindowingTransformation methodsFor:'applying transform'!
- scale == nil ifTrue:[
- ^ Point x:1 y:1
+applyToX:aNumber
+ "Apply the receiver to a number representing an x-coordinate
+ and return the result."
+
+ scale isNil ifTrue:[
+ ^ aNumber + translation x
].
- ^ scale copy
-!
-
-scaleOfOne
- "Set the scale of the receiver to the identity scale"
-
- scale := nil
+ ^ (aNumber * scale x + translation x) asInteger
!
-translation
- "return a copy of the receiver's translation."
+applyToY:aNumber
+ "Apply the receiver to a number representing an y-coordinate
+ and return the result."
- ^ translation copy
+ scale isNil ifTrue:[
+ ^ aNumber + translation y
+ ].
+ ^ (aNumber * scale y + translation y) asInteger
!
-translation: aValue
- "Set the receiver's translation to aValue."
+applyScaleY:aNumber
+ "apply the scale only (if heights are to be transformed)"
- translation := aValue
-! !
-
-!WindowingTransformation methodsFor: 'testing'!
+ scale isNil ifTrue:[^ aNumber].
+ ^ (aNumber * scale y) asInteger
+!
-noScale
- "return true if the identity scale is in effect;
- answer false, otherwise."
+applyScaleX:aNumber
+ "apply the scale only (if widths are to be transformed)"
- ^ scale == nil
-! !
-
-!WindowingTransformation methodsFor: 'applying transform'!
+ scale isNil ifTrue:[^ aNumber].
+ ^ (aNumber * scale x) asInteger
+!
applyInverseTo:anObject
"Apply the inverse of the receiver to anObject
- and answer the result."
+ and return the result."
|transformedObject|
transformedObject := anObject translatedBy:(self inverseTranslation).
scale == nil ifFalse:[
- transformedObject scaleBy:(self inverseScale)
+ transformedObject scaleBy:(self inverseScale)
].
^ transformedObject
!
applyTo:anObject
- "Apply the receiver to anObject and answer the result."
+ "Apply the receiver to anObject and return the result."
|transformedObject|
scale == nil ifTrue:[
- ^ anObject translateBy:translation.
+ ^ anObject translateBy:translation.
].
transformedObject := anObject scaledBy:scale
transformedObject translateBy:translation.
@@ -138,26 +216,62 @@
aTransformationScale := aTransformation scale.
scale == nil ifTrue:[
- aTransformation noScale ifTrue:[
- newScale := nil
- ] ifFalse:[
- newScale := aTransformationScale
- ].
- newTranslation := translation + aTransformation translation
+ aTransformation noScale ifTrue:[
+ newScale := nil
+ ] ifFalse:[
+ newScale := aTransformationScale
+ ].
+ newTranslation := translation + aTransformation translation
] ifFalse:[
- aTransformation noScale ifTrue:[
- newScale := scale
- ] ifFalse:[
- newScale := scale * aTransformationScale
- ].
- newTranslation := translation
- + (scale * aTransformation translation)
+ aTransformation noScale ifTrue:[
+ newScale := scale
+ ] ifFalse:[
+ newScale := scale * aTransformationScale
+ ].
+ newTranslation := translation
+ + (scale * aTransformation translation)
].
- ^ WindowingTransformation scale:newScale
- translation:newTranslation
+ ^ (self class)
+ scale:newScale
+ translation:newTranslation
! !
-!WindowingTransformation methodsFor: 'transforming'!
+!WindowingTransformation methodsFor:'transforming'!
+
+scaleBy:aScale
+ "scale the receiver.
+ This is a destructive operation, modifying the transformation
+ represented by the receiver"
+
+ |newScale newTranslation|
+
+ aScale isNil ifTrue:[^ self].
+
+ scale isNil ifTrue:[
+ newScale := aScale asPoint
+ ] ifFalse:[
+ newScale := scale * aScale
+ ].
+ translation := translation * aScale.
+ scale := newScale.
+!
+
+translateBy:aTranslation
+ "translate the receiver.
+ This is a destructive operation, modifying the transformation
+ represented by the receiver"
+
+ aTranslation isNil ifTrue:[^ self].
+
+ translation isNil ifTrue:[
+ translation := 0@0
+ ].
+ scale isNil ifTrue:[
+ translation := translation + aTranslation asPoint
+ ] ifFalse:[
+ translation := translation + (scale * aTranslation)
+ ].
+!
scaledBy:aScale
"return a new WindowingTransformation with the scale and translation of
@@ -166,19 +280,20 @@
|checkedScale newScale newTranslation|
aScale == nil ifTrue:[
- newScale := scale.
- newTranslation := translation
+ newScale := scale.
+ newTranslation := translation
] ifFalse:[
- checkedScale := self checkScale:aScale.
- scale == nil ifTrue:[
- newScale := checkedScale
- ] ifFalse:[
- newScale := scale * checkedScale
- ].
- newTranslation := checkedScale * translation
+ checkedScale := self checkScale:aScale.
+ scale == nil ifTrue:[
+ newScale := checkedScale
+ ] ifFalse:[
+ newScale := scale * checkedScale
+ ].
+ newTranslation := checkedScale * translation
].
- ^ WindowingTransformation scale:newScale
- translation:newTranslation
+ ^ (self class)
+ scale:newScale
+ translation:newTranslation
!
translatedBy:aPoint
@@ -186,18 +301,12 @@
rotations as the receiver and with a translation of the current
translation plus aPoint."
- ^ WindowingTransformation scale:scale
- translation:(translation + aPoint)
+ ^ (self class)
+ scale:scale
+ translation:(translation + aPoint)
! !
-!WindowingTransformation methodsFor: 'printing'!
-
-printString
- ^ (self class name, ' scale: ', scale printString,
- ' translation: ', translation printString)
-! !
-
-!WindowingTransformation methodsFor: 'private'!
+!WindowingTransformation methodsFor:'private'!
checkScale:aScale
"Converts aScale to the internal format of a floating-point Point."
@@ -206,7 +315,7 @@
checkedScale := aScale asPoint.
^ Point x:checkedScale x asFloat
- y:checkedScale y asFloat
+ y:checkedScale y asFloat
!
inverseScale
@@ -217,7 +326,7 @@
newScale := self checkScale:scale.
^ Point x:(1.0 / newScale x)
- y:(1.0 / newScale y)
+ y:(1.0 / newScale y)
!
inverseTranslation
@@ -228,47 +337,68 @@
trans := translation asPoint.
^ Point x:trans x negated
- y:trans y negated
+ y:trans y negated
+! !
+
+!WindowingTransformation methodsFor:'accessing'!
+
+scale:aScale translation:aTranslation
+ "sets the scale to aScale and the translation to aTranslation."
+
+ scale := aScale asPoint.
+ translation := aTranslation asPoint
!
-setScale:aScale translation:aTranslation
- "Sets the scale to aScale and the translation to aTranslation."
-
- scale := aScale.
- translation := aTranslation
-! !
+translation:aValue
+ "Set the receiver's translation to aValue, a Point or Number."
-!WindowingTransformation class methodsFor: 'instance creation'!
+ translation := aValue asPoint
+!
-identity
- "returns a windowing transformation with no scaling (nil)
- and no translation (0@0)."
+scale:aValue
+ "Set the receiver's scale to aValue, a Point or Number."
- ^ self new setScale:nil translation:(Point x:0.0 y:0.0)
+ scale := aValue asPoint
!
-scale:aScale translation:aTranslation
- "returns a windowing transformation with a scale factor of
- aScale and a translation offset of aTranslation."
+scale
+ "return a copy of the Point that represents the
+ current scale of the receiver."
- ^ self new setScale:aScale translation:aTranslation
+ scale == nil ifTrue:[
+ ^ Point x:1 y:1
+ ].
+ ^ scale copy
+!
+
+translation
+ "return a copy of the receiver's translation."
+
+ ^ translation copy
!
-window:sourceRectangle viewport:destinationRectangle
- "returns a windowing transformation with a scale and
- translation computed from sourceRectangle and destinationRectangle.
- The scale and transformation are computed such that sourceRectangle
- is transformed to destinationRectangle."
+scaleOfOne
+ "Set the scale of the receiver to the identity scale"
+
+ scale := nil
+! !
+
+!WindowingTransformation methodsFor:'testing'!
+
+noScale
+ "return true if the identity scale is in effect;
+ return false, otherwise."
- |sX sY tX tY newScale|
- sX := destinationRectangle width / sourceRectangle width.
- sY := destinationRectangle height / sourceRectangle height.
- tX := destinationRectangle left - sourceRectangle left.
- tY := destinationRectangle top - sourceRectangle top.
- ((sX = 1.0) and:[sY = 1.0]) ifTrue:[
- newScale := nil
- ] ifFalse:[
- newScale := Point x:sX y:sY
- ].
- ^ self new setScale:newScale translation:(Point x:tX y:tY)
+ ^ scale == nil
! !
+
+!WindowingTransformation methodsFor:'printing'!
+
+printOn:aStream
+ aStream nextPutAll:self class name.
+ aStream nextPutAll:' scale: '.
+ scale printOn:aStream
+ aStream nextPutAll:' translation: '.
+ translation printOn:aStream
+! !
+
--- a/WindowEvent.st Mon Oct 10 03:30:48 1994 +0100
+++ b/WindowEvent.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,17 @@
"
Object subclass:#WindowEvent
- instanceVariableNames:'view type arguments'
- classVariableNames:''
- poolDictionaries:''
- category:'Interface-Support'
+ instanceVariableNames:'view type arguments'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Support'
!
WindowEvent comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/WindowEvent.st,v 1.6 1994-08-05 01:16:15 claus Exp $
+$Header: /cvs/stx/stx/libview/WindowEvent.st,v 1.7 1994-10-10 02:33:48 claus Exp $
'!
!WindowEvent class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,15 +42,16 @@
version
"
-$Header: /cvs/stx/stx/libview/WindowEvent.st,v 1.6 1994-08-05 01:16:15 claus Exp $
+$Header: /cvs/stx/stx/libview/WindowEvent.st,v 1.7 1994-10-10 02:33:48 claus Exp $
"
!
documentation
"
Instances of WindowEvent are created for every event coming from
- the graphics device, to be handled by a windowGroup. Usually, they
- are queued by a sensor, and processed in some ebent loop in the window group.
+ the graphics device, to be handled by a windowGroup.
+ Usually, they are queued by a sensor, and processed in some event loop
+ in the window group.
"
! !
@@ -63,6 +64,13 @@
^ (self new) for:aView type:aSymbol arguments:argArray
!
+for:aView type:aSymbol
+ "create and return a new windowEvent for sending
+ aSymbol-message with no arguments to aView"
+
+ ^ (self new) for:aView type:aSymbol arguments:#()
+!
+
damageFor:aView rectangle:aRectangle
"create and return a new damage Event for aRectangle
in aView"
@@ -71,6 +79,20 @@
! !
+!WindowEvent methodsFor:'queries'!
+
+isKeyEvent
+ "return true, if this event is a keyboard event"
+
+ ^ (type == #keyPress:x:y) or:[type == #keyRelease:x:y]
+!
+
+isDamage
+ "return true, if this is a damage event"
+
+ ^ type == #damage
+! !
+
!WindowEvent methodsFor:'accessing'!
view
@@ -79,18 +101,18 @@
^ view
!
+view:aView
+ "set the view, for which the event is for"
+
+ view := aView
+!
+
type
"return the type of the event"
^ type
!
-isDamage
- "return true, if this is a damage event"
-
- ^ type == #damage
-!
-
arguments
"return the arguments of the event"
@@ -118,33 +140,33 @@
|delegate selector|
"/ type == #keyPress:x:y: ifTrue:[
- "/
- "/ send it via the device, which does the key-mapping
- "/
+ "/
+ "/ send it via the device, which does the key-mapping
+ "/
"/ view device sendKeyPress:(arguments at:1)
"/ x:(arguments at:2)
"/ y:(arguments at:3)
"/ to:view
"/ ] ifFalse:[
- delegate := view delegate.
- delegate notNil ifTrue:[
- "what a kludge - sending to delegate needs another
- selector and an additional argument.
- have to edit the selector ..."
+ delegate := view delegate.
+ delegate notNil ifTrue:[
+ "what a kludge - sending to delegate needs another
+ selector and an additional argument.
+ have to edit the selector ..."
- (type endsWith:':') ifTrue:[
- selector := (type , 'view:') asSymbol.
- ] ifFalse:[
- selector := (type , 'View:') asSymbol.
- ].
- arguments isNil ifTrue:[
- delegate perform:selector with:view
- ] ifFalse:[
- delegate perform:selector withArguments:(arguments copyWith:view)
- ]
- ] ifFalse:[
- view perform:type withArguments:arguments
- ]
+ (type endsWith:':') ifTrue:[
+ selector := (type , 'view:') asSymbol.
+ ] ifFalse:[
+ selector := (type , 'View:') asSymbol.
+ ].
+ arguments isNil ifTrue:[
+ delegate perform:selector with:view
+ ] ifFalse:[
+ delegate perform:selector withArguments:(arguments copyWith:view)
+ ]
+ ] ifFalse:[
+ view perform:type withArguments:arguments
+ ]
"/ ]
! !
--- a/WindowGroup.st Mon Oct 10 03:30:48 1994 +0100
+++ b/WindowGroup.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,17 +11,17 @@
"
Object subclass:#WindowGroup
- instanceVariableNames:'views topViews myProcess mySensor isModal previousGroup'
- classVariableNames:'ActiveGroup ScheduledWindowGroups LeaveSignal'
- poolDictionaries:''
- category:'Interface-Support'
+ instanceVariableNames:'views topViews myProcess mySensor isModal previousGroup'
+ classVariableNames:'ActiveGroup ScheduledWindowGroups LeaveSignal'
+ poolDictionaries:''
+ category:'Interface-Support'
!
WindowGroup comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/WindowGroup.st,v 1.11 1994-08-22 13:15:31 claus Exp $
+$Header: /cvs/stx/stx/libview/WindowGroup.st,v 1.12 1994-10-10 02:33:56 claus Exp $
'!
!WindowGroup class methodsFor:'documentation'!
@@ -29,7 +29,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -42,7 +42,7 @@
version
"
-$Header: /cvs/stx/stx/libview/WindowGroup.st,v 1.11 1994-08-22 13:15:31 claus Exp $
+$Header: /cvs/stx/stx/libview/WindowGroup.st,v 1.12 1994-10-10 02:33:56 claus Exp $
"
!
@@ -55,14 +55,21 @@
initialize
LeaveSignal isNil ifTrue:[
- LeaveSignal := (Signal new) mayProceed:true.
- LeaveSignal notifierString:'unhandled leave signal'.
- ScheduledWindowGroups := IdentitySet new.
+ LeaveSignal := (Signal new) mayProceed:true.
+ LeaveSignal nameClass:self message:#leaveSignal.
+ LeaveSignal notifierString:'unhandled leave signal'.
+ "/ ScheduledWindowGroups := IdentitySet new.
].
"WindowGroup initialize"
! !
+!WindowGroup class methodsFor:'signal access'!
+
+leaveSignal
+ ^ LeaveSignal
+! !
+
!WindowGroup class methodsFor:'instance creation'!
new
@@ -95,7 +102,7 @@
"add aView to the windowGroup"
views isNil ifTrue:[
- views := OrderedCollection new.
+ views := OrderedCollection new.
].
views add:aView
!
@@ -104,7 +111,7 @@
"add a topview to the group"
topViews isNil ifTrue:[
- topViews := OrderedCollection new.
+ topViews := OrderedCollection new.
].
topViews add:aView
!
@@ -115,16 +122,16 @@
also shut down the corresponding process"
views notNil ifTrue:[
- views remove:aView ifAbsent:[].
- views isEmpty ifTrue:[
- views := nil
- ]
+ views remove:aView ifAbsent:[].
+ views isEmpty ifTrue:[
+ views := nil
+ ]
].
topViews notNil ifTrue:[
- topViews remove:aView ifAbsent:[].
- topViews isEmpty ifTrue:[
- topViews := nil
- ]
+ topViews remove:aView ifAbsent:[].
+ topViews isEmpty ifTrue:[
+ topViews := nil
+ ]
].
"
wakeup my process to look if last view has been
@@ -170,7 +177,7 @@
g := self.
[g notNil and:[g isModal]] whileTrue:[
- g := g previousGroup
+ g := g previousGroup
].
^ g
!
@@ -194,9 +201,9 @@
"evaluate aBlock for all topviews except aView in this group"
topViews notNil ifTrue:[
- topViews do:[:v |
- v ~~ aView ifTrue:[aBlock value:v]
- ]
+ topViews do:[:v |
+ v ~~ aView ifTrue:[aBlock value:v]
+ ]
].
! !
@@ -209,8 +216,8 @@
c := aCursor.
self allViewsDo:[:aView |
- c := c on:(aView device).
- aView device setCursor:c id in:aView id.
+ c := c on:(aView device).
+ aView device setCursor:c id in:aView id.
].
!
@@ -220,8 +227,8 @@
|c|
self allViewsDo:[:aView |
- c := aView cursor on:(aView device).
- aView device setCursor:(c id) in:(aView id).
+ c := aView cursor on:(aView device).
+ aView device setCursor:(c id) in:(aView id).
].
!
@@ -231,16 +238,22 @@
|oldCursors|
+ "
+ get mapping of view->cursor for all of my subviews
+ "
oldCursors := IdentityDictionary new.
self allViewsDo:[:aView |
- oldCursors at:aView put:(aView cursor).
- aView cursor:aCursor
+ oldCursors at:aView put:(aView cursor).
+ aView cursor:aCursor
].
aBlock valueNowOrOnUnwindDo:[
- oldCursors keysAndValuesDo:[:view :cursor |
- view cursor:cursor
- ]
+ "
+ restore cursors
+ "
+ oldCursors keysAndValuesDo:[:view :cursor |
+ view cursor:cursor
+ ]
]
! !
@@ -250,23 +263,15 @@
"process a single event from either the damage- or user input queues.
Debugger abort brings us back here."
- |event oldActive|
+ |event|
- oldActive := ActiveGroup.
- Object abortSignal handle:[:ex |
- ex return
- ] do:[
- self processExposeEvents.
- [mySensor hasEvents] whileTrue:[
- event := mySensor nextEvent.
- (views isNil and:[topViews isNil]) ifFalse:[
- ActiveGroup := self.
- event sendEvent.
- ActiveGroup := oldActive
- ].
- ].
- ].
- ActiveGroup := oldActive
+ self processExposeEvents.
+ [mySensor hasEvents] whileTrue:[
+ event := mySensor nextEvent.
+ (views isNil and:[topViews isNil]) ifFalse:[
+ event sendEvent.
+ ].
+ ]
!
processExposeEvents
@@ -277,18 +282,18 @@
oldActive := ActiveGroup.
ActiveGroup := self.
[mySensor hasDamage] whileTrue:[
- event := mySensor nextDamage.
- (views isNil and:[topViews isNil]) ifFalse:[
- event isDamage ifTrue:[
- view := event view.
- rect := event rectangle.
- view shown ifTrue:[
- view exposeX:(rect left) y:(rect top) width:(rect width) height:(rect height)
- ]
- ] ifFalse:[
- event sendEvent.
- ]
- ]
+ event := mySensor nextDamage.
+ (views isNil and:[topViews isNil]) ifFalse:[
+ event isDamage ifTrue:[
+ view := event view.
+ rect := event rectangle.
+ view shown ifTrue:[
+ view exposeX:(rect left) y:(rect top) width:(rect width) height:(rect height)
+ ]
+ ] ifFalse:[
+ event sendEvent.
+ ]
+ ]
].
ActiveGroup := oldActive
!
@@ -303,41 +308,60 @@
eventLoopWhile:aBlock
"wait-for and process events while aBlock evaluates to true."
- ScheduledWindowGroups add:self.
- LeaveSignal handle:[:ex |
- ex return
+ "/ ScheduledWindowGroups add:self.
+"/ LeaveSignal
+ (SignalSet with:LeaveSignal with:(Object abortSignal))
+ handle:[:ex |
+ ex return
] do:[
- |p g|
+ |p g oldActive|
- aBlock whileTrue:[
- (views isNil and:[topViews isNil]) ifTrue:[
- ScheduledWindowGroups remove:self ifAbsent:[].
- myProcess notNil ifTrue:[
- p := myProcess.
- myProcess := nil.
- p terminate.
- "not reached - there is no life after death"
- ].
- "
- this is the end of a modal loop
- (not having a private process ...)
- "
- ^ self
- ].
- mySensor eventSemaphore wait.
- self processEvent
- "
- if modal, also check for redraw events in my maingroup
- (this is a kludge, since it only handles exposures there
- when events arrive for myself)
- "
- isModal ifTrue:[
- g := self mainGroup.
- g notNil ifTrue:[g processExposeEvents].
- ]
- ]
+ aBlock whileTrue:[
+ (views isNil and:[topViews isNil]) ifTrue:[
+ "/ ScheduledWindowGroups remove:self ifAbsent:[].
+ myProcess notNil ifTrue:[
+ p := myProcess.
+ myProcess := nil.
+ p terminate.
+ "not reached - there is no life after death"
+ ].
+ "
+ this is the end of a modal loop
+ (not having a private process ...)
+ "
+ ^ self
+ ].
+ Object abortSignal handle:[:ex |
+ ex return
+ ] do:[
+ "
+ if modal, break out of the wait after some time
+ to allow servicing update-events of the blocked
+ windowgroup.
+ "
+ isModal ifTrue:[
+ mySensor eventSemaphore waitWithTimeout:0.2.
+ ] ifFalse:[
+ mySensor eventSemaphore wait.
+ ].
+ oldActive := ActiveGroup.
+ ActiveGroup := self.
+ self processEvent
+ ].
+ ActiveGroup := oldActive.
+
+ "
+ if modal, also check for redraw events in my maingroup
+ (this is a kludge, since it only handles exposures there
+ when events arrive for myself - but at least updates sometimes)
+ "
+ isModal ifTrue:[
+ g := self mainGroup.
+ g notNil ifTrue:[g processExposeEvents].
+ ]
+ ]
].
- ScheduledWindowGroups remove:self ifAbsent:[].
+ "/ ScheduledWindowGroups remove:self ifAbsent:[].
!
waitForExposeFor:aView
@@ -358,12 +382,14 @@
"restart after a snapin."
topViews notNil ifTrue:[
- "
- need a new semaphore, since obsolete processes
- (from out previous live) may still sit on the current semaphore
- "
- mySensor eventSemaphore:Semaphore new.
- self startup
+ "
+ need a new semaphore, since obsolete processes
+ (from our previous live) may still sit on the current semaphore
+ "
+ mySensor eventSemaphore:Semaphore new.
+ isModal ifFalse:[
+ self startup
+ ]
]
!
@@ -376,32 +402,32 @@
previousGroup := nil.
myProcess isNil ifTrue:[
- isModal := false.
- ScheduledWindowGroups add:self.
- myProcess := [
- topViews notNil ifTrue:[
- topViews do:[:aView |
- aView realize
- ].
- ].
- self eventLoopWhile:[true]
- ] forkAt:Processor userSchedulingPriority.
+ isModal := false.
+ "/ ScheduledWindowGroups add:self.
+ myProcess := [
+ topViews notNil ifTrue:[
+ topViews do:[:aView |
+ aView realize
+ ].
+ ].
+ self eventLoopWhile:[true]
+ ] forkAt:Processor userSchedulingPriority.
- (topViews notNil and:[topViews isEmpty not]) ifTrue:[
- "give the handler process a user friendly name"
- nm := topViews first name.
- nm isNil ifTrue:[
- nm := topViews first label.
- ].
- myProcess name:(topViews first name)
- ] ifFalse:[
- myProcess name:'window handler'.
- ].
+ (topViews notNil and:[topViews isEmpty not]) ifTrue:[
+ "give the handler process a user friendly name"
+ nm := topViews first name.
+ nm isNil ifTrue:[
+ nm := topViews first label.
+ ].
+ myProcess name:(topViews first name)
+ ] ifFalse:[
+ myProcess name:'window handler'.
+ ].
- "when the process dies, we have to close-down
- the views as well
- "
- myProcess exitAction:[self closeDownViews]
+ "when the process dies, we have to close-down
+ the views as well
+ "
+ myProcess exitAction:[self closeDownViews]
]
!
@@ -416,7 +442,7 @@
previousGroup := WindowGroup activeGroup.
isModal := true.
topViews do:[:aView |
- aView realize.
+ aView realize.
].
self eventLoopWhile:checkBlock.
!
@@ -425,11 +451,11 @@
"destroy all views associated to this window group"
topViews notNil ifTrue:[
- topViews do:[:aTopView | aTopView destroy]
+ topViews do:[:aTopView | aTopView destroy]
].
views := nil.
topViews := nil.
- ScheduledWindowGroups remove:self ifAbsent:[].
+ "/ ScheduledWindowGroups remove:self ifAbsent:[].
!
shutdown
@@ -440,21 +466,29 @@
self closeDownViews.
myProcess notNil ifTrue:[
- p := myProcess.
- myProcess := nil.
- ScheduledWindowGroups remove:self ifAbsent:[].
- p terminate.
+ p := myProcess.
+ myProcess := nil.
+ "/ ScheduledWindowGroups remove:self ifAbsent:[].
+ p terminate.
]
! !
!WindowGroup methodsFor:'initialization'!
reinitialize
+ "reinitialize the windowgroup after an image restart"
+
"throw away old (zombie) process"
- myProcess := nil.
+ myProcess notNil ifTrue:[
+ "careful: the old processes exitaction must be cleared
+ otherwise, it might do destroy or other actions when it
+ gets finalized ...
+ "
+ myProcess exitAction:nil.
+ myProcess := nil.
+ ].
"throw away old events"
-"/ self initialize
mySensor reinitialize
!
@@ -463,7 +497,8 @@
and an event semaphore"
mySensor := WindowSensor new.
- mySensor eventSemaphore:Semaphore new
+ mySensor eventSemaphore:Semaphore new.
+ isModal := false.
! !
!WindowGroup methodsFor:'printing'!
--- a/WindowSensor.st Mon Oct 10 03:30:48 1994 +0100
+++ b/WindowSensor.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -11,21 +11,21 @@
"
Object subclass:#WindowSensor
- instanceVariableNames:'eventSemaphore damage mouseAndKeyboard
- compressMotionEvents ignoreUserInput
- buttonState exposeEventSemaphore
- catchExpose gotExpose gotOtherEvent
- '
- classVariableNames:'ControlCEnabled'
- poolDictionaries:''
- category:'Interface-Support'
+ instanceVariableNames:'eventSemaphore damage mouseAndKeyboard
+ compressMotionEvents ignoreUserInput
+ buttonState exposeEventSemaphore
+ catchExpose gotExpose gotOtherEvent
+ '
+ classVariableNames:'ControlCEnabled'
+ poolDictionaries:''
+ category:'Interface-Support'
!
WindowSensor comment:'
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/WindowSensor.st,v 1.11 1994-08-22 13:16:44 claus Exp $
+$Header: /cvs/stx/stx/libview/WindowSensor.st,v 1.12 1994-10-10 02:34:01 claus Exp $
'!
!WindowSensor class methodsFor:'documentation'!
@@ -33,7 +33,7 @@
copyright
"
COPYRIGHT (c) 1993 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -46,53 +46,56 @@
version
"
-$Header: /cvs/stx/stx/libview/WindowSensor.st,v 1.11 1994-08-22 13:16:44 claus Exp $
+$Header: /cvs/stx/stx/libview/WindowSensor.st,v 1.12 1994-10-10 02:34:01 claus Exp $
"
!
documentation
"
- Instances of this class keep track of events and damage areas for a group of views.
- All incoming expose rectangles and events (from Workstation) are collected here, until someone
- gets a chance to handle them.
- When adding an expose rectangle, WindowSensor tries to merge the rectangle with the list of
- existing damages to minimize redrawing.
+ Instances of this class keep track of events and damage areas for a group of
+ views. All incoming expose rectangles and events (from Workstation) are
+ collected here, until someone gets a chance to handle them.
+ When adding an expose rectangle, WindowSensor tries to merge the rectangle
+ with the list of existing damages to minimize redrawing.
instance variables:
- eventSemaphore <Semaphore> the semaphore to be signalled when an event
- (or damage) arrives
+ eventSemaphore <Semaphore> the semaphore to be signalled when an event
+ (or damage) arrives
- damage <Collection> collection of damage events
+ damage <Collection> collection of damage events
- mouseAndKeyboard <Collection> collection of user events
+ mouseAndKeyboard <Collection> collection of user events
- compressMotionEvents <Boolean> if true, multiple motion events are
- compressed to one event. If false, each
- event is handled individual.
- (should be set to false when doing free-hand drawing)
+ compressMotionEvents <Boolean> if true, multiple motion events are
+ compressed to one event. If false, each
+ event is handled individual.
+ (should be set to false when doing free-hand drawing)
- ignoreUserInput <Boolean> if true, key & button events are ignored
- (usually set to true by WindowGroup, while a
- modalbox covers a view)
+ ignoreUserInput <Boolean> if true, key & button events are ignored
+ (usually set to true by WindowGroup, while a
+ modalbox covers a view)
- buttonState the current state
+ buttonState the current state (currently unused)
+
+ exposeEventSemaphore <Semaphore> X-special: semaphore to be signalled when
+ expose event arrives after a copyArea.
- exposeEventSemaphore <Semaphore> X-special: semaphore to be signalled when
- expose event arrives after a copyArea.
+ catchExpose <Boolean> true, while waiting for an expose event
+ (after a copyArea)
- catchExpose <Boolean> true, while waiting for an expose event
- (after a copyArea)
+ gotExpose <Boolean> set to true, when an expose event arrives
+ (after a copyarea)
- gotExpose set to true, when an expose event arrives
- (after a copyarea)
+ gotOtherEvent <Boolean> set to true if other events arrive while
+ waiting for expose (after a copyarea).
class variables:
- ControlCEnabled <Boolean> if true (which is the default) Control-C
- will interrupt the process handling the
- view.
- For secure stand-alone applications,
- this can be set to false, in which case
- Control-C does NOT interrupt the process.
+ ControlCEnabled <Boolean> if true (which is the default) Control-C
+ will interrupt the process handling the
+ view.
+ For secure stand-alone applications,
+ this can be set to false, in which case
+ Control-C does NOT interrupt the process.
"
! !
@@ -103,10 +106,9 @@
!
disableControlC
- "
- disable Control-C processing. If enabled,
+ "disable Control-C processing. If enabled,
pressing CNTL-C in a view will interrupt it and bring
- its process into the debugger.
+ its process into the debugger (actually raising signal).
Otherwise, CNTL-C is sent to the view like any other key.
"
@@ -114,10 +116,9 @@
!
enableControlC
- "
- enable Control-C processing. If enabled,
+ "enable Control-C processing. If enabled,
pressing CNTL-C in a view will interrupt it and bring
- its process into the debugger.
+ its process into the debugger (actually raising signal).
Otherwise, CNTL-C is sent to the view like any other key.
"
@@ -144,9 +145,9 @@
sz := damage size.
sz == 0 ifTrue: [
- newEvent := WindowEvent damageFor:aView rectangle:aRectangle.
- damage := OrderedCollection with:newEvent.
- ^ self
+ newEvent := WindowEvent damageFor:aView rectangle:aRectangle.
+ damage := OrderedCollection with:newEvent.
+ ^ self
].
"
@@ -154,13 +155,13 @@
if so, dont add to queue
"
damage do: [:aDamage |
- aDamage notNil ifTrue:[
- aDamage isDamage ifTrue:[
- aDamage view == aView ifTrue:[
- ((aDamage rectangle) contains:aRectangle) ifTrue: [^self]
- ]
- ]
- ].
+ aDamage notNil ifTrue:[
+ aDamage isDamage ifTrue:[
+ aDamage view == aView ifTrue:[
+ ((aDamage rectangle) contains:aRectangle) ifTrue: [^self]
+ ]
+ ]
+ ].
].
"
@@ -169,30 +170,30 @@
"
count := 0.
1 to:sz do:[:i |
- |aDamage|
+ |aDamage|
- aDamage := damage at:i.
- aDamage notNil ifTrue:[
- aDamage isDamage ifTrue:[
- (aDamage view) == aView ifTrue:[
- (aRectangle contains:(aDamage rectangle)) ifTrue: [
- damage at:i put:nil.
- count := count + 1
- ]
- ]
- ]
- ]
+ aDamage := damage at:i.
+ aDamage notNil ifTrue:[
+ aDamage isDamage ifTrue:[
+ (aDamage view) == aView ifTrue:[
+ (aRectangle contains:(aDamage rectangle)) ifTrue: [
+ damage at:i put:nil.
+ count := count + 1
+ ]
+ ]
+ ]
+ ]
].
count > 10 ifTrue: [
- temp := OrderedCollection new:(sz - count + 1).
- index := 1.
- damage do:[:aDamage |
- aDamage notNil ifTrue: [
- temp add: aDamage.
- ]
- ].
- damage := temp
+ temp := OrderedCollection new:(sz - count + 1).
+ index := 1.
+ damage do:[:aDamage |
+ aDamage notNil ifTrue: [
+ temp add: aDamage.
+ ]
+ ].
+ damage := temp
].
newEvent := WindowEvent damageFor:aView rectangle:aRectangle.
damage add:newEvent.
@@ -204,8 +205,8 @@
|d|
[d isNil] whileTrue:[
- damage size == 0 ifTrue:[^ nil].
- d := damage removeFirst.
+ damage size == 0 ifTrue:[^ nil].
+ d := damage removeFirst.
].
^ d
!
@@ -216,8 +217,8 @@
|e|
[e isNil] whileTrue:[
- mouseAndKeyboard size == 0 ifTrue:[^ nil].
- e := mouseAndKeyboard removeFirst.
+ mouseAndKeyboard size == 0 ifTrue:[^ nil].
+ e := mouseAndKeyboard removeFirst.
].
^ e
! !
@@ -241,22 +242,33 @@
"/ aView device synchronizeOutput.
Processor activePriority < Processor userInterruptPriority ifTrue:[
- [gotExpose] whileFalse:[
- exposeEventSemaphore wait
- ].
+ [gotExpose] whileFalse:[
+ "
+ just in case we have (network or software) a problem ...
+ "
+ (exposeEventSemaphore waitWithTimeout:5) ifFalse:[
+ 'oops: lost expose event' printNL.
+ aView device synchronizeOutput.
+ (exposeEventSemaphore waitWithTimeout:10) ifFalse:[
+ 'oops: lost expose event again - ignore' printNL.
+ ].
+ gotExpose := true.
+ ^ self
+ ]
+ ].
- "
- other incoming events have been ignored during the wait.
- Now handle those ...
- "
- gotOtherEvent ifTrue:[
- eventSemaphore signal
- ].
+ "
+ other incoming events have been ignored during the wait.
+ Now handle those ...
+ "
+ gotOtherEvent ifTrue:[
+ eventSemaphore signal
+ ].
] ifFalse:[
- [gotExpose] whileFalse:[
- aView device dispatchExposeEventFor:aView id.
- Processor yield.
- ]
+ [gotExpose] whileFalse:[
+ aView device dispatchExposeEventFor:aView id.
+ Processor yield.
+ ]
].
catchExpose := false
!
@@ -265,31 +277,33 @@
"throw away all events for aView"
1 to: damage size do:[:i |
- |aDamage|
+ |aDamage|
- aDamage := damage at:i.
- aDamage notNil ifTrue:[
- aDamage view == aView ifTrue:[
- damage at:i put:nil
- ]
- ]
+ aDamage := damage at:i.
+ aDamage notNil ifTrue:[
+ aDamage view == aView ifTrue:[
+ damage at:i put:nil
+ ]
+ ]
].
1 to: mouseAndKeyboard size do:[:i |
- |anEvent|
+ |anEvent|
- anEvent := mouseAndKeyboard at:i.
- anEvent notNil ifTrue:[
- anEvent view == aView ifTrue:[
- mouseAndKeyboard at:i put:nil
- ]
- ]
+ anEvent := mouseAndKeyboard at:i.
+ anEvent notNil ifTrue:[
+ anEvent view == aView ifTrue:[
+ mouseAndKeyboard at:i put:nil
+ ]
+ ]
].
!
flushUserEvents
"throw away all pending user events"
- mouseAndKeyboard := OrderedCollection new.
+ (mouseAndKeyboard isNil or:[mouseAndKeyboard size > 0]) ifTrue:[
+ mouseAndKeyboard := OrderedCollection new
+ ].
!
flushExposeEvents
@@ -297,7 +311,60 @@
can be done after a full redraw (or in views, which are
doing full redraws anly)"
- damage := OrderedCollection new.
+ (damage isNil or:[damage size > 0]) ifTrue:[
+ damage := OrderedCollection new
+ ].
+!
+
+pushUserEvent:anEvent
+ "manually put an event into the queue - this allows
+ simulation of events (implementation of recorders & playback)."
+
+ mouseAndKeyboard addLast:anEvent.
+ self notifyEventArrival
+!
+
+pushUserEvent:aSelector for:aView withArguments:arguments
+ "manually put an event into the queue - this allows
+ simulation of events (implementation of recorders & playback)."
+
+ self pushEvent:(WindowEvent
+ for:aView
+ type:aSelector
+ arguments:arguments).
+
+ "
+ |b|
+ b := Button label:'test'.
+ b open.
+ (Delay forSeconds:5) wait.
+ b sensor pushEvent:#pointerEnter:x:y: for:b withArguments:#(0 1 1).
+ (Delay forSeconds:1) wait.
+ b sensor pushEvent:#buttonPress:x:y: for:b withArguments:#(1 1 1).
+ (Delay forSeconds:2) wait.
+ b sensor pushEvent:#buttonRelease:x:y: for:b withArguments:#(1 1 1).
+ (Delay forSeconds:1) wait.
+ b sensor pushEvent:#pointerLeave: for:b withArguments:#(0).
+ "
+!
+
+forwardKeyEventsTo:aView
+ "remove all keyboard events and send them to aSensor instead"
+
+"/ 'fwd' printNL.
+ 1 to:mouseAndKeyboard size do:[:i |
+ |anEvent|
+
+ anEvent := mouseAndKeyboard at:i.
+ anEvent notNil ifTrue:[
+ anEvent isKeyEvent ifTrue:[
+ anEvent view:aView.
+ aView sensor pushUserEvent:anEvent.
+"/ anEvent type printNL.
+ mouseAndKeyboard at:i put:nil
+ ]
+ ]
+ ].
! !
!WindowSensor methodsFor:'event processing'!
@@ -307,14 +374,15 @@
signal it, to wake up any controller process"
catchExpose == true ifTrue:[
- "
- dont wake up, if we are currently waiting for an expose
- "
- gotOtherEvent := true.
- ^ self
+ "
+ dont wake up, if we are currently waiting for an expose
+ but remember arrival of something.
+ "
+ gotOtherEvent := true.
+ ^ self
].
eventSemaphore notNil ifTrue:[
- eventSemaphore signal
+ eventSemaphore signal
]
!
@@ -351,7 +419,7 @@
"/ catchExpose := false.
exposeEventSemaphore notNil ifTrue:[
- exposeEventSemaphore signal
+ exposeEventSemaphore signal
]
!
@@ -365,30 +433,30 @@
|args|
ignoreUserInput == true ifTrue:[
- ^ self
+ ^ self
].
args := Array with:state with:x with:y.
compressMotionEvents ifTrue:[
- "
- merge with last motion
- "
- mouseAndKeyboard reverseDo:[:ev |
- ev notNil ifTrue:[
- ((ev type == #buttonMotion:x:y:)
- and:[(ev view == aView)
- and:[(ev arguments at:1) == state]]) ifTrue:[
- ev arguments:args.
- ^ self
- ]
- ]
- ]
+ "
+ merge with last motion
+ "
+ mouseAndKeyboard reverseDo:[:ev |
+ ev notNil ifTrue:[
+ ((ev type == #buttonMotion:x:y:)
+ and:[(ev view == aView)
+ and:[(ev arguments at:1) == state]]) ifTrue:[
+ ev arguments:args.
+ ^ self
+ ]
+ ]
+ ]
].
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#buttonMotion:x:y:
- arguments:args).
+ addLast:(WindowEvent
+ for:aView
+ type:#buttonMotion:x:y:
+ arguments:args).
self notifyEventArrival
!
@@ -396,13 +464,13 @@
"mouse button was pressed - this is sent from the device (Display)"
ignoreUserInput == true ifTrue:[
- ^ self
+ ^ self
].
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#buttonPress:x:y:
- arguments:(Array with:button with:x with:y)).
+ addLast:(WindowEvent
+ for:aView
+ type:#buttonPress:x:y:
+ arguments:(Array with:button with:x with:y)).
self notifyEventArrival
!
@@ -410,13 +478,13 @@
"mouse button was released- this is sent from the device (Display)"
ignoreUserInput == true ifTrue:[
- ^ self
+ ^ self
].
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#buttonRelease:x:y:
- arguments:(Array with:button with:x with:y)).
+ addLast:(WindowEvent
+ for:aView
+ type:#buttonRelease:x:y:
+ arguments:(Array with:button with:x with:y)).
self notifyEventArrival
!
@@ -424,13 +492,13 @@
"mouse button was pressed - this is sent from the device (Display)"
ignoreUserInput == true ifTrue:[
- ^ self
+ ^ self
].
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#buttonMultiPress:x:y:
- arguments:(Array with:button with:x with:y)).
+ addLast:(WindowEvent
+ for:aView
+ type:#buttonMultiPress:x:y:
+ arguments:(Array with:button with:x with:y)).
self notifyEventArrival
!
@@ -438,47 +506,53 @@
"mouse button was pressed - this is sent from the device (Display)"
ignoreUserInput == true ifTrue:[
- ^ self
+ ^ self
].
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#buttonShiftPress:x:y:
- arguments:(Array with:button with:x with:y)).
+ addLast:(WindowEvent
+ for:aView
+ type:#buttonShiftPress:x:y:
+ arguments:(Array with:button with:x with:y)).
self notifyEventArrival
!
keyPress:key x:x y:y view:aView
- "key was pressed - this is sent from the device (Display)"
+ "key was pressed - this is sent from the device (Display).
+ beside the keyboard translation, CntlC processing is done here."
|xlatedKey group process|
xlatedKey := aView device translateKey:key.
((xlatedKey == #Ctrlc) and:[ControlCEnabled]) ifTrue:[
- "
- Special handling for Cntl-C: interrupt the underlying process.
+ "
+ Special handling for Cntl-C: interrupt the underlying process.
- cannot halt here (this would stop the event-dispatcher),
- but instead interrupt the underlying process and have it
- perform the userInterrupt in the interrupt-method.
- "
- group := aView windowGroup.
- group notNil ifTrue:[
- process := group process.
- process notNil ifTrue:[
- process interruptWith:[process userInterrupt]
- ]
- ].
- ^ self
+ cannot halt here (this would stop the event-dispatcher),
+ but instead interrupt the underlying process and have it
+ perform the userInterrupt in the interrupt-method.
+ "
+ group := aView windowGroup.
+ group notNil ifTrue:[
+ process := group process.
+ process notNil ifTrue:[
+ process interruptWith:[process userInterrupt]
+ ]
+ ].
+ ^ self
].
+ (xlatedKey == #CtrlV) ifTrue:[
+ 'Smalltalk/X ' print. Smalltalk versionString printNL.
+ Smalltalk copyrightString printNL.
+ ].
+
ignoreUserInput == true ifTrue:[
- ^ self
+ ^ self
].
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#keyPress:x:y:
- arguments:(Array with:xlatedKey with:x with:y)).
+ addLast:(WindowEvent
+ for:aView
+ type:#keyPress:x:y:
+ arguments:(Array with:xlatedKey with:x with:y)).
self notifyEventArrival
!
@@ -488,14 +562,14 @@
|xlatedKey|
ignoreUserInput == true ifTrue:[
- ^ self
+ ^ self
].
xlatedKey := aView device translateKey:key.
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#keyRelease:x:y:
- arguments:(Array with:xlatedKey with:x with:y)).
+ addLast:(WindowEvent
+ for:aView
+ type:#keyRelease:x:y:
+ arguments:(Array with:xlatedKey with:x with:y)).
self notifyEventArrival
!
@@ -503,10 +577,10 @@
"mouse cursor was moved into the view - this is sent from the device (Display)"
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#pointerEnter:x:y:
- arguments:(Array with:state with:x with:y)).
+ addLast:(WindowEvent
+ for:aView
+ type:#pointerEnter:x:y:
+ arguments:(Array with:state with:x with:y)).
self notifyEventArrival
!
@@ -514,19 +588,30 @@
"mouse cursor was moved out of the view - this is sent from the device (Display)"
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#pointerLeave:
- arguments:(Array with:state)).
+ addLast:(WindowEvent
+ for:aView
+ type:#pointerLeave:
+ arguments:(Array with:state)).
self notifyEventArrival
!
configureX:x y:y width:w height:h view:aView
damage
- addLast:(WindowEvent
- for:aView
- type:#configureX:y:width:height:
- arguments:(Array with:x with:y with:w with:h)).
+ addLast:(WindowEvent
+ for:aView
+ type:#configureX:y:width:height:
+ arguments:(Array with:x with:y with:w with:h)).
+ self notifyEventArrival
+!
+
+coveredBy:sibling view:aView
+ "aView was covered by one of its siblings"
+
+ damage
+ addLast:(WindowEvent
+ for:aView
+ type:#coveredBy:
+ arguments:(Array with:sibling)).
self notifyEventArrival
!
@@ -534,10 +619,9 @@
"view got input focus - this is sent from the device (Display)"
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#focusIn
- arguments:#()).
+ addLast:(WindowEvent
+ for:aView
+ type:#focusIn).
self notifyEventArrival
!
@@ -545,10 +629,9 @@
"view lost input focus - this is sent from the device (Display)"
mouseAndKeyboard
- addLast:(WindowEvent
- for:aView
- type:#focusOut
- arguments:#()).
+ addLast:(WindowEvent
+ for:aView
+ type:#focusOut).
self notifyEventArrival
!
@@ -556,10 +639,9 @@
"view was mapped (from window manager)"
damage
- addLast:(WindowEvent
- for:aView
- type:#mapped
- arguments:#()).
+ addLast:(WindowEvent
+ for:aView
+ type:#mapped).
self notifyEventArrival
!
@@ -567,10 +649,9 @@
"view was unmapped (from window manager)"
damage
- addLast:(WindowEvent
- for:aView
- type:#unmapped
- arguments:#()).
+ addLast:(WindowEvent
+ for:aView
+ type:#unmapped).
self notifyEventArrival
!
@@ -579,10 +660,9 @@
self flushEventsFor:aView.
damage
- addLast:(WindowEvent
- for:aView
- type:#terminate
- arguments:#()).
+ addLast:(WindowEvent
+ for:aView
+ type:#terminate).
self notifyEventArrival
!
@@ -591,10 +671,9 @@
self flushEventsFor:aView.
damage
- addLast:(WindowEvent
- for:aView
- type:#saveAndTerminate
- arguments:#()).
+ addLast:(WindowEvent
+ for:aView
+ type:#saveAndTerminate).
self notifyEventArrival
!
@@ -606,10 +685,9 @@
self flushEventsFor:aView.
damage
- addLast:(WindowEvent
- for:aView
- type:#destroyed
- arguments:#()).
+ addLast:(WindowEvent
+ for:aView
+ type:#destroyed).
self notifyEventArrival
! !
@@ -629,8 +707,8 @@
reinitialize
"reinitialize the event queues to empty; leave other setup as-is"
- damage := OrderedCollection new.
- mouseAndKeyboard := OrderedCollection new.
+ self flushUserEvents.
+ self flushExposeEvents.
gotExpose := true.
catchExpose := false.
! !
--- a/WindowingTransformation.st Mon Oct 10 03:30:48 1994 +0100
+++ b/WindowingTransformation.st Mon Oct 10 03:34:45 1994 +0100
@@ -1,6 +1,6 @@
"
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -10,25 +10,108 @@
hereby transferred.
"
-Object subclass: #WindowingTransformation
- instanceVariableNames: 'scale translation'
- classVariableNames: ''
- poolDictionaries: ''
- category: 'Graphics-Support'!
+'From Smalltalk/X, Version:2.10.3 on 20-sep-1994 at 0:15:56'!
+
+Object subclass:#WindowingTransformation
+ instanceVariableNames:'scale translation'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Graphics-Support'
+!
WindowingTransformation comment:'
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ All Rights Reserved
-$Header: /cvs/stx/stx/libview/WindowingTransformation.st,v 1.5 1994-08-05 01:16:22 claus Exp $
+$Header: /cvs/stx/stx/libview/WindowingTransformation.st,v 1.6 1994-10-10 02:34:07 claus Exp $
'!
-!WindowingTransformation class methodsFor: 'documentation'!
+!WindowingTransformation class methodsFor:'instance creation'!
+
+unit:unitSymbol on:device
+ "returns a windowing transformation with scaling
+ for unitSymbol and no translation (0@0).
+ With such a transformation, you can draw in your preferred
+ units.
+ UnitSymbol may be #mm, #cm, #inch, #point, #twip or #pixel (default).
+ Twip is 1/20th of a point, point is 1/72th of an inch
+ (i.e. the print-unit which is also used for font sizes etc.)
+ - not to confuse with device pixels."
+
+ |pixelPerUnitV pixelPerUnitH|
+
+ unitSymbol == #mm ifTrue:[
+ pixelPerUnitV := device verticalPixelPerMillimeter.
+ pixelPerUnitH := device horizontalPixelPerMillimeter
+ ] ifFalse:[
+ unitSymbol == #cm ifTrue:[
+ pixelPerUnitV := device verticalPixelPerMillimeter * 10.
+ pixelPerUnitH := device horizontalPixelPerMillimeter * 10
+ ] ifFalse:[
+ unitSymbol == #twip ifTrue:[
+ pixelPerUnitV := device verticalPixelPerInch / 1440.
+ pixelPerUnitH := device horizontalPixelPerInch / 1440
+ ] ifFalse:[
+ unitSymbol == #point ifTrue:[
+ pixelPerUnitV := device verticalPixelPerInch / 72.
+ pixelPerUnitH := device horizontalPixelPerInch / 72
+ ] ifFalse:[
+ unitSymbol == #inch ifTrue:[
+ pixelPerUnitV := device verticalPixelPerInch.
+ pixelPerUnitH := device horizontalPixelPerInch
+ ] ifFalse:[
+ "sorry: unknown unit is taken as pixel"
+ ^ self new scale:nil translation:(0 @ 0)
+ ]
+ ]
+ ]
+ ]
+ ].
+ ^ self new scale:(pixelPerUnitH @ pixelPerUnitV) translation:0
+!
+
+scale:aScale translation:aTranslation
+ "returns a windowing transformation with a scale factor of
+ aScale and a translation offset of aTranslation."
+
+ ^ self new scale:aScale translation:aTranslation
+!
+
+window:sourceRectangle viewport:destinationRectangle
+ "returns a windowing transformation with a scale and
+ translation computed from sourceRectangle and destinationRectangle.
+ The scale and transformation are computed such that sourceRectangle
+ is transformed to destinationRectangle. Typically sourceRectangle
+ represents the logical coordinateSpace while destinationRectangle
+ represents the device coordinateSpace."
+
+ |sX sY tX tY newScale|
+
+ sX := destinationRectangle width / sourceRectangle width.
+ sY := destinationRectangle height / sourceRectangle height.
+ tX := destinationRectangle left - sourceRectangle left.
+ tY := destinationRectangle top - sourceRectangle top.
+ ((sX = 1.0) and:[sY = 1.0]) ifTrue:[
+ newScale := 1 @ 1
+ ] ifFalse:[
+ newScale := sX @ sY
+ ].
+ ^ self new scale:newScale translation:(tX @ tY)
+!
+
+identity
+ "returns a windowing transformation with no scaling (nil)
+ and no translation (0@0)."
+
+ ^ self new scale:1 translation:0
+! !
+
+!WindowingTransformation class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1992 by Claus Gittinger
- All Rights Reserved
+ 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
@@ -41,7 +124,7 @@
version
"
-$Header: /cvs/stx/stx/libview/WindowingTransformation.st,v 1.5 1994-08-05 01:16:22 claus Exp $
+$Header: /cvs/stx/stx/libview/WindowingTransformation.st,v 1.6 1994-10-10 02:34:07 claus Exp $
"
!
@@ -50,8 +133,8 @@
I represent the ability to perform transformations in 2-D space.
Instance variables are:
- scale <Number> or <Point> representing a linear scaling factor.
- translation <Number> or <Point> representing a translation in 2-D.
+ scale <Number> or <Point> representing a linear scaling factor.
+ translation <Number> or <Point> representing a translation in 2-D.
All 2-D objects are supposed to be able to be transformed using
instances of me. Instances of me can also be combined to form a
@@ -59,67 +142,62 @@
"
! !
-!WindowingTransformation methodsFor: 'accessing'!
-
-scale
- "return a copy of the Point that represents the
- current scale of the receiver."
+!WindowingTransformation methodsFor:'applying transform'!
- scale == nil ifTrue:[
- ^ Point x:1 y:1
+applyToX:aNumber
+ "Apply the receiver to a number representing an x-coordinate
+ and return the result."
+
+ scale isNil ifTrue:[
+ ^ aNumber + translation x
].
- ^ scale copy
-!
-
-scaleOfOne
- "Set the scale of the receiver to the identity scale"
-
- scale := nil
+ ^ (aNumber * scale x + translation x) asInteger
!
-translation
- "return a copy of the receiver's translation."
+applyToY:aNumber
+ "Apply the receiver to a number representing an y-coordinate
+ and return the result."
- ^ translation copy
+ scale isNil ifTrue:[
+ ^ aNumber + translation y
+ ].
+ ^ (aNumber * scale y + translation y) asInteger
!
-translation: aValue
- "Set the receiver's translation to aValue."
+applyScaleY:aNumber
+ "apply the scale only (if heights are to be transformed)"
- translation := aValue
-! !
-
-!WindowingTransformation methodsFor: 'testing'!
+ scale isNil ifTrue:[^ aNumber].
+ ^ (aNumber * scale y) asInteger
+!
-noScale
- "return true if the identity scale is in effect;
- answer false, otherwise."
+applyScaleX:aNumber
+ "apply the scale only (if widths are to be transformed)"
- ^ scale == nil
-! !
-
-!WindowingTransformation methodsFor: 'applying transform'!
+ scale isNil ifTrue:[^ aNumber].
+ ^ (aNumber * scale x) asInteger
+!
applyInverseTo:anObject
"Apply the inverse of the receiver to anObject
- and answer the result."
+ and return the result."
|transformedObject|
transformedObject := anObject translatedBy:(self inverseTranslation).
scale == nil ifFalse:[
- transformedObject scaleBy:(self inverseScale)
+ transformedObject scaleBy:(self inverseScale)
].
^ transformedObject
!
applyTo:anObject
- "Apply the receiver to anObject and answer the result."
+ "Apply the receiver to anObject and return the result."
|transformedObject|
scale == nil ifTrue:[
- ^ anObject translateBy:translation.
+ ^ anObject translateBy:translation.
].
transformedObject := anObject scaledBy:scale
transformedObject translateBy:translation.
@@ -138,26 +216,62 @@
aTransformationScale := aTransformation scale.
scale == nil ifTrue:[
- aTransformation noScale ifTrue:[
- newScale := nil
- ] ifFalse:[
- newScale := aTransformationScale
- ].
- newTranslation := translation + aTransformation translation
+ aTransformation noScale ifTrue:[
+ newScale := nil
+ ] ifFalse:[
+ newScale := aTransformationScale
+ ].
+ newTranslation := translation + aTransformation translation
] ifFalse:[
- aTransformation noScale ifTrue:[
- newScale := scale
- ] ifFalse:[
- newScale := scale * aTransformationScale
- ].
- newTranslation := translation
- + (scale * aTransformation translation)
+ aTransformation noScale ifTrue:[
+ newScale := scale
+ ] ifFalse:[
+ newScale := scale * aTransformationScale
+ ].
+ newTranslation := translation
+ + (scale * aTransformation translation)
].
- ^ WindowingTransformation scale:newScale
- translation:newTranslation
+ ^ (self class)
+ scale:newScale
+ translation:newTranslation
! !
-!WindowingTransformation methodsFor: 'transforming'!
+!WindowingTransformation methodsFor:'transforming'!
+
+scaleBy:aScale
+ "scale the receiver.
+ This is a destructive operation, modifying the transformation
+ represented by the receiver"
+
+ |newScale newTranslation|
+
+ aScale isNil ifTrue:[^ self].
+
+ scale isNil ifTrue:[
+ newScale := aScale asPoint
+ ] ifFalse:[
+ newScale := scale * aScale
+ ].
+ translation := translation * aScale.
+ scale := newScale.
+!
+
+translateBy:aTranslation
+ "translate the receiver.
+ This is a destructive operation, modifying the transformation
+ represented by the receiver"
+
+ aTranslation isNil ifTrue:[^ self].
+
+ translation isNil ifTrue:[
+ translation := 0@0
+ ].
+ scale isNil ifTrue:[
+ translation := translation + aTranslation asPoint
+ ] ifFalse:[
+ translation := translation + (scale * aTranslation)
+ ].
+!
scaledBy:aScale
"return a new WindowingTransformation with the scale and translation of
@@ -166,19 +280,20 @@
|checkedScale newScale newTranslation|
aScale == nil ifTrue:[
- newScale := scale.
- newTranslation := translation
+ newScale := scale.
+ newTranslation := translation
] ifFalse:[
- checkedScale := self checkScale:aScale.
- scale == nil ifTrue:[
- newScale := checkedScale
- ] ifFalse:[
- newScale := scale * checkedScale
- ].
- newTranslation := checkedScale * translation
+ checkedScale := self checkScale:aScale.
+ scale == nil ifTrue:[
+ newScale := checkedScale
+ ] ifFalse:[
+ newScale := scale * checkedScale
+ ].
+ newTranslation := checkedScale * translation
].
- ^ WindowingTransformation scale:newScale
- translation:newTranslation
+ ^ (self class)
+ scale:newScale
+ translation:newTranslation
!
translatedBy:aPoint
@@ -186,18 +301,12 @@
rotations as the receiver and with a translation of the current
translation plus aPoint."
- ^ WindowingTransformation scale:scale
- translation:(translation + aPoint)
+ ^ (self class)
+ scale:scale
+ translation:(translation + aPoint)
! !
-!WindowingTransformation methodsFor: 'printing'!
-
-printString
- ^ (self class name, ' scale: ', scale printString,
- ' translation: ', translation printString)
-! !
-
-!WindowingTransformation methodsFor: 'private'!
+!WindowingTransformation methodsFor:'private'!
checkScale:aScale
"Converts aScale to the internal format of a floating-point Point."
@@ -206,7 +315,7 @@
checkedScale := aScale asPoint.
^ Point x:checkedScale x asFloat
- y:checkedScale y asFloat
+ y:checkedScale y asFloat
!
inverseScale
@@ -217,7 +326,7 @@
newScale := self checkScale:scale.
^ Point x:(1.0 / newScale x)
- y:(1.0 / newScale y)
+ y:(1.0 / newScale y)
!
inverseTranslation
@@ -228,47 +337,68 @@
trans := translation asPoint.
^ Point x:trans x negated
- y:trans y negated
+ y:trans y negated
+! !
+
+!WindowingTransformation methodsFor:'accessing'!
+
+scale:aScale translation:aTranslation
+ "sets the scale to aScale and the translation to aTranslation."
+
+ scale := aScale asPoint.
+ translation := aTranslation asPoint
!
-setScale:aScale translation:aTranslation
- "Sets the scale to aScale and the translation to aTranslation."
-
- scale := aScale.
- translation := aTranslation
-! !
+translation:aValue
+ "Set the receiver's translation to aValue, a Point or Number."
-!WindowingTransformation class methodsFor: 'instance creation'!
+ translation := aValue asPoint
+!
-identity
- "returns a windowing transformation with no scaling (nil)
- and no translation (0@0)."
+scale:aValue
+ "Set the receiver's scale to aValue, a Point or Number."
- ^ self new setScale:nil translation:(Point x:0.0 y:0.0)
+ scale := aValue asPoint
!
-scale:aScale translation:aTranslation
- "returns a windowing transformation with a scale factor of
- aScale and a translation offset of aTranslation."
+scale
+ "return a copy of the Point that represents the
+ current scale of the receiver."
- ^ self new setScale:aScale translation:aTranslation
+ scale == nil ifTrue:[
+ ^ Point x:1 y:1
+ ].
+ ^ scale copy
+!
+
+translation
+ "return a copy of the receiver's translation."
+
+ ^ translation copy
!
-window:sourceRectangle viewport:destinationRectangle
- "returns a windowing transformation with a scale and
- translation computed from sourceRectangle and destinationRectangle.
- The scale and transformation are computed such that sourceRectangle
- is transformed to destinationRectangle."
+scaleOfOne
+ "Set the scale of the receiver to the identity scale"
+
+ scale := nil
+! !
+
+!WindowingTransformation methodsFor:'testing'!
+
+noScale
+ "return true if the identity scale is in effect;
+ return false, otherwise."
- |sX sY tX tY newScale|
- sX := destinationRectangle width / sourceRectangle width.
- sY := destinationRectangle height / sourceRectangle height.
- tX := destinationRectangle left - sourceRectangle left.
- tY := destinationRectangle top - sourceRectangle top.
- ((sX = 1.0) and:[sY = 1.0]) ifTrue:[
- newScale := nil
- ] ifFalse:[
- newScale := Point x:sX y:sY
- ].
- ^ self new setScale:newScale translation:(Point x:tX y:tY)
+ ^ scale == nil
! !
+
+!WindowingTransformation methodsFor:'printing'!
+
+printOn:aStream
+ aStream nextPutAll:self class name.
+ aStream nextPutAll:' scale: '.
+ scale printOn:aStream
+ aStream nextPutAll:' translation: '.
+ translation printOn:aStream
+! !
+
--- a/Workstat.st Mon Oct 10 03:30:48 1994 +0100
+++ b/Workstat.st Mon Oct 10 03:34:45 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libview/Attic/Workstat.st,v 1.8 1994-08-05 01:16:26 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/Workstat.st,v 1.9 1994-10-10 02:34:16 claus Exp $
'!
Smalltalk at:#Display put:nil!
@@ -45,7 +45,7 @@
version
"
-$Header: /cvs/stx/stx/libview/Attic/Workstat.st,v 1.8 1994-08-05 01:16:26 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/Workstat.st,v 1.9 1994-10-10 02:34:16 claus Exp $
"
!
@@ -72,6 +72,9 @@
].
workstationType notNil ifTrue:[
+ "make sure its initialized ..."
+ workstationType initialize.
+
"look for a '-display xxx' argument"
1 to:(Arguments size - 1) do:[:i |
((Arguments at:i) = '-display') ifTrue:[
--- a/Workstation.st Mon Oct 10 03:30:48 1994 +0100
+++ b/Workstation.st Mon Oct 10 03:34:45 1994 +0100
@@ -21,7 +21,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libview/Attic/Workstation.st,v 1.8 1994-08-05 01:16:26 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/Workstation.st,v 1.9 1994-10-10 02:34:16 claus Exp $
'!
Smalltalk at:#Display put:nil!
@@ -45,7 +45,7 @@
version
"
-$Header: /cvs/stx/stx/libview/Attic/Workstation.st,v 1.8 1994-08-05 01:16:26 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/Workstation.st,v 1.9 1994-10-10 02:34:16 claus Exp $
"
!
@@ -72,6 +72,9 @@
].
workstationType notNil ifTrue:[
+ "make sure its initialized ..."
+ workstationType initialize.
+
"look for a '-display xxx' argument"
1 to:(Arguments size - 1) do:[:i |
((Arguments at:i) = '-display') ifTrue:[
--- a/XWorkstat.st Mon Oct 10 03:30:48 1994 +0100
+++ b/XWorkstat.st Mon Oct 10 03:34:45 1994 +0100
@@ -30,7 +30,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libview/Attic/XWorkstat.st,v 1.21 1994-10-04 18:10:54 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/XWorkstat.st,v 1.22 1994-10-10 02:34:25 claus Exp $
'!
!XWorkstation class methodsFor:'documentation'!
@@ -51,7 +51,7 @@
version
"
-$Header: /cvs/stx/stx/libview/Attic/XWorkstat.st,v 1.21 1994-10-04 18:10:54 claus Exp $
+$Header: /cvs/stx/stx/libview/Attic/XWorkstat.st,v 1.22 1994-10-10 02:34:25 claus Exp $
"
!
@@ -1172,7 +1172,7 @@
minExtent:(aView minExtent)
maxExtent:(aView maxExtent)
borderWidth:(aView borderWidth)
- borderColor:(aView borderColor)
+"/ borderColor:(aView borderColor)
subViewOf:(aView superView)
onTop:(aView createOnTop)
inputOnly:(aView inputOnly)
@@ -1188,7 +1188,7 @@
minExtent:minExt
maxExtent:maxExt
borderWidth:bWidth
- borderColor:bColor
+"/ borderColor:bColor
subViewOf:wsuperView
onTop:wcreateOnTop
inputOnly:winputOnly
@@ -1223,9 +1223,11 @@
maxHeight := maxExt y
].
+"
bColor notNil ifTrue:[
bColorId := bColor colorId
].
+"
"
viewBg := aView viewBackground.
@@ -1255,12 +1257,12 @@
].
weventMask := aView eventMask.
- bitGravity := aView bitGravity.
- viewGravity := aView viewGravity.
+"/ bitGravity := aView bitGravity.
+"/ viewGravity := aView viewGravity.
preferedVisual := aView preferedVisual.
preferedDepth := aView preferedDepth.
-%{ /* STACK:32768 used to be:8192 */
+%{ /* STACK:16000 */
Display *dpy = myDpy;
int screen = _intVal(_INST(screen));
Visual visual;
@@ -1323,11 +1325,15 @@
bw = 0;
}
+#ifdef OLD
if (_isSmallInteger(bColor)) {
bd = _intVal(bColor);
} else {
bd = BlackPixel(dpy, screen);
}
+#else
+ bd = BlackPixel(dpy, screen);
+#endif
if (_isSmallInteger(wsuperViewId)) {
parentWindow = _WindowVal(wsuperViewId);
@@ -1336,6 +1342,7 @@
isTopWindow = 1;
}
+#ifdef OLD
if (bitGravity == @symbol(NorthWest)) {
xswa.bit_gravity = NorthWestGravity;
flags |= CWBitGravity;
@@ -1379,6 +1386,7 @@
flags |= CWWinGravity;
}
}
+#endif
if (wcreateOnTop == true)
xswa.override_redirect = 1;
@@ -2818,6 +2826,86 @@
self primitiveFailed
!
+setBitGravity:how in:aWindowId
+ "set bit gravity for a window"
+
+%{ /* NOCONTEXT */
+
+ XSetWindowAttributes wa;
+
+ if (_isSmallInteger(aWindowId)) {
+ if (how == @symbol(NorthWest)) {
+ wa.bit_gravity = NorthWestGravity;
+ } else if (how == @symbol(NorthEast)) {
+ wa.bit_gravity = NorthEastGravity;
+ } else if (how == @symbol(SouthWest)) {
+ wa.bit_gravity = SouthWestGravity;
+ } else if (how == @symbol(SouthEast)) {
+ wa.bit_gravity = SouthEastGravity;
+ } else if (how == @symbol(Center)) {
+ wa.bit_gravity = CenterGravity;
+ } else if (how == @symbol(North)) {
+ wa.bit_gravity = NorthGravity;
+ } else if (how == @symbol(South)) {
+ wa.bit_gravity = SouthGravity;
+ } else if (how == @symbol(West)) {
+ wa.bit_gravity = WestGravity;
+ } else if (how == @symbol(East)) {
+ wa.bit_gravity = EastGravity;
+ } else {
+ wa.bit_gravity = NorthWestGravity;
+ }
+
+ BEGIN_INTERRUPTSBLOCKED
+ XChangeWindowAttributes(myDpy, _WindowVal(aWindowId), CWBitGravity, &wa);
+ END_INTERRUPTSBLOCKED
+ RETURN ( self );
+ }
+%}
+.
+ self primitiveFailed
+!
+
+setWindowGravity:how in:aWindowId
+ "set window gravity for a window"
+
+%{ /* NOCONTEXT */
+
+ XSetWindowAttributes wa;
+
+ if (_isSmallInteger(aWindowId)) {
+ if (how == @symbol(NorthWest)) {
+ wa.win_gravity = NorthWestGravity;
+ } else if (how == @symbol(NorthEast)) {
+ wa.win_gravity = NorthEastGravity;
+ } else if (how == @symbol(SouthWest)) {
+ wa.win_gravity = SouthWestGravity;
+ } else if (how == @symbol(SouthEast)) {
+ wa.win_gravity = SouthEastGravity;
+ } else if (how == @symbol(Center)) {
+ wa.win_gravity = CenterGravity;
+ } else if (how == @symbol(North)) {
+ wa.win_gravity = NorthGravity;
+ } else if (how == @symbol(South)) {
+ wa.win_gravity = SouthGravity;
+ } else if (how == @symbol(West)) {
+ wa.win_gravity = WestGravity;
+ } else if (how == @symbol(East)) {
+ wa.win_gravity = EastGravity;
+ } else {
+ wa.win_gravity = NorthWestGravity;
+ }
+
+ BEGIN_INTERRUPTSBLOCKED
+ XChangeWindowAttributes(myDpy, _WindowVal(aWindowId), CWWinGravity, &wa);
+ END_INTERRUPTSBLOCKED
+ RETURN ( self );
+ }
+%}
+.
+ self primitiveFailed
+!
+
setSaveUnder:yesOrNo in:aWindowId
"turn on/off save-under for a window"
@@ -3707,82 +3795,92 @@
getBitsFrom:aDrawableId x:srcx y:srcy width:w height:h into:imageBits
"get bits from a drawable into the imageBits. The storage for the bits
- be big enough for the data to fit. If ok, returns an array with some
- info and the bits in imageBits."
-
- |info|
-
- ((w <= 0) or:[h <= 0]) ifTrue:[
+ must be big enough for the data to fit. If ok, returns an array with some
+ info and the bits in imageBits. The info contains the depth, bitOrder and
+ number of bytes per scanline. The number of bytes per scanline is not known
+ in advance, since the X-server is free to return whatever it thinks is a good padding."
+
+ |info|
+
+ ((w <= 0) or:[h <= 0]) ifTrue:[
self primitiveFailed.
^ nil
- ].
-
- info := Array with:nil "depth"
- with:nil "bit order"
- with:nil "bytes_per_line".
-
-%{
- {
- Display *dpy = myDpy;
- Window win = _WindowVal(aDrawableId);
- extern OBJ ByteArray;
- XImage *image;
- int pad, bytes_per_line, bytes;
-
- if (_isSmallInteger(aDrawableId)
- && _isSmallInteger(srcx) && _isSmallInteger(srcy)
- && _isSmallInteger(w) && _isSmallInteger(h)
- && __isArray(info)
- && __isByteArray(imageBits)) {
- image = XGetImage(dpy, win, _intVal(srcx), _intVal(srcy),
- _intVal(w), _intVal(h),
- (unsigned)AllPlanes, ZPixmap);
-
- pad = image->bitmap_pad;
+ ].
+
+ info := Array with:nil "depth"
+ with:nil "bit order"
+ with:nil "bytes_per_line".
+
+ (self primGetBitsFrom:aDrawableId x:srcx y:srcy width:w height:h into:imageBits infoInfo:info) ifTrue:[
+ ^ info
+ ].
+ "
+ some error occured - either args are not smallintegers, imageBits is not a ByteArray
+ or is too small to hold the bits
+ "
+ ^ self primitiveFailed
+!
+
+primGetBitsFrom:aDrawableId x:srcx y:srcy width:w height:h into:imageBits infoInfo:info
+%{ /* UNLIMITEDSTACK */
+
+ Display *dpy = myDpy;
+ Window win = _WindowVal(aDrawableId);
+ extern OBJ ByteArray;
+ XImage *image;
+ int pad, bytes_per_line, bytes;
+
+ if (_isSmallInteger(aDrawableId)
+ && _isSmallInteger(srcx) && _isSmallInteger(srcy)
+ && _isSmallInteger(w) && _isSmallInteger(h)
+ && __isArray(info)
+ && __isByteArray(imageBits)) {
+ image = XGetImage(dpy, win, _intVal(srcx), _intVal(srcy),
+ _intVal(w), _intVal(h),
+ (unsigned)AllPlanes, ZPixmap);
+
+ pad = image->bitmap_pad;
#ifdef SUPERDEBUG
- printf("pad:%d depth:%d\n", image->bitmap_pad, image->depth);
+ printf("pad:%d depth:%d\n", image->bitmap_pad, image->depth);
#endif
- switch (image->depth) {
- case 1:
- case 2:
- case 4:
- case 8:
- case 16:
- case 24:
- bytes = image->bytes_per_line * image->height;
- break;
- default:
- /* unsupported depth */
- XDestroyImage(image);
- goto fail;
- }
+ switch (image->depth) {
+ case 1:
+ case 2:
+ case 4:
+ case 8:
+ case 16:
+ case 24:
+ bytes = image->bytes_per_line * image->height;
+ break;
+ default:
+ /* unsupported depth */
+ XDestroyImage(image);
+ goto fail;
+ }
#ifdef SUPERDEBUG
- printf("bytes need:%d bytes given:%d\n", bytes,
- (_qSize(imageBits) - OHDR_SIZE));
+ printf("bytes need:%d bytes given:%d\n", bytes,
+ (_qSize(imageBits) - OHDR_SIZE));
#endif
- if (bytes > (_qSize(imageBits) - OHDR_SIZE)) {
- /* imageBits too small */
- XDestroyImage(image);
- goto fail;
- }
- if (image->bitmap_bit_order == MSBFirst)
- _ArrayInstPtr(info)->a_element[0] = @symbol(msbFirst);
- else
- _ArrayInstPtr(info)->a_element[0] = @symbol(lsbFirst);
- _ArrayInstPtr(info)->a_element[1] = _MKSMALLINT(image->depth);
- _ArrayInstPtr(info)->a_element[2] = _MKSMALLINT(image->bytes_per_line);
- bcopy(image->data, _ByteArrayInstPtr(imageBits)->ba_element, bytes);
+ if (bytes > (_qSize(imageBits) - OHDR_SIZE)) {
+ /* imageBits too small */
XDestroyImage(image);
- RETURN ( info );
+ goto fail;
}
-fail: ;
+ if (image->bitmap_bit_order == MSBFirst)
+ _ArrayInstPtr(info)->a_element[0] = @symbol(msbFirst);
+ else
+ _ArrayInstPtr(info)->a_element[0] = @symbol(lsbFirst);
+ _ArrayInstPtr(info)->a_element[1] = _MKSMALLINT(image->depth);
+ _ArrayInstPtr(info)->a_element[2] = _MKSMALLINT(image->bytes_per_line);
+ bcopy(image->data, _ByteArrayInstPtr(imageBits)->ba_element, bytes);
+ XDestroyImage(image);
+ RETURN ( true );
}
-%}
-.
- self primitiveFailed.
- ^ nil
+fail: ;
+%}.
+ ^ false
! !
!XWorkstation methodsFor:'drawing'!
--- a/XWorkstation.st Mon Oct 10 03:30:48 1994 +0100
+++ b/XWorkstation.st Mon Oct 10 03:34:45 1994 +0100
@@ -30,7 +30,7 @@
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
-$Header: /cvs/stx/stx/libview/XWorkstation.st,v 1.21 1994-10-04 18:10:54 claus Exp $
+$Header: /cvs/stx/stx/libview/XWorkstation.st,v 1.22 1994-10-10 02:34:25 claus Exp $
'!
!XWorkstation class methodsFor:'documentation'!
@@ -51,7 +51,7 @@
version
"
-$Header: /cvs/stx/stx/libview/XWorkstation.st,v 1.21 1994-10-04 18:10:54 claus Exp $
+$Header: /cvs/stx/stx/libview/XWorkstation.st,v 1.22 1994-10-10 02:34:25 claus Exp $
"
!
@@ -1172,7 +1172,7 @@
minExtent:(aView minExtent)
maxExtent:(aView maxExtent)
borderWidth:(aView borderWidth)
- borderColor:(aView borderColor)
+"/ borderColor:(aView borderColor)
subViewOf:(aView superView)
onTop:(aView createOnTop)
inputOnly:(aView inputOnly)
@@ -1188,7 +1188,7 @@
minExtent:minExt
maxExtent:maxExt
borderWidth:bWidth
- borderColor:bColor
+"/ borderColor:bColor
subViewOf:wsuperView
onTop:wcreateOnTop
inputOnly:winputOnly
@@ -1223,9 +1223,11 @@
maxHeight := maxExt y
].
+"
bColor notNil ifTrue:[
bColorId := bColor colorId
].
+"
"
viewBg := aView viewBackground.
@@ -1255,12 +1257,12 @@
].
weventMask := aView eventMask.
- bitGravity := aView bitGravity.
- viewGravity := aView viewGravity.
+"/ bitGravity := aView bitGravity.
+"/ viewGravity := aView viewGravity.
preferedVisual := aView preferedVisual.
preferedDepth := aView preferedDepth.
-%{ /* STACK:32768 used to be:8192 */
+%{ /* STACK:16000 */
Display *dpy = myDpy;
int screen = _intVal(_INST(screen));
Visual visual;
@@ -1323,11 +1325,15 @@
bw = 0;
}
+#ifdef OLD
if (_isSmallInteger(bColor)) {
bd = _intVal(bColor);
} else {
bd = BlackPixel(dpy, screen);
}
+#else
+ bd = BlackPixel(dpy, screen);
+#endif
if (_isSmallInteger(wsuperViewId)) {
parentWindow = _WindowVal(wsuperViewId);
@@ -1336,6 +1342,7 @@
isTopWindow = 1;
}
+#ifdef OLD
if (bitGravity == @symbol(NorthWest)) {
xswa.bit_gravity = NorthWestGravity;
flags |= CWBitGravity;
@@ -1379,6 +1386,7 @@
flags |= CWWinGravity;
}
}
+#endif
if (wcreateOnTop == true)
xswa.override_redirect = 1;
@@ -2818,6 +2826,86 @@
self primitiveFailed
!
+setBitGravity:how in:aWindowId
+ "set bit gravity for a window"
+
+%{ /* NOCONTEXT */
+
+ XSetWindowAttributes wa;
+
+ if (_isSmallInteger(aWindowId)) {
+ if (how == @symbol(NorthWest)) {
+ wa.bit_gravity = NorthWestGravity;
+ } else if (how == @symbol(NorthEast)) {
+ wa.bit_gravity = NorthEastGravity;
+ } else if (how == @symbol(SouthWest)) {
+ wa.bit_gravity = SouthWestGravity;
+ } else if (how == @symbol(SouthEast)) {
+ wa.bit_gravity = SouthEastGravity;
+ } else if (how == @symbol(Center)) {
+ wa.bit_gravity = CenterGravity;
+ } else if (how == @symbol(North)) {
+ wa.bit_gravity = NorthGravity;
+ } else if (how == @symbol(South)) {
+ wa.bit_gravity = SouthGravity;
+ } else if (how == @symbol(West)) {
+ wa.bit_gravity = WestGravity;
+ } else if (how == @symbol(East)) {
+ wa.bit_gravity = EastGravity;
+ } else {
+ wa.bit_gravity = NorthWestGravity;
+ }
+
+ BEGIN_INTERRUPTSBLOCKED
+ XChangeWindowAttributes(myDpy, _WindowVal(aWindowId), CWBitGravity, &wa);
+ END_INTERRUPTSBLOCKED
+ RETURN ( self );
+ }
+%}
+.
+ self primitiveFailed
+!
+
+setWindowGravity:how in:aWindowId
+ "set window gravity for a window"
+
+%{ /* NOCONTEXT */
+
+ XSetWindowAttributes wa;
+
+ if (_isSmallInteger(aWindowId)) {
+ if (how == @symbol(NorthWest)) {
+ wa.win_gravity = NorthWestGravity;
+ } else if (how == @symbol(NorthEast)) {
+ wa.win_gravity = NorthEastGravity;
+ } else if (how == @symbol(SouthWest)) {
+ wa.win_gravity = SouthWestGravity;
+ } else if (how == @symbol(SouthEast)) {
+ wa.win_gravity = SouthEastGravity;
+ } else if (how == @symbol(Center)) {
+ wa.win_gravity = CenterGravity;
+ } else if (how == @symbol(North)) {
+ wa.win_gravity = NorthGravity;
+ } else if (how == @symbol(South)) {
+ wa.win_gravity = SouthGravity;
+ } else if (how == @symbol(West)) {
+ wa.win_gravity = WestGravity;
+ } else if (how == @symbol(East)) {
+ wa.win_gravity = EastGravity;
+ } else {
+ wa.win_gravity = NorthWestGravity;
+ }
+
+ BEGIN_INTERRUPTSBLOCKED
+ XChangeWindowAttributes(myDpy, _WindowVal(aWindowId), CWWinGravity, &wa);
+ END_INTERRUPTSBLOCKED
+ RETURN ( self );
+ }
+%}
+.
+ self primitiveFailed
+!
+
setSaveUnder:yesOrNo in:aWindowId
"turn on/off save-under for a window"
@@ -3707,82 +3795,92 @@
getBitsFrom:aDrawableId x:srcx y:srcy width:w height:h into:imageBits
"get bits from a drawable into the imageBits. The storage for the bits
- be big enough for the data to fit. If ok, returns an array with some
- info and the bits in imageBits."
-
- |info|
-
- ((w <= 0) or:[h <= 0]) ifTrue:[
+ must be big enough for the data to fit. If ok, returns an array with some
+ info and the bits in imageBits. The info contains the depth, bitOrder and
+ number of bytes per scanline. The number of bytes per scanline is not known
+ in advance, since the X-server is free to return whatever it thinks is a good padding."
+
+ |info|
+
+ ((w <= 0) or:[h <= 0]) ifTrue:[
self primitiveFailed.
^ nil
- ].
-
- info := Array with:nil "depth"
- with:nil "bit order"
- with:nil "bytes_per_line".
-
-%{
- {
- Display *dpy = myDpy;
- Window win = _WindowVal(aDrawableId);
- extern OBJ ByteArray;
- XImage *image;
- int pad, bytes_per_line, bytes;
-
- if (_isSmallInteger(aDrawableId)
- && _isSmallInteger(srcx) && _isSmallInteger(srcy)
- && _isSmallInteger(w) && _isSmallInteger(h)
- && __isArray(info)
- && __isByteArray(imageBits)) {
- image = XGetImage(dpy, win, _intVal(srcx), _intVal(srcy),
- _intVal(w), _intVal(h),
- (unsigned)AllPlanes, ZPixmap);
-
- pad = image->bitmap_pad;
+ ].
+
+ info := Array with:nil "depth"
+ with:nil "bit order"
+ with:nil "bytes_per_line".
+
+ (self primGetBitsFrom:aDrawableId x:srcx y:srcy width:w height:h into:imageBits infoInfo:info) ifTrue:[
+ ^ info
+ ].
+ "
+ some error occured - either args are not smallintegers, imageBits is not a ByteArray
+ or is too small to hold the bits
+ "
+ ^ self primitiveFailed
+!
+
+primGetBitsFrom:aDrawableId x:srcx y:srcy width:w height:h into:imageBits infoInfo:info
+%{ /* UNLIMITEDSTACK */
+
+ Display *dpy = myDpy;
+ Window win = _WindowVal(aDrawableId);
+ extern OBJ ByteArray;
+ XImage *image;
+ int pad, bytes_per_line, bytes;
+
+ if (_isSmallInteger(aDrawableId)
+ && _isSmallInteger(srcx) && _isSmallInteger(srcy)
+ && _isSmallInteger(w) && _isSmallInteger(h)
+ && __isArray(info)
+ && __isByteArray(imageBits)) {
+ image = XGetImage(dpy, win, _intVal(srcx), _intVal(srcy),
+ _intVal(w), _intVal(h),
+ (unsigned)AllPlanes, ZPixmap);
+
+ pad = image->bitmap_pad;
#ifdef SUPERDEBUG
- printf("pad:%d depth:%d\n", image->bitmap_pad, image->depth);
+ printf("pad:%d depth:%d\n", image->bitmap_pad, image->depth);
#endif
- switch (image->depth) {
- case 1:
- case 2:
- case 4:
- case 8:
- case 16:
- case 24:
- bytes = image->bytes_per_line * image->height;
- break;
- default:
- /* unsupported depth */
- XDestroyImage(image);
- goto fail;
- }
+ switch (image->depth) {
+ case 1:
+ case 2:
+ case 4:
+ case 8:
+ case 16:
+ case 24:
+ bytes = image->bytes_per_line * image->height;
+ break;
+ default:
+ /* unsupported depth */
+ XDestroyImage(image);
+ goto fail;
+ }
#ifdef SUPERDEBUG
- printf("bytes need:%d bytes given:%d\n", bytes,
- (_qSize(imageBits) - OHDR_SIZE));
+ printf("bytes need:%d bytes given:%d\n", bytes,
+ (_qSize(imageBits) - OHDR_SIZE));
#endif
- if (bytes > (_qSize(imageBits) - OHDR_SIZE)) {
- /* imageBits too small */
- XDestroyImage(image);
- goto fail;
- }
- if (image->bitmap_bit_order == MSBFirst)
- _ArrayInstPtr(info)->a_element[0] = @symbol(msbFirst);
- else
- _ArrayInstPtr(info)->a_element[0] = @symbol(lsbFirst);
- _ArrayInstPtr(info)->a_element[1] = _MKSMALLINT(image->depth);
- _ArrayInstPtr(info)->a_element[2] = _MKSMALLINT(image->bytes_per_line);
- bcopy(image->data, _ByteArrayInstPtr(imageBits)->ba_element, bytes);
+ if (bytes > (_qSize(imageBits) - OHDR_SIZE)) {
+ /* imageBits too small */
XDestroyImage(image);
- RETURN ( info );
+ goto fail;
}
-fail: ;
+ if (image->bitmap_bit_order == MSBFirst)
+ _ArrayInstPtr(info)->a_element[0] = @symbol(msbFirst);
+ else
+ _ArrayInstPtr(info)->a_element[0] = @symbol(lsbFirst);
+ _ArrayInstPtr(info)->a_element[1] = _MKSMALLINT(image->depth);
+ _ArrayInstPtr(info)->a_element[2] = _MKSMALLINT(image->bytes_per_line);
+ bcopy(image->data, _ByteArrayInstPtr(imageBits)->ba_element, bytes);
+ XDestroyImage(image);
+ RETURN ( true );
}
-%}
-.
- self primitiveFailed.
- ^ nil
+fail: ;
+%}.
+ ^ false
! !
!XWorkstation methodsFor:'drawing'!