--- a/Color.st Wed Oct 13 01:30:35 1993 +0100
+++ b/Color.st Wed Oct 13 01:32:53 1993 +0100
@@ -15,7 +15,8 @@
classVariableNames:'lobby
Black White LightGrey Grey DarkGrey
Pseudo0 Pseudo1 PseudoAll
- Red Green Blue DitherColors'
+ Red Green Blue
+ DitherColors ColorsByHue ColorsByRed'
poolDictionaries:''
category:'Graphics-Support'
!
@@ -90,6 +91,9 @@
lobby isNil ifTrue:[
lobby := Registry new.
+ ColorsByHue := ShadowArray new:20.
+ ColorsByRed := ShadowArray new:20.
+
self getPrimaryColors.
"want to be informed when returning from snapshot"
@@ -125,8 +129,11 @@
"unassign all colors from their device"
lobby contentsDo:[:aColor |
- aColor resetDevice.
+ aColor restored.
+"
lobby changed:aColor
+"
+ lobby unregister:aColor
]
!
@@ -166,52 +173,51 @@
!
veryLightGrey
+ "return very light-grey color"
+
^ self grey:87
!
lightGrey
- "return light-grey color -
- take value from resource file - 67% is very dark on some, very light
- on other displays ... sigh"
+ "return light-grey color"
- LightGrey isNil ifTrue:[
- LightGrey := self grey:(Resource name:'COLOR_LIGHTGREY_VALUE'
- default:67
- fromFile:'Smalltalk.rs')
+ Lightrey isNil ifTrue:[
+ Lightrey := self grey:67
].
- ^ LightGrey
+ ^ Lightrey
!
darkGrey
- "return dark-grey color -
- take value from resource file - 33% is very dark on some, very light
- on other displays ... sigh"
+ "return dark-grey color"
DarkGrey isNil ifTrue:[
- DarkGrey := self grey:(Resource name:'COLOR_DARKGREY_VALUE'
- default:33
- fromFile:'Smalltalk.rs')
+ DarkGrey := self grey:33
].
^ DarkGrey
!
veryDarkGrey
+ "return very dark-grey color"
+
^ self grey:13
!
grey
- "return a medium grey color -
- take value from resource file - 50% is very dark on some, very light
- on other displays ... sigh"
+ "return a medium grey color"
Grey isNil ifTrue:[
- Grey := self grey:(Resource name:'COLOR_GREY_VALUE'
- default:50
- fromFile:'Smalltalk.rs')
+ Grey := self grey:50
].
^ Grey
!
+brightness:grey
+ "return a grey color. For ST-80 compatibility,
+ the grey value is given in 0..1 instead of percent"
+
+ ^ self grey:(grey * 100)
+!
+
grey:grey
"return a grey color. The argument, grey is interpreted as
percent (0..100)."
@@ -277,6 +283,7 @@
rb := (b * 3) rounded / 3.0.
"look if already known"
+
lobby contentsDo:[:aColor |
(rr = aColor red) ifTrue:[
(rg = aColor green) ifTrue:[
@@ -287,7 +294,9 @@
]
].
newColor := self basicNew setRed:rr green:rg blue:rb device:nil.
+"
lobby register:newColor.
+"
^ newColor
!
@@ -297,19 +306,38 @@
^ self nameOrDither:aString
!
+name:aString ifIllegal:aBlock
+ "return a named color - or try do do as good as possible"
+
+ ^ self nameOrDither:aString ifIllegal:aBlock
+!
+
nameOrDither:aString
"return a named color - if the exact color is not available,
- return a dithered color"
+ return a dithered color. Report an error, if the colorname is
+ illegal."
+
+ ^ self nameOrDither:aString ifIllegal:[
+ self error:'no color named ' , aString.
+ nil
+ ]
+
+ "Color nameOrDither:'Brown'"
+!
+
+nameOrDither:aString ifIllegal:errorBlock
+ "return a named color - if the exact color is not available,
+ return a dithered color. If the colorname is illegal, return
+ the value of evaluating errorBlock."
Display getRGBFromName:aString into:[:r :g :b |
r notNil ifTrue:[
^ self red:r green:g blue:b
].
].
- self error:'no color named ' , aString.
- ^ nil
+ ^ errorBlock value
- "Color nameOrDither:'Brown'"
+ "Color nameOrDither:'Brown' ifIllegal:[nil]"
!
nameOrNearest:aString
@@ -401,14 +429,20 @@
"return a special color which, when used for bit-blitting will
behave like a 0-color (i.e. have a device-pixel value of all-0s)"
- ^ self basicNew colorId:0
+ Pseudo0 isNil ifTrue:[
+ Pseudo0 := self basicNew colorId:0
+ ].
+ ^ Pseudo0
!
allColor
"return a special color which, when used for bit-blitting will
behave like a all-1-color (i.e. have a device-pixel value of all-1s)"
- ^ self basicNew colorId:-1
+ PseudoAll isNil ifTrue:[
+ PseudoAll := self basicNew colorId:-1
+ ].
+ ^ PseudoAll
!
colorId:id
@@ -417,10 +451,7 @@
or for bitblits if you want to manipulate a specific colorplane."
id == 0 ifTrue:[
- Pseudo0 isNil ifTrue:[
- Pseudo0 := self basicNew colorId:0
- ].
- ^ Pseudo0
+ ^ self noColor
].
id == 1 ifTrue:[
Pseudo1 isNil ifTrue:[
@@ -429,10 +460,14 @@
^ Pseudo1
].
id == -1 ifTrue:[
- PseudoAll isNil ifTrue:[
- PseudoAll := self basicNew colorId:-1
- ].
- ^ PseudoAll
+ ^ self allColor
+ ].
+ "look if already known"
+
+ lobby contentsDo:[:aColor |
+ (aColor colorId == id) ifTrue:[
+ ^ aColor
+ ]
].
^ self basicNew colorId:id
! !
@@ -450,11 +485,11 @@
rb := (b * 3) rounded / 3.0.
lobby contentsDo:[:aColor |
- (aColor device == aDevice) ifTrue:[
- aColor colorId notNil ifTrue:[
- (rr = aColor red) ifTrue:[
- (rg = aColor green) ifTrue:[
- (rb = aColor blue) ifTrue:[
+ aColor colorId notNil ifTrue:[
+ (rr = aColor red) ifTrue:[
+ (rg = aColor green) ifTrue:[
+ (rb = aColor blue) ifTrue:[
+ (aColor device == aDevice) ifTrue:[
^ aColor
]
]
@@ -486,6 +521,10 @@
+ (rg - aColor green) asInteger squared
+ (rb - aColor blue) asInteger squared.
diff < minDelta ifTrue:[
+ diff = 0 ifTrue:[
+ "got it"
+ ^ aColor
+ ].
bestColor := aColor.
minDelta := diff
]
@@ -614,7 +653,7 @@
!Color methodsFor:'private'!
-resetDevice
+restored
"private: color has been restored (either from snapin or binary store);
flush device stuff"
@@ -663,8 +702,7 @@
and needs much more work. Currently only some special cases
are handled"
- |full none rest primary val gr values primaries sum
- rr rg rb rh rl rs color1 color2
+ |rr rg rb rh rl rs
lowL hiL lowValL hiValL lowS hiS lowValS hiValS lowH hiH lowValH hiValH d|
"get hls (since we dither anyway, round them a bit"
@@ -860,17 +898,35 @@
"found bounds for light ?"
- (lowL notNil and:[hiL notNil]) ifTrue:[
- rl = lowValL ifTrue:[
- ^ aBlock value:lowL value:nil
- ].
- ^ self monoDitherFor:100 / ((hiValL - lowValL)/(rl - lowValL))
+ lowL notNil ifTrue:[
+ rl = lowValL ifTrue:[
+ ^ aBlock value:lowL value:nil
+ ].
+ hiL notNil ifTrue:[
+ ^ self monoDitherFor:100 / ((hiValL - lowValL)/(rl - lowValL))
+ between:lowL
+ and:hiL
+ on:aDevice
+ into:aBlock
+ ].
+ "found bound for light - dither with white"
+ ^ self monoDitherFor:100 / ((100 - lowValL)/(rl - lowValL))
between:lowL
+ and:White
+ on:aDevice
+ into:aBlock
+ ].
+
+ "found bound for light - dither with black"
+ hiL notNil ifTrue:[
+ ^ self monoDitherFor:100 / ((hiValL - 0)/(rl - 0))
+ between:Black
and:hiL
on:aDevice
into:aBlock
].
+
"found bounds for saturation?"
(lowS notNil and:[hiS notNil]) ifTrue:[
@@ -883,24 +939,6 @@
into:aBlock
].
- "found one for light, dither with black or white"
-
- lowL notNil ifTrue:[
- ^ self monoDitherFor:100 / ((100 - lowValL)/(rl - lowValL))
- between:lowL
- and:White
- on:aDevice
- into:aBlock
- ].
-
- hiL notNil ifTrue:[
- ^ self monoDitherFor:100 / ((hiValL - 0)/(rl - 0))
- between:Black
- and:hiL
- on:aDevice
- into:aBlock
- ].
-
"found bounds for hue ?"
(lowH notNil and:[hiH notNil]) ifTrue:[
@@ -936,8 +974,7 @@
Returns 2 values (either color or ditherForm) through
aBlock."
- |form bits color clr1 clr2
- gr index|
+ |form bits clr1 clr2 gr index|
"having forms with: [1 .. 31] of 64 pixels,
we get dithers for: 0, 1/64, 2/64, ... 32/64"
@@ -954,21 +991,18 @@
gr := gr * 64.
index := (gr // 100) asInteger.
- index < 1 ifTrue:[
- color := color1 exactOn:aDevice.
- ] ifFalse:[
- index > 63 ifTrue:[
- color := color2 exactOn:aDevice
- ] ifFalse:[
- bits := Form ditherBitsForXin64:index
- ]
+
+ index <= 1 ifTrue:[
+ ^ aBlock value:(clr1 exactOn:aDevice) value:nil
].
- bits notNil ifTrue:[
- form := Form width:8 height:8 fromArray:bits on:aDevice.
- form colorMap:(Array with:(clr1 exactOn:aDevice)
- with:(clr2 exactOn:aDevice))
+ index >= 64 ifTrue:[
+ ^ aBlock value:(clr2 exactOn:aDevice) value:nil
].
- ^ aBlock value:color value:form
+ bits := Form ditherBitsForXin64:index.
+ form := Form width:8 height:8 fromArray:bits on:aDevice.
+ form colorMap:(Array with:(clr1 exactOn:aDevice)
+ with:(clr2 exactOn:aDevice)).
+ ^ aBlock value:nil value:form
!
dither2PlaneFor:grey on:aDevice into:aBlock
@@ -978,7 +1012,7 @@
This code optimized for 2-plane displays (NeXT),
- must be generalized for any number of planes."
- |form color
+ |color
gr "{ Class:SmallInteger }"
color1 color2 low high scaled|
@@ -1035,7 +1069,7 @@
"create a new Color representing the same color as
myself on aDevice; if one already exists, return the one"
- |newColor index id grey form sav|
+ |newColor id grey form|
"if Iam already assigned to that device ..."
(device == aDevice) ifTrue:[^ self].
@@ -1046,13 +1080,16 @@
"want to release color ?"
(aDevice isNil and:[device notNil and:[colorId notNil]]) ifTrue:[
(device notNil and:[colorId notNil]) ifTrue:[
+ lobby unregister:self.
device freeColor:colorId
].
device := nil.
colorId := nil.
"have to tell lobby - otherwise it keeps old info around"
+"
lobby changed:self.
+"
^ self
].
@@ -1087,23 +1124,31 @@
(id isNil and:[form isNil]) ifTrue:[
"still no result - try greying"
- grey := (0.3 * redVal) + (0.6 * greenVal) + (0.1 * blueVal).
+ grey := (3 * redVal) + (6 * greenVal) + (1 * blueVal).
"avoid things like 100.00000001"
- grey := ((grey * 100) rounded) / 100.0.
+ grey := ((grey * 10) rounded) / 100.0.
- ((grey = 0) or:[(grey = 100) or:[aDevice hasGreyscales]]) ifTrue:[
- "kludge for 2-plane display - dither using 4 grey levels"
+ grey = 0 ifTrue:[
+ id := aDevice blackpixel
+ ] ifFalse:[
+ grey = 100 ifTrue:[
+ id := aDevice whitepixel
+ ] ifFalse:[
+ aDevice hasGreyscales ifTrue:[
+ "kludge for 2-plane display - dither using 4 grey levels"
- (aDevice depth == 2) ifTrue:[
- grey := grey rounded.
- self dither2PlaneFor:grey on:aDevice
- into:[:c :f | newColor := c. form := f].
- newColor notNil ifTrue:[^ newColor].
- ] ifFalse:[
- id := aDevice colorRed:grey green:grey blue:grey.
- id isNil ifTrue:[
- ObjectMemory scavenge.
- id := aDevice colorRed:redVal green:greenVal blue:blueVal
+ (aDevice depth == 2) ifTrue:[
+ grey := grey rounded.
+ self dither2PlaneFor:grey on:aDevice
+ into:[:c :f | newColor := c. form := f].
+ newColor notNil ifTrue:[^ newColor].
+ ] ifFalse:[
+ id := aDevice colorRed:grey green:grey blue:grey.
+ id isNil ifTrue:[
+ ObjectMemory scavenge.
+ id := aDevice colorRed:redVal green:greenVal blue:blueVal
+ ].
+ ].
].
]
].
@@ -1128,7 +1173,12 @@
colorId := id.
"have to tell lobby - otherwise it keeps old info around"
+"
lobby changed:self.
+"
+ id notNil ifTrue:[
+ lobby register:self
+ ].
^ self
].
@@ -1138,8 +1188,11 @@
newColor ditherForm:form
] ifFalse:[
newColor colorId:id.
+ lobby register:newColor.
].
+"
lobby register:newColor.
+"
^ newColor
!
@@ -1150,7 +1203,7 @@
nil, if the exact color is not available.
Used to aquire primary colors for dithering, during startup."
- |newColor index id|
+ |newColor id|
"if Iam already assigned to that device ..."
(device == aDevice) ifTrue:[^ self].
@@ -1177,9 +1230,10 @@
device isNil ifTrue:[
device := aDevice.
colorId := id.
-
- "have to tell lobby - otherwise it keeps old info around"
+"
lobby changed:self.
+"
+ lobby register:self.
^ self
].
@@ -1195,7 +1249,7 @@
if one already exists, return the one. If no exact match is found,
search for one with an error less than the argument error (in percent)."
- |newColor index id|
+ |newColor id|
"if Iam already assigned to that device ..."
(device == aDevice) ifTrue:[^ self].
@@ -1224,8 +1278,10 @@
device := aDevice.
colorId := id.
- "have to tell lobby - otherwise it keeps old info around"
+"
lobby changed:self.
+"
+ lobby register:self.
^ self
].
@@ -1401,3 +1457,12 @@
' green:' , greenVal storeString ,
' blue:' , blueVal storeString
! !
+
+!Color methodsFor: 'binary storage'!
+
+readBinaryContentsFrom: stream manager: manager
+ "tell the newly restored Color about restoration"
+
+ super readBinaryContentsFrom: stream manager: manager.
+ self restored
+! !
--- a/Cursor.st Wed Oct 13 01:30:35 1993 +0100
+++ b/Cursor.st Wed Oct 13 01:32:53 1993 +0100
@@ -20,7 +20,8 @@
ReadCursor WriteCursor WaitCursor
XeqCursor CrossHairCursor OriginCursor
CornerCursor SquareCursor FourWayCursor
- UpDownArrowCursor LeftRightArrowCursor'
+ UpDownArrowCursor LeftRightArrowCursor
+ Wait2Cursor Wait3Cursor Wait4Cursor'
poolDictionaries:''
category:'Graphics-Support'
!
@@ -55,7 +56,7 @@
class variables:
-lobby <Registry> keeps track of known cursors
+lobby <Registry> keeps track of known device cursors
DefaultFgColor <Color> default foreground color for cursors (usually black)
DefaultBgColor <Color> default background color for cursors (usually white)
@@ -81,7 +82,7 @@
"unassign all cursors from their device"
lobby contentsDo:[:aCursor |
- aCursor resetDevice.
+ aCursor restored.
lobby changed:aCursor
]
!
@@ -171,8 +172,10 @@
]
]
].
- newCursor := self basicNew sourceForm:sourceForm maskForm:maskForm
- hotX:hotX hotY:hotY on:nil.
+ newCursor := self basicNew setSourceForm:sourceForm
+ maskForm:maskForm
+ hotX:hotX
+ hotY:hotY.
lobby register:newCursor.
^ newCursor
!
@@ -190,7 +193,7 @@
^ aCursor
]
].
- newCursor := self basicNew shape:aShape on:nil.
+ newCursor := self basicNew setShape:aShape.
lobby register:newCursor.
^ newCursor
!
@@ -367,6 +370,150 @@
^ WaitCursor
!
+wait2
+ "return a wait cursor showing 3 o'clock"
+
+ Wait2Cursor isNil ifTrue:[
+ Wait2Cursor := (self
+ extent: 16@16
+ sourceArray: #(
+ 2r0001111111100000
+ 2r0001111111100000
+ 2r0001111111100000
+ 2r0011111111110000
+ 2r0110000000011000
+ 2r1100000000001100
+ 2r1000000000000111
+ 2r1000001110000111
+ 2r1000001111111111
+ 2r1000010000000111
+ 2r1100100000001100
+ 2r0110000000011000
+ 2r0011111111110000
+ 2r0001111111100000
+ 2r0001111111100000
+ 2r0001111111100000
+ )
+ maskArray: #(
+ 2r0011111111110000
+ 2r0011111111110000
+ 2r0011111111110000
+ 2r0111111111111000
+ 2r1111111111111100
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111100
+ 2r0111111111111000
+ 2r0011111111110000
+ 2r0011111111110000
+ 2r0011111111110000
+ )
+ offset: -15 @ -9).
+ Wait2Cursor := Wait2Cursor on:Display.
+ ].
+ ^ Wait2Cursor
+!
+
+wait3
+ "return a wait cursor showing 6 o'clock"
+
+ Wait3Cursor isNil ifTrue:[
+ Wait3Cursor := (Cursor
+ extent: 16@16
+ sourceArray: #(
+ 2r0001111111100000
+ 2r0001111111100000
+ 2r0001111111100000
+ 2r0011111111110000
+ 2r0110000000011000
+ 2r1100000000001100
+ 2r1000000000000111
+ 2r1000001110000111
+ 2r1000001110000111
+ 2r1000010100000111
+ 2r1100100100001100
+ 2r0110000100011000
+ 2r0011111111110000
+ 2r0001111111100000
+ 2r0001111111100000
+ 2r0001111111100000
+ )
+ maskArray: #(
+ 2r0011111111110000
+ 2r0011111111110000
+ 2r0011111111110000
+ 2r0111111111111000
+ 2r1111111111111100
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111100
+ 2r0111111111111000
+ 2r0011111111110000
+ 2r0011111111110000
+ 2r0011111111110000
+ )
+ offset: -15 @ -9).
+ Wait3Cursor := Wait3Cursor on:Display.
+ ].
+ ^ Wait3Cursor
+!
+
+wait4
+ "return a wait cursor showing 9 o'clock"
+
+ Wait4Cursor isNil ifTrue:[
+ Wait4Cursor := (Cursor
+ extent: 16@16
+ sourceArray: #(
+ 2r0001111111100000
+ 2r0001111111100000
+ 2r0001111111100000
+ 2r0011111111110000
+ 2r0110000000011000
+ 2r1100000000001100
+ 2r1000000000000111
+ 2r1111111110000111
+ 2r1000001110000111
+ 2r1000010000000111
+ 2r1100100000001100
+ 2r0110000000011000
+ 2r0011111111110000
+ 2r0001111111100000
+ 2r0001111111100000
+ 2r0001111111100000
+ )
+ maskArray: #(
+ 2r0011111111110000
+ 2r0011111111110000
+ 2r0011111111110000
+ 2r0111111111111000
+ 2r1111111111111100
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111111
+ 2r1111111111111100
+ 2r0111111111111000
+ 2r0011111111110000
+ 2r0011111111110000
+ 2r0011111111110000
+ )
+ offset: -15 @ -9).
+ Wait4Cursor := Wait4Cursor on:Display.
+ ].
+ ^ Wait4Cursor
+!
+
read
"return a reading-file cursor"
@@ -404,6 +551,30 @@
]
! !
+!Cursor methodsFor:'private accessing'!
+
+setShape:aShapeSymbol
+ "set the shape"
+
+ shape := aShapeSymbol.
+!
+
+setSourceForm:sForm maskForm:mForm hotX:hx hotY:hy
+ "set the forms and hotspot"
+
+ sourceForm := sForm.
+ maskForm := mForm.
+ hotX := hx.
+ hotY := hy.
+!
+
+setDevice:aDevice id:anId
+ "set the device and deviceId of the receiver"
+
+ device := aDevice.
+ cursorId := anId
+! !
+
!Cursor methodsFor:'accessing'!
id
@@ -424,23 +595,6 @@
^ shape
!
-shape:aShapeSymbol on:aDevice
- "set the shape and device of the receiver"
-
- shape := aShapeSymbol.
- device := aDevice
-!
-
-sourceForm:sForm maskForm:mForm hotX:hx hotY:hy on:aDevice
- "set the forms, hotspot and device of the receiver"
-
- sourceForm := sForm.
- maskForm := mForm.
- hotX := hx.
- hotY := hy.
- device := aDevice
-!
-
sourceForm
"return the source-form of the receiver"
@@ -471,24 +625,12 @@
^ hotX
!
-hotX:aNumber
- "set the hotspots x-coordinate of the receiver"
-
- hotX := aNumber
-!
-
hotY
"return the hotspots y-coordinate of the receiver"
^ hotY
!
-hotY:aNumber
- "set the hotspots y-coordinate of the receiver"
-
- hotY := aNumber
-!
-
foreground:fgColor background:bgColor
"set the cursor colors"
@@ -534,17 +676,20 @@
"ask that device for the cursor"
shape notNil ifTrue:[
- id := aDevice createCursorShape:shape
+ id := aDevice createCursorShape:shape.
+ id isNil ifTrue:[
+ 'no cursor with shape:' print. shape printNewline.
+ ^ nil
+ ].
] ifFalse:[
id := aDevice createCursorSourceForm:sourceForm
maskForm:maskForm
hotX:hotX
- hotY:hotY
- ].
- id isNil ifTrue:[
- "no such cursor on this device"
- 'no cursor with shape:' print. shape printNewline.
- ^ nil
+ hotY:hotY.
+ id isNil ifTrue:[
+ 'cannot create cursor' printNewline.
+ ^ nil
+ ].
].
"goody for IRIXs red cursor"
@@ -564,16 +709,16 @@
].
"receiver was already associated to another device - need a new cursor"
+ newCursor := self class basicNew.
shape notNil ifTrue:[
- newCursor := (self class basicNew) shape:shape on:aDevice
+ newCursor setShape:shape.
] ifFalse:[
- newCursor := (self class basicNew) sourceForm:sourceForm
- maskForm:maskForm
- hotX:hotX
- hotY:hotY
- on:aDevice
+ newCursor setSourceForm:sourceForm
+ maskForm:maskForm
+ hotX:hotX
+ hotY:hotY
].
- newCursor id:id.
+ newCursor setDevice:aDevice id:id.
lobby register:newCursor.
^ newCursor
! !
@@ -590,7 +735,7 @@
cursorId := anId
!
-resetDevice
+restored
"set both device and id"
device := nil.
--- a/DRootView.st Wed Oct 13 01:30:35 1993 +0100
+++ b/DRootView.st Wed Oct 13 01:32:53 1993 +0100
@@ -11,7 +11,7 @@
"
PseudoView subclass:#DisplayRootView
- instanceVariableNames:'errorOccured'
+ instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
category:'Views-Basic'
@@ -65,7 +65,8 @@
width := device width.
height := device height.
- drawableId := device rootWindowFor:self
+ drawableId := device rootWindowFor:self.
+ gcId := nil.
! !
!DisplayRootView methodsFor:'accessing'!
@@ -86,24 +87,22 @@
redefined in views which can take objects"
^ false
-! !
-
-!DisplayRootView methodsFor:'window managing functions'!
-
-errorInterrupt
- errorOccured := true
-!
+!
isWindowManagerRunning
- "answer true, if a window manager is currently running"
+ "answer true, if a window manager is currently running.
+ This is done by performing an action (enabling button events of
+ root window), which will fail if a winman is running."
- |oldErrorHandler|
+ |errorOccured|
- oldErrorHandler := Smalltalk at:#ErrorInterruptHandler.
- Smalltalk at:#ErrorInterruptHandler put:self.
errorOccured := false.
- self enableButtonEvents.
- device synchronizeOutput.
- Smalltalk at:#ErrorInterruptHandler put:oldErrorHandler.
+ device class deviceErrorSignal handle:[:ex |
+ errorOccured := true.
+ ex return
+ ] do:[
+ self enableButtonEvents.
+ device synchronizeOutput.
+ ].
^ errorOccured
! !
--- a/DevDraw.st Wed Oct 13 01:30:35 1993 +0100
+++ b/DevDraw.st Wed Oct 13 01:32:53 1993 +0100
@@ -659,6 +659,13 @@
clipRect := aRectangle
!
+clipRect
+ "return the clipping rectangle for drawing"
+
+ clipRect isNil ifTrue:[^ 0@0 extent:width@height].
+ ^ clipRect
+!
+
setGraphicsExposures:aBoolean
"want to if aBoolean is true - or dont want to be notified
of graphics exposures"
--- a/DevWorkst.st Wed Oct 13 01:30:35 1993 +0100
+++ b/DevWorkst.st Wed Oct 13 01:32:53 1993 +0100
@@ -24,7 +24,8 @@
timeOutBlocks timeOutTimes
lastId lastView
keyboardMap'
- classVariableNames: 'ButtonTranslation MultiClickTimeDelta'
+ classVariableNames: 'ButtonTranslation MultiClickTimeDelta
+ DeviceErrorSignal'
poolDictionaries:''
category:'Interface-Graphics'
!
@@ -46,25 +47,46 @@
instance variables:
+displayId <Number> the device id of the display
visualType <Symbol> one of #StaticGray, #PseudoColor, ... #TrueColor
monitorType <Symbol> one of #monochrome, #color, #unknown
-height <Integer> number of vertical pixels
-width <Integer> number of horizontal pixels
-heightMM <Number> screen height in millimeter
-widthMM <Number> screen width in millimeter
+
depth <Integer> bits per color
ncells <Integer> number of colors (i.e. colormap size; not always == 2^depth)
bitsPerRGB <Integer> number of valid bits per rgb component
- (actual number taken in A/D converter)
+ (actual number taken in A/D converter; not all devices report the true value)
+hasColors <Boolean> true, if display supports colors
+hasGreyscales <Boolean> true, if display supports grey-scales (i.e is not b/w display)
+width <Integer> number of horizontal pixels
+height <Integer> number of vertical pixels
+heightMM <Number> screen height in millimeter
+widthMM <Number> screen width in millimeter
resolutionHor <Number> pixels per horizontal millimeter
resolutionVer <Number> pixels per vertical millimeter
-...
+knownViews <Collection> all views known
+knownIds <Collection> corresponding device-view ids
+knownBitmaps <Collection> all known device bitmaps
+knownBitmapIds <Collection> corresponding device-bitmap ids
+
+dispatching <Boolean> true, if currently in dispatch loop
+
+idleBlocks <Collection> blocks to evaluate, when no events are pending
controlDown <Boolean> control key currently pressed
shiftDown <Boolean> shift key currently pressed
-hasColor <Boolean> true if display can display colors
-hasGreyscales <Boolean> true, if display can display grey (i.e. is not b/w display)
+metaDown <Boolean>
+altDown <Boolean>
+
+ignoreBackingStore
+motionEventCompression
+
+timeOutBlocks <Collection>
+timeOutTimes <Collection>
+
+lastId <Number>
+lastView <View>
+
keyboardMap <KeyBdMap> mapping for keys
"
@@ -72,6 +94,13 @@
!DeviceWorkstation class methodsFor:'initialization'!
+initialize
+ DeviceErrorSignal isNil ifTrue:[
+ DeviceErrorSignal := (Signal new) mayProceed:true.
+ DeviceErrorSignal notifierString:'device error'.
+ ].
+!
+
initializeConstants
"initialize some (soft) constants"
@@ -79,6 +108,14 @@
ButtonTranslation := #(1 2 3) "identity translation"
! !
+!DeviceWorkstation class methodsFor:'signal access'!
+
+deviceErrorSignal
+ "return the signal used for device error reporting"
+
+ ^ DeviceErrorSignal
+! !
+
!DeviceWorkstation class methodsFor:'accessing'!
buttonTranslation:anArray
@@ -107,6 +144,8 @@
!
close
+ "close down connection to Display - usually never done"
+
^ self subclassResponsibility
!
@@ -201,7 +240,7 @@
"
kludge for my next server with german keyboard:
the modifier map does not allow me to include alt-key
- modification.
+ modification - therefore, its done here, which is stupid
"
keyboardMap bindValue:$~ to:#Alt1.
keyboardMap bindValue:$< to:#Alt4.
@@ -226,6 +265,19 @@
keyboardMap bindValue:(Character value:16rC4) to:#Adiaeresis.
keyboardMap bindValue:(Character value:16rD6) to:#Odiaeresis.
keyboardMap bindValue:(Character value:16rDF) to:#ssharp.
+ "
+ and also the pre-translated characters
+ for those characters which are already translated by
+ modifier map
+ "
+ keyboardMap bindValue:$~ to:#'Cmd~'.
+ keyboardMap bindValue:$\ to:#'Cmd\'.
+ keyboardMap bindValue:$| to:#'Cmd|'.
+ keyboardMap bindValue:${ to:#'Cmd{'.
+ keyboardMap bindValue:$[ to:#'Cmd['.
+ keyboardMap bindValue:$] to:#'Cmd]'.
+ keyboardMap bindValue:$} to:#'Cmd}'.
+ keyboardMap bindValue:$@ to:#'Cmd@'.
"
more needed, french for example ...
@@ -241,6 +293,64 @@
keyboardMap bindValue:(Character value:16rB5) to:#mu.
! !
+!DeviceWorkstation class methodsFor:'error handling'!
+
+resourceIdOfLastError
+ "return the resource id responsible for the last error"
+
+ ^ self subclassResponsibility
+!
+
+lastError
+ "return a string descibing the last error"
+
+ ^ self subclassResponsibility
+!
+
+errorInterrupt
+ "x-error interrupt"
+
+ |badId badResource|
+
+ badId := self resourceIdOfLastError.
+ badId ~~ 0 ifTrue:[
+ badResource := self resourceOfId:badId.
+ ].
+ ^ DeviceErrorSignal
+ raiseRequestWith:badResource
+ errorString: 'Display error: ' , (self lastError)
+!
+
+resourceOfId:id
+ "search thru all device stuff for a resource.
+ Needed for error handling"
+
+ Form allInstances do:[:f |
+ f id == id ifTrue:[^ f]
+ ].
+
+ self allInstances do:[:aDisplay |
+ |views|
+
+ views := aDisplay knownViews.
+ views notNil ifTrue:[
+ views do:[:v |
+ v id == id ifTrue:[^ v].
+ v gcId == id ifTrue:[^ v]
+ ].
+ ].
+ ].
+
+ Color allInstances do:[:c |
+ c colorId == id ifTrue:[^ c]
+ ].
+
+ Font allInstances do:[:f |
+ f fontId == id ifTrue:[^ f]
+ ].
+ ^ nil
+! !
+
!DeviceWorkstation methodsFor:'misc'!
metaDown
@@ -955,6 +1065,7 @@
(endIndex ~~ 0) ifTrue:[
now := OperatingSystem getMillisecondTime.
index := 1.
+ blocksToEvaluate := nil.
[index <= endIndex] whileTrue:[
tBlock := timeOutTimes at:index.
(OperatingSystem millisecondTime:tBlock isAfter:now) ifFalse:[
@@ -999,11 +1110,7 @@
((knownViews size == 1) and:[(knownViews at:1) == RootView]) ifTrue:[
dispatching := false
] ifFalse:[
- ((idleBlocks size == 0) and:[timeOutBlocks size == 0]) ifTrue:[
- self dispatchEventFor:nil withMask:nil
- ] ifFalse:[
- self dispatchCheckingIdleAndTimeoutsFor:nil
- ]
+ self dispatchCheckingIdleAndTimeoutsFor:nil
]
].
Processor yield
@@ -1040,21 +1147,35 @@
"if there is any event pending, process it;
otherwise evaluate idle blocks (if any)"
+ |limit doingGC|
+
self eventPendingWithoutSync ifTrue:[
self dispatchEventFor:aViewIdOrNil withMask:nil
] ifFalse:[
+ "no event pending - do background stuff"
+
+ "if its worth doing, collect a bit of garbage"
+ limit := ObjectMemory incrementalGCLimit.
+ doingGC := limit notNil and:[ObjectMemory oldSpaceAllocatedSinceLastGC > limit].
+ doingGC ifTrue:[
+ ObjectMemory gcStep.
+ ].
(idleBlocks size ~~ 0) ifTrue:[
idleBlocks do:[:aBlock |
aBlock value
- ]
+ ].
] ifFalse:[
- "no idle blocks defined, no event pending;
- wait 'til either event arrives or time to next timeoutBlock
- has passed ..."
- self waitForEventOrTimeoutFor:nil
+ doingGC ifFalse:[
+ "no idle blocks defined, no event pending;
+ wait 'til either event arrives or time to next timeoutBlock
+ has passed ..."
+ self waitForEventOrTimeoutFor:nil
+ ]
]
].
- self evaluateTimeOutBlocks
+ timeOutBlocks size ~~ 0 ifTrue:[
+ self evaluateTimeOutBlocks
+ ].
! !
!DeviceWorkstation methodsFor:'bitmap/window creation'!
--- a/DeviceWorkstation.st Wed Oct 13 01:30:35 1993 +0100
+++ b/DeviceWorkstation.st Wed Oct 13 01:32:53 1993 +0100
@@ -24,7 +24,8 @@
timeOutBlocks timeOutTimes
lastId lastView
keyboardMap'
- classVariableNames: 'ButtonTranslation MultiClickTimeDelta'
+ classVariableNames: 'ButtonTranslation MultiClickTimeDelta
+ DeviceErrorSignal'
poolDictionaries:''
category:'Interface-Graphics'
!
@@ -46,25 +47,46 @@
instance variables:
+displayId <Number> the device id of the display
visualType <Symbol> one of #StaticGray, #PseudoColor, ... #TrueColor
monitorType <Symbol> one of #monochrome, #color, #unknown
-height <Integer> number of vertical pixels
-width <Integer> number of horizontal pixels
-heightMM <Number> screen height in millimeter
-widthMM <Number> screen width in millimeter
+
depth <Integer> bits per color
ncells <Integer> number of colors (i.e. colormap size; not always == 2^depth)
bitsPerRGB <Integer> number of valid bits per rgb component
- (actual number taken in A/D converter)
+ (actual number taken in A/D converter; not all devices report the true value)
+hasColors <Boolean> true, if display supports colors
+hasGreyscales <Boolean> true, if display supports grey-scales (i.e is not b/w display)
+width <Integer> number of horizontal pixels
+height <Integer> number of vertical pixels
+heightMM <Number> screen height in millimeter
+widthMM <Number> screen width in millimeter
resolutionHor <Number> pixels per horizontal millimeter
resolutionVer <Number> pixels per vertical millimeter
-...
+knownViews <Collection> all views known
+knownIds <Collection> corresponding device-view ids
+knownBitmaps <Collection> all known device bitmaps
+knownBitmapIds <Collection> corresponding device-bitmap ids
+
+dispatching <Boolean> true, if currently in dispatch loop
+
+idleBlocks <Collection> blocks to evaluate, when no events are pending
controlDown <Boolean> control key currently pressed
shiftDown <Boolean> shift key currently pressed
-hasColor <Boolean> true if display can display colors
-hasGreyscales <Boolean> true, if display can display grey (i.e. is not b/w display)
+metaDown <Boolean>
+altDown <Boolean>
+
+ignoreBackingStore
+motionEventCompression
+
+timeOutBlocks <Collection>
+timeOutTimes <Collection>
+
+lastId <Number>
+lastView <View>
+
keyboardMap <KeyBdMap> mapping for keys
"
@@ -72,6 +94,13 @@
!DeviceWorkstation class methodsFor:'initialization'!
+initialize
+ DeviceErrorSignal isNil ifTrue:[
+ DeviceErrorSignal := (Signal new) mayProceed:true.
+ DeviceErrorSignal notifierString:'device error'.
+ ].
+!
+
initializeConstants
"initialize some (soft) constants"
@@ -79,6 +108,14 @@
ButtonTranslation := #(1 2 3) "identity translation"
! !
+!DeviceWorkstation class methodsFor:'signal access'!
+
+deviceErrorSignal
+ "return the signal used for device error reporting"
+
+ ^ DeviceErrorSignal
+! !
+
!DeviceWorkstation class methodsFor:'accessing'!
buttonTranslation:anArray
@@ -107,6 +144,8 @@
!
close
+ "close down connection to Display - usually never done"
+
^ self subclassResponsibility
!
@@ -201,7 +240,7 @@
"
kludge for my next server with german keyboard:
the modifier map does not allow me to include alt-key
- modification.
+ modification - therefore, its done here, which is stupid
"
keyboardMap bindValue:$~ to:#Alt1.
keyboardMap bindValue:$< to:#Alt4.
@@ -226,6 +265,19 @@
keyboardMap bindValue:(Character value:16rC4) to:#Adiaeresis.
keyboardMap bindValue:(Character value:16rD6) to:#Odiaeresis.
keyboardMap bindValue:(Character value:16rDF) to:#ssharp.
+ "
+ and also the pre-translated characters
+ for those characters which are already translated by
+ modifier map
+ "
+ keyboardMap bindValue:$~ to:#'Cmd~'.
+ keyboardMap bindValue:$\ to:#'Cmd\'.
+ keyboardMap bindValue:$| to:#'Cmd|'.
+ keyboardMap bindValue:${ to:#'Cmd{'.
+ keyboardMap bindValue:$[ to:#'Cmd['.
+ keyboardMap bindValue:$] to:#'Cmd]'.
+ keyboardMap bindValue:$} to:#'Cmd}'.
+ keyboardMap bindValue:$@ to:#'Cmd@'.
"
more needed, french for example ...
@@ -241,6 +293,64 @@
keyboardMap bindValue:(Character value:16rB5) to:#mu.
! !
+!DeviceWorkstation class methodsFor:'error handling'!
+
+resourceIdOfLastError
+ "return the resource id responsible for the last error"
+
+ ^ self subclassResponsibility
+!
+
+lastError
+ "return a string descibing the last error"
+
+ ^ self subclassResponsibility
+!
+
+errorInterrupt
+ "x-error interrupt"
+
+ |badId badResource|
+
+ badId := self resourceIdOfLastError.
+ badId ~~ 0 ifTrue:[
+ badResource := self resourceOfId:badId.
+ ].
+ ^ DeviceErrorSignal
+ raiseRequestWith:badResource
+ errorString: 'Display error: ' , (self lastError)
+!
+
+resourceOfId:id
+ "search thru all device stuff for a resource.
+ Needed for error handling"
+
+ Form allInstances do:[:f |
+ f id == id ifTrue:[^ f]
+ ].
+
+ self allInstances do:[:aDisplay |
+ |views|
+
+ views := aDisplay knownViews.
+ views notNil ifTrue:[
+ views do:[:v |
+ v id == id ifTrue:[^ v].
+ v gcId == id ifTrue:[^ v]
+ ].
+ ].
+ ].
+
+ Color allInstances do:[:c |
+ c colorId == id ifTrue:[^ c]
+ ].
+
+ Font allInstances do:[:f |
+ f fontId == id ifTrue:[^ f]
+ ].
+ ^ nil
+! !
+
!DeviceWorkstation methodsFor:'misc'!
metaDown
@@ -955,6 +1065,7 @@
(endIndex ~~ 0) ifTrue:[
now := OperatingSystem getMillisecondTime.
index := 1.
+ blocksToEvaluate := nil.
[index <= endIndex] whileTrue:[
tBlock := timeOutTimes at:index.
(OperatingSystem millisecondTime:tBlock isAfter:now) ifFalse:[
@@ -999,11 +1110,7 @@
((knownViews size == 1) and:[(knownViews at:1) == RootView]) ifTrue:[
dispatching := false
] ifFalse:[
- ((idleBlocks size == 0) and:[timeOutBlocks size == 0]) ifTrue:[
- self dispatchEventFor:nil withMask:nil
- ] ifFalse:[
- self dispatchCheckingIdleAndTimeoutsFor:nil
- ]
+ self dispatchCheckingIdleAndTimeoutsFor:nil
]
].
Processor yield
@@ -1040,21 +1147,35 @@
"if there is any event pending, process it;
otherwise evaluate idle blocks (if any)"
+ |limit doingGC|
+
self eventPendingWithoutSync ifTrue:[
self dispatchEventFor:aViewIdOrNil withMask:nil
] ifFalse:[
+ "no event pending - do background stuff"
+
+ "if its worth doing, collect a bit of garbage"
+ limit := ObjectMemory incrementalGCLimit.
+ doingGC := limit notNil and:[ObjectMemory oldSpaceAllocatedSinceLastGC > limit].
+ doingGC ifTrue:[
+ ObjectMemory gcStep.
+ ].
(idleBlocks size ~~ 0) ifTrue:[
idleBlocks do:[:aBlock |
aBlock value
- ]
+ ].
] ifFalse:[
- "no idle blocks defined, no event pending;
- wait 'til either event arrives or time to next timeoutBlock
- has passed ..."
- self waitForEventOrTimeoutFor:nil
+ doingGC ifFalse:[
+ "no idle blocks defined, no event pending;
+ wait 'til either event arrives or time to next timeoutBlock
+ has passed ..."
+ self waitForEventOrTimeoutFor:nil
+ ]
]
].
- self evaluateTimeOutBlocks
+ timeOutBlocks size ~~ 0 ifTrue:[
+ self evaluateTimeOutBlocks
+ ].
! !
!DeviceWorkstation methodsFor:'bitmap/window creation'!
--- a/DisplayRootView.st Wed Oct 13 01:30:35 1993 +0100
+++ b/DisplayRootView.st Wed Oct 13 01:32:53 1993 +0100
@@ -11,7 +11,7 @@
"
PseudoView subclass:#DisplayRootView
- instanceVariableNames:'errorOccured'
+ instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
category:'Views-Basic'
@@ -65,7 +65,8 @@
width := device width.
height := device height.
- drawableId := device rootWindowFor:self
+ drawableId := device rootWindowFor:self.
+ gcId := nil.
! !
!DisplayRootView methodsFor:'accessing'!
@@ -86,24 +87,22 @@
redefined in views which can take objects"
^ false
-! !
-
-!DisplayRootView methodsFor:'window managing functions'!
-
-errorInterrupt
- errorOccured := true
-!
+!
isWindowManagerRunning
- "answer true, if a window manager is currently running"
+ "answer true, if a window manager is currently running.
+ This is done by performing an action (enabling button events of
+ root window), which will fail if a winman is running."
- |oldErrorHandler|
+ |errorOccured|
- oldErrorHandler := Smalltalk at:#ErrorInterruptHandler.
- Smalltalk at:#ErrorInterruptHandler put:self.
errorOccured := false.
- self enableButtonEvents.
- device synchronizeOutput.
- Smalltalk at:#ErrorInterruptHandler put:oldErrorHandler.
+ device class deviceErrorSignal handle:[:ex |
+ errorOccured := true.
+ ex return
+ ] do:[
+ self enableButtonEvents.
+ device synchronizeOutput.
+ ].
^ errorOccured
! !
--- a/Font.st Wed Oct 13 01:30:35 1993 +0100
+++ b/Font.st Wed Oct 13 01:32:53 1993 +0100
@@ -14,7 +14,7 @@
instanceVariableNames:'family face style size encoding
device fontId replacementFont
ascent descent height width isFixedWidth
- minWidth maxWidth'
+ minWidth maxWidth'
classVariableNames:'lobby'
poolDictionaries:''
category:'Graphics-Support'
@@ -54,32 +54,32 @@
Instance variables:
-family <String> the fonts family ('courier', 'helvetica' etc)
-face <String> the fonts face ('bold', 'medium' etc)
-style <String> the fonts style ('roman', 'italic', 'oblique')
-size <String> the fonts size (not in pixels)
-encoding <Symbol> the fonts encoding (usually #iso8859)
+family <String> the fonts family ('courier', 'helvetica' etc)
+face <String> the fonts face ('bold', 'medium' etc)
+style <String> the fonts style ('roman', 'italic', 'oblique')
+size <String> the fonts size (not in pixels)
+encoding <Symbol> the fonts encoding (usually #iso8859)
-device <Object> the device the font is associated to, or nil
-fontId <Object> the id of the font on that device, or nil
-replacement <Font> the replacement font or nil
+device <Object> the device the font is associated to, or nil
+fontId <Object> the id of the font on that device, or nil
+replacement <Font> the replacement font or nil
-ascent <Integer> the fonts ascent in device units on device
-descent <Integer> the fonts descent in device units on device
-height <Integer> the fonts height in device units on device
-width <Integer> the character width in device units on device
- (for variable fonts, its the width of a space)
-isFixedWidth <Boolean> true if font is a fixed width font
-minWidth <Integer> width of the smallest-width character in
- in device units on device
-maxWidth <Integer> width of the largest-width character in
- in device units on device
+ascent <Integer> the fonts ascent in device units on device
+descent <Integer> the fonts descent in device units on device
+height <Integer> the fonts height in device units on device
+width <Integer> the character width in device units on device
+ (for variable fonts, its the width of a space)
+isFixedWidth <Boolean> true if font is a fixed width font
+minWidth <Integer> width of the smallest-width character in
+ in device units on device
+maxWidth <Integer> width of the largest-width character in
+ in device units on device
class variables:
-lobby <Registry> keeps track of all known fonts
+lobby <Registry> keeps track of all known fonts
-Replacements <Dictionary> replacement fonts
+Replacements <Dictionary> replacement fonts
"
! !
@@ -94,16 +94,16 @@
"want to be informed when returning from snapshot"
ObjectMemory addDependent:self.
- Replacements := Dictionary new.
+ Replacements := Dictionary new.
- Replacements at:'clean' put:'courier'.
- Replacements at:'fixed' put:'courier'.
- Replacements at:'new century schoolbook' put:'times'.
- Replacements at:'lucida' put:'helvetica'.
- Replacements at:'lucidabright' put:'helvetica'.
- Replacements at:'lucidatypewriter' put:'courier'.
- Replacements at:'charter' put:'times'.
- Replacements at:'terminal' put:'courier'.
+ Replacements at:'clean' put:'courier'.
+ Replacements at:'fixed' put:'courier'.
+ Replacements at:'new century schoolbook' put:'times'.
+ Replacements at:'lucida' put:'helvetica'.
+ Replacements at:'lucidabright' put:'helvetica'.
+ Replacements at:'lucidatypewriter' put:'courier'.
+ Replacements at:'charter' put:'times'.
+ Replacements at:'terminal' put:'courier'.
]
!
@@ -111,7 +111,7 @@
"unassign all fonts from their device"
lobby contentsDo:[:aFont |
- aFont resetDevice.
+ aFont restored.
lobby changed:aFont
]
!
@@ -208,18 +208,18 @@
id isNil ifTrue:[
"oops did not work - (device has no such font)"
- rep := self replacementFontOn:aDevice.
- device isNil ifTrue:[
- device := aDevice.
- replacementFont := rep.
- lobby changed:self.
- ^ self
- ].
- newFont := (self class basicNew)
+ rep := self replacementFontOn:aDevice.
+ device isNil ifTrue:[
+ device := aDevice.
+ replacementFont := rep.
+ lobby changed:self.
+ ^ self
+ ].
+ newFont := (self class basicNew)
setFamily:family face:face style:style size:size encoding:encoding device:aDevice.
- newFont setReplacementFont:rep.
+ newFont setReplacementFont:rep.
lobby register:newFont.
- ^ newFont
+ ^ newFont
].
"receiver was not associated - do it now"
@@ -253,12 +253,12 @@
alternative := Replacements at:family.
alternative notNil ifTrue:[
id := aDevice getFontWithFamily:alternative face:face style:style size:size encoding:encoding.
- id notNil ifTrue:[
- ('replaced ' , family , '- with ' , alternative , '-font') print.
- ] ifFalse:[
+ id notNil ifTrue:[
+ ('replaced ' , family , '- with ' , alternative , '-font') print.
+ ] ifFalse:[
id := aDevice getDefaultFont.
- ('replaced ' , family , '- with default-font') print.
- ]
+ ('replaced ' , family , '- with default-font') print.
+ ]
].
id isNil ifTrue:[
"oops did not work - this is a serious an error"
@@ -291,7 +291,7 @@
device := aDevice
!
-resetDevice
+restored
device := nil.
fontId := nil.
replacementFont := nil
@@ -320,8 +320,8 @@
descent := device descentOf:fontId.
height := descent + ascent.
width := device widthOf:' ' inFont:fontId.
- minWidth := device minWidthOfFont:fontId.
- maxWidth := device maxWidthOfFont:fontId.
+ minWidth := device minWidthOfFont:fontId.
+ maxWidth := device maxWidthOfFont:fontId.
] ifFalse:[
ascent := replacementFont ascent.
descent := replacementFont descent.
@@ -491,7 +491,7 @@
^ 0
].
replacementFont notNil ifTrue:[
- ^ replacementFont widthOf:aStringOrText
+ ^ replacementFont widthOf:aStringOrText
].
(aStringOrText isMemberOf:String) ifTrue:[
@@ -527,7 +527,7 @@
^ 0
].
replacementFont notNil ifTrue:[
- ^ replacementFont widthOf:aString from:start to:stop
+ ^ replacementFont widthOf:aString from:start to:stop
].
(stop < start) ifTrue:[^ 0].
isFixedWidth ifFalse:[
@@ -536,6 +536,52 @@
^ (stop - start + 1) * width
! !
+!Font methodsFor:'st-80 queries'!
+
+serif
+ "return true, if this font has serifs"
+
+ "this should be done in a better way ..."
+
+ family = 'Times' ifTrue:[^ true].
+ family = 'times' ifTrue:[^ true].
+ ^ false.
+!
+
+fixedWidth
+ "return true, if this font is a fixed width font -
+ for st-80 compatibility"
+
+ ^ self isFixedWidth
+!
+
+pixelSize
+ "return the height of the font in pixels -
+ for st-80 compatibility"
+
+ ^ self height
+!
+
+italic
+ "return true if this is an italic font -
+ for st-80 compatibility"
+
+ face = 'italic' ifTrue:[^ true].
+ face = 'obligue' ifTrue:[^ true].
+ ^ false
+!
+
+boldness
+ "return the boldness of the characters in this font 0 .. 1 -
+ for st-80 compatibility"
+
+ style = 'roman' ifTrue:[^ 0.5].
+ style = 'normal' ifTrue:[^ 0.5].
+ style = 'bold' ifTrue:[^ 0.75].
+ style = 'light' ifTrue:[^ 0.25].
+ ^ 0.5
+! !
+
!Font methodsFor:'printing & storing'!
printString
@@ -552,3 +598,12 @@
' size:' , size printString ,
' encoding:' , encoding storeString , ')')
! !
+
+!Font methodsFor: 'binary storage'!
+
+readBinaryContentsFrom: stream manager: manager
+ "tell the newly restored Font about restoration"
+
+ super readBinaryContentsFrom: stream manager: manager.
+ self restored
+! !
--- a/Form.st Wed Oct 13 01:30:35 1993 +0100
+++ b/Form.st Wed Oct 13 01:32:53 1993 +0100
@@ -71,8 +71,8 @@
(something == #restarted) ifTrue:[
"remove all left-over device info"
lobby contentsDo:[:aForm |
- aForm resetDevice.
- lobby changed:aForm
+ aForm restored.
+ lobby changed:self
]
]
! !
@@ -338,11 +338,11 @@
|sel|
DitherPatterns isNil ifTrue:[
- DitherPatterns := Array new:32.
- 1 to:32 do:[:i |
- sel := ('dither' , i printString , 'in64') asSymbol.
- DitherPatterns at:i put:(self perform:sel)
- ]
+ DitherPatterns := Array new:32.
+ 1 to:32 do:[:i |
+ sel := ('dither' , i printString , 'in64') asSymbol.
+ DitherPatterns at:i put:(self perform:sel)
+ ]
].
^ DitherPatterns at:x
!
@@ -350,417 +350,417 @@
dither1in64
"return a pattern for dithering"
- ^ #(2r10000000
+ ^ #[2r10000000
2r00000000
2r00000000
2r00000000
2r00000000
2r00000000
2r00000000
- 2r00000000)
+ 2r00000000]
!
dither2in64
"return a pattern for dithering"
- ^ #(2r10000000
+ ^ #[2r10000000
2r00000000
2r00000000
2r00000000
2r00001000
2r00000000
2r00000000
- 2r00000000)
+ 2r00000000]
!
dither3in64
"return a pattern for dithering"
- ^ #(2r10000000
+ ^ #[2r10000000
2r00000000
2r00000000
2r00000000
2r10001000
2r00000000
2r00000000
- 2r00000000)
+ 2r00000000]
!
dither4in64
"return a pattern for dithering"
- ^ #(2r10001000
+ ^ #[2r10001000
2r00000000
2r00000000
2r00000000
2r10001000
2r00000000
2r00000000
- 2r00000000)
+ 2r00000000]
!
dither5in64
"return a pattern for dithering"
- ^ #(2r10001000
+ ^ #[2r10001000
2r00000000
2r00000000
2r00000000
2r10001000
2r00000000
2r00000010
- 2r00000000)
+ 2r00000000]
!
dither6in64
"return a pattern for dithering"
- ^ #(2r10001000
+ ^ #[2r10001000
2r00000000
2r00100000
2r00000000
2r10001000
2r00000000
2r00000010
- 2r00000000)
+ 2r00000000]
!
dither7in64
"return a pattern for dithering"
- ^ #(2r10001000
+ ^ #[2r10001000
2r00000000
2r00100010
2r00000000
2r10001000
2r00000000
2r00000010
- 2r00000000)
+ 2r00000000]
!
dither8in64
"return a pattern for dithering"
- ^ #(2r10001000
+ ^ #[2r10001000
2r00000000
2r00100010
2r00000000
2r10001000
2r00000000
2r00100010
- 2r00000000)
+ 2r00000000]
!
dither9in64
"return a pattern for dithering"
- ^ #(2r10001000
+ ^ #[2r10001000
2r00000000
2r00100010
2r00000000
2r10001000
2r00000000
2r10100010
- 2r00000000)
+ 2r00000000]
!
dither10in64
"return a pattern for dithering"
- ^ #(2r10001000
+ ^ #[2r10001000
2r00000000
2r00101010
2r00000000
2r10001000
2r00000000
2r10100010
- 2r00000000)
+ 2r00000000]
!
dither11in64
"return a pattern for dithering"
- ^ #(2r10001000
+ ^ #[2r10001000
2r00000000
2r00101010
2r00000000
2r10001000
2r00000000
2r10101010
- 2r00000000)
+ 2r00000000]
!
dither12in64
"return a pattern for dithering"
- ^ #(2r10001000
+ ^ #[2r10001000
2r00000000
2r10101010
2r00000000
2r10001000
2r00000000
2r10101010
- 2r00000000)
+ 2r00000000]
!
dither13in64
"return a pattern for dithering"
- ^ #(2r10001000
+ ^ #[2r10001000
2r00000000
2r10101010
2r00000000
2r10101000
2r00000000
2r10101010
- 2r00000000)
+ 2r00000000]
!
dither14in64
"return a pattern for dithering"
- ^ #(2r10001010
+ ^ #[2r10001010
2r00000000
2r10101010
2r00000000
2r10101000
2r00000000
2r10101010
- 2r00000000)
+ 2r00000000]
!
dither15in64
"return a pattern for dithering"
- ^ #(2r10001010
+ ^ #[2r10001010
2r00000000
2r10101010
2r00000000
2r10101010
2r00000000
2r10101010
- 2r00000000)
+ 2r00000000]
!
dither16in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r00000000
2r10101010
2r00000000
2r10101010
2r00000000
2r10101010
- 2r00000000)
+ 2r00000000]
!
dither17in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000000
2r10101010
2r00000000
2r10101010
2r00000000
2r10101010
- 2r00000000)
+ 2r00000000]
!
dither18in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000000
2r10101010
2r00000000
2r10101010
2r00000100
2r10101010
- 2r00000000)
+ 2r00000000]
!
dither19in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000000
2r10101010
2r00000000
2r10101010
2r01000100
2r10101010
- 2r00000000)
+ 2r00000000]
!
dither20in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000100
2r10101010
2r00000000
2r10101010
2r01000100
2r10101010
- 2r00000000)
+ 2r00000000]
!
dither21in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000100
2r10101010
2r00000000
2r10101010
2r01000100
2r10101010
- 2r00000001)
+ 2r00000001]
!
dither22in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000100
2r10101010
2r00010000
2r10101010
2r01000100
2r10101010
- 2r00000001)
+ 2r00000001]
!
dither23in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000100
2r10101010
2r00010001
2r10101010
2r01000100
2r10101010
- 2r00000001)
+ 2r00000001]
!
dither24in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000100
2r10101010
2r00010001
2r10101010
2r01000100
2r10101010
- 2r00010001)
+ 2r00010001]
!
dither25in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000100
2r10101010
2r00010001
2r10101010
2r01000100
2r10101010
- 2r01010001)
+ 2r01010001]
!
dither26in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000100
2r10101010
2r00010101
2r10101010
2r01000100
2r10101010
- 2r01010001)
+ 2r01010001]
!
dither27in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000100
2r10101010
2r00010101
2r10101010
2r01000100
2r10101010
- 2r01010101)
+ 2r01010101]
!
dither28in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000100
2r10101010
2r01010101
2r10101010
2r01000100
2r10101010
- 2r01010101)
+ 2r01010101]
!
dither29in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000100
2r10101010
2r01010101
2r10101010
2r01010100
2r10101010
- 2r01010101)
+ 2r01010101]
!
dither30in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000101
2r10101010
2r01010101
2r10101010
2r01010100
2r10101010
- 2r01010101)
+ 2r01010101]
!
dither31in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01000101
2r10101010
2r01010101
2r10101010
2r01010101
2r10101010
- 2r01010101)
+ 2r01010101]
!
dither32in64
"return a pattern for dithering"
- ^ #(2r10101010
+ ^ #[2r10101010
2r01010101
2r10101010
2r01010101
2r10101010
2r01010101
2r10101010
- 2r01010101)
+ 2r01010101]
!
grey6Bits
@@ -876,8 +876,11 @@
"reconstruct the form after a snapin"
data notNil ifTrue:[
- drawableId := device createBitmapFromArray:data width:width height:height.
- ^ self
+ (depth == 1 or:[depth == device depth]) ifTrue:[
+ drawableId := device createBitmapFromArray:data width:width height:height.
+ ^ self
+ ].
+ data := nil.
].
fileName notNil ifTrue:[
drawableId := device createBitmapFromFile:fileName for:self.
@@ -888,7 +891,30 @@
depth == 1 ifTrue:[
drawableId := device createBitmapWidth:width height:height
] ifFalse:[
- drawableId := device createPixmapWidth:width height:height depth:depth
+ drawableId := device createPixmapWidth:width height:height depth:device depth
+ ]
+! !
+
+!Form methodsFor:'binary storage'!
+
+readBinaryContentsFrom: stream manager: manager
+ "tell the newly restored Form about restoration"
+
+ super readBinaryContentsFrom: stream manager: manager.
+ self restored.
+ lobby register:self
+! !
+
+!Form methodsFor:'inspecting'!
+
+inspect
+ "redefined to launch an ImageInspector on the receiver
+ (instead of the default InspectorView)."
+
+ ImageInspectorView isNil ifTrue:[
+ super inspect
+ ] ifFalse:[
+ ImageInspectorView openOn:self
]
! !
@@ -912,7 +938,7 @@
!Form methodsFor:'private'!
-resetDevice
+restored
drawableId := nil.
gcId := nil.
!
@@ -964,7 +990,7 @@
anArray size ~~ (((w + 7) // 8) * h) ifTrue:[
anArray size == (((w + 15) // 16) * h) ifTrue:[
"I want the bytes but got shorts (ST-80)"
- bytes := ByteArray new:(((w + 7) // 8) * h).
+ bytes := ByteArray uninitializedNew:(((w + 7) // 8) * h).
srcPerRow := (w + 15) // 16.
dstPerRow := (w + 7) // 8.
srcStart := 1.
@@ -1097,29 +1123,54 @@
bits
"return a ByteArray filled with my bits -
for depth 8 forms, 1 pixel/byte is filled;
- for depth 1 forms, 8 pixels/byte are filled"
+ for depth 1 forms, 8 pixels/byte are filled
+ for depth 4 forms, 2 pixels/byte are filled"
+
+ |pixelArray bytesPerRow bits
+ byteIndex "{ Class: SmallInteger }"
+ bitMask "{ Class: SmallInteger }"
+ hEnd "{ Class: SmallInteger }"
+ wEnd "{ Class: SmallInteger }"|
- |pixelArray bytesPerRow byteIndex bitMask bits|
+ data notNil ifTrue:[
+ ^ data
+ ].
+ drawableId isNil ifTrue:[
+ fileName notNil ifTrue:[
+ ^ (self on:Display) bits
+ ].
+ ^ nil
+ ].
+
+ "this is a very slow operation - every pixel is fetched from
+ the device.
+ This MUST be replaced by code basied on getImage ....
+ "
+
(depth == 8) ifTrue:[
bytesPerRow := width
] ifFalse:[
bytesPerRow := (width + 7) // 8
].
- pixelArray := ByteArray new:(bytesPerRow * height).
+ pixelArray := ByteArray uninitializedNew:(bytesPerRow * height).
byteIndex := 1.
+ hEnd := height - 1.
+ wEnd := width - 1.
+
(depth == 8) ifTrue:[
- 0 to:(height - 1) do:[:h |
- 0 to:(width - 1)do:[:w |
- pixelArray at:byteIndex put:(self at:w @ h).
+ 0 to:hEnd do:[:row |
+ 0 to:wEnd do:[:col |
+ pixelArray at:byteIndex put:(self at:col @ row).
byteIndex := byteIndex + 1
]
- ]
+ ].
+ ^ pixelArray
] ifFalse:[
- 0 to:(height - 1) do:[:h |
+ 0 to:hEnd do:[:row |
bitMask := 2r10000000.
bits := 0.
- 0 to:(width - 1) do:[:w |
- ((self at:w @ h) == 0) ifFalse:[
+ 0 to:wEnd do:[:col |
+ ((self at:col @ row) == 0) ifFalse:[
bits := bits bitOr:bitMask
].
bitMask := bitMask bitShift:(1 negated).
@@ -1265,9 +1316,9 @@
width storeOn:aStream.
aStream nextPutAll:' height:'.
height storeOn:aStream.
- aStream nextPutAll:' fromArray:'.
+ aStream nextPutAll:' fromArray:('.
self bits storeOn:aStream.
- aStream nextPut:$)
+ aStream nextPutAll:'))'
! !
!Form methodsFor:'editing'!
--- a/GC.st Wed Oct 13 01:30:35 1993 +0100
+++ b/GC.st Wed Oct 13 01:32:53 1993 +0100
@@ -193,6 +193,14 @@
]
! !
+!GraphicsContext methodsFor:'misc'!
+
+flush
+ "st-80 compatibility"
+
+ ^ self
+! !
+
!GraphicsContext methodsFor:'accessing'!
paint
@@ -204,14 +212,15 @@
paint:aColor
"set the drawing painting color, aColor can be a dithered one"
- ^ self subclassResponsibility
+ paint := aColor
!
paint:fgColor on:bgColor
"set the paint used for text and bitmaps, both colors may be
dithered colors"
- ^ self subclassResponsibility
+ paint := fgColor.
+ bgPaint := bgColor
!
backgroundPaint
@@ -238,7 +247,7 @@
"set the drawing foreground color.
aColor MUST be a real (i.e. device-) color"
- ^ self subclassResponsibility
+ foreground := aColor
!
background
@@ -251,7 +260,7 @@
"set the drawing background color.
aColor MUST be a real (i.e. device-) color"
- ^ self subclassResponsibility
+ background := aColor
!
function
@@ -290,7 +299,7 @@
lineWidth:aNumber
"set the line drawing width in pixels"
- ^ self subclassResponsibility
+ lineWidth := aNumber
!
lineStyle
@@ -303,7 +312,7 @@
"set the line-drawing-style;
possible styles are: #solid, #dashed, #doubleDashed"
- ^ self subclassResponsibility
+ lineStyle := aStyleSymbol
!
capStyle
@@ -366,6 +375,19 @@
"for ST-80 compatibility"
^ self
+!
+
+viewOrigin
+ ^ 0@0
+!
+
+setMaskOriginX:x y:y
+ ^ self
+!
+
+withPattern:aForm do:aBlock
+ 'pattern drawing not implemented' printNewline.
+ aBlock value
! !
!GraphicsContext methodsFor:'displaying'!
--- a/GraphicsContext.st Wed Oct 13 01:30:35 1993 +0100
+++ b/GraphicsContext.st Wed Oct 13 01:32:53 1993 +0100
@@ -193,6 +193,14 @@
]
! !
+!GraphicsContext methodsFor:'misc'!
+
+flush
+ "st-80 compatibility"
+
+ ^ self
+! !
+
!GraphicsContext methodsFor:'accessing'!
paint
@@ -204,14 +212,15 @@
paint:aColor
"set the drawing painting color, aColor can be a dithered one"
- ^ self subclassResponsibility
+ paint := aColor
!
paint:fgColor on:bgColor
"set the paint used for text and bitmaps, both colors may be
dithered colors"
- ^ self subclassResponsibility
+ paint := fgColor.
+ bgPaint := bgColor
!
backgroundPaint
@@ -238,7 +247,7 @@
"set the drawing foreground color.
aColor MUST be a real (i.e. device-) color"
- ^ self subclassResponsibility
+ foreground := aColor
!
background
@@ -251,7 +260,7 @@
"set the drawing background color.
aColor MUST be a real (i.e. device-) color"
- ^ self subclassResponsibility
+ background := aColor
!
function
@@ -290,7 +299,7 @@
lineWidth:aNumber
"set the line drawing width in pixels"
- ^ self subclassResponsibility
+ lineWidth := aNumber
!
lineStyle
@@ -303,7 +312,7 @@
"set the line-drawing-style;
possible styles are: #solid, #dashed, #doubleDashed"
- ^ self subclassResponsibility
+ lineStyle := aStyleSymbol
!
capStyle
@@ -366,6 +375,19 @@
"for ST-80 compatibility"
^ self
+!
+
+viewOrigin
+ ^ 0@0
+!
+
+setMaskOriginX:x y:y
+ ^ self
+!
+
+withPattern:aForm do:aBlock
+ 'pattern drawing not implemented' printNewline.
+ aBlock value
! !
!GraphicsContext methodsFor:'displaying'!
--- a/Image.st Wed Oct 13 01:30:35 1993 +0100
+++ b/Image.st Wed Oct 13 01:32:53 1993 +0100
@@ -11,8 +11,9 @@
"
Object subclass:#Image
- instanceVariableNames:'width height data photometric samplesPerPixel
- bitsPerSample colorMap
+ instanceVariableNames:'bytes width height
+ bitsPerSample samplesPerPixel
+ colorMap photometric
device deviceForm monoDeviceForm
fullColorDeviceForm'
classVariableNames:'lobby
@@ -37,7 +38,7 @@
"
this class provides (some time in the future) representation
for all kinds of images (monochrome, greyscale and color)
-and will finally replace Form.
+and will finally replace Form - its still under construction.
An Image keeps all info in a device independent way, but may get
associated to a device. The data held keeps all information which
@@ -46,13 +47,13 @@
process and manipulate images without loosing color information.
Usually, you get a device specific representation of the image by
-sending an image the 'image>>on:aDevice' message, which will create
+sending an image the 'on:aDevice' message, which will create
a (possibly) dithered form representing the image using the currently
available colors.
Sometimes, a monochrome representation is needed (X servers take monochrome
icons only), this will be created by 'image>>monochromeOn:aDevice'.
-Also, it is planned to generate anothe hi-color resolution version,
-which needs its own colormap to be installed, which allows use of all
+Also, it is planned to generate another hi-color resolution version,
+which needs its own colormap to be installed and allows use of all
256 colors on an 8bit display (not currently implemented).
To convert pictures from/to external file-formats, readers are used
@@ -62,15 +63,12 @@
experimental and far from beeing perfect (some are very slow).
Much more work is needed and will be done in the near future ...
Dithering is done as:
+
DitherAlgorithm:
nil a simple threshold algorithm
(i.e. for mono, p<0.5 -> black, p>=0.5 -> white)
- #random random dither,
- (i.e. for p, take black with probability p,
- white with probability 1-p)
-
#pattern patterned dither
(for p, take dithered color to fill pixel;
uses dithering in color-class)
@@ -80,13 +78,14 @@
File formats are handled by subclasses of ImageReader, which understand
a specific format. You can add more readers, by adding an association
-such as ('.jpg' -> JPEGReader) to the class variable 'FileFormats'.
+such as ('.jpg' -> JPEGReader) to the class variable 'FileFormats' (see
+Image initialize.
instance variables:
width <Integer> the width in pixels
height <Integer> the height in pixels
-data <ByteArray> the full image information
+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
@@ -116,13 +115,12 @@
!Image class methodsFor:'misc'!
dither:aSymbol
- "define how to dither - #random, #pattern, #error or none;
+ "define how to dither - #pattern, #error or none;
error diffusion dithering is currently not implemented,
pattern dither is currently very slow."
DitherAlgorithm := aSymbol
- "Image dither:#random"
"Image dither:#pattern"
"Image dither:#error"
"Image dither:nil"
@@ -138,27 +136,43 @@
!Image class methodsFor:'initialization'!
initialize
+ "initialize class constants"
+
"setup tracker of known pictures"
-
lobby isNil ifTrue:[
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"
- NumberOfDitherColors := 13. "13 seems a good value, more makes pattern dither
- look more like random ..."
+ (Display notNil and:[Display hasGreyscales]) ifFalse:[
+ NumberOfDitherColors := 64
+ ] ifTrue:[
+ "as far as I remember, this is about the number of grey values, the eye can distinguish"
+ NumberOfDitherColors := 100
+ ].
+ "define reader classes"
FileFormats := Dictionary new.
FileFormats at:'.xbm' put:XBMReader.
FileFormats at:'.tiff' put:TIFFReader.
+ FileFormats at:'.tif' put:TIFFReader.
FileFormats at:'.gif' put:GIFReader.
FileFormats at:'.img' put:IMGReader.
FileFormats at:'.pcx' put:PCXReader.
FileFormats at:'.mac' put:MacPaintReader.
FileFormats at:'.im8' put:SunRasterReader.
+ FileFormats at:'.icon' put:SunRasterReader.
FileFormats at:'.face' put:FaceReader.
FileFormats at:'.g3' put:G3FileReader.
+ FileFormats at:'.bmp' put:WindowsIconReader.
FileFormats at:'.ico' put:WindowsIconReader.
+ FileFormats at:'.jpg' put:JPEGReader.
+ FileFormats at:'.jpeg' put:JPEGReader.
+ FileFormats at:'.ppm' put:PBMReader.
+ FileFormats at:'.pbm' put:PBMReader.
+ FileFormats at:'.pgm' put:PBMReader.
!
flushDeviceImages
@@ -177,38 +191,55 @@
]
! !
-!Image methodsFor:'instance release'!
+!Image class methodsFor:'screen capture'!
-restored
- device := nil.
- deviceForm := nil.
- monoDeviceForm := nil.
- fullColorDeviceForm := nil
+fromScreen
+ "return an image of the full screen"
+
+ ^ self fromScreen:(0@0 corner:(Display width@Display height))
!
-disposed
- "some Image has been collected - nothing to do"
+fromScreen:aRectangle
+ "return an image of a part of the screen"
+
+ |depth img|
+
+ depth := Display depth.
+ img := (self implementorForDepth: depth) new.
+ ^ img fromScreen:aRectangle
+
+ "Image fromScreen:(0@0 corner:100@100)"
! !
!Image class methodsFor:'reading from file'!
fromFile:aFileName
- FileFormats associationsDo:[:a |
- (aFileName endsWith:(a key)) ifTrue:[
- ^ (a value) fromFile:aFileName
+ |readerClass image|
+
+ FileFormats associationsDo:[:assoc |
+ (aFileName endsWith:(assoc key)) ifTrue:[
+ readerClass := assoc value.
+ readerClass notNil ifTrue:[
+ image := readerClass fromFile:aFileName.
+ image notNil ifTrue:[^ image].
+ ]
]
].
"no known extension - ask all readers if they know
this format ..."
- FileFormats associationsDo:[:a |
- ((a value) isValidImageFile:aFileName) ifTrue:[
- ^ (a value) fromFile:aFileName
+ FileFormats associationsDo:[:assoc |
+ readerClass := assoc value.
+ readerClass notNil ifTrue:[
+ (readerClass isValidImageFile:aFileName) ifTrue:[
+ ^ readerClass fromFile:aFileName
+ ]
]
].
"nope - unknown format"
- self error:'unknown image file format'
+'unknown image file format' printNewline.
+ ^ nil
"Image fromFile:'bitmaps/dano.tiff'"
"Image fromFile:'bitmaps/test.fax'"
@@ -223,6 +254,46 @@
"Image fromFile:'/LocalLibrary/Images/OS2/dos3.ico'"
"Image fromFile:'bitmaps/globe1.xbm'"
+ "Image fromFile:'bitmaps/hello_world.icon'"
+! !
+
+!Image class methodsFor:'queries'!
+
+implementorForDepth: depth
+ "return the class, which best implements images of depth"
+
+ depth == 1 ifTrue:[^ Depth1Image].
+ depth == 2 ifTrue:[^ Depth2Image].
+ depth == 4 ifTrue:[^ Depth4Image].
+ depth == 8 ifTrue:[^ Depth8Image].
+ depth == 24 ifTrue:[^ Depth24Image].
+ ^ self
+! !
+
+!Image methodsFor:'instance release'!
+
+restored
+ device := nil.
+ deviceForm := nil.
+ monoDeviceForm := nil.
+ fullColorDeviceForm := nil
+!
+
+disposed
+ "some Image has been collected - nothing to do"
+! !
+
+!Image methodsFor:'inpecting'!
+
+inspect
+ "redefined to launch an ImageInspector on the receiver
+ (instead of the default InspectorView)."
+
+ ImageInspectorView isNil ifTrue:[
+ super inspect
+ ] ifFalse:[
+ ImageInspectorView openOn:self
+ ]
! !
!Image methodsFor:'accessing'!
@@ -298,15 +369,12 @@
depth
"return the depth of the image"
- |d|
-
- d := 0.
- bitsPerSample do:[:s | d := d + s].
- ^ d
+ ^ self bitsPerPixel
!
bitsPerSample
- "return the number of bits per sample"
+ "return the number of bits per sample.
+ The return value is an array of bits-per-plane."
^ bitsPerSample
!
@@ -315,25 +383,56 @@
bitsPerSample := aNumber
!
+bitsPerPixel
+ "return the number of bits per pixel"
+
+ ^ (bitsPerSample inject:0 into:[:sum :i | sum + i])
+!
+
+bitsPerRow
+ "return the number of bits in one scanline of the image"
+
+ ^ width * (self bitsPerPixel).
+!
+
+bytesPerRow
+ "return the number of bytes in one scanline of the image"
+
+ |bitsPerRow bytesPerRow|
+
+ bitsPerRow := width * (self bitsPerPixel).
+ bytesPerRow := bitsPerRow // 8.
+ ((bitsPerRow \\ 8) ~~ 0) ifTrue:[
+ bytesPerRow := bytesPerRow + 1
+ ].
+ ^ bytesPerRow
+!
+
data
+ "for backward compatibility - will vanish"
+
+ ^ bytes
+!
+
+data:aByteArray
+ "for backward compatibility - will vanish"
+
+ bytes := aByteArray
+!
+
+bits:aByteArray
+ "set the raw data"
+
+ bytes := aByteArray
+!
+
+bits
"return the raw image data; depending on the photometric,
this has to be interpreted as monochrome, greyscale,
palette or rgb data. It is also packed to be dense, so
a 4 bitPerSample palette image will store 2 pixels per byte."
- ^ data
-!
-
-data:aByteArray
- "set the raw data"
-
- data := aByteArray
-!
-
-bits
- "return the raw data - for compatibility"
-
- ^ data
+ ^ bytes
!
photometric
@@ -359,13 +458,84 @@
!
at:aPoint
- "retrieve the pixel at aPoint; return a color"
+ "retrieve the pixel at aPoint; return a color.
+ Pixels start at 0@0 for upper left pixel, end at
+ width-1@height-1 for lower right pixel.
+ You should not use this method for image-processing, its
+ very slow ..."
^ self atX:aPoint x y:aPoint y
!
+valueAt:aPoint
+ "retrieve the pixel at aPoint; return a pixel value.
+ Pixels start at 0@0 for upper left pixel, end at
+ width-1@height-1 for lower right pixel.
+ You should not use this method for image-processing, its
+ very slow ..."
+
+ ^ self valueAtX:aPoint x y:aPoint y
+!
+
atX:x y:y
- "retrieve a pixel at x/y; return a color"
+ "retrieve a pixel at x/y; return a color.
+ Pixels start at x=0 , y=0 for upper left pixel, end at
+ x = width-1, y=height-1 for lower right pixel.
+ You should not use this method for image-processing, its
+ very slow ..."
+
+ ^ self subclassResponsibility
+!
+
+valueAtX:x y:y
+ "retrieve the pixel at aPoint; return a pixel value.
+ Pixels start at x=0 , y=0 for upper left pixel, end at
+ width-1@height-1 for lower right pixel.
+ You should not use this method for image-processing, its
+ very slow ..."
+
+ ^ self subclassResponsibility
+!
+
+at:aPoint put:aColor
+ "set the pixel at aPoint to aColor.
+ Pixels start at 0@0 for upper left pixel, end at
+ width-1@height-1 for lower right pixel.
+ You should not use this method for image-processing, its
+ very slow ..."
+
+ ^ self atX:aPoint x y:aPoint y put:aColor
+!
+
+atX:x y:y put:aColor
+ "set the pixel at x/y to aColor.
+ Pixels start at x=0 , y=0 for upper left pixel, end at
+ x = width-1, y=height-1 for lower right pixel.
+ You should not use this method for image-processing, its
+ very slow ..."
+
+ ^ self subclassResponsibility
+!
+
+atX:x y:y putValue:aPixelValue
+ "set the pixel at x/y to aPixelValue.
+ Pixels start at x=0 , y=0 for upper left pixel, end at
+ x = width-1, y=height-1 for lower right pixel.
+ You should not use this method for image-processing, its
+ very slow ..."
+
+ ^ self subclassResponsibility
+!
+
+atY:y from:x1 to:x2 do:aBlock
+ "perform aBlock for each pixel from x1 to x2 in row y.
+ The block is passed the color at each pixel.
+ This method allows slighly faster processing of an
+ image than using atX:y:, since some processing can be
+ avoided when going from pixel to pixel. However, for
+ real image processing, specialized methods should be written."
+
+ ^ self subclassResponsibility.
! !
!Image methodsFor:'screen capture'!
@@ -456,7 +626,7 @@
((visType == #StaticGray) or:[visType == #TrueColor]) ifTrue:[
"were done, the pixel values are the rgb/grey values"
- data := inData.
+ bytes := inData.
^ self
].
@@ -482,7 +652,7 @@
]
].
colorMap := Array with:rMap with:gMap with:bMap.
- data := inData.
+ bytes := inData.
"Image new fromScreen:((0 @ 0) corner:(100 @ 100)) on:Display"
"Image new fromScreen:((0 @ 0) corner:(500 @ 500)) on:Display"
@@ -496,9 +666,11 @@
^ (a value) save:self onFile:aFileName
]
].
- "no known extension - could ask user for the format here"
+ "no known extension - could ask user for the format here.
+ currently default to tiff format."
- self error:'unknown extension - could not figure out format'
+ 'unknown extension - could not figure out format - using tiff' printNewline.
+ ^ self saveOn:aFileName using:TIFFReader
!
saveOn:aFileName using:readerClass
@@ -512,6 +684,8 @@
!Image methodsFor:'converting'!
on:aDevice
+ "make the image device dependent for aDevice"
+
((aDevice == device) and:[deviceForm notNil]) ifTrue:[^ self].
deviceForm := self asFormOn:aDevice.
device := aDevice
@@ -584,9 +758,6 @@
DitherAlgorithm == #pattern ifTrue:[
^ self rgbImageAsPatternDitheredGreyFormOn:aDevice
].
- DitherAlgorithm == #random ifTrue:[
- ^ self rgbImageAsRandomDitheredMonoFormOn:aDevice
- ].
^ self rgbImageAsMonoFormOn:aDevice
].
@@ -598,9 +769,6 @@
DitherAlgorithm == #pattern ifTrue:[
^ self rgbImageAsPatternDitheredGreyFormOn:aDevice
].
- DitherAlgorithm == #random ifTrue:[
- ^ self rgbImageAsRandomDithered2PlaneFormOn:aDevice
- ].
^ self rgbImageAs2PlaneFormOn:aDevice
].
@@ -624,106 +792,7 @@
using a threshold algorithm.
(i.e. grey value < 0.5 -> black, grey value >= 0.5 -> white)."
- |monoBits f
- r "{ Class: SmallInteger }"
- g "{ Class: SmallInteger }"
- b "{ Class: SmallInteger }"
- map rMap gMap bMap
- srcIndex "{ Class: SmallInteger }"
- dstIndex "{ Class: SmallInteger }"
- bits "{ Class: SmallInteger }"
- bitCount "{ Class: SmallInteger }"
- fast |
-
- monoBits := ByteArray uninitializedNew:(((width + 7) // 8) * height).
- fast := false.
-%{
- register unsigned char *srcPtr, *dstPtr;
- register _v, _bits, _bitCount;
- register j;
- register i;
- extern OBJ ByteArray;
-
- if (_isNonNilObject(_INST(data)) && (_qClass(_INST(data)) == ByteArray)
- && _isNonNilObject(monoBits) && (_qClass(monoBits) == ByteArray)) {
- fast = true;
- srcPtr = _ByteArrayInstPtr(_INST(data))->ba_element;
- dstPtr = _ByteArrayInstPtr(monoBits)->ba_element;
- for (i=_intVal(_INST(height)); i>0; i--) {
- _bitCount = 0;
- _bits = 0;
- for (j=_intVal(_INST(width)); j>0; j--) {
- _v = (*srcPtr++ * 3); /* 0.3*r + 0.6*g + b */
- _v += (*srcPtr++ * 6);
- _v += *srcPtr++;
- _v /= 10;
-
- _bits <<= 1;
- if (_v & 0x80)
- _bits |= 1;
-
- _bitCount++;
- if (_bitCount == 8) {
- *dstPtr++ = _bits;
- _bits = 0;
- _bitCount = 0;
- }
- }
- if (_bitCount != 0) {
- *dstPtr++ = _bits;
- }
- }
- }
-%}
-.
- fast ifFalse:[
- srcIndex := 1.
- dstIndex := 1.
- 1 to:height do:[:row |
- bitCount := 0.
- bits := 0.
- 1 to:width do:[:col |
- |v|
-
- r := data at:srcIndex.
- srcIndex := srcIndex + 1.
- g := data at:srcIndex.
- srcIndex := srcIndex + 1.
- b := data at:srcIndex.
- srcIndex := srcIndex + 1.
- v := ((0.3 * r) + (0.6 * g) + (0.1 * b)) asInteger.
- v := v bitShift:-7.
- (v == 0) ifTrue:[
- bits := bits bitShift:1
- ] ifFalse:[
- bits := (bits bitShift:1) bitOr:1
- ].
- bitCount := bitCount + 1.
- (bitCount == 8) ifTrue:[
- monoBits at:dstIndex put:bits.
- dstIndex := dstIndex + 1.
- bits := 0.
- bitCount := 0
- ]
- ].
- (bitCount ~~ 0) ifTrue:[
- monoBits at:dstIndex put:bits.
- dstIndex := dstIndex + 1
- ]
- ]
- ].
-
- f := Form width:width height:height depth:1 on:aDevice.
- f isNil ifTrue:[^ nil].
- f initGC.
- (aDevice blackpixel == 0) ifFalse:[
- "have to invert bits"
- f function:#copyInverted
- ].
- aDevice drawBits:monoBits depth:1 width:width height:height
- x:0 y:0
- into:(f id) x:0 y:0 width:width height:height with:(f gcId).
- ^ f
+ ^ self subclassResponsibility
!
rgbImageAsPatternDitheredGreyFormOn:aDevice
@@ -732,151 +801,7 @@
A slow algorithm, using draw into the form (which indirectly does
the dither) - should be rewritten."
- |f v
- map run last
- srcIndex ditherColors nDither first delta|
-
- Transcript showCr:'dithering ..'. Transcript endEntry.
-
- nDither := NumberOfDitherColors.
- ditherColors := Array new:nDither.
-
- first := (100 / nDither / 2).
- delta := 100 / nDither.
- 0 to:nDither-1 do:[:i |
- ditherColors at:i+1 put:(Color grey:(i * delta + first)).
- ].
-
- map := Array new:256.
- 1 to:256 do:[:i |
- v := i - 1.
- " v is now in the range 0 .. 255 "
- v := (v * (nDither - 1) // 255) rounded.
- " v is now 0 .. nDither-1 "
- map at:i put:(ditherColors at:(v + 1))
- ].
-
- f := Form width:width height:height depth:(aDevice depth) on:aDevice.
- f isNil ifTrue:[^ nil].
- f initGC.
- "draw each pixel using dither color"
-
- srcIndex := 1.
- 0 to:height-1 do:[:dstY |
- run := 0.
- last := nil.
- 0 to:width-1 do:[:dstX |
- |clr v r g b|
- r := data at:srcIndex.
- srcIndex := srcIndex + 1.
- g := data at:srcIndex.
- srcIndex := srcIndex + 1.
- b := data at:srcIndex.
- srcIndex := srcIndex + 1.
-
- v := ((0.3 * r) + (0.6 * g) + (0.1 * b)) asInteger.
-
- clr := map at:(v + 1).
-
- clr == last ifTrue:[
- run := run + 1
- ] ifFalse:[
- (run ~~ 0) ifTrue:[
- f fillRectangleX:dstX-run y:dstY width:run height:1.
- ].
- run := 1.
- f paint:clr.
- last := clr
- ].
- ].
- f fillRectangleX:width-run y:dstY width:run height:1.
- ].
- ^ f
-!
-
-rgbImageAsRandomDitheredMonoFormOn:aDevice
- "return a dithered 1-bit form from the rgb picture"
-
- |monoBits f v
- r g b
- map rMap gMap bMap
- srcIndex "{ Class: SmallInteger }"
- dstIndex "{ Class: SmallInteger }"
- bits "{ Class: SmallInteger }"
- bitCount "{ Class: SmallInteger }" |
-
- monoBits := ByteArray uninitializedNew:(((width + 7) // 8) * height).
-%{
- register unsigned char *srcPtr, *dstPtr;
- register _v, _bits, _bitCount;
- register j;
- register i;
- extern OBJ ByteArray;
- int rnd;
-
- if (_isNonNilObject(_INST(data)) && (_qClass(_INST(data)) == ByteArray)
- && _isNonNilObject(monoBits) && (_qClass(monoBits) == ByteArray)) {
- srcPtr = _ByteArrayInstPtr(_INST(data))->ba_element;
- dstPtr = _ByteArrayInstPtr(monoBits)->ba_element;
- for (i=_intVal(_INST(height)); i>0; i--) {
- _bitCount = 0;
- _bits = 0;
- for (j=_intVal(_INST(width)); j>0; j--) {
- _bits <<= 1;
-
- _v = (*srcPtr++ * 3); /* 0.3*r + 0.6*g + b */
- _v += (*srcPtr++ * 6);
- _v += *srcPtr++;
- /* v now 0 .. 256*10 */
-#ifdef OLD
- _v = _v / (10*2); /* v now 0 .. 127 */
- rnd = (rand() >> 12) & 7;
- if (_v < 25) {
- /* _bits |= 0; */ /* 0 */
- } else if (_v < 50) {
- if ((rnd & 3) == 3) /* p(0) = 75 */
- _bits |= 1; /* p(1) = 25 */
- else
- _bits |= 0;
- } else if (_v < 75) {
- if ((rnd & 3) == 3) /* p(0) = 25 */
- _bits |= 0; /* p(1) = 75 */
- else
- _bits |= 1;
- } else {
- _bits |= 1;
- }
-#else
- _v = _v / (10); /* v now 0 .. 255 */
- rnd = ((rand() >> 3) & 0xFF);
- if (_v > rnd)
- _bits |= 1;
-#endif
- _bitCount++;
- if (_bitCount == 8) {
- *dstPtr++ = _bits;
- _bits = 0;
- _bitCount = 0;
- }
- }
- if (_bitCount != 0) {
- *dstPtr++ = _bits;
- }
- }
- }
-%}
-.
- f := Form width:width height:height depth:1 on:aDevice.
- f isNil ifTrue:[^ nil].
- f initGC.
- (aDevice blackpixel == 0) ifFalse:[
- "have to invert bits"
- f function:#copyInverted
- ].
- aDevice drawBits:monoBits depth:1 width:width height:height
- x:0 y:0
- into:(f id) x:0 y:0 width:width height:height with:(f gcId).
- ^ f
+ ^ self subclassResponsibility
!
rgbImageAs2PlaneFormOn:aDevice
@@ -885,496 +810,19 @@
(i.e. grey value < 0.25 -> black // 0.25..0.5 -> darkgrey //
0.5 .. 0.75 -> lightgrey // > 0.75 -> white)."
- |twoPlaneBits f
- r g b
- map rMap gMap bMap
- fast
- srcIndex "{ Class: SmallInteger }"
- dstIndex "{ Class: SmallInteger }"
- bits "{ Class: SmallInteger }"
- bitCount "{ Class: SmallInteger }" |
-
- twoPlaneBits := ByteArray uninitializedNew:(((width * 2 + 7) // 8) * height).
-
- fast := false.
-%{
- register unsigned char *srcPtr, *dstPtr;
- register _v, _bits, _bitCount;
- register j;
- register i;
- extern OBJ ByteArray;
-
- if ((_Class(_INST(data)) == ByteArray)
- && (_Class(twoPlaneBits) == ByteArray)) {
- fast = true;
- srcPtr = _ByteArrayInstPtr(_INST(data))->ba_element;
- dstPtr = _ByteArrayInstPtr(twoPlaneBits)->ba_element;
- for (i=_intVal(_INST(height)); i>0; i--) {
- _bitCount = 0;
- _bits = 0;
- for (j=_intVal(_INST(width)); j>0; j--) {
- _v = (*srcPtr++ * 3); /* 0.3*r + 0.6*g + b */
- _v += (*srcPtr++ * 6);
- _v += *srcPtr++;
- _v /= 10;
- _bits <<= 2;
- _bits |= (_v >> 6); /* take top 2 bits */
- _bitCount++;
- if (_bitCount == 4) {
- *dstPtr++ = _bits;
- _bits = 0;
- _bitCount = 0;
- }
- }
- if (_bitCount != 0) {
- *dstPtr++ = _bits;
- }
- }
- }
-%}
-.
- fast ifFalse:[
- srcIndex := 1.
- dstIndex := 1.
- 1 to:height do:[:row |
- bitCount := 0.
- bits := 0.
- 1 to:width do:[:col |
- |v|
-
- r := data at:srcIndex.
- srcIndex := srcIndex + 1.
- g := data at:srcIndex.
- srcIndex := srcIndex + 1.
- b := data at:srcIndex.
- srcIndex := srcIndex + 1.
- v := ((0.3 * r) + (0.6 * g) + (0.1 * b)) asInteger.
- v := v bitShift:-6. "take 2 hi bits"
- bits := (bits bitShift:2) bitOr:v.
- bitCount := bitCount + 1.
- (bitCount == 4) ifTrue:[
- twoPlaneBits at:dstIndex put:bits.
- dstIndex := dstIndex + 1.
- bits := 0.
- bitCount := 0
- ]
- ].
- (bitCount ~~ 0) ifTrue:[
- twoPlaneBits at:dstIndex put:bits.
- dstIndex := dstIndex + 1
- ]
- ]
- ].
-
- f := Form width:width height:height depth:2 on:aDevice.
- f isNil ifTrue:[^ nil].
- f initGC.
- (aDevice blackpixel == 0) ifFalse:[
- "have to invert bits"
- f function:#copyInverted
- ].
- aDevice drawBits:twoPlaneBits depth:2 width:width height:height
- x:0 y:0
- into:(f id) x:0 y:0 width:width height:height with:(f gcId).
- ^ f
-!
-
-rgbImageAsRandomDithered2PlaneFormOn:aDevice
- "return a 2-bit form from the rgb picture"
-
- |twoPlaneBits f v
- r g b
- map rMap gMap bMap
- srcIndex "{ Class: SmallInteger }"
- dstIndex "{ Class: SmallInteger }"
- bits "{ Class: SmallInteger }"
- bitCount "{ Class: SmallInteger }" |
-
- twoPlaneBits := ByteArray uninitializedNew:(((width * 2 + 7) // 8) * height).
-%{
- register unsigned char *srcPtr, *dstPtr;
- register _v, _bits, _bitCount;
- register j;
- register i;
- int rnd;
- extern OBJ ByteArray;
-
- if ((_Class(_INST(data)) == ByteArray)
- && (_Class(twoPlaneBits) == ByteArray)) {
- srcPtr = _ByteArrayInstPtr(_INST(data))->ba_element;
- dstPtr = _ByteArrayInstPtr(twoPlaneBits)->ba_element;
- for (i=_intVal(_INST(height)); i>0; i--) {
- _bitCount = 0;
- _bits = 0;
- for (j=_intVal(_INST(width)); j>0; j--) {
- _v = (*srcPtr++ * 3); /* 0.3*r + 0.6*g + b */
- _v += (*srcPtr++ * 6);
- _v += *srcPtr++;
- /* v now 0 .. 256*10 */
- _v = _v / (10*2); /* v now 0 .. 127 */
- _bits <<= 2;
- rnd = (rand() >> 12) & 3;
- if (_v < 10) {
- /* _bits |= 0; */ /* 0 */
- } else if (_v < 20) {
- if (rnd == 3) /* p(0) = 75 */
- _bits |= 1; /* p(1) = 25 */
- else
- _bits |= 0;
- } else if (_v < 30) {
- if (rnd & 2) /* p(0) = 50 */
- _bits |= 1; /* p(1) = 50 */
- else
- _bits |= 0;
- } else if (_v < 40) {
- if (rnd == 0) /* p(0) = 25 */
- _bits |= 0; /* p(1) = 75 */
- else
- _bits |= 1;
- } else if (_v < 49) {
- _bits |= 1; /* 1 */
- } else if (_v < 59) {
- if (rnd == 3) /* p(1) = 75 */
- _bits |= 2; /* p(2) = 25 */
- else
- _bits |= 1;
- } else if (_v < 69) {
- if (rnd & 2) /* p(1) = 50 */
- _bits |= 2; /* p(2) = 50 */
- else
- _bits |= 1;
- } else if (_v < 79) {
- if (rnd == 0) /* p(1) = 25 */
- _bits |= 1; /* p(2) = 75 */
- else
- _bits |= 2;
- } else if (_v < 88) {
- _bits |= 2; /* 2 */
- } else if (_v < 98) {
- if (rnd == 3) /* p(2) = 75 */
- _bits |= 3; /* p(3) = 25 */
- else
- _bits |= 2;
- } else if (_v < 108) {
- if (rnd & 2) /* p(2) = 50 */
- _bits |= 3; /* p(3) = 50 */
- else
- _bits |= 2;
- } else if (_v < 118) {
- if (rnd == 0) /* p(2) = 25 */
- _bits |= 2; /* p(3) = 75 */
- else
- _bits |= 3;
- } else {
- _bits |= 3;
- }
- _bitCount++;
- if (_bitCount == 4) {
- *dstPtr++ = _bits;
- _bits = 0;
- _bitCount = 0;
- }
- }
- if (_bitCount != 0) {
- *dstPtr++ = _bits;
- }
- }
- }
-%}
-.
- f := Form width:width height:height depth:2 on:aDevice.
- f isNil ifTrue:[^ nil].
- f initGC.
- (aDevice blackpixel == 0) ifFalse:[
- "have to invert bits"
- f function:#copyInverted
- ].
- aDevice drawBits:twoPlaneBits depth:2 width:width height:height
- x:0 y:0
- into:(f id) x:0 y:0 width:width height:height with:(f gcId).
- ^ f
+ ^ self subclassResponsibility
!
rgbImageAs8BitGreyFormOn:aDevice
"return an 8-bit greyForm from the rgb picture"
- |greyBits f v
- srcIndex "{ Class: SmallInteger }"
- dstIndex "{ Class: SmallInteger }"
- fast|
-
- greyBits := ByteArray uninitializedNew:(width * height).
- fast := false.
-%{
- register unsigned char *srcPtr, *dstPtr;
- register _v;
- register j;
- register i;
- extern OBJ ByteArray;
-
- if ((_Class(_INST(data)) == ByteArray)
- && (_Class(greyBits) == ByteArray)) {
- fast = true;
- srcPtr = _ByteArrayInstPtr(_INST(data))->ba_element;
- dstPtr = _ByteArrayInstPtr(greyBits)->ba_element;
- for (i=_intVal(_INST(height)); i>0; i--) {
- for (j=_intVal(_INST(width)); j>0; j--) {
- _v = (*srcPtr * 3); /* 0.3*r + 0.6*g + b */
- _v += (*srcPtr++ * 6);
- _v += *srcPtr++;
- _v /= 10;
- *dstPtr++ = _v >> 4 ;
- }
- }
- }
-%}
-.
- fast ifFalse:[
- srcIndex := 1.
- dstIndex := 1.
-
- 1 to:height do:[:h |
- 1 to:width do:[:w |
- |v
- r "{ Class: SmallInteger }"
- g "{ Class: SmallInteger }"
- b "{ Class: SmallInteger }"|
-
- r := data at:srcIndex.
- srcIndex := srcIndex + 1.
- g := data at:srcIndex.
- srcIndex := srcIndex + 1.
- b := data at:srcIndex.
- srcIndex := srcIndex + 1.
-
- v := ((0.3 * r) + (0.6 * g) + (0.1 * b)) asInteger.
- v := v bitShift:-4.
- greyBits at:dstIndex put:v.
- dstIndex := dstIndex + 1
- ]
- ]
- ].
-
- f := Form width:width height:height depth:8 on:aDevice.
- f isNil ifTrue:[^ nil].
- f initGC.
- aDevice drawBits:greyBits depth:8 width:width height:height
- x:0 y:0
- into:(f id) x:0 y:0
- width:width height:height with:(f gcId).
- ^ f
+ ^ self subclassResponsibility
!
rgbImageAsPseudoFormOn:aDevice
"return a pseudocolor form from the rgb-picture"
- |pseudoBits f
- r "{ Class: SmallInteger }"
- g "{ Class: SmallInteger }"
- b "{ Class: SmallInteger }"
- srcIndex "{ Class: SmallInteger }"
- dstIndex "{ Class: SmallInteger }"
- rMask "{ Class: SmallInteger }"
- gMask "{ Class: SmallInteger }"
- bMask "{ Class: SmallInteger }"
- redArray greenArray blueArray
- dataSize "{ Class: SmallInteger }"
- nColors "{ Class: SmallInteger }"
- fit fitMap colors color
- fast
- colorIndex "{ Class: SmallInteger }"
- depth nColorCells|
-
- "find used colors; build color-tree"
-
- fit := false.
- fitMap := false.
- depth := aDevice depth.
- nColorCells := aDevice ncells.
-
- rMask := 2r11111111.
- gMask := 2r11111111.
- bMask := 2r11111111.
-
- [fit] whileFalse:[
- [fitMap] whileFalse:[
- srcIndex := 1.
- redArray := Array new:256.
-
- "find used colors"
-
- nColors := 0.
- srcIndex := 1.
- dataSize := data size.
- [srcIndex < dataSize] whileTrue:[
-%{
- if (_isNonNilObject(_INST(data))
- && (_qClass(_INST(data)) == ByteArray)) {
- int sI = _intVal(srcIndex);
- unsigned char *cp = (unsigned char *)
- (_ArrayInstPtr(_INST(data))->a_element);
-
- r = _MKSMALLINT((cp[sI - 1] & _intVal(rMask)) + 1);
- g = _MKSMALLINT((cp[sI] & _intVal(gMask)) + 1);
- b = _MKSMALLINT((cp[sI + 1] & _intVal(bMask)) + 1);
- srcIndex = _MKSMALLINT(sI + 3);
- fast = true;
- } else {
- fast = false;
- }
-%}
-.
- fast ifFalse:[
- r := data at:srcIndex.
- r := r bitAnd:rMask.
- r := r + 1.
- srcIndex := srcIndex + 1.
- g := data at:srcIndex.
- g := g bitAnd:gMask.
- g := g + 1.
- srcIndex := srcIndex + 1.
- b := data at:srcIndex.
- b := b bitAnd:bMask.
- b := b + 1.
- srcIndex := srcIndex + 1
- ].
-
- greenArray := redArray at:r.
- greenArray isNil ifTrue:[
- greenArray := Array new:256.
- redArray at:r put:greenArray
- ].
- blueArray := greenArray at:g.
- blueArray isNil ifTrue:[
- blueArray := Array new:256.
- greenArray at:g put:blueArray
- ].
- (blueArray at:b) isNil ifTrue:[
- blueArray at:b put:true.
- nColors := nColors + 1.
- (nColors > nColorCells) ifTrue:[
- 'more than ' print. nColorCells print.
- ' colors' printNewline.
- srcIndex := dataSize + 1
- ]
- ]
- ].
-
- "again with less color bits if it does not fit colormap"
-
- (nColors <= nColorCells) ifTrue:[
- fitMap := true
- ] ifFalse:[
- "must try again - cutting off some bits"
- (bMask == 2r11111111) ifTrue:[
- bMask := 2r11111110
- ] ifFalse:[
- rMask := (rMask bitShift:1) bitAnd:2r11111111.
- gMask := (gMask bitShift:1) bitAnd:2r11111111.
- bMask := (bMask bitShift:1) bitAnd:2r11111111
- ].
- 'masks:' print. rMask print. ' ' print. gMask print. ' ' print.
- bMask printNewline
- ]
- ].
-
- nColors print. ' colors used' printNewline.
- colors := Array new:nColors.
- colorIndex := 1.
-
- "allocate all used colors"
-
- fit := true.
-
- r := 0.
- redArray do:[:greenArray |
- (fit and:[greenArray notNil]) ifTrue:[
- g := 0.
- greenArray do:[:blueArray |
- (fit and:[blueArray notNil]) ifTrue:[
- b := 0.
- blueArray do:[:x |
- (fit and:[x notNil]) ifTrue:[
- color := Color red:(r * 100.0 / 255.0)
- green:(g * 100.0 / 255.0)
- blue:(b * 100.0 / 255.0).
- color := color on:aDevice.
- color colorId isNil ifTrue:[
- fit := false
- ] ifFalse:[
- colors at:colorIndex put:color.
- colorIndex := colorIndex + 1.
- blueArray at:(b + 1)
- put:color colorId
- ]
- ].
- b := b + 1
- ]
- ].
- g := g + 1
- ]
- ].
- r := r + 1
- ].
-
- "again with less color bits if we didnt get all colors"
-
- fit ifFalse:[
- 'still no fit' printNewline.
-
- "free the allocated colors"
- colors atAllPut:nil.
- "a kludge - force immediate freeing of colors"
- ObjectMemory scavenge.
-
- "cut off one more color-bit - cut off blue first"
- (bMask == 2r11111111) ifTrue:[
- bMask := 2r11111110
- ] ifFalse:[
- (bMask == 2r11111110) ifTrue:[
- bMask := 2r11111100
- ] ifFalse:[
- rMask := (rMask bitShift:1) bitAnd:2r11111111.
- gMask := (gMask bitShift:1) bitAnd:2r11111111.
- bMask := (bMask bitShift:1) bitAnd:2r11111111
- ]
- ].
- fitMap := false.
- redArray := nil
- ]
- ].
-
- "create pseudocolor bits and translate"
-
- pseudoBits := ByteArray uninitializedNew:(width * height).
-
- srcIndex := 1.
- dstIndex := 1.
-
- [srcIndex < dataSize] whileTrue:[
- r := data at:srcIndex.
- r := r bitAnd:rMask.
- srcIndex := srcIndex + 1.
- g := data at:srcIndex.
- g := g bitAnd:gMask.
- srcIndex := srcIndex + 1.
- b := data at:srcIndex.
- b := b bitAnd:bMask.
- srcIndex := srcIndex + 1.
- greenArray := redArray at:(r + 1).
- blueArray := greenArray at:(g + 1).
- pseudoBits at:dstIndex put:(blueArray at:(b + 1)).
- dstIndex := dstIndex + 1
- ].
-
- f := Form width:width height:height depth:8 on:aDevice.
- f isNil ifTrue:[^ nil].
- f colorMap:colors.
- f initGC.
- aDevice drawBits:pseudoBits depth:8 width:width height:height
- x:0 y:0
- into:(f id) x:0 y:0 width:width height:height with:(f gcId).
- ^ f
+ ^ self subclassResponsibility
! !
!Image methodsFor:'converting palette images'!
@@ -1390,15 +838,9 @@
].
(aDevice depth == 2) ifTrue:[
- DitherAlgorithm == #random ifTrue:[
- ^ self paletteImageAsRandomDithered2PlaneFormOn:aDevice
- ].
^ self paletteImageAs2PlaneFormOn:aDevice
].
- DitherAlgorithm == #random ifTrue:[
- ^ self paletteImageAsRandomDitheredMonoFormOn:aDevice
- ].
^ self paletteImageAsMonoFormOn:aDevice
].
^ self paletteImageAsPseudoFormOn:aDevice
@@ -1407,674 +849,38 @@
paletteImageAsMonoFormOn:aDevice
"return a 1-bit monoForm from the palette picture"
- |monoBits f
- map rMap gMap bMap
- fast
- r g b v
- mapSize "{ Class: SmallInteger }"
- srcIndex "{ Class: SmallInteger }"
- dstIndex "{ Class: SmallInteger }" |
-
- monoBits := ByteArray uninitializedNew:(((width + 7) // 8) * height).
-
- rMap := colorMap at:1.
- gMap := colorMap at:2.
- bMap := colorMap at:3.
- map := ByteArray uninitializedNew:256.
-
- mapSize := rMap size.
- 1 to:mapSize do:[:i |
- r := rMap at:i.
- r notNil ifTrue:[
- g := gMap at:i.
- b := bMap at:i.
- v := ((0.3 * r) + (0.6 * g) + (0.1 * b)) asInteger.
- v := v bitShift:-7. "only keep hi-bit"
- (v == 1) ifTrue:[
- map at:i put:1
- ] ifFalse:[
- map at:i put:0
- ]
- ]
- ].
-
- fast := false.
-%{
- register unsigned char *srcPtr, *dstPtr, *mapPtr;
- register _v, _bits, _bitCount;
- register j;
- register i;
- extern OBJ ByteArray;
-
- if (_isNonNilObject(_INST(data)) && (_qClass(_INST(data)) == ByteArray)
- && _isNonNilObject(map) && (_qClass(map) == ByteArray)
- && _isNonNilObject(monoBits) && (_qClass(monoBits) == ByteArray)) {
- fast = true;
- srcPtr = _ByteArrayInstPtr(_INST(data))->ba_element;
- dstPtr = _ByteArrayInstPtr(monoBits)->ba_element;
- mapPtr = _ByteArrayInstPtr(map)->ba_element;
- for (i=_intVal(_INST(height)); i>0; i--) {
- _bitCount = 0;
- _bits = 0;
- for (j=_intVal(_INST(width)); j>0; j--) {
- _v = mapPtr[*srcPtr++];
- _bits = (_bits<<1) | _v;
- _bitCount++;
- if (_bitCount == 8) {
- *dstPtr++ = _bits;
- _bits = 0;
- _bitCount = 0;
- }
- }
- if (_bitCount != 0) {
- *dstPtr++ = _bits;
- }
- }
- }
-%}
-.
- fast ifFalse:[
- srcIndex := 1.
- dstIndex := 1.
- 1 to:height do:[:row |
- |v
- bitCount "{ Class: SmallInteger }"
- bits "{ Class: SmallInteger }"|
-
- bitCount := 0.
- bits := 0.
- 1 to:width do:[:col |
- v := data at:srcIndex.
- srcIndex := srcIndex + 1.
- v := map at:(v + 1).
- bits := (bits bitShift:1) bitOr:v.
- bitCount := bitCount + 1.
- (bitCount == 8) ifTrue:[
- monoBits at:dstIndex put:bits.
- dstIndex := dstIndex + 1.
- bits := 0.
- bitCount := 0
- ]
- ].
- (bitCount ~~ 0) ifTrue:[
- monoBits at:dstIndex put:bits.
- dstIndex := dstIndex + 1
- ]
- ]
- ].
-
- f := Form width:width height:height depth:1 on:aDevice.
- f isNil ifTrue:[^ nil].
- f initGC.
- (aDevice blackpixel == 0) ifFalse:[
- "have to invert bits"
- f function:#copyInverted
- ].
- aDevice drawBits:monoBits depth:1 width:width height:height
- x:0 y:0
- into:(f id) x:0 y:0 width:width height:height with:(f gcId).
- ^ f
-!
-
-paletteImageAsRandomDitheredMonoFormOn:aDevice
- "return a dithered 1-bit form from the rgb picture"
-
- |monoBits f
- map rMap gMap bMap
- fast
- r g b v
- mapSize "{ Class: SmallInteger }"
- srcIndex "{ Class: SmallInteger }"
- dstIndex "{ Class: SmallInteger }"
- bits "{ Class: SmallInteger }"
- bitCount "{ Class: SmallInteger }" |
-
- monoBits := ByteArray uninitializedNew:(((width + 7) // 8) * height).
-
- rMap := colorMap at:1.
- gMap := colorMap at:2.
- bMap := colorMap at:3.
- map := ByteArray new:256.
-
- mapSize := rMap size.
- 1 to:mapSize do:[:i |
- r := rMap at:i.
- r notNil ifTrue:[
- g := gMap at:i.
- b := bMap at:i.
- v := ((0.3 * r) + (0.6 * g) + (0.1 * b)) asInteger.
- map at:i put:v
- ]
- ].
-%{
- register unsigned char *srcPtr, *dstPtr, *mapPtr;
- register _v, _bits, _bitCount;
- register j;
- register i;
- extern OBJ ByteArray;
- int rnd;
-
- if (_isNonNilObject(_INST(data)) && (_qClass(_INST(data)) == ByteArray)
- && _isNonNilObject(map) && (_qClass(map) == ByteArray)
- && _isNonNilObject(monoBits) && (_qClass(monoBits) == ByteArray)) {
- fast = true;
- srcPtr = _ByteArrayInstPtr(_INST(data))->ba_element;
- dstPtr = _ByteArrayInstPtr(monoBits)->ba_element;
- mapPtr = _ByteArrayInstPtr(map)->ba_element;
- for (i=_intVal(_INST(height)); i>0; i--) {
- _bitCount = 0;
- _bits = 0;
- for (j=_intVal(_INST(width)); j>0; j--) {
- _bits <<= 1;
- _v = mapPtr[*srcPtr++];
- rnd = ((rand() >> 3) & 0xFF);
- if (_v > rnd)
- _bits |= 1;
-
- _bitCount++;
- if (_bitCount == 8) {
- *dstPtr++ = _bits;
- _bits = 0;
- _bitCount = 0;
- }
- }
- if (_bitCount != 0) {
- *dstPtr++ = _bits;
- }
- }
- }
-%}
-.
- f := Form width:width height:height depth:1 on:aDevice.
- f isNil ifTrue:[^ nil].
- f initGC.
- (aDevice blackpixel == 0) ifFalse:[
- "have to invert bits"
- f function:#copyInverted
- ].
- aDevice drawBits:monoBits depth:1 width:width height:height
- x:0 y:0
- into:(f id) x:0 y:0 width:width height:height with:(f gcId).
- ^ f
+ ^ self subclassResponsibility
!
paletteImageAs2PlaneFormOn:aDevice
"return a 2-bit greyForm from the palette picture"
- |twoPlaneBits f
- map rMap gMap bMap fast
- srcIndex dstIndex|
-
- twoPlaneBits := ByteArray uninitializedNew:(((width * 2 + 7) // 8) * height).
-
- rMap := colorMap at:1.
- gMap := colorMap at:2.
- bMap := colorMap at:3.
- map := ByteArray uninitializedNew:256.
- 1 to:(rMap size) do:[:i |
- |r g b v|
-
- r := rMap at:i.
- r notNil ifTrue:[
- g := gMap at:i.
- b := bMap at:i.
- v := ((0.3 * r) + (0.6 * g) + (0.1 * b)) asInteger.
- v := v bitShift:-6. "only keep hi-2-bits"
- map at:i put:v
- ]
- ].
- fast := false.
-%{
- register unsigned char *srcPtr, *dstPtr, *mapPtr;
- register _v, _bits, _bitCount;
- register j;
- register i;
- extern OBJ ByteArray;
-
- if ((_Class(_INST(data)) == ByteArray)
- && (_Class(map) == ByteArray)
- && (_Class(twoPlaneBits) == ByteArray)) {
- fast = true;
- srcPtr = _ByteArrayInstPtr(_INST(data))->ba_element;
- dstPtr = _ByteArrayInstPtr(twoPlaneBits)->ba_element;
- mapPtr = _ByteArrayInstPtr(map)->ba_element;
- for (i=_intVal(_INST(height)); i>0; i--) {
- _bitCount = 0;
- _bits = 0;
- for (j=_intVal(_INST(width)); j>0; j--) {
- _v = mapPtr[*srcPtr++];
- _bits = (_bits<<2) | _v;
- _bitCount++;
- if (_bitCount == 4) {
- *dstPtr++ = _bits;
- _bits = 0;
- _bitCount = 0;
- }
- }
- if (_bitCount != 0) {
- *dstPtr++ = _bits;
- }
- }
- }
-%}
-.
- fast ifFalse:[
- srcIndex := 1.
- dstIndex := 1.
- 1 to:height do:[:row |
- |bits bitCount|
-
- bitCount := 0.
- bits := 0.
- 1 to:width do:[:col |
- |v|
-
- v := data at:srcIndex.
- srcIndex := srcIndex + 1.
- v := map at:(v + 1).
- bits := (bits bitShift:2) bitOr:v.
- bitCount := bitCount + 1.
- (bitCount == 4) ifTrue:[
- twoPlaneBits at:dstIndex put:bits.
- dstIndex := dstIndex + 1.
- bits := 0.
- bitCount := 0
- ]
- ].
- (bitCount ~~ 0) ifTrue:[
- twoPlaneBits at:dstIndex put:bits.
- dstIndex := dstIndex + 1
- ]
- ]
- ].
-
- f := Form width:width height:height depth:2 on:aDevice.
- f isNil ifTrue:[^ nil].
- f initGC.
- (aDevice blackpixel == 0) ifFalse:[
- "have to invert bits"
- f function:#copyInverted
- ].
- aDevice drawBits:twoPlaneBits depth:2 width:width height:height
- x:0 y:0
- into:(f id) x:0 y:0 width:width height:height with:(f gcId).
- ^ f
-!
-
-paletteImageAsRandomDithered2PlaneFormOn:aDevice
- "return a 2-bit greyForm from the palette picture"
-
- |twoPlaneBits f
- map rMap gMap bMap
- srcIndex dstIndex bits bitCount |
-
- twoPlaneBits := ByteArray uninitializedNew:(((width * 2 + 7) // 8) * height).
-
- rMap := colorMap at:1.
- gMap := colorMap at:2.
- bMap := colorMap at:3.
- map := ByteArray uninitializedNew:256.
- 1 to:(rMap size) do:[:i |
- |r g b v|
-
- r := rMap at:i.
- r notNil ifTrue:[
- g := gMap at:i.
- b := bMap at:i.
- v := ((6 * r) + (3 * g) + (1 * b)) asInteger.
- " v is now in the range 0 .. 2550 "
- v := (v // 10).
- " v is now 0 .. 255 "
- v := v bitShift:-1. "v now 0 .. 127 "
- map at:i put:v
- ]
- ].
-%{
- register unsigned char *srcPtr, *dstPtr, *mapPtr;
- register _v, _bits, _bitCount;
- register j;
- register i;
- int rnd;
- extern OBJ ByteArray;
-
- if ((_Class(_INST(data)) == ByteArray)
- && (_Class(map) == ByteArray)
- && (_Class(twoPlaneBits) == ByteArray)) {
- srcPtr = _ByteArrayInstPtr(_INST(data))->ba_element;
- dstPtr = _ByteArrayInstPtr(twoPlaneBits)->ba_element;
- mapPtr = _ByteArrayInstPtr(map)->ba_element;
- for (i=_intVal(_INST(height)); i>0; i--) {
- _bitCount = 0;
- _bits = 0;
- for (j=_intVal(_INST(width)); j>0; j--) {
- _v = mapPtr[*srcPtr++];
- _bits = _bits<<2;
- rnd = (rand() >> 17) & 3;
- if (_v < 10) {
- /* _bits |= 0; */ /* 0 */
- } else if (_v < 20) {
- if (rnd == 3) /* p(0) = 75 */
- _bits |= 1; /* p(1) = 25 */
- else
- _bits |= 0;
- } else if (_v < 30) {
- if (rnd & 2) /* p(0) = 50 */
- _bits |= 1; /* p(1) = 50 */
- else
- _bits |= 0;
- } else if (_v < 40) {
- if (rnd == 3) /* p(0) = 25 */
- _bits |= 0; /* p(1) = 75 */
- else
- _bits |= 1;
- } else if (_v < 49) {
- _bits |= 1; /* 1 */
- } else if (_v < 59) {
- if (rnd == 3) /* p(1) = 75 */
- _bits |= 2; /* p(2) = 25 */
- else
- _bits |= 1;
- } else if (_v < 69) {
- if (rnd & 2) /* p(1) = 50 */
- _bits |= 2; /* p(2) = 50 */
- else
- _bits |= 1;
- } else if (_v < 79) {
- if (rnd == 3) /* p(1) = 25 */
- _bits |= 1; /* p(2) = 75 */
- else
- _bits |= 2;
- } else if (_v < 88) {
- _bits |= 2; /* 2 */
- } else if (_v < 98) {
- if (rnd == 3) /* p(2) = 75 */
- _bits |= 3; /* p(3) = 25 */
- else
- _bits |= 2;
- } else if (_v < 108) {
- if (rnd & 2) /* p(2) = 50 */
- _bits |= 3; /* p(3) = 50 */
- else
- _bits |= 2;
- } else if (_v < 118) {
- if (rnd == 3) /* p(2) = 25 */
- _bits |= 2; /* p(3) = 75 */
- else
- _bits |= 3;
- } else {
- _bits |= 3;
- }
- _bitCount++;
- if (_bitCount == 4) {
- *dstPtr++ = _bits;
- _bits = 0;
- _bitCount = 0;
- }
- }
- if (_bitCount != 0) {
- *dstPtr++ = _bits;
- }
- }
- }
-%}
-.
- f := Form width:width height:height depth:2 on:aDevice.
- f isNil ifTrue:[^ nil].
- f initGC.
- (aDevice blackpixel == 0) ifFalse:[
- "have to invert bits"
- f function:#copyInverted
- ].
- aDevice drawBits:twoPlaneBits depth:2 width:width height:height
- x:0 y:0
- into:(f id) x:0 y:0 width:width height:height with:(f gcId).
- ^ f
-!
-
-paletteImageAsPatternDitheredGreyFormOn:aDevice
- "return a dithered greyForm from the palette picture.
- works for any destination depth."
-
- |f
- r g b v
- map rMap gMap bMap run last
- srcIndex ditherColors nDither first delta|
-
- Transcript showCr:'dithering ..'. Transcript endEntry.
-
- nDither := NumberOfDitherColors.
- ditherColors := Array new:nDither.
-
- first := (100 / nDither / 2).
- delta := 100 / nDither.
- 0 to:nDither-1 do:[:i |
- ditherColors at:i+1 put:(Color grey:(i * delta + first)).
- ].
-
- rMap := colorMap at:1.
- gMap := colorMap at:2.
- bMap := colorMap at:3.
- map := Array new:256.
- 1 to:(rMap size) do:[:i |
- r := rMap at:i.
- r notNil ifTrue:[
- g := gMap at:i.
- b := bMap at:i.
- v := ((6 * r) + (3 * g) + (1 * b)) asInteger.
- " v is now in the range 0 .. 2550 "
- v := (v * (nDither - 1) // 2550) rounded.
- " v is now 0 .. nDither-1 "
- map at:i put:(ditherColors at:(v + 1))
- ]
- ].
-
- f := Form width:width height:height depth:(aDevice depth) on:aDevice.
- f isNil ifTrue:[^ nil].
- f initGC.
- "draw each pixel using dither color"
-
- srcIndex := 1.
- 0 to:height-1 do:[:dstY |
- run := 0.
- last := nil.
- 0 to:width-1 do:[:dstX |
- |clr v|
- v := data at:srcIndex.
- srcIndex := srcIndex + 1.
- clr := map at:(v + 1).
-
- clr == last ifTrue:[
- run := run + 1
- ] ifFalse:[
- (run ~~ 0) ifTrue:[
- f fillRectangleX:dstX-run y:dstY width:run height:1.
- ].
- run := 1.
- f paint:clr.
- last := clr
- ].
- ].
- f fillRectangleX:width-run y:dstY width:run height:1.
- ].
- ^ f
+ ^ self subclassResponsibility
!
paletteImageAsPseudoFormOn:aDevice
- "return a pseudoForm from the palette picture. The main work is
- in color reduction, when not all colors can be aquired."
-
- |pseudoBits f
- imgMap
- usedColors usageCounts nUsed map mapIndex rMap gMap bMap color
- fit scale lastOK sum error
- div
- shift "{Class: SmallInteger }"
- m "{Class: SmallInteger }"
- rMask "{Class: SmallInteger }"
- gMask "{Class: SmallInteger }"
- bMask "{Class: SmallInteger }" |
-
- 'allocating colors ...' printNewline.
-
- "find used colors"
-
- usedColors := data usedValues. "gets us an array filled with used values"
- "(could use data asBag)"
- nUsed := usedColors maximumValue + 1.
-
- "sort by usage"
- usageCounts := data usageCounts.
- usageCounts := usedColors asArray collect:[:clr | usageCounts at:(clr + 1)].
- usageCounts sort:[:a :b | a > b] with:usedColors.
-
- "allocate the colors (in order of usage count)"
-
- rMap := colorMap at:1.
- gMap := colorMap at:2.
- bMap := colorMap at:3.
-
- imgMap := Array new:nUsed.
-
- "first, we try to get the exact colors"
-
- shift := (8 - aDevice bitsPerRGB) negated.
- m := (1 bitShift:(aDevice bitsPerRGB)) - 1.
- div := m asFloat.
- gMask := bMask := rMask := m.
-
- fit := true.
- scale := 100.0 / div. "to scale 0..255 into 0.0 .. 100.0"
- lastOK := 0.
- usedColors do:[:aColorIndex |
- |r g b|
+ "return a pseudoForm from the palette picture."
- fit ifTrue:[
- mapIndex := aColorIndex + 1.
- r := rMap at:mapIndex.
- r := ((r bitShift:shift) bitAnd:rMask) * scale.
- g := gMap at:mapIndex.
- g := ((g bitShift:shift) bitAnd:gMask) * scale.
- b := bMap at:mapIndex.
- b := ((b bitShift:shift) bitAnd:bMask) * scale.
- color := Color red:r green:g blue:b.
- color := color exactOn:aDevice.
- (color notNil and:[color colorId notNil]) ifTrue:[
- imgMap at:mapIndex put:color.
- lastOK := lastOK + 1.
- ] ifFalse:[
- fit := false
- ]
- ]
- ].
-
- "again, this time allow wrong colors (loop while increasing allowed
- error)"
-
- fit ifFalse:[
- error := 10.
- [fit] whileFalse:[
- fit := true.
- usedColors from:(lastOK+1) to:(usedColors size) do:[:aColorIndex |
- |r g b|
-
- fit ifTrue:[
- mapIndex := aColorIndex + 1.
- r := rMap at:mapIndex.
- r := ((r bitShift:shift) bitAnd:rMask) * scale.
- g := gMap at:mapIndex.
- g := ((g bitShift:shift) bitAnd:gMask) * scale.
- b := bMap at:mapIndex.
- b := ((b bitShift:shift) bitAnd:bMask) * scale.
- color := Color red:r green:g blue:b.
- color := color nearestOn:aDevice error:error.
- (color notNil and:[color colorId notNil]) ifTrue:[
- imgMap at:mapIndex put:color.
- lastOK := lastOK + 1.
- ] ifFalse:[
- fit := false
- ]
- ].
- ].
- error := error * 2
- ].
-
- error > 100 ifTrue:[
- 'not enough colors for a reasonable image' printNewline
- ] ifFalse:[
- 'not enough colors for exact picture' printNewline.
- ]
- ].
-
- pseudoBits := ByteArray uninitializedNew:(width * height).
-
- "create translation map"
- map := ByteArray uninitializedNew:256.
- 1 to:imgMap size do:[:i |
- (imgMap at:i) notNil ifTrue:[
- map at:i put:(imgMap at:i) colorId
- ]
- ].
-
- data expandPixels:8 "xlate only"
- width:width
- height:height
- into:pseudoBits
- mapping:map.
-
- map := nil.
-
- f := Form width:width height:height depth:8 on:aDevice.
- f isNil ifTrue:[^ nil].
- f colorMap:imgMap.
- f initGC.
- aDevice drawBits:pseudoBits depth:8 width:width height:height
- x:0 y:0
- into:(f id) x:0 y:0
- width:width height:height with:(f gcId).
- ^ f
+ ^ self subclassResponsibility
!
paletteImageAsGreyFormOn:aDevice
"return an 8-bit greyForm from the palette picture"
- |greyBits f v
- r g b
- map rMap gMap bMap|
-
- greyBits := ByteArray uninitializedNew:(width * height).
+ ^ self subclassResponsibility
+!
- rMap := colorMap at:1.
- gMap := colorMap at:2.
- bMap := colorMap at:3.
- map := ByteArray uninitializedNew:256.
- 1 to:(rMap size) do:[:i |
- r := rMap at:i.
- r notNil ifTrue:[
- g := gMap at:i.
- b := bMap at:i.
- v := ((0.3 * r) + (0.6 * g) + (0.1 * b)) asInteger.
- map at:i put:v
- ]
- ].
- data expandPixels:8 "xlate only"
- width:width
- height:height
- into:greyBits
- mapping:map.
+paletteImageAsPatternDitheredGreyFormOn:aDevice
+ "return a dithered greyForm from the palette picture."
- f := Form width:width height:height depth:8 on:aDevice.
- f isNil ifTrue:[^ nil].
- f initGC.
- aDevice drawBits:greyBits depth:8 width:width height:height
- x:0 y:0
- into:(f id) x:0 y:0
- width:width height:height with:(f gcId).
- ^ f
+ ^ self subclassResponsibility
! !
!Image methodsFor:'converting greyscale images'!
greyImageAsFormOn:aDevice
+ "return a thresholded greyForm from the grey picture."
+
|pictureDepth nPlanes f|
nPlanes := samplesPerPixel.
@@ -2088,7 +894,7 @@
"monochrome is very easy ..."
(pictureDepth == 1) ifTrue:[
- ^ Form width:width height:height fromArray:data on:aDevice
+ ^ Form width:width height:height fromArray:bytes on:aDevice
].
(aDevice visualType == #StaticGray) ifTrue:[
@@ -2105,7 +911,7 @@
"have to invert bits"
f function:#copyInverted
].
- aDevice drawBits:data depth:pictureDepth width:width height:height
+ 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).
@@ -2119,9 +925,6 @@
DitherAlgorithm == #error ifTrue:[
^ self greyImageAsErrorDitheredGreyFormOn:aDevice
].
- DitherAlgorithm == #random ifTrue:[
- ^ self greyImageAsErrorDitheredGreyFormOn:aDevice
- ].
"
DitherAlgorithm == #pattern ifTrue:[
^ self greyImageAsPatternDitheredGreyFormOn:aDevice
@@ -2147,173 +950,56 @@
!
greyImageAsMonoFormOn:aDevice
- "return a monochrome Form from the picture"
-
- |bytesPerRow bitsPerRow left4pixel right4pixel pixel
- bytesPerMonoRow monoData
- byte "{Class: SmallInteger }"
- mask "{Class: SmallInteger }"
- srcIndex "{Class: SmallInteger }"
- dstIndex "{Class: SmallInteger }"
- nextSrc "{Class: SmallInteger }"
- nextDst "{Class: SmallInteger }"
- bitNumber pictureDepth|
-
- pictureDepth := bitsPerSample at:1.
- bitsPerRow := width * pictureDepth.
- bytesPerRow := bitsPerRow // 8.
- ((bitsPerRow \\ 8) ~~ 0) ifTrue:[
- bytesPerRow := bytesPerRow + 1
- ].
- bytesPerMonoRow := width // 8.
- ((width \\ 8) ~~ 0) ifTrue:[
- bytesPerMonoRow := bytesPerMonoRow + 1
- ].
- monoData := ByteArray uninitializedNew:(bytesPerMonoRow * height).
-
- (pictureDepth == 2) ifTrue:[
- "2 bit -> 1 bit extract; take most significant bit"
+ "return a (thresholded) monochrome Form from the picture."
- srcIndex := 1.
- dstIndex := 1.
- 1 to:height do:[:count |
- nextSrc := srcIndex + bytesPerRow.
- nextDst := dstIndex + bytesPerMonoRow.
- bitNumber := 1.
- [bitNumber <= width] whileTrue:[
- left4pixel := data at:srcIndex.
- srcIndex := srcIndex + 1.
- byte := 0.
- ((left4pixel bitAnd:16r80) ~~ 0) ifTrue:[
- byte := byte bitOr:2r10000000
- ].
- ((left4pixel bitAnd:16r20) ~~ 0) ifTrue:[
- byte := byte bitOr:2r01000000
- ].
- ((left4pixel bitAnd:16r08) ~~ 0) ifTrue:[
- byte := byte bitOr:2r00100000
- ].
- ((left4pixel bitAnd:16r02) ~~ 0) ifTrue:[
- byte := byte bitOr:2r00010000
- ].
- bitNumber := bitNumber + 4.
- (bitNumber <= width) ifTrue:[
- right4pixel := data at:srcIndex.
- srcIndex := srcIndex + 1.
- ((right4pixel bitAnd:16r80) ~~ 0) ifTrue:[
- byte := byte bitOr:2r00001000
- ].
- ((right4pixel bitAnd:16r20) ~~ 0) ifTrue:[
- byte := byte bitOr:2r00000100
- ].
- ((right4pixel bitAnd:16r08) ~~ 0) ifTrue:[
- byte := byte bitOr:2r00000010
- ].
- ((right4pixel bitAnd:16r02) ~~ 0) ifTrue:[
- byte := byte bitOr:2r00000001
- ].
- bitNumber := bitNumber + 4
- ].
- monoData at:dstIndex put:byte.
- dstIndex := dstIndex + 1
- ].
- srcIndex := nextSrc.
- dstIndex := nextDst
- ]
- ].
- (pictureDepth == 8) ifTrue:[
- "8 bit -> 1 bit extract; take most significant bit"
-
- srcIndex := 1.
- dstIndex := 1.
- 1 to:height do:[:count |
- nextSrc := srcIndex + bytesPerRow.
- nextDst := dstIndex + bytesPerMonoRow.
- bitNumber := 1.
- mask := 2r10000000.
- [bitNumber <= width] whileTrue:[
- byte := 0.
- pixel := data at:srcIndex.
- srcIndex := srcIndex + 1.
- ((pixel bitAnd:2r10000000) ~~ 0) ifTrue:[
- byte := byte bitOr:mask
- ].
- mask := mask bitShift: -1.
- (mask == 0) ifTrue:[
- monoData at:dstIndex put:byte.
- dstIndex := dstIndex + 1.
- byte := 0.
- mask := 2r10000000
- ].
- bitNumber := bitNumber + 1
- ].
- (mask == 2r10000000) ifFalse:[
- monoData at:dstIndex put:byte.
- dstIndex := dstIndex + 1
- ].
- srcIndex := nextSrc.
- dstIndex := nextDst
- ]
- ].
-
- ^ Form width:width height:height fromArray:monoData on:aDevice
+ ^ self subclassResponsibility
!
greyImageAsPatternDitheredGreyFormOn:aDevice
"return a dithered greyForm from the grey picture.
- Works for any destination depth.
- Used to reduce the number of grey levels."
-
- |f v
- map run last
- srcIndex ditherColors nDither first delta|
-
- Transcript showCr:'dithering ..'. Transcript endEntry.
-
- nDither := NumberOfDitherColors.
- ditherColors := Array new:nDither.
+ Works for any source/destination depths, but very very slow
+ since each pixel is processed individually.
+ Usually redefined by subclasses for more performance"
- first := (100 / nDither / 2).
- delta := 100 / nDither.
- 0 to:nDither-1 do:[:i |
- ditherColors at:i+1 put:(Color grey:(i * delta + first)).
- ].
+ |f last
+ x0 "{Class: SmallInteger }"
+ w "{Class: SmallInteger }"
+ h "{Class: SmallInteger }"
+ v "{Class: SmallInteger }"
+ run "{Class: SmallInteger }" |
- map := Array new:256.
- 1 to:256 do:[:i |
- v := i - 1.
- v := (v * (nDither - 1) // 255) rounded.
- " v is now 0 .. nDither-1 "
- map at:i put:(ditherColors at:(v + 1))
- ].
+ Transcript showCr:'slow dithering ..'. Transcript endEntry.
+
+ w := width - 1.
+ h := height - 1.
- f := Form width:width height:height depth:(aDevice depth) on:aDevice.
+ "draw each pixel using dither color (let others do the dithering)
+ although the code is simple, its very slow"
+
+ f := Form width:width height:height depth:aDevice depth on:aDevice.
f isNil ifTrue:[^ nil].
f initGC.
- "draw each pixel using dither color"
- srcIndex := 1.
- 0 to:height-1 do:[:dstY |
+ 0 to:h do:[:dstY |
+ x0 := 0.
run := 0.
last := nil.
- 0 to:width-1 do:[:dstX |
- |clr v|
- v := data at:srcIndex.
- srcIndex := srcIndex + 1.
- clr := map at:(v + 1).
+ self atY:dstY from:0 to:w do:[:x :srcColor |
+ |dstColor|
- clr == last ifTrue:[
- run := run + 1
- ] ifFalse:[
+ srcColor ~~ last ifTrue:[
(run ~~ 0) ifTrue:[
- f fillRectangleX:dstX-run y:dstY width:run height:1.
+ f fillRectangleX:x0 y:dstY width:run height:1.
].
- run := 1.
- f paint:clr.
- last := clr
+ run := 0.
+ dstColor := Color grey:(srcColor greyIntensity).
+ f paint:dstColor.
+ last := srcColor.
+ x0 := x
].
+ run := run + 1
].
- f fillRectangleX:width-run y:dstY width:run height:1.
+ f fillRectangleX:x0 y:dstY width:run height:1.
].
^ f
!
@@ -2367,7 +1053,7 @@
map at:index put:newValue
]
].
- data expandPixels:pictureDepth
+ bytes expandPixels:pictureDepth
width:width
height:height
into:wideBits
@@ -2401,7 +1087,7 @@
"for 8bits, we scan for used colors first;
to avoid allocating too many colors"
- usedColors := data usedValues.
+ usedColors := bytes usedValues.
nUsed := usedColors maximumValue + 1.
colorMap := Array new:nUsed.
@@ -2435,7 +1121,7 @@
].
"expand & translate"
- data expandPixels:pictureDepth
+ bytes expandPixels:pictureDepth
width:width
height:height
into:wideBits
@@ -2469,12 +1155,7 @@
^ self hardMagnifyBy:extent
].
- bitsPerPixel := (bitsPerSample inject:0 into:[:sum :i | sum + i]).
- (#(1 2 4 8 24) includes:bitsPerPixel) ifFalse:[
- "for now, only support 1, 2, 4, 8 and 24 bits/pixel"
- self error:'image depth currently not supported'.
- ^ nil
- ].
+ bitsPerPixel := self depth.
oldBytesPerRow := ((width * bitsPerPixel) + 7) // 8.
newWidth := width * mX.
@@ -2483,7 +1164,7 @@
newBits := ByteArray uninitializedNew:(newBytesPerRow * newHeight).
newImage := self species new.
- newImage data:newBits.
+ newImage bits:newBits.
newImage width:newWidth.
newImage height:newHeight.
newImage photometric:photometric.
@@ -2499,7 +1180,7 @@
1 to:height do:[:row |
1 to:mY do:[:i |
newBits replaceFrom:dstOffset to:(dstOffset + oldBytesPerRow - 1)
- with:data startingAt:srcOffset.
+ with:bytes startingAt:srcOffset.
dstOffset := dstOffset + newBytesPerRow
].
srcOffset := srcOffset + oldBytesPerRow.
@@ -2510,11 +1191,12 @@
dstOffset := 1.
srcOffset := 1.
1 to:height do:[:row |
- self magnifyRowFrom:data offset:srcOffset bytes:oldBytesPerRow
- into:newBits offset:dstOffset unit:bitsPerPixel factor:mX.
+ 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.
@@ -2527,61 +1209,76 @@
^ newImage
"((Image fromFile:'bitmaps/claus.gif') magnifyBy:1@2)"
+!
+
+hardMagnifyBy:extent
+ "return a new image magnified by extent, aPoint.
+ This is the general magnification method, handling non-integral values"
+
+ |mX mY
+ newWidth "{ Class: SmallInteger }"
+ newHeight "{ Class: SmallInteger }"
+ w "{ Class: SmallInteger }"
+ h "{ Class: SmallInteger }"
+ newImage newBits bitsPerPixel newBytesPerRow
+ value srcRow|
+
+ mX := extent x.
+ mY := extent y.
+ ((mX < 0) or:[mY < 0]) ifTrue:[^ nil].
+ ((mX = 1) and:[mY = 1]) ifTrue:[^ self].
+
+
+ newWidth := (width * mX) truncated.
+ newHeight := (height * mY) truncated.
+
+ bitsPerPixel := self depth.
+ newBytesPerRow := ((newWidth * bitsPerPixel) + 7) // 8.
+ newBits := ByteArray uninitializedNew:(newBytesPerRow * newHeight).
+
+ newImage := self species new.
+ newImage bits:newBits.
+ newImage width:newWidth.
+ newImage height:newHeight.
+ newImage photometric:photometric.
+ newImage samplesPerPixel:samplesPerPixel.
+ newImage bitsPerSample:bitsPerSample.
+ newImage colorMap:colorMap copy.
+
+ "walk over destination image fetching pixels from source image"
+
+ w := newWidth - 1.
+ 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.
+ ]
+ ].
+
+ ^ newImage
+
+ "((Image fromFile:'bitmaps/claus.gif') magnifyBy:0.5@0.5)"
! !
!Image methodsFor:'private'!
-magnifyRowFrom:srcBytes offset:srcStart bytes:oldBytesPerRow
- into:dstBytes offset:dstStart unit:unit factor:mX
-
- "magnify a single pixel row - limited functionality since in construction"
-
- |srcOffset dstOffset byte|
+magnifyRowFrom:srcBytes offset:srcStart pixels:oldPixels
+ into:dstBytes offset:dstStart factor:mX
-%{
- int _srcOffset, _dstOffset;
- unsigned char *srcP, *dstP;
- int _dstStart, _mag;
- REGISTER int i;
- REGISTER unsigned char _byte;
+ "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."
+
+ self subclassResponsibility
+! !
- if (_isSmallInteger(unit)
- && _isSmallInteger(srcStart) && _isSmallInteger(dstStart)
- && _isSmallInteger(oldBytesPerRow) && _isSmallInteger(mX)
- && _isNonNilObject(srcBytes) && (_qClass(srcBytes) == ByteArray)
- && _isNonNilObject(dstBytes) && (_qClass(dstBytes) == ByteArray)) {
- _mag = _intVal(mX);
- srcP = _ByteArrayInstPtr(srcBytes)->ba_element - 1;
- dstP = _ByteArrayInstPtr(dstBytes)->ba_element - 1;
- _dstStart = _intVal(dstStart);
- _srcOffset = _intVal(srcStart) + _intVal(oldBytesPerRow) - 1;
- _dstOffset = _dstStart + (_intVal(oldBytesPerRow) * _intVal(mX)) - 1;
- switch (_intVal(unit)) {
- case 8:
- while (_dstOffset > _dstStart) {
- _byte = srcP[_srcOffset--];
- for (i=_mag; i>0; i--)
- dstP[_dstOffset--] = _byte;
- }
- RETURN (self);
- break;
- default:
- break;
- }
- }
-%}
-.
- unit == 8 ifFalse:[
- ^ self error:'not implemented'
- ].
- dstOffset := dstStart + (oldBytesPerRow * mX) - 1.
- srcOffset := srcStart + oldBytesPerRow - 1.
- [dstOffset > dstStart] whileTrue:[
- byte := srcBytes at:srcOffset.
- 1 to:mX do:[:i |
- dstBytes at:dstOffset put:byte.
- dstOffset := dstOffset - 1
- ].
- srcOffset := srcOffset - 1
- ]
+!Image methodsFor: 'binary storage'!
+
+readBinaryContentsFrom: stream manager: manager
+ "tell the newly restored Image about restoration"
+
+ super readBinaryContentsFrom: stream manager: manager.
+ self restored
! !
--- a/ImageRdr.st Wed Oct 13 01:30:35 1993 +0100
+++ b/ImageRdr.st Wed Oct 13 01:32:53 1993 +0100
@@ -14,7 +14,7 @@
instanceVariableNames:'width height data byteOrder inStream outStream
photometric samplesPerPixel bitsPerSample
colorMap'
- classVariableNames:''
+ classVariableNames:'ReverseBits'
poolDictionaries:''
category:'Graphics-Support'
!
@@ -39,14 +39,46 @@
^ false
! !
+!ImageReader class methodsFor:'constants'!
+
+reverseBits
+ "return a table filled with bit reverse information.
+ To convert from msbit-first to lsbit-first bytes, use
+ the value as index into the table, retrieving the reverse
+ value. Since indexing must start at 1, use (value + 1) as
+ index."
+
+ |val index|
+
+ ReverseBits isNil ifTrue:[
+ ReverseBits := ByteArray new:256.
+ 0 to:255 do:[:i |
+ val := 0.
+ index := i.
+ (index bitTest:16r01) ifTrue:[val := val bitOr:16r80].
+ (index bitTest:16r02) ifTrue:[val := val bitOr:16r40].
+ (index bitTest:16r04) ifTrue:[val := val bitOr:16r20].
+ (index bitTest:16r08) ifTrue:[val := val bitOr:16r10].
+ (index bitTest:16r10) ifTrue:[val := val bitOr:16r08].
+ (index bitTest:16r20) ifTrue:[val := val bitOr:16r04].
+ (index bitTest:16r40) ifTrue:[val := val bitOr:16r02].
+ (index bitTest:16r80) ifTrue:[val := val bitOr:16r01].
+ ReverseBits at:(index + 1) put:val
+ ]
+ ].
+ ^ ReverseBits
+! !
+
!ImageReader class methodsFor:'fileIn / fileOut'!
fromFile:aFileName
- |reader image|
+ |reader image depth|
reader := self new.
- (reader fromFile:aFileName) notNil ifTrue:[
- image := Image new.
+ reader := reader fromFile:aFileName.
+ reader notNil ifTrue:[
+ depth := reader bitsPerPixel.
+ image := (Image implementorForDepth: depth) new.
image width:(reader width).
image height:(reader height).
image photometric:(reader photometric).
@@ -91,6 +123,12 @@
bitsPerSample
^ bitsPerSample
+!
+
+bitsPerPixel
+ "return the number of bits per pixel"
+
+ ^ (bitsPerSample inject:0 into:[:sum :i | sum + i])
! !
!ImageReader methodsFor:'fileIn / fileOut'!
@@ -106,6 +144,11 @@
!ImageReader methodsFor:'i/o support'!
readLong
+ "return the next 4-byte long, honoring the byte-order"
+
+ ^ inStream nextLongMSB:(byteOrder ~~ #lsb)
+
+"
|bytes val|
bytes := ByteArray new:4.
@@ -122,9 +165,15 @@
val := val * 256 + (bytes at:4)
].
^ val
+"
!
readShort
+ "return the next 2-byte short, honoring the byte-order"
+
+ ^ inStream nextShortMSB:(byteOrder ~~ #lsb)
+
+"
|bytes val|
bytes := ByteArray new:2.
@@ -137,9 +186,13 @@
val := val * 256 + (bytes at:2)
].
^ val
+"
!
readShortLong
+ "return the next 2-byte short, honoring the byte-order.
+ There are actually 4 bytes read, but only 2 looked at."
+
|bytes val|
bytes := ByteArray new:4.
@@ -155,6 +208,11 @@
!
writeLong:anInteger
+ "write a 4-byte long, honoring the byte-order."
+
+ outStream nextLongPut:anInteger MSB:(byteOrder ~~ #lsb)
+
+"
|bytes i|
i := anInteger.
@@ -177,9 +235,15 @@
bytes at:1 put:(i bitAnd:16rFF).
].
outStream nextPutBytes:4 from:bytes
+"
!
writeShort:anInteger
+ "write a 2-byte short, honoring the byte-order."
+
+ outStream nextShortPut:anInteger MSB:(byteOrder ~~ #lsb)
+
+"
|bytes i|
i := anInteger.
@@ -194,6 +258,7 @@
bytes at:1 put:(i bitAnd:16rFF).
].
outStream nextPutBytes:2 from:bytes
+"
! !
!ImageReader class methodsFor:'decompression support'!
--- a/ImageReader.st Wed Oct 13 01:30:35 1993 +0100
+++ b/ImageReader.st Wed Oct 13 01:32:53 1993 +0100
@@ -14,7 +14,7 @@
instanceVariableNames:'width height data byteOrder inStream outStream
photometric samplesPerPixel bitsPerSample
colorMap'
- classVariableNames:''
+ classVariableNames:'ReverseBits'
poolDictionaries:''
category:'Graphics-Support'
!
@@ -39,14 +39,46 @@
^ false
! !
+!ImageReader class methodsFor:'constants'!
+
+reverseBits
+ "return a table filled with bit reverse information.
+ To convert from msbit-first to lsbit-first bytes, use
+ the value as index into the table, retrieving the reverse
+ value. Since indexing must start at 1, use (value + 1) as
+ index."
+
+ |val index|
+
+ ReverseBits isNil ifTrue:[
+ ReverseBits := ByteArray new:256.
+ 0 to:255 do:[:i |
+ val := 0.
+ index := i.
+ (index bitTest:16r01) ifTrue:[val := val bitOr:16r80].
+ (index bitTest:16r02) ifTrue:[val := val bitOr:16r40].
+ (index bitTest:16r04) ifTrue:[val := val bitOr:16r20].
+ (index bitTest:16r08) ifTrue:[val := val bitOr:16r10].
+ (index bitTest:16r10) ifTrue:[val := val bitOr:16r08].
+ (index bitTest:16r20) ifTrue:[val := val bitOr:16r04].
+ (index bitTest:16r40) ifTrue:[val := val bitOr:16r02].
+ (index bitTest:16r80) ifTrue:[val := val bitOr:16r01].
+ ReverseBits at:(index + 1) put:val
+ ]
+ ].
+ ^ ReverseBits
+! !
+
!ImageReader class methodsFor:'fileIn / fileOut'!
fromFile:aFileName
- |reader image|
+ |reader image depth|
reader := self new.
- (reader fromFile:aFileName) notNil ifTrue:[
- image := Image new.
+ reader := reader fromFile:aFileName.
+ reader notNil ifTrue:[
+ depth := reader bitsPerPixel.
+ image := (Image implementorForDepth: depth) new.
image width:(reader width).
image height:(reader height).
image photometric:(reader photometric).
@@ -91,6 +123,12 @@
bitsPerSample
^ bitsPerSample
+!
+
+bitsPerPixel
+ "return the number of bits per pixel"
+
+ ^ (bitsPerSample inject:0 into:[:sum :i | sum + i])
! !
!ImageReader methodsFor:'fileIn / fileOut'!
@@ -106,6 +144,11 @@
!ImageReader methodsFor:'i/o support'!
readLong
+ "return the next 4-byte long, honoring the byte-order"
+
+ ^ inStream nextLongMSB:(byteOrder ~~ #lsb)
+
+"
|bytes val|
bytes := ByteArray new:4.
@@ -122,9 +165,15 @@
val := val * 256 + (bytes at:4)
].
^ val
+"
!
readShort
+ "return the next 2-byte short, honoring the byte-order"
+
+ ^ inStream nextShortMSB:(byteOrder ~~ #lsb)
+
+"
|bytes val|
bytes := ByteArray new:2.
@@ -137,9 +186,13 @@
val := val * 256 + (bytes at:2)
].
^ val
+"
!
readShortLong
+ "return the next 2-byte short, honoring the byte-order.
+ There are actually 4 bytes read, but only 2 looked at."
+
|bytes val|
bytes := ByteArray new:4.
@@ -155,6 +208,11 @@
!
writeLong:anInteger
+ "write a 4-byte long, honoring the byte-order."
+
+ outStream nextLongPut:anInteger MSB:(byteOrder ~~ #lsb)
+
+"
|bytes i|
i := anInteger.
@@ -177,9 +235,15 @@
bytes at:1 put:(i bitAnd:16rFF).
].
outStream nextPutBytes:4 from:bytes
+"
!
writeShort:anInteger
+ "write a 2-byte short, honoring the byte-order."
+
+ outStream nextShortPut:anInteger MSB:(byteOrder ~~ #lsb)
+
+"
|bytes i|
i := anInteger.
@@ -194,6 +258,7 @@
bytes at:1 put:(i bitAnd:16rFF).
].
outStream nextPutBytes:2 from:bytes
+"
! !
!ImageReader class methodsFor:'decompression support'!
--- a/Make.proto Wed Oct 13 01:30:35 1993 +0100
+++ b/Make.proto Wed Oct 13 01:32:53 1993 +0100
@@ -19,7 +19,8 @@
InputMgr.$(O) KeybdMap.$(O) ResourcePack.$(O)
AUXOBJS=InputView.$(O) TIFFRdr.$(O) GIFReader.$(O) XBMReader.$(O) SunReader.$(O) \
- WinIconRdr.$(O) FaceReader.$(O)
+ WinIconRdr.$(O) FaceReader.$(O) Depth1Image.$(O) Depth2Image.$(O) \
+ Depth4Image.$(O) Depth8Image.$(O) Depth24Image.$(O)
all:: $(OBJTARGET)
@@ -84,6 +85,10 @@
-mkdir $(DESTLIBDIR)
-$(INSTALL) $(LIBNAME)$(OBJNAME) $(DESTLIBDIR)
+qinstall::
+ -mkdir $(DESTLIBDIR)
+ -$(INSTALL) $(LIBNAME)$(OBJNAME) $(DESTLIBDIR)
+
cleanjunk::
-rm -f *.c *.H bitmaps/*.bak bitmaps/*~
@@ -115,6 +120,8 @@
PSEUDOVIEW=$(I)/PseudoV.H $(DEVDRAWABLE)
VIEW=$(I)/View.H $(PSEUDOVIEW)
STDSYSVIEW=$(I)/StdSysV.H $(VIEW)
+IMAGE=$(I)/Image.H $(OBJECT)
+IMAGERDR=$(I)/ImageRdr.H $(OBJECT)
DevWorkst.o: DevWorkst.st $(OBJECT)
XWorkstat.o: XWorkstat.st $(OBJECT)
@@ -131,12 +138,14 @@
ResourcePack.o: ResourcePack.st $(I)/Dict.H $(OBJECT)
Image.o: Image.st $(OBJECT)
ImageRdr.o: ImageRdr.st $(OBJECT)
-TIFFRdr.o: TIFFRdr.st $(I)/ImageRdr.H $(OBJECT)
-GIFReader.o: GIFReader.st $(I)/ImageRdr.H $(OBJECT)
-XBMReader.o: XBMReader.st $(I)/ImageRdr.H $(OBJECT)
-SunReader.o: SunReader.st $(I)/ImageRdr.H $(OBJECT)
-FaceReader.o: FaceReader.st $(I)/ImageRdr.H $(OBJECT)
-WinIconRdr.o: WinIconRdr.st $(I)/ImageRdr.H $(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)
Color.o: Color.st $(OBJECT)
XObject.o: XObject.st $(OBJECT)
Workstat.o: Workstat.st $(OBJECT)
@@ -155,3 +164,8 @@
ModalBox.o: ModalBox.st $(STDSYSVIEW)
PopUpView.o: PopUpView.st $(VIEW)
ShadowV.o: ShadowV.st $(VIEW)
+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)
--- a/ModalBox.st Wed Oct 13 01:30:35 1993 +0100
+++ b/ModalBox.st Wed Oct 13 01:32:53 1993 +0100
@@ -22,17 +22,33 @@
COPYRIGHT (c) 1990-93 by Claus Gittinger
All Rights Reserved
-this class implements modal boxes; those that take control until all
-processing is done.
+%W% %E%
+
+written Jan 90 by claus
+'!
+
+!ModalBox class methodsFor:'documentation'!
+
+documentation
+"
+this class implements modal boxes; ModalBoxes are different from
+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
-%W% %E%
+"
+! !
+
+!ModalBox class methodsFor:'initialization'!
-written Jan 90 by claus
-'!
+initialize
+ super initialize.
+ PopShadow := self classResources name:'POPUP_SHADOW' default:false
+! !
!ModalBox class methodsFor:'instance creation'!
@@ -40,27 +56,17 @@
^ super on:ModalDisplay
! !
-!ModalBox class methodsFor:'initialization'!
-
-initialize
- super initialize.
- PopShadow := Resource name:'POPUP_SHADOW'
- default:View3D
- fromFile:'Smalltalk.rs'
-! !
-
!ModalBox methodsFor:'initialize / release'!
initialize
super initialize.
- resources := ResourcePack fromFile:'Boxes.rs'.
-
haveControl := false.
self is3D ifTrue:[
borderWidth := 0.
self level:2
].
+
PopShadow ifTrue:[
shadowView := (ShadowView on:device) for:self
]
@@ -84,7 +90,9 @@
create
super create.
- self saveUnder:true
+ PopShadow ifFalse:[
+ self saveUnder:true
+ ]
!
createOnTop
@@ -147,10 +155,10 @@
hide
"make myself invisible and leave control"
- shadowView notNil ifTrue:[shadowView unrealize].
self unrealize.
device synchronizeOutput.
- self leaveControl
+ shadowView notNil ifTrue:[shadowView unrealize].
+ self leaveControl.
! !
!ModalBox methodsFor:'private'!
--- a/PopUpView.st Wed Oct 13 01:30:35 1993 +0100
+++ b/PopUpView.st Wed Oct 13 01:32:53 1993 +0100
@@ -22,13 +22,6 @@
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-this class implements an abstract superclass for all views which bypass the window manager
-and pop up on top of the screen. These are: PopUpMenus, Alertboxes etc...
-
-class variables:
-
-PopShadow <Boolean> if true, popupviews show a shadow
-
%W% %E%
written spring/summer 89 by claus
@@ -36,6 +29,21 @@
Smalltalk at:#ActiveGrab put:nil!
+!PopUpView class methodsFor:'documentation'!
+
+documentation
+"
+this class implements an abstract superclass for all views which bypass the window manager
+and pop up on top of the screen. They are usually not decorated by
+window managers.
+
+class variables:
+
+PopShadow <Boolean> if true, popupviews show a shadow
+
+"
+! !
+
!PopUpView class methodsFor:'defaults'!
defaultExtent
@@ -46,9 +54,7 @@
initialize
super initialize.
- PopShadow := Resource name:'POPUP_SHADOW'
- default:View3D
- fromFile:'Smalltalk.rs'
+ PopShadow := self classResources name:'POPUP_SHADOW' default:false
! !
!PopUpView methodsFor:'initialization / release'!
@@ -84,7 +90,9 @@
create
super create.
- self saveUnder:true
+ PopShadow ifFalse:[
+ self saveUnder:true
+ ]
! !
!PopUpView methodsFor:'dispatching'!
@@ -139,11 +147,11 @@
!
unrealize
- shadowView notNil ifTrue:[shadowView unrealize].
haveControl := false.
ActiveGrab := nil.
device ungrabPointer.
- super unrealize
+ super unrealize.
+ shadowView notNil ifTrue:[shadowView unrealize].
! !
!PopUpView methodsFor:'accessing'!
--- a/PseudoV.st Wed Oct 13 01:30:35 1993 +0100
+++ b/PseudoV.st Wed Oct 13 01:32:53 1993 +0100
@@ -209,16 +209,20 @@
cursor:aCursor
"set the views cursor"
+ |id|
+
aCursor notNil ifTrue:[
(aCursor ~~ cursor) ifTrue:[
cursor := aCursor.
drawableId notNil ifTrue:[
cursor := cursor on:device.
- cursor id isNil ifTrue:[
+ id := cursor id.
+ id isNil ifTrue:[
'nil cursorId shape=' print. cursor shape printNewline.
^ self
].
- device setCursor:(cursor id) in:drawableId.
+ device setCursor:id in:drawableId.
+ "flush, to make cursor immediately visible"
device synchronizeOutput
]
]
@@ -380,11 +384,13 @@
backingStore:how
"turn on/off backingStore (saving my pixels)
- how may also be #always, #whenMapped or #never."
+ how may true/false, but also #always, #whenMapped or #never."
- backed := how.
- drawableId notNil ifTrue:[
- device setBackingStore:how in:drawableId
+ how ~~ backed ifTrue:[
+ backed := how.
+ drawableId notNil ifTrue:[
+ device setBackingStore:how in:drawableId
+ ]
]
! !
@@ -431,15 +437,19 @@
!PseudoView methodsFor:'keyboard commands'!
-addKeyboardCommand:aKey forAction:aBlock
+addActionForKey:aKey action:aBlock
+ "define a keyboard command function"
+
keyCommands isNil ifTrue:[
- keyCommands := Dictionary new
+ keyCommands := IdentityDictionary new
].
keyCommands at:aKey put:aBlock
!
-removeKeyboardCommand:aKey
- ^ self
+removeActionForKey:aKey
+ keyCommands notNil ifTrue:[
+ keyCommands removeKey:aKey ifAbsent:[]
+ ]
! !
!PseudoView methodsFor:'button menus'!
@@ -458,6 +468,14 @@
].
middleButtonMenu := aMenu.
self enableButtonEvents
+!
+
+setMiddleButtonMenu:aMenu
+ "associate aMenu with the middle mouse button.
+ Do not destroy old menu if any"
+
+ middleButtonMenu := aMenu.
+ self enableButtonEvents
! !
!PseudoView methodsFor:'enable/disable events'!
@@ -465,10 +483,10 @@
enableEvent:anEventSymbol
"enable an event -
this is a private (internal) method not to be used externally.
- for a list of allowed event symvols see Workstation class"
+ for a list of allowed event symbols see Workstation class"
eventMask := eventMask bitOr:(device eventMaskFor:anEventSymbol).
- drawableId isNil ifFalse:[
+ drawableId notNil ifTrue:[
device setEventMask:eventMask in:drawableId
]
!
@@ -476,11 +494,11 @@
disableEvent:anEventSymbol
"disable an event -
this is a private (internal) method not to be used externally.
- for a list of allowed event symvols see Workstation class"
+ for a list of allowed event symbols see Workstation class"
eventMask := eventMask bitAnd:
(device eventMaskFor:anEventSymbol) bitInvert.
- drawableId isNil ifFalse:[
+ drawableId notNil ifTrue:[
device setEventMask:eventMask in:drawableId
]
!
@@ -549,7 +567,7 @@
!
enableButtonMotionEvents
- "enable mouse-pointer motion while button-is-pressed events"
+ "enable mouse-pointer motion-while-button-is-pressed events"
self enableEvent:#buttonMotion
!
@@ -586,7 +604,7 @@
!
disableButtonMotionEvents
- "disable button motion while button-is-pressed events"
+ "disable button motion-while-button-is-pressed events"
self disableEvent:#buttonMotion
! !
@@ -594,19 +612,19 @@
!PseudoView methodsFor:'queries'!
exposeEventPending
- "return true, if button motion event is pending"
+ "return true, if a button motion event is pending"
^ device eventPending:#expose for:drawableId
!
buttonMotionEventPending
- "return true, if button motion event is pending"
+ "return true, if a button motion event is pending"
^ device eventPending:#buttonMotion for:drawableId
!
buttonReleaseEventPending
- "return true, if button release event is pending"
+ "return true, if a button release event is pending"
^ device eventPending:#buttonRelease for:drawableId
! !
@@ -650,11 +668,9 @@
|action|
keyCommands notNil ifTrue:[
- device controlState ifTrue:[
- action := keyCommands at:key ifAbsent:[nil].
- action notNil ifTrue:[
- action value
- ]
+ action := keyCommands at:key ifAbsent:[nil].
+ action notNil ifTrue:[
+ action value
]
]
!
@@ -725,3 +741,18 @@
^ self
! !
+
+!PseudoView methodsFor: 'binary storage'!
+
+readBinaryContentsFrom: stream manager: manager
+ "tell the newly restored View to recreate itself"
+
+ super readBinaryContentsFrom: stream manager: manager.
+
+ gcId := nil.
+ drawableId := nil.
+ self recreate.
+ realized ifTrue:[
+ self rerealize
+ ]
+! !
--- a/ResourcePack.st Wed Oct 13 01:30:35 1993 +0100
+++ b/ResourcePack.st Wed Oct 13 01:32:53 1993 +0100
@@ -37,9 +37,10 @@
]
].
+ newPack := self new.
inStream := Smalltalk systemFileStreamFor:('resources/' , aFileName).
- inStream isNil ifTrue:[^ self new].
- newPack := self new readFromResourceStream:inStream.
+ inStream isNil ifTrue:[newPack fileName:aFileName. ^ newPack].
+ newPack readFromResourceStream:inStream.
newPack fileName:aFileName.
inStream close.
@@ -85,8 +86,8 @@
dependents := aCollection
!
-at:aKey
- ^ self at:aKey ifAbsent:[aKey]
+dependents
+ ^ dependents
!
fileName
@@ -97,14 +98,22 @@
fileName := aString
!
-dependents
- ^ dependents
+at:aKey
+ ^ self at:aKey ifAbsent:[aKey]
!
at:aKey default:default
^ self at:aKey ifAbsent:[default]
!
+name:aKey
+ ^ self at:aKey ifAbsent:[aKey]
+!
+
+name:aKey default:default
+ ^ self at:aKey ifAbsent:[default]
+!
+
array:anArray
^ anArray collect:[:r | self at:r default:r]
!
@@ -134,6 +143,7 @@
^ 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 , '%'
@@ -141,7 +151,8 @@
expandedString := expandedString , (argArray at:(next digitValue)) printString
].
start := idx + 2
- ]
+ ].
+ ^ expandedString
! !
!ResourcePack methodsFor:'file reading'!
--- a/RsrcPack.st Wed Oct 13 01:30:35 1993 +0100
+++ b/RsrcPack.st Wed Oct 13 01:32:53 1993 +0100
@@ -37,9 +37,10 @@
]
].
+ newPack := self new.
inStream := Smalltalk systemFileStreamFor:('resources/' , aFileName).
- inStream isNil ifTrue:[^ self new].
- newPack := self new readFromResourceStream:inStream.
+ inStream isNil ifTrue:[newPack fileName:aFileName. ^ newPack].
+ newPack readFromResourceStream:inStream.
newPack fileName:aFileName.
inStream close.
@@ -85,8 +86,8 @@
dependents := aCollection
!
-at:aKey
- ^ self at:aKey ifAbsent:[aKey]
+dependents
+ ^ dependents
!
fileName
@@ -97,14 +98,22 @@
fileName := aString
!
-dependents
- ^ dependents
+at:aKey
+ ^ self at:aKey ifAbsent:[aKey]
!
at:aKey default:default
^ self at:aKey ifAbsent:[default]
!
+name:aKey
+ ^ self at:aKey ifAbsent:[aKey]
+!
+
+name:aKey default:default
+ ^ self at:aKey ifAbsent:[default]
+!
+
array:anArray
^ anArray collect:[:r | self at:r default:r]
!
@@ -134,6 +143,7 @@
^ 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 , '%'
@@ -141,7 +151,8 @@
expandedString := expandedString , (argArray at:(next digitValue)) printString
].
start := idx + 2
- ]
+ ].
+ ^ expandedString
! !
!ResourcePack methodsFor:'file reading'!
--- a/ShadowV.st Wed Oct 13 01:30:35 1993 +0100
+++ b/ShadowV.st Wed Oct 13 01:32:53 1993 +0100
@@ -44,7 +44,7 @@
realize
"realize the shadowView some distance away from myView"
- |root shW shH right bot|
+ |root shW shH right bot kludge|
myView notNil ifTrue:[
self origin:(myView origin + (myView borderWidth * 2) + shadowLength) extent:(myView extent).
@@ -55,10 +55,17 @@
shW := shadowLength x.
shH := shadowLength y.
- right := width - shW.
- bot := height - shH.
+ right := width - shW.
+ bot := height - shH.
root := DisplayRootView new.
+
+ kludge := root device depth == 1.
+ (kludge and:[root device blackpixel == 0]) ifTrue:[
+ imageUnderShadow foreground:(Color colorId:0)
+ background:(Color colorId:1).
+ ].
+
imageUnderShadow copyFrom:root x:(self origin x + right) y:(self origin y)
toX:right y:0 width:shW height:height.
@@ -67,14 +74,23 @@
"grey out image in area"
- 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.
+ (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 foreground:(Color black on:device) background:(Color colorId:0).
- imageUnderShadow function:#or.
- imageUnderShadow fillRectangleX:0 y:0 width:width height:height.
+ (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.
+ ]
+ ] 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.
+ ].
super realize.
self raise
@@ -91,7 +107,11 @@
create
super create.
self backingStore:false.
- self saveUnder:true
+
+ "X11/NeWS server is broken here ..."
+ (device serverVendor startsWith:'X11/NeWS') ifFalse:[
+ self saveUnder:true
+ ]
! !
!ShadowView methodsFor:'events'!
@@ -99,6 +119,8 @@
redraw
"fill all of myself with black"
+ imageUnderShadow isNil ifTrue:[^ self].
+
"
self foreground:(Color colorId:-1) background:(Color colorId:0).
self function:#copy.
--- a/ShadowView.st Wed Oct 13 01:30:35 1993 +0100
+++ b/ShadowView.st Wed Oct 13 01:32:53 1993 +0100
@@ -44,7 +44,7 @@
realize
"realize the shadowView some distance away from myView"
- |root shW shH right bot|
+ |root shW shH right bot kludge|
myView notNil ifTrue:[
self origin:(myView origin + (myView borderWidth * 2) + shadowLength) extent:(myView extent).
@@ -55,10 +55,17 @@
shW := shadowLength x.
shH := shadowLength y.
- right := width - shW.
- bot := height - shH.
+ right := width - shW.
+ bot := height - shH.
root := DisplayRootView new.
+
+ kludge := root device depth == 1.
+ (kludge and:[root device blackpixel == 0]) ifTrue:[
+ imageUnderShadow foreground:(Color colorId:0)
+ background:(Color colorId:1).
+ ].
+
imageUnderShadow copyFrom:root x:(self origin x + right) y:(self origin y)
toX:right y:0 width:shW height:height.
@@ -67,14 +74,23 @@
"grey out image in area"
- 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.
+ (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 foreground:(Color black on:device) background:(Color colorId:0).
- imageUnderShadow function:#or.
- imageUnderShadow fillRectangleX:0 y:0 width:width height:height.
+ (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.
+ ]
+ ] 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.
+ ].
super realize.
self raise
@@ -91,7 +107,11 @@
create
super create.
self backingStore:false.
- self saveUnder:true
+
+ "X11/NeWS server is broken here ..."
+ (device serverVendor startsWith:'X11/NeWS') ifFalse:[
+ self saveUnder:true
+ ]
! !
!ShadowView methodsFor:'events'!
@@ -99,6 +119,8 @@
redraw
"fill all of myself with black"
+ imageUnderShadow isNil ifTrue:[^ self].
+
"
self foreground:(Color colorId:-1) background:(Color colorId:0).
self function:#copy.
--- a/StandardSystemView.st Wed Oct 13 01:30:35 1993 +0100
+++ b/StandardSystemView.st Wed Oct 13 01:32:53 1993 +0100
@@ -204,7 +204,11 @@
icon := icon on:device
].
].
- super create
+ super create.
+ iconView notNil ifTrue:[
+ iconView create.
+ device setWindowIconWindow:iconView in:drawableId
+ ]
!
openWithExtent:anExtent
@@ -279,6 +283,7 @@
iconView := aView.
drawableId notNil ifTrue:[
+ aView create.
device setWindowIconWindow:aView in:drawableId
]
!
--- a/StdSysV.st Wed Oct 13 01:30:35 1993 +0100
+++ b/StdSysV.st Wed Oct 13 01:32:53 1993 +0100
@@ -204,7 +204,11 @@
icon := icon on:device
].
].
- super create
+ super create.
+ iconView notNil ifTrue:[
+ iconView create.
+ device setWindowIconWindow:iconView in:drawableId
+ ]
!
openWithExtent:anExtent
@@ -279,6 +283,7 @@
iconView := aView.
drawableId notNil ifTrue:[
+ aView create.
device setWindowIconWindow:aView in:drawableId
]
!
--- a/View.st Wed Oct 13 01:30:35 1993 +0100
+++ b/View.st Wed Oct 13 01:32:53 1993 +0100
@@ -30,20 +30,34 @@
keyboardHandler model controller
aspectSymbol changeSymbol menuSymbol'
classVariableNames: 'Grey ZeroPoint CentPoint
- ViewSpacing DefaultStyle
- Resources'
+ ViewSpacing DefaultStyle'
poolDictionaries: ''
category:'Views-Basic'
!
+View class instanceVariableNames:'ClassResources'!
+
View comment:'
COPYRIGHT (c) 1989-93 by Claus Gittinger
All Rights Reserved
-this class implements functions common to all Views. Instances of View are seldom
-used, most views in the system inherit from this class. However, sometimes a view
-is used to create a dummy view for framing purposes.
+%W% %E%
+
+written spring/summer 89 by claus
+3D effects summer 90 by claus
+MVC, viewport and window stuff summer 92 by claus (for ST-80 compatibility)
+'!
+
+"this flag controls (globally) how views look"
+
+Smalltalk at:#View3D put:false!
+
+!View class methodsFor:'documentation'!
+"
+this class implements functions common to all Views.
+Instances of View are seldom used, most views in the system inherit from this class.
+However, sometimes a view is used to create a dummy view for framing purposes.
Instance variables:
@@ -88,17 +102,8 @@
spacing between views)
ZeroPoint <Point> 0 @ 0 - its used so often
CentPoint <Point> 100 @ 100 - its used so often
-
-%W% %E%
-
-written spring/summer 89 by claus
-3D effects summer 90 by claus
-MVC, viewport and window stuff summer 92 by claus (for ST-80 compatibility)
-'!
-
-"this flag controls (globally) how views look"
-
-Smalltalk at:#View3D put:false!
+"
+! !
!View class methodsFor:'initialization'!
@@ -106,21 +111,8 @@
"Workstation initialize."
super initialize.
-
- Resources := ResourcePack for:self.
-
Form initialize.
Color initialize.
-
- Grey := Resource name:'VIEW_GREY'
- default:nil
- fromFile:'Smalltalk.rs'.
- Grey isNil ifTrue:[
- Grey := Color grey
- ].
- DefaultStyle := Resource name:'VIEW_STYLE'
- default:(View3D ifTrue:[#view3D] ifFalse:[#normal])
- fromFile:'Smalltalk.rs'
! !
!View class methodsFor:'defaults'!
@@ -142,6 +134,13 @@
DefaultStyle := aStyle
"View defaultStyle:#next"
+!
+
+classResources
+ ClassResources isNil ifTrue:[
+ ClassResources := ResourcePack for:self.
+ ].
+ ^ ClassResources
! !
!View class methodsFor:'instance creation'!
@@ -352,6 +351,8 @@
margin := 0.
softEdge := false.
+ resources := self class classResources.
+
self initStyle.
left := 0.
@@ -381,6 +382,18 @@
!
initStyle
+ Grey isNil ifTrue:[
+ Grey := resources name:'VIEW_GREY' default:nil.
+ Grey isNil ifTrue:[
+ Grey := Color grey
+ ].
+ ].
+ DefaultStyle isNil ifTrue:[
+ DefaultStyle := resources name:'VIEW_STYLE'
+ default:(View3D ifTrue:[#view3D]
+ ifFalse:[#normal])
+ ].
+
style := DefaultStyle.
self is3D ifTrue:[
@@ -484,7 +497,7 @@
viewShape notNil ifTrue:[
device setWindowShape:(viewShape id) in:drawableId
].
- backed notNil ifTrue:[
+ (backed notNil and:[backed ~~ false]) ifTrue:[
device setBackingStore:backed in:drawableId
].
saveUnder ifTrue:[
@@ -1533,6 +1546,13 @@
self scrollVerticalTo:0
!
+scrollToTopLeft
+ "move viewOrigin to top/left"
+
+ self scrollVerticalTo:0.
+ self scrollHorizontalTo:0
+!
+
scrollUp:nPixels
"change origin to scroll up some pixels"
@@ -1992,13 +2012,13 @@
bw2 := borderWidth * 2.
rel := relativeOrigin x.
(rel isMemberOf:Float) ifTrue:[
- newX := (rel * (inRect width + bw2)) asInteger + inRect left
+ newX := (rel * (inRect width + borderWidth "bw2")) asInteger + inRect left
] ifFalse:[
newX := rel
].
rel := relativeOrigin y.
(rel isMemberOf:Float) ifTrue:[
- newY := (rel * (inRect height + bw2)) asInteger + inRect top
+ newY := (rel * (inRect height + borderWidth "bw2")) asInteger + inRect top
] ifFalse:[
newY := rel
].
@@ -2189,7 +2209,7 @@
viewShape notNil ifTrue:[
device setWindowShape:(viewShape id) in:drawableId
].
- backed notNil ifTrue:[
+ (backed notNil and:[backed ~~ false]) ifTrue:[
device setBackingStore:backed in:drawableId
].
saveUnder ifTrue:[
@@ -2197,11 +2217,11 @@
].
font := font on:device.
-"
+" "
self inputOnly ifFalse:[
self initGC
].
-"
+" "
self initializeMiddleButtonMenu.
self initEvents.
controller notNil ifTrue:[
--- a/WTrans.st Wed Oct 13 01:30:35 1993 +0100
+++ b/WTrans.st Wed Oct 13 01:32:53 1993 +0100
@@ -84,9 +84,9 @@
|transformedObject|
- transformedObject := anObject translateBy:(self inverseTranslation).
+ transformedObject := anObject translatedBy:(self inverseTranslation).
scale == nil ifFalse:[
- transformedObject := transformedObject scaleBy:(self inverseScale)
+ transformedObject scaleBy:(self inverseScale)
].
^ transformedObject
!
@@ -97,11 +97,10 @@
|transformedObject|
scale == nil ifTrue:[
- transformedObject := anObject
- ] ifFalse:[
- transformedObject := anObject scaleBy:scale
+ ^ anObject translateBy:translation.
].
- transformedObject := transformedObject translateBy:translation.
+ transformedObject := anObject scaledBy:scale
+ transformedObject translateBy:translation.
^ transformedObject
!
@@ -138,7 +137,7 @@
!WindowingTransformation methodsFor: 'transforming'!
-scaleBy:aScale
+scaledBy:aScale
"return a new WindowingTransformation with the scale and translation of
the receiver both scaled by aScale."
@@ -160,7 +159,7 @@
translation:newTranslation
!
-translateBy:aPoint
+translatedBy:aPoint
"return a new WindowingTransformation with the same scale and
rotations as the receiver and with a translation of the current
translation plus aPoint."
@@ -223,16 +222,14 @@
"returns a windowing transformation with no scaling (nil)
and no translation (0@0)."
- ^ self new setScale:nil
- translation:(Point x:0.0 y:0.0)
+ ^ self new setScale:nil translation:(Point x:0.0 y:0.0)
!
scale:aScale translation:aTranslation
"returns a windowing transformation with a scale factor of
aScale and a translation offset of aTranslation."
- ^ self new setScale:aScale
- translation:aTranslation
+ ^ self new setScale:aScale translation:aTranslation
!
window:sourceRectangle viewport:destinationRectangle
@@ -251,6 +248,5 @@
] ifFalse:[
newScale := Point x:sX y:sY
].
- ^ self new setScale:newScale
- translation:(Point x:tX y:tY)
+ ^ self new setScale:newScale translation:(Point x:tX y:tY)
! !
--- a/WindowingTransformation.st Wed Oct 13 01:30:35 1993 +0100
+++ b/WindowingTransformation.st Wed Oct 13 01:32:53 1993 +0100
@@ -84,9 +84,9 @@
|transformedObject|
- transformedObject := anObject translateBy:(self inverseTranslation).
+ transformedObject := anObject translatedBy:(self inverseTranslation).
scale == nil ifFalse:[
- transformedObject := transformedObject scaleBy:(self inverseScale)
+ transformedObject scaleBy:(self inverseScale)
].
^ transformedObject
!
@@ -97,11 +97,10 @@
|transformedObject|
scale == nil ifTrue:[
- transformedObject := anObject
- ] ifFalse:[
- transformedObject := anObject scaleBy:scale
+ ^ anObject translateBy:translation.
].
- transformedObject := transformedObject translateBy:translation.
+ transformedObject := anObject scaledBy:scale
+ transformedObject translateBy:translation.
^ transformedObject
!
@@ -138,7 +137,7 @@
!WindowingTransformation methodsFor: 'transforming'!
-scaleBy:aScale
+scaledBy:aScale
"return a new WindowingTransformation with the scale and translation of
the receiver both scaled by aScale."
@@ -160,7 +159,7 @@
translation:newTranslation
!
-translateBy:aPoint
+translatedBy:aPoint
"return a new WindowingTransformation with the same scale and
rotations as the receiver and with a translation of the current
translation plus aPoint."
@@ -223,16 +222,14 @@
"returns a windowing transformation with no scaling (nil)
and no translation (0@0)."
- ^ self new setScale:nil
- translation:(Point x:0.0 y:0.0)
+ ^ self new setScale:nil translation:(Point x:0.0 y:0.0)
!
scale:aScale translation:aTranslation
"returns a windowing transformation with a scale factor of
aScale and a translation offset of aTranslation."
- ^ self new setScale:aScale
- translation:aTranslation
+ ^ self new setScale:aScale translation:aTranslation
!
window:sourceRectangle viewport:destinationRectangle
@@ -251,6 +248,5 @@
] ifFalse:[
newScale := Point x:sX y:sY
].
- ^ self new setScale:newScale
- translation:(Point x:tX y:tY)
+ ^ self new setScale:newScale translation:(Point x:tX y:tY)
! !
--- a/XWorkstat.st Wed Oct 13 01:30:35 1993 +0100
+++ b/XWorkstat.st Wed Oct 13 01:32:53 1993 +0100
@@ -88,7 +88,6 @@
# endif
#endif
-static char lastErrorMsg[80] = "";
extern int _immediateInterrupt;
#ifdef THIS_CONTEXT
@@ -100,6 +99,11 @@
/*
* a private error handler
*/
+static char lastErrorMsg[80] = "";
+static unsigned lastRequestCode = 0;
+static unsigned lastMinorCode = 0;
+static unsigned lastResource = 0;
+
static
ErrorHandler(dpy, event)
Display *dpy;
@@ -109,6 +113,10 @@
if (lastErrorMsg[0] == '\0') {
sprintf(lastErrorMsg, "code: %d", event->error_code);
}
+ lastRequestCode = event->request_code;
+ lastMinorCode = event->minor_code;
+ lastResource = event->resourceid;
+
printf("x-error (%s) cought maj=%x min=%x resource=%x\n",
lastErrorMsg, event->request_code, event->minor_code,
event->resourceid);
@@ -170,6 +178,39 @@
%}
! !
+!XWorkstation class methodsFor:'error handling'!
+
+requestCodeOfLastError
+%{ /* NOCONTEXT */
+
+ RETURN ( _MKSMALLINT(lastRequestCode) );
+%}
+!
+
+minorCodeOfLastError
+%{ /* NOCONTEXT */
+
+ RETURN ( _MKSMALLINT(lastMinorCode) );
+%}
+!
+
+resourceIdOfLastError
+%{ /* NOCONTEXT */
+
+ RETURN ( _MKSMALLINT(lastResource) );
+%}
+!
+
+lastError
+ "return the last X-error string -
+ when buffering is on, this may be
+ an error for a long-ago operation"
+%{
+
+ RETURN ( _MKSTRING(lastErrorMsg, __context) );
+%}
+! !
+
!XWorkstation methodsFor:'initialize / release'!
initializeFor:aDisplayName
@@ -316,7 +357,9 @@
DeleteWindowAtom := nil.
SaveYourselfAtom := nil.
QuitAppAtom := nil.
- self initializeKeyboardMap
+ self initializeKeyboardMap.
+
+ ObjectMemory errorInterruptHandler:self class.
!
close
@@ -391,13 +434,25 @@
self primitiveFailed
!
-lastError
- "return the last X-error string - when buffering is on, this may be
- an error for a long-ago operation"
+beep:volumeInPercent
+ "output an audible beep"
%{
-
- RETURN ( _MKSTRING(lastErrorMsg, __context) );
+ int volume;
+
+ if (_isSmallInteger(volume)) {
+ /* stupid: X wants -100 .. 100 and calls this percent */
+ volume = _intVal(volumeInPercent) * 2 - 100;
+ if (volume < -100) volume = -100;
+ else if (volume > 100) volume = 100;
+ XBell(myDpy, volume);
+ }
%}
+!
+
+beep
+ "output an audible beep or bell"
+
+ self beep:50
! !
!XWorkstation methodsFor:'accessing & queries'!
@@ -1387,11 +1442,11 @@
aName notNil ifTrue:[
self decomposeXFontName:aName into:
[:family :face :style :size :coding |
- arr := Array with:family
- with:face
- with:style
+ arr := Array with:family asSymbol
+ with:face asSymbol
+ with:style asSymbol
with:size
- with:coding.
+ with:coding asSymbol.
listOfXFonts add:arr
]
]
@@ -1451,7 +1506,7 @@
'-' , faceString ,
'-' , xlatedStyle , '-*-*-'
, theSize printString , '0-*-*-*-*-'
- , encodingSym , '-*').
+ , encodingSym , '-1').
theId := self createFontFor:theName.
theId isNil ifTrue:[
@@ -1472,7 +1527,9 @@
!
createFontFor:aFontName
- "a basic method for X-font allocation"
+ "a basic method for X-font allocation; this method allows
+ any font to be aquired (even thhose not conforming to
+ standard naming conventions, such as cursor or fixed)"
%{ /* NOCONTEXT */
@@ -2132,15 +2189,15 @@
/* scale to 0..100 and round to the first decimal */
- /*
- * have to compensate for an error in X ?, which does not scale
+ /*
+ * have to compensate for an error in X ?, which does not scale
* colors correctly if lesser than 16bits are valid in a color,
* (for example, color white on a 4bitsPerRGB server will return
- * (16rF000 16rF000 16rF000) instead of (16rFFFF 16rFFFF 16rFFFF)
- */
- bits = _intVal(_INST(bitsPerRGB));
- scale = (1<<bits) - 1;
- shift = 16 - bits;
+ * (16rF000 16rF000 16rF000) instead of (16rFFFF 16rFFFF 16rFFFF)
+ */
+ bits = _intVal(_INST(bitsPerRGB));
+ scale = (1<<bits) - 1;
+ shift = 16 - bits;
fr = floor( ( ((double)(color.red>>shift) * 1000.0) / scale) + 0.5) / 10.0;
fg = floor( ( ((double)(color.green>>shift) * 1000.0) / scale) + 0.5) / 10.0;
--- a/XWorkstation.st Wed Oct 13 01:30:35 1993 +0100
+++ b/XWorkstation.st Wed Oct 13 01:32:53 1993 +0100
@@ -88,7 +88,6 @@
# endif
#endif
-static char lastErrorMsg[80] = "";
extern int _immediateInterrupt;
#ifdef THIS_CONTEXT
@@ -100,6 +99,11 @@
/*
* a private error handler
*/
+static char lastErrorMsg[80] = "";
+static unsigned lastRequestCode = 0;
+static unsigned lastMinorCode = 0;
+static unsigned lastResource = 0;
+
static
ErrorHandler(dpy, event)
Display *dpy;
@@ -109,6 +113,10 @@
if (lastErrorMsg[0] == '\0') {
sprintf(lastErrorMsg, "code: %d", event->error_code);
}
+ lastRequestCode = event->request_code;
+ lastMinorCode = event->minor_code;
+ lastResource = event->resourceid;
+
printf("x-error (%s) cought maj=%x min=%x resource=%x\n",
lastErrorMsg, event->request_code, event->minor_code,
event->resourceid);
@@ -170,6 +178,39 @@
%}
! !
+!XWorkstation class methodsFor:'error handling'!
+
+requestCodeOfLastError
+%{ /* NOCONTEXT */
+
+ RETURN ( _MKSMALLINT(lastRequestCode) );
+%}
+!
+
+minorCodeOfLastError
+%{ /* NOCONTEXT */
+
+ RETURN ( _MKSMALLINT(lastMinorCode) );
+%}
+!
+
+resourceIdOfLastError
+%{ /* NOCONTEXT */
+
+ RETURN ( _MKSMALLINT(lastResource) );
+%}
+!
+
+lastError
+ "return the last X-error string -
+ when buffering is on, this may be
+ an error for a long-ago operation"
+%{
+
+ RETURN ( _MKSTRING(lastErrorMsg, __context) );
+%}
+! !
+
!XWorkstation methodsFor:'initialize / release'!
initializeFor:aDisplayName
@@ -316,7 +357,9 @@
DeleteWindowAtom := nil.
SaveYourselfAtom := nil.
QuitAppAtom := nil.
- self initializeKeyboardMap
+ self initializeKeyboardMap.
+
+ ObjectMemory errorInterruptHandler:self class.
!
close
@@ -391,13 +434,25 @@
self primitiveFailed
!
-lastError
- "return the last X-error string - when buffering is on, this may be
- an error for a long-ago operation"
+beep:volumeInPercent
+ "output an audible beep"
%{
-
- RETURN ( _MKSTRING(lastErrorMsg, __context) );
+ int volume;
+
+ if (_isSmallInteger(volume)) {
+ /* stupid: X wants -100 .. 100 and calls this percent */
+ volume = _intVal(volumeInPercent) * 2 - 100;
+ if (volume < -100) volume = -100;
+ else if (volume > 100) volume = 100;
+ XBell(myDpy, volume);
+ }
%}
+!
+
+beep
+ "output an audible beep or bell"
+
+ self beep:50
! !
!XWorkstation methodsFor:'accessing & queries'!
@@ -1387,11 +1442,11 @@
aName notNil ifTrue:[
self decomposeXFontName:aName into:
[:family :face :style :size :coding |
- arr := Array with:family
- with:face
- with:style
+ arr := Array with:family asSymbol
+ with:face asSymbol
+ with:style asSymbol
with:size
- with:coding.
+ with:coding asSymbol.
listOfXFonts add:arr
]
]
@@ -1451,7 +1506,7 @@
'-' , faceString ,
'-' , xlatedStyle , '-*-*-'
, theSize printString , '0-*-*-*-*-'
- , encodingSym , '-*').
+ , encodingSym , '-1').
theId := self createFontFor:theName.
theId isNil ifTrue:[
@@ -1472,7 +1527,9 @@
!
createFontFor:aFontName
- "a basic method for X-font allocation"
+ "a basic method for X-font allocation; this method allows
+ any font to be aquired (even thhose not conforming to
+ standard naming conventions, such as cursor or fixed)"
%{ /* NOCONTEXT */
@@ -2132,15 +2189,15 @@
/* scale to 0..100 and round to the first decimal */
- /*
- * have to compensate for an error in X ?, which does not scale
+ /*
+ * have to compensate for an error in X ?, which does not scale
* colors correctly if lesser than 16bits are valid in a color,
* (for example, color white on a 4bitsPerRGB server will return
- * (16rF000 16rF000 16rF000) instead of (16rFFFF 16rFFFF 16rFFFF)
- */
- bits = _intVal(_INST(bitsPerRGB));
- scale = (1<<bits) - 1;
- shift = 16 - bits;
+ * (16rF000 16rF000 16rF000) instead of (16rFFFF 16rFFFF 16rFFFF)
+ */
+ bits = _intVal(_INST(bitsPerRGB));
+ scale = (1<<bits) - 1;
+ shift = 16 - bits;
fr = floor( ( ((double)(color.red>>shift) * 1000.0) / scale) + 0.5) / 10.0;
fg = floor( ( ((double)(color.green>>shift) * 1000.0) / scale) + 0.5) / 10.0;