"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
DeviceDrawable subclass:#Form
instanceVariableNames:'depth localColorMap offset data fileName'
classVariableNames:'VeryLightGreyForm LightGreyForm GreyForm
DarkGreyForm VeryDarkGreyForm
AdditionalBitmapDirectoryNames
BlackAndWhiteColorMap DitherPatternArray
Lobby'
poolDictionaries:''
category:'Graphics-Display Objects'
!
Form comment:'
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
$Header: /cvs/stx/stx/libview/Form.st,v 1.11 1994-08-11 23:41:38 claus Exp $
'!
!Form class methodsFor:'documentation'!
copyright
"
COPYRIGHT (c) 1989 by Claus Gittinger
All Rights Reserved
This software is furnished under a license and may be used
only in accordance with the terms of that license and with the
inclusion of the above copyright notice. This software may not
be provided or otherwise made available to, or used by, any
other person. No title to or ownership of the software is
hereby transferred.
"
!
version
"
$Header: /cvs/stx/stx/libview/Form.st,v 1.11 1994-08-11 23:41:38 claus Exp $
"
!
documentation
"
Instances of this class represent forms (i.e. bit- and pixmaps)
which can be created on the drawing device. In X, these are XPixmaps.
Not all devices will support forms.
"
! !
!Form class methodsFor:'initialization'!
initialize
"initialize set of dictionaries to look for bitmaps
and Lobby to keep track of dead forms"
AdditionalBitmapDirectoryNames isNil ifTrue:[
super initialize.
AdditionalBitmapDirectoryNames := #('/usr/lib/X11/bitmaps').
Lobby := Registry new.
"want to be informed when returning from snapshot"
ObjectMemory addDependent:self.
]
!
reinitializeAllOn:aDevice
"recreate all forms on aDevice; called by Workstation, to
have all background bitmaps at hand, when views are restored"
Lobby contentsDo:[:aForm |
(aForm device == aDevice) ifTrue:[
"now, try to recreate it"
aForm recreate.
Lobby changed:aForm
]
]
!
update:something
"sent just before snapOut and just after a snapIn"
(something == #save) ifTrue:[
"get all bits from the device into saveable arrays"
Lobby contentsDo:[:aForm |
aForm getBits
]
].
(something == #restarted) ifTrue:[
"remove all left-over device info"
Lobby contentsDo:[:aForm |
aForm restored.
Lobby changed:self
]
]
! !
!Form class methodsFor:'cleanup'!
lowSpaceCleanup
"cleanup in low-memory situations"
DitherPatternArray := nil
! !
!Form methodsFor:'instance release'!
disposed
"some Form has been collected - tell it to the x-server"
drawableId notNil ifTrue:[
device destroyPixmap:drawableId.
gcId notNil ifTrue:[
device destroyGC:gcId
]
]
! !
!Form class methodsFor:'file search'!
findBitmapFile:fileName
"find the bitmap file in one of the standard places;
return the pathName or nil"
|aStream path|
((fileName at:1) == $/) ifTrue:[^ fileName].
(fileName startsWith:'../') ifTrue:[^ fileName].
(fileName startsWith:'./') ifTrue:[^ fileName].
aStream := Smalltalk systemFileStreamFor:('bitmaps/' , fileName).
aStream notNil ifTrue:[
path := aStream pathName.
aStream close.
^ path
].
AdditionalBitmapDirectoryNames notNil ifTrue:[
AdditionalBitmapDirectoryNames do:[:aPath |
path := aPath , '/' , fileName.
(OperatingSystem isReadable:path) ifTrue:[
^ path
]
]
].
^ nil
! !
!Form class methodsFor:'private instance creation'!
grey:percent on:aDevice
"return a form for dithering"
(percent < 20) ifTrue:[^ Color black on:aDevice].
(percent < 40) ifTrue:[^ self darkGreyFormOn:aDevice].
(percent < 60) ifTrue:[^ self mediumGreyFormOn:aDevice].
(percent < 80) ifTrue:[^ self lightGreyFormOn:aDevice].
^ Color white on:aDevice
!
mediumGreyFormOn:aDevice
"return a grey form"
|f|
((aDevice == Display) and:[GreyForm notNil]) ifTrue:[
^ GreyForm
].
f := self width:8 height:4 fromArray:(self greyFormBits) on:aDevice.
(aDevice == Display) ifTrue:[
GreyForm := f
].
^ f
!
veryLightGreyFormOn:aDevice
"return a veryLightGrey form"
|f|
((aDevice == Display) and:[VeryLightGreyForm notNil]) ifTrue:[
^ VeryLightGreyForm
].
f := self width:8 height:4 fromArray:(self veryLightGreyFormBits) on:aDevice.
(aDevice == Display) ifTrue:[
VeryLightGreyForm := f
].
^ f
!
lightGreyFormOn:aDevice
"return a lightGrey form"
|f|
((aDevice == Display) and:[LightGreyForm notNil]) ifTrue:[
^ LightGreyForm
].
f := self width:8 height:4 fromArray:(self lightGreyFormBits) on:aDevice.
(aDevice == Display) ifTrue:[
LightGreyForm := f
].
^ f
!
darkGreyFormOn:aDevice
"return a darkGrey form"
|f|
((aDevice == Display) and:[DarkGreyForm notNil]) ifTrue:[
^ DarkGreyForm
].
f := self width:8 height:4 fromArray:(self darkGreyFormBits) on:aDevice.
(aDevice == Display) ifTrue:[
DarkGreyForm := f
].
^ f
!
veryDarkGreyFormOn:aDevice
"return a veryDarkGrey form"
|f|
((aDevice == Display) and:[VeryDarkGreyForm notNil]) ifTrue:[
^ VeryDarkGreyForm
].
f := self width:8 height:4 fromArray:(self veryDarkGreyFormBits) on:aDevice.
(aDevice == Display) ifTrue:[
VeryDarkGreyForm := f
].
^ f
! !
!Form class methodsFor:'ST-80 compatibility'!
over
"return a constant usable as bitblt-combinationrule"
^ #copy
!
under
"return a constant usable as bitblt-combinationrule"
^ #or
!
reverse
"return a constant usable as bitblt-combinationrule"
^ #xor
! !
!Form class methodsFor:'instance creation'!
extent:ext
"create a new, cleared form, take dimensions from ext.
Smalltalk-80 compatibility"
|newForm|
newForm := self width:(ext x) height:(ext y).
newForm fill:(Color colorId:0).
newForm paint:(Color colorId:1).
^ newForm
!
extent:ext fromArray:data offset:offs
"create a new form, take dimensions from ext, bits from data.
Smalltalk-80 compatibility."
^ self width:(ext x) height:(ext y) offset:offs fromArray:data
!
width:w height:h on:aDevice
"create a new form on device, aDevice; depth is what device likes most"
^ (self on:aDevice) width:w height:h
!
width:w height:h depth:d on:aDevice
"create a new form with depth d on device, aDevice"
^ (self on:aDevice) width:w height:h depth:d
!
width:w height:h fromArray:anArray on:aDevice
"create a new form on device, aDevice and
initialize the pixels from anArray"
^ (self on:aDevice) width:w height:h fromArray:anArray
!
width:w height:h
"create a new form on the default device"
^ (self on:Display) width:w height:h
!
width:w height:h depth:d
"create a new form on the default device"
^ (self on:Display) width:w height:h depth:d
!
width:w height:h fromArray:anArray
"create a new form on the default device"
^ (self on:Display) width:w height:h fromArray:anArray
!
width:w height:h offset:offs fromArray:anArray
"create a new form on the default device"
^ (self on:Display) width:w height:h offset:offs fromArray:anArray
!
white
"ST80 compatibility;
in st80, return a white form - here we return white color"
^ Color white
!
black
"ST80 compatibility;
in st80, return a black form - here we return black color"
^ Color black
!
gray
"ST80 compatibility;
in st80, return a grey form - here we return grey color"
^ self grey
!
grey
"ST80 compatibility;
in st80, return a grey form - here we return grey color"
^ Color grey
!
lightGrey
"ST80 compatibility;
in st80, return a lightGrey form - here we return lightGrey color"
^ Color lightGrey
!
darkGrey
"ST80 compatibility;
in st80, return a darkGrey form - here we return darkGrey color"
^ Color darkGrey
!
darkGray
"ST80 compatibility;
in st80, return a darkGrey form - here we return darkGrey color"
^ Color darkGrey
! !
!Form class methodsFor:'patterns'!
ditherBitsForXin64:x
"return a dither pattern for x/64; x in 1..63"
|sel|
DitherPatternArray isNil ifTrue:[
DitherPatternArray := Array new:63.
1 to:63 do:[:i |
"
compute the selector as #'dither<n>in64'
"
sel := ('dither' , i printString , 'in64') asSymbol.
DitherPatternArray at:i put:(self perform:sel)
]
].
^ DitherPatternArray at:x
!
dither1in64
"return a pattern for dithering"
^ #[2r10000000
2r00000000
2r00000000
2r00000000
2r00000000
2r00000000
2r00000000
2r00000000]
!
dither2in64
"return a pattern for dithering"
^ #[2r10000000
2r00000000
2r00000000
2r00000000
2r00001000
2r00000000
2r00000000
2r00000000]
!
dither3in64
"return a pattern for dithering"
^ #[2r10000000
2r00000000
2r00000000
2r00000000
2r10001000
2r00000000
2r00000000
2r00000000]
!
dither4in64
"return a pattern for dithering"
^ #[2r10001000
2r00000000
2r00000000
2r00000000
2r10001000
2r00000000
2r00000000
2r00000000]
!
dither5in64
"return a pattern for dithering"
^ #[2r10001000
2r00000000
2r00000000
2r00000000
2r10001000
2r00000000
2r00000010
2r00000000]
!
dither6in64
"return a pattern for dithering"
^ #[2r10001000
2r00000000
2r00100000
2r00000000
2r10001000
2r00000000
2r00000010
2r00000000]
!
dither7in64
"return a pattern for dithering"
^ #[2r10001000
2r00000000
2r00100010
2r00000000
2r10001000
2r00000000
2r00000010
2r00000000]
!
dither8in64
"return a pattern for dithering"
^ #[2r10001000
2r00000000
2r00100010
2r00000000
2r10001000
2r00000000
2r00100010
2r00000000]
!
dither9in64
"return a pattern for dithering"
^ #[2r10001000
2r00000000
2r00100010
2r00000000
2r10001000
2r00000000
2r10100010
2r00000000]
!
dither10in64
"return a pattern for dithering"
^ #[2r10001000
2r00000000
2r00101010
2r00000000
2r10001000
2r00000000
2r10100010
2r00000000]
!
dither11in64
"return a pattern for dithering"
^ #[2r10001000
2r00000000
2r00101010
2r00000000
2r10001000
2r00000000
2r10101010
2r00000000]
!
dither12in64
"return a pattern for dithering"
^ #[2r10001000
2r00000000
2r10101010
2r00000000
2r10001000
2r00000000
2r10101010
2r00000000]
!
dither13in64
"return a pattern for dithering"
^ #[2r10001000
2r00000000
2r10101010
2r00000000
2r10101000
2r00000000
2r10101010
2r00000000]
!
dither14in64
"return a pattern for dithering"
^ #[2r10001010
2r00000000
2r10101010
2r00000000
2r10101000
2r00000000
2r10101010
2r00000000]
!
dither15in64
"return a pattern for dithering"
^ #[2r10001010
2r00000000
2r10101010
2r00000000
2r10101010
2r00000000
2r10101010
2r00000000]
!
dither16in64
"return a pattern for dithering"
^ #[2r10101010
2r00000000
2r10101010
2r00000000
2r10101010
2r00000000
2r10101010
2r00000000]
!
dither17in64
"return a pattern for dithering"
^ #[2r10101010
2r01000000
2r10101010
2r00000000
2r10101010
2r00000000
2r10101010
2r00000000]
!
dither18in64
"return a pattern for dithering"
^ #[2r10101010
2r01000000
2r10101010
2r00000000
2r10101010
2r00000100
2r10101010
2r00000000]
!
dither19in64
"return a pattern for dithering"
^ #[2r10101010
2r01000000
2r10101010
2r00000000
2r10101010
2r01000100
2r10101010
2r00000000]
!
dither20in64
"return a pattern for dithering"
^ #[2r10101010
2r01000100
2r10101010
2r00000000
2r10101010
2r01000100
2r10101010
2r00000000]
!
dither21in64
"return a pattern for dithering"
^ #[2r10101010
2r01000100
2r10101010
2r00000000
2r10101010
2r01000100
2r10101010
2r00000001]
!
dither22in64
"return a pattern for dithering"
^ #[2r10101010
2r01000100
2r10101010
2r00010000
2r10101010
2r01000100
2r10101010
2r00000001]
!
dither23in64
"return a pattern for dithering"
^ #[2r10101010
2r01000100
2r10101010
2r00010001
2r10101010
2r01000100
2r10101010
2r00000001]
!
dither24in64
"return a pattern for dithering"
^ #[2r10101010
2r01000100
2r10101010
2r00010001
2r10101010
2r01000100
2r10101010
2r00010001]
!
dither25in64
"return a pattern for dithering"
^ #[2r10101010
2r01000100
2r10101010
2r00010001
2r10101010
2r01000100
2r10101010
2r01010001]
!
dither26in64
"return a pattern for dithering"
^ #[2r10101010
2r01000100
2r10101010
2r00010101
2r10101010
2r01000100
2r10101010
2r01010001]
!
dither27in64
"return a pattern for dithering"
^ #[2r10101010
2r01000100
2r10101010
2r00010101
2r10101010
2r01000100
2r10101010
2r01010101]
!
dither28in64
"return a pattern for dithering"
^ #[2r10101010
2r01000100
2r10101010
2r01010101
2r10101010
2r01000100
2r10101010
2r01010101]
!
dither29in64
"return a pattern for dithering"
^ #[2r10101010
2r01000100
2r10101010
2r01010101
2r10101010
2r01010100
2r10101010
2r01010101]
!
dither30in64
"return a pattern for dithering"
^ #[2r10101010
2r01000101
2r10101010
2r01010101
2r10101010
2r01010100
2r10101010
2r01010101]
!
dither31in64
"return a pattern for dithering"
^ #[2r10101010
2r01000101
2r10101010
2r01010101
2r10101010
2r01010101
2r10101010
2r01010101]
!
dither32in64
"return a pattern for dithering"
^ #[2r10101010
2r01010101
2r10101010
2r01010101
2r10101010
2r01010101
2r10101010
2r01010101]
!
dither33in64
"return a pattern for dithering"
^ #[2r11101010
2r01010101
2r10101010
2r01010101
2r10101010
2r01010101
2r10101010
2r01010101]
!
dither34in64
"return a pattern for dithering"
^ #[2r11101010
2r01010101
2r10101010
2r01010101
2r10101110
2r01010101
2r10101010
2r01010101]
!
dither35in64
"return a pattern for dithering"
^ #[2r11101010
2r01010101
2r10101010
2r01010101
2r11101110
2r01010101
2r10101010
2r01010101]
!
dither36in64
"return a pattern for dithering"
^ #[2r11101110
2r01010101
2r10101010
2r01010101
2r11101110
2r01010101
2r10101010
2r01010101]
!
dither37in64
"return a pattern for dithering"
^ #[2r11101110
2r01010101
2r10101010
2r01010101
2r11101110
2r01010101
2r10101011
2r01010101]
!
dither38in64
"return a pattern for dithering"
^ #[2r11101110
2r01010101
2r10111010
2r01010101
2r11101110
2r01010101
2r10101011
2r01010101]
!
dither39in64
"return a pattern for dithering"
^ #[2r11101110
2r01010101
2r10111011
2r01010101
2r11101110
2r01010101
2r10101011
2r01010101]
!
dither40in64
"return a pattern for dithering"
^ #[2r11101110
2r01010101
2r10111011
2r01010101
2r11101110
2r01010101
2r10111011
2r01010101]
!
dither41in64
"return a pattern for dithering"
^ #[2r11101110
2r01010101
2r10111011
2r01010101
2r11101110
2r01010101
2r11111011
2r01010101]
!
dither42in64
"return a pattern for dithering"
^ #[2r11101110
2r01010101
2r10111111
2r01010101
2r11101110
2r01010101
2r11111011
2r01010101]
!
dither43in64
"return a pattern for dithering"
^ #[2r11101110
2r01010101
2r10111111
2r01010101
2r11101110
2r01010101
2r11111111
2r01010101]
!
dither44in64
"return a pattern for dithering"
^ #[2r11101110
2r01010101
2r11111111
2r01010101
2r11101110
2r01010101
2r11111111
2r01010101]
!
dither45in64
"return a pattern for dithering"
^ #[2r11101110
2r01010101
2r11111111
2r01010101
2r11111110
2r01010101
2r11111111
2r01010101]
!
dither46in64
"return a pattern for dithering"
^ #[2r11101111
2r01010101
2r11111111
2r01010101
2r11111110
2r01010101
2r11111111
2r01010101]
!
dither47in64
"return a pattern for dithering"
^ #[2r11101111
2r01010101
2r11111111
2r01010101
2r11111111
2r01010101
2r11111111
2r01010101]
!
dither48in64
"return a pattern for dithering"
^ #[2r11111111
2r01010101
2r11111111
2r01010101
2r11111111
2r01010101
2r11111111
2r01010101]
!
dither49in64
"return a pattern for dithering"
^ #[2r11111111
2r01110101
2r11111111
2r01010101
2r11111111
2r01010101
2r11111111
2r01010101]
!
dither50in64
"return a pattern for dithering"
^ #[2r11111111
2r01110101
2r11111111
2r01010101
2r11111111
2r01010111
2r11111111
2r01010101]
!
dither51in64
"return a pattern for dithering"
^ #[2r11111111
2r01110101
2r11111111
2r01010101
2r11111111
2r01110111
2r11111111
2r01010101]
!
dither52in64
"return a pattern for dithering"
^ #[2r11111111
2r01110111
2r11111111
2r01010101
2r11111111
2r01110111
2r11111111
2r01010101]
!
dither53in64
"return a pattern for dithering"
^ #[2r11111111
2r01110111
2r11111111
2r01010101
2r11111111
2r01110111
2r11111111
2r11010101]
!
dither54in64
"return a pattern for dithering"
^ #[2r11111111
2r01110111
2r11111111
2r01011101
2r11111111
2r01110111
2r11111111
2r11010101]
!
dither55in64
"return a pattern for dithering"
^ #[2r11111111
2r01110111
2r11111111
2r11011101
2r11111111
2r01110111
2r11111111
2r11010101]
!
dither56in64
"return a pattern for dithering"
^ #[2r11111111
2r01110111
2r11111111
2r11011101
2r11111111
2r01110111
2r11111111
2r11011101]
!
dither57in64
"return a pattern for dithering"
^ #[2r11111111
2r01110111
2r11111111
2r11011101
2r11111111
2r01110111
2r11111111
2r11111101]
!
dither58in64
"return a pattern for dithering"
^ #[2r11111111
2r01110111
2r11111111
2r11011111
2r11111111
2r01110111
2r11111111
2r11111101]
!
dither59in64
"return a pattern for dithering"
^ #[2r11111111
2r01110111
2r11111111
2r11011111
2r11111111
2r01110111
2r11111111
2r11111111]
!
dither60in64
"return a pattern for dithering"
^ #[2r11111111
2r01110111
2r11111111
2r11111111
2r11111111
2r01110111
2r11111111
2r11111111]
!
dither61in64
"return a pattern for dithering"
^ #[2r11111111
2r01110111
2r11111111
2r11111111
2r11111111
2r01111111
2r11111111
2r11111111]
!
dither62in64
"return a pattern for dithering"
^ #[2r11111111
2r11110111
2r11111111
2r11111111
2r11111111
2r01111111
2r11111111
2r11111111]
!
dither63in64
"return a pattern for dithering"
^ #[2r11111111
2r11110111
2r11111111
2r11111111
2r11111111
2r11111111
2r11111111
2r11111111]
!
grey6Bits
"return a pattern with 6% grey, usable for dithering"
^ #(2r00000001
2r00000000
2r00010000
2r00000000)
!
grey12Bits
"return a pattern with 12% grey, usable for dithering"
^ #(2r00010001
2r00000000
2r01000100
2r00000000)
!
grey25Bits
"return a pattern with 25% grey, usable for dithering"
^ #(2r00010001
2r01000100
2r00010001
2r01000100)
!
grey37Bits
"return a pattern with 37% grey, usable for dithering"
^ #(2r00010001
2r10101010
2r01000100
2r10101010)
!
grey50Bits
"return a pattern with 50% grey, usable for dithering"
^ #(2r01010101
2r10101010
2r01010101
2r10101010)
!
veryLightGreyFormBits
"return a pattern usable to simulate veryDarkGray on monochrome device"
^ #(2r10001000
2r00000000
2r00100010
2r00000000)
!
lightGreyFormBits
"return a pattern usable to simulate lightGray on monochrome device"
^ #(2r01000100
2r00010001
2r01000100
2r00010001
2r01000100)
!
greyFormBits
"return a pattern usable to simulate gray on monochrome device"
^ #(2r01010101
2r10101010
2r01010101
2r10101010)
!
darkGreyFormBits
"return a pattern usable to simulate darkGray on monochrome device"
^ #(2r10111011
2r11101110
2r10111011
2r11101110)
!
veryDarkGreyFormBits
"return a pattern usable to simulate veryDarkGray on monochrome device"
^ #(2r01110111
2r11111111
2r11011101
2r11111111)
! !
!Form methodsFor:'initialization'!
initialize
super initialize.
depth := 1.
foreground := Color colorId:1.
background := Color colorId:0
!
initGC
"stop server from sending exposure events for Forms -
(will fill up stream-queue on some stupid (i.e. sco) systems"
super initGC.
Lobby changed:self.
self setGraphicsExposures:false
!
recreate
"reconstruct the form after a snapin"
data notNil ifTrue:[
(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.
^ self
].
'FORM: cannot recreate form' errorPrintNewline.
"create an empty one"
depth == 1 ifTrue:[
drawableId := device createBitmapWidth:width height:height
] ifFalse:[
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
]
! !
!Form methodsFor:'getting a device form'!
on:aDevice
aDevice == device ifTrue:[
^ self
].
^ nil
!
asMonochromeFormOn:aDevice
aDevice == device ifTrue:[
depth == 1 ifTrue:[
^ self
].
].
^ nil
!
asForm
^ self
!
asFormOn:aDevice
aDevice == device ifTrue:[
^ self
].
^ nil
! !
!Form methodsFor:'private'!
restored
"flush device data, when restored
(sent after snapin or binaryLoad)"
drawableId := nil.
gcId := nil.
!
getBits
"if the receiver was not created from a file, or
an array (i.e. it was drawn), read the pixels from the
device into a local data array. This has to be done before
an image is saved, or the receiver is storedBinary, since
the information present in the device is lost after restart/reload"
(data isNil and:[fileName isNil]) ifTrue:[
data := self bits
]
!
width:w height:h
"actual create of a monochrome form"
((w == 0) or:[h == 0]) ifTrue:[
self error:'invalid form extent'.
^ nil
].
width := w.
height := h.
depth := 1.
offset := 0@0.
drawableId := device createBitmapWidth:w height:h.
drawableId isNil ifTrue:[^ nil].
BlackAndWhiteColorMap isNil ifTrue:[
BlackAndWhiteColorMap := Array with:(Color white) with:(Color black)
].
localColorMap := BlackAndWhiteColorMap.
realized := true.
Lobby register:self
!
width:w height:h depth:d
"actual create of an arbitrary deep form (but, must be supported by device)"
width := w.
height := h.
offset := 0@0.
drawableId := device createPixmapWidth:w height:h depth:d.
drawableId isNil ifTrue:[^ nil].
realized := true.
depth := d.
Lobby register:self
!
width:w height:h fromArray:anArray
"actual create of a monochrome form from array.
This method is somewhat more complicated as it should be due to
supporting both byte-wise (ST/X-type) and short-word-wise (ST-80-type)
Arrays; in the later case, the shorts are first converted to bytes in
a ByteArray, then passed to the device."
|bytes bits srcPerRow dstPerRow srcStart srcIndex dstIndex tmp isST80|
bytes := anArray.
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 uninitializedNew:(((w + 7) // 8) * h).
srcPerRow := (w + 15) // 16.
dstPerRow := (w + 7) // 8.
srcStart := 1.
dstIndex := 1.
1 to:h do:[:hi |
srcIndex := srcStart.
bits := anArray at:srcIndex.
1 to:dstPerRow do:[:di |
di odd ifTrue:[
bits := anArray at:srcIndex.
bytes at:dstIndex put:(bits bitShift:-8)
] ifFalse:[
bytes at:dstIndex put:(bits bitAnd:16rFF).
srcIndex := srcIndex + 1
].
dstIndex := dstIndex + 1
].
srcStart := srcStart + srcPerRow
]
]
].
width := w.
height := h.
depth := 1.
offset := 0@0.
drawableId := device createBitmapFromArray:bytes width:w height:h.
drawableId isNil ifTrue:[^ nil].
data := bytes.
BlackAndWhiteColorMap isNil ifTrue:[
BlackAndWhiteColorMap := Array with:(Color white) with:(Color black)
].
localColorMap := BlackAndWhiteColorMap.
realized := true.
Lobby register:self
!
width:w height:h offset:offs fromArray:anArray
"actual create of a monochrome form from array"
self width:w height:h fromArray:anArray.
offset := offs
!
readFromFile:filename
"read a monochrome form from a file (in xbm-format)"
|pathName|
pathName := self class findBitmapFile:filename.
pathName notNil ifTrue:[
drawableId := device createBitmapFromFile:pathName for:self.
drawableId isNil ifTrue:[^ nil].
fileName := pathName.
offset := 0@0.
realized := true.
BlackAndWhiteColorMap isNil ifTrue:[
BlackAndWhiteColorMap := Array with:(Color white) with:(Color black)
].
localColorMap := BlackAndWhiteColorMap.
Lobby register:self.
^ self
].
^ nil
!
readFromFile:filename resolution:dpi
"read a monochrome form from a file, which is assumed to have data for a dpi-resolution;
if the actual resolution of the device differs, magnify the form."
|dpiH mag|
(self readFromFile:filename) isNil ifTrue:[^ nil].
"if the device is within +- 50% of dpi, no magnify is needed"
dpiH := Display horizontalPixelPerInch.
((dpi >= (dpiH * 0.75)) and:[dpi <= (dpiH * 1.5)]) ifTrue:[^ self].
mag := (dpiH / dpi) rounded.
mag == 0 ifTrue:[
^ self
].
^ self magnifyBy:(mag @ mag)
"Form fromFile:'SBrowser.icn' resolution:50"
! !
!Form methodsFor:'ST-80 compatibility'!
offset:org
"set the offset.
Smalltalk-80 compatibility"
offset := org
!
offset
"set the offset.
Smalltalk-80 compatibility"
^ offset
!
displayOn:aGC at:aPoint
"draw in aGC.
Smalltalk-80 compatibility"
aGC displayOpaqueForm:self x:aPoint x y:aPoint y
! !
!Form methodsFor:'accessing'!
colorMap
"return the receivers colormap"
^ localColorMap
!
colorMap:anArray
"set the receivers colormap"
localColorMap := anArray
!
depth
"return the receivers depth"
^ depth
!
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 4 forms, 2 pixels/byte are filled.
Padding is done to the next byte-boundary
(i.e. a with:13/depth:1 form will return 2 bytes per scanline)"
|pixelArray bytesPerRow bits
byteIndex "{ Class: SmallInteger }"
bitMask "{ Class: SmallInteger }"
hEnd "{ Class: SmallInteger }"
wEnd "{ Class: SmallInteger }"
bytesPerLine "{ Class: SmallInteger }"
bytesPerLineIn
inData tmpData info
srcIndex "{ Class: SmallInteger }"
dstIndex "{ Class: SmallInteger }"|
data notNil ifTrue:[
^ data
].
drawableId isNil ifTrue:[
fileName notNil ifTrue:[
^ (self on:Display) bits
].
^ nil
].
bytesPerLine := (width * depth + 31) // 32 * 4.
inData := ByteArray uninitializedNew:(bytesPerLine * height).
info := device getBitsFrom:drawableId x:0 y:0 width:width height:height into:inData.
bytesPerLineIn := (info at:3). "what I got"
bytesPerLine := (width * depth + 7) // 8. "what I want"
(bytesPerLine ~~ bytesPerLineIn) ifTrue:[
tmpData := inData.
inData := ByteArray uninitializedNew:(bytesPerLine * height).
srcIndex := 1.
dstIndex := 1.
1 to:height do:[:hi |
inData replaceFrom:dstIndex to:(dstIndex + bytesPerLine - 1)
with:tmpData startingAt:srcIndex.
dstIndex := dstIndex + bytesPerLine.
srcIndex := srcIndex + bytesPerLineIn
]
] ifFalse:[
(bytesPerLine * height) ~~ inData size ifTrue:[
tmpData := inData.
inData := ByteArray uninitializedNew:(bytesPerLine * height).
inData replaceFrom:1 to:bytesPerLine * height with:tmpData startingAt:1
]
].
^ inData.
"/ "this is a very slow operation - every pixel is fetched from
"/ the device.
"/ This MUST be replaced by code based on getImage ....
"/ "
"/
"/ (depth == 8) ifTrue:[
"/ bytesPerRow := width
"/ ] ifFalse:[
"/ bytesPerRow := (width + 7) // 8
"/ ].
"/ pixelArray := ByteArray uninitializedNew:(bytesPerRow * height).
"/ byteIndex := 1.
"/ hEnd := height - 1.
"/ wEnd := width - 1.
"/
"/ (depth == 8) ifTrue:[
"/ 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:hEnd do:[:row |
"/ bitMask := 2r10000000.
"/ bits := 0.
"/ 0 to:wEnd do:[:col |
"/ ((self at:col @ row) == 0) ifFalse:[
"/ bits := bits bitOr:bitMask
"/ ].
"/ bitMask := bitMask bitShift:-1.
"/ (bitMask == 0) ifTrue:[
"/ pixelArray at:byteIndex put:bits.
"/ bitMask := 2r10000000.
"/ bits := 0.
"/ byteIndex := byteIndex + 1
"/ ]
"/ ].
"/ (bitMask == 2r10000000) ifFalse:[
"/ pixelArray at:byteIndex put:bits.
"/ byteIndex := byteIndex + 1
"/ ]
"/ ]
"/ ].
"/ ^ pixelArray
!
forgetBits
"for image, which also keeps the bits - so there is
no need to hold them again here"
data := nil
!
photometric
"for compatibility with Image class ..."
depth == 1 ifTrue:[
((localColorMap at:1) = Color white) ifTrue:[
((localColorMap at:1) = Color black) ifTrue:[
^ #whiteIs0
].
].
((localColorMap at:1) = Color black) ifTrue:[
((localColorMap at:1) = Color white) ifTrue:[
^ #blackIs0
].
].
].
^ #palette
!
samplesperPixel
"for compatibility with Image class ..."
^ 1
!
bitsPerSample
"for compatibility with Image class ..."
^ Array with:depth
!
filename
"return the filename, from which the receiver was created,
or nil, if it was not read from a file"
^ fileName
! !
!Form methodsFor:'image manipulations'!
lightened
"kludge - actually should return a lightened image ..
(or Color white ?)"
^ self
!
darkened
"kludge - actually should return a darkened image ..
(or Color black ?)"
^ self
!
magnifyBy:extent
"return a new form magnified by extent, aPoint.
If non-integral magnify is asked for, pass the work on to 'hardMagnifyBy:'"
|mX mY dstX dstY newForm|
mX := extent x.
mY := extent y.
((mX = 1) and:[mY = 1]) ifTrue:[^ self].
((mX isMemberOf:SmallInteger) and:[mY isMemberOf:SmallInteger]) ifFalse:[
^ self hardMagnifyBy:extent
].
newForm := ((self class) on:device)
width:(width * mX)
height:(height * mY)
depth:depth.
"expand rows"
(mY > 1) ifTrue:[
dstY := 0.
0 to:(height - 1) do:[:srcY |
1 to:mY do:[:i |
newForm copyFrom:self
x:0 y:srcY
toX:0 y:dstY
width:width height:1.
dstY := dstY + 1
]
]
].
"expand cols"
(mX > 1) ifTrue:[
dstX := (width * mX) - 1.
(width - 1) to:0 by:-1 do:[:srcX |
1 to:mX do:[:i |
newForm copyFrom:newForm
x:srcX y:0
toX:dstX y:0
width:1 height:(height * mY).
dstX := dstX - 1
]
]
].
newForm colorMap:localColorMap.
^ newForm
"ScrollBar scrollUpButtonForm magnifyBy:(2 @ 2)"
!
flipVertical
"return a new form flipped vertically"
|dstX newForm|
newForm := ((self class) on:device)
width:width
height:height
depth:depth.
"expand cols"
dstX := width - 1.
0 to:((width - 1) // 2) do:[:srcX |
newForm copyFrom:self
x:srcX y:0
toX:dstX y:0
width:1 height:height.
dstX := dstX - 1
].
newForm colorMap:localColorMap.
^ newForm
!
flipHorizontal
"return a new form flipped horizontally"
|dstY newForm|
newForm := ((self class) on:device)
width:width
height:height
depth:depth.
"expand rows"
dstY = height - 1.
0 to:((height - 1) // 2) do:[:srcY |
newForm copyFrom:self
x:0 y:srcY
toX:0 y:dstY
width:width height:1.
dstY := dstY - 1
].
newForm colorMap:localColorMap.
^ newForm
! !
!Form methodsFor:'storing'!
storeOn:aStream
aStream nextPutAll:'(Form width:'.
width storeOn:aStream.
aStream nextPutAll:' height:'.
height storeOn:aStream.
aStream nextPutAll:' fromArray:('.
self bits storeOn:aStream.
aStream nextPutAll:'))'
! !
!Form methodsFor:'editing'!
edit
FormEditView editForm:self
"ScrollBar scrollUpButtonForm edit"
!
show
((FormView new model:self) extent:self extent) open
"ScrollBar scrollUpButtonForm show"
! !
!Form class methodsFor:'fileIn/Out'!
readFrom:fileName
"same as Form>>fromFile: - for ST-80 compatibility"
^ self fromFile:fileName
!
fromFile:filename on:aDevice
"create a new form on device, aDevice and
initialize the pixels from the file filename"
^ (self on:aDevice) readFromFile:filename
!
fromFile:filename resolution:dpi on:aDevice
"create a new form on device, aDevice and
initialize the pixels from the file filename;
the data in the file is assumed to be for dpi resolution;
if it is different from the displays resolution, magnify or
shrink the picture (but only in integer magnification steps)"
^ (self on:aDevice) readFromFile:filename resolution:dpi
!
fromFile:filename
"create a new form taking the bits from a file on the default device"
^ (self on:Display) readFromFile:filename
!
fromFile:filename resolution:dpi
"create a new form taking the bits from a file on the default device
the data in the file is assumed to be for dpi resolution;
if it is different from the displays resolution, magnify or
shrink the picture (but only in integer magnification steps)"
^ (self on:Display) readFromFile:filename resolution:dpi
! !