"
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'
poolDictionaries:''
category:'Graphics-Display Objects'
!
!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.
"
!
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.
NOTICE:
the Form class is a historic leftover and now only used for real
device forms (i.e. on devices which support downloading bitmaps).
In your application, you should always use Image, both for compatibility
with ST-80 and for device independence, since Form may not be supported
by all devices (for example: PostscriptPrinters).
"
! !
!Form class methodsFor:'initialization'!
initialize
"initialize set of dictionaries to look for bitmaps"
AdditionalBitmapDirectoryNames isNil ifTrue:[
AdditionalBitmapDirectoryNames := #('/usr/lib/X11/bitmaps').
"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 do:[:aDrawable |
(aDrawable device == aDevice) ifTrue:[
aDrawable isForm ifTrue:[
"now, try to recreate it"
aDrawable recreate.
]
]
]
!
update:something
"sent just before snapOut and just after a snapIn"
(something == #save) ifTrue:[
"get all bits from the device into saveable arrays"
Lobby do:[:aDrawable |
aDrawable isForm ifTrue:[
aDrawable getBits
]
]
].
(something == #restarted) ifTrue:[
"remove all left-over device info"
Lobby do:[:aDrawable |
aDrawable isForm ifTrue:[
aDrawable restored.
Lobby registerChange:aDrawable
]
]
]
! !
!Form class methodsFor:'instance creation'!
black
"ST80 compatibility;
in st80, return a black form - here we return black color"
^ Color black
!
darkGray
"ST80 compatibility;
in st80, return a darkGrey form - here we return darkGrey color"
^ Color darkGrey
!
darkGrey
"ST80 compatibility;
in st80, return a darkGrey form - here we return darkGrey color"
^ Color darkGrey
!
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
"create a new form, take dimensions from ext, bits from data.
Smalltalk-80 compatibility."
^ self width:(ext x) height:(ext y) offset:0@0 fromArray:data
!
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
!
extent:ext offset:anOffset
"create a new, cleared form, take dimensions from ext.
Smalltalk-80 compatibility"
^ (self extent:ext) offset:anOffset.
!
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
!
white
"ST80 compatibility;
in st80, return a white form - here we return white color"
^ Color white
!
width:w height:h
"create a new form on the default device"
^ (self on:Screen current) width:w height:h
!
width:w height:h depth:d
"create a new form on the default device"
^ (self on:Screen current) width:w height:h depth:d
!
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
"create a new form on the default device"
^ (self on:Screen current) width:w height:h fromArray:anArray
!
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 offset:offs fromArray:anArray
"create a new form on the default device"
^ (self on:Screen current) width:w height:h offset:offs fromArray:anArray
!
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
! !
!Form class methodsFor:'ST-80 compatibility'!
and
"return a constant usable as bitblt-combinationrule"
^ #and
!
over
"return a constant usable as bitblt-combinationrule"
^ #copy
!
paint
"return a constant usable as bitblt-combinationrule"
^ #copy
!
reverse
"return a constant usable as bitblt-combinationrule"
^ #xor
!
under
"return a constant usable as bitblt-combinationrule"
^ #or
! !
!Form class methodsFor:'cleanup'!
lowSpaceCleanup
"cleanup in low-memory situations"
DitherPatternArray := nil
! !
!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].
fileName asFilename exists ifTrue:[^ fileName].
aStream := Smalltalk bitmapFileStreamFor: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:'fileIn/Out'!
fromFile:filename
"create a new form taking the bits from a file on the default device.
WARNING:
Please do no longer use this, since it will not work
correctly in multi-display applications (creates the form on the
default Display).
Use #fromFile:on: and pass the devive as argument."
^ self fromFile:filename on:Screen current
!
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
"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).
WARNING:
Please do no longer use this, since it will not work
correctly in multi-display applications (creates the form on the
default Display).
Use #fromFile:resolution:on: and pass the devive as argument."
^ self fromFile:filename resolution:dpi on:Screen current
!
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
!
readFrom:fileName
"same as Form>>fromFile: - for ST-80 compatibility.
WARNING:
Please do no longer use this, since it will not work
correctly in multi-display applications (creates the form on the
default Display).
Use #fromFile:on: and pass the devive as argument."
^ self fromFile:fileName on:Screen current
! !
!Form class methodsFor:'patterns'!
darkGreyFormBits
"return a pattern usable to simulate darkGray on monochrome device"
^ #(2r10111011
2r11101110
2r10111011
2r11101110)
!
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]
!
dither1in64
"return a pattern for dithering"
^ #[2r10000000
2r00000000
2r00000000
2r00000000
2r00000000
2r00000000
2r00000000
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]
!
dither2in64
"return a pattern for dithering"
^ #[2r10000000
2r00000000
2r00000000
2r00000000
2r00001000
2r00000000
2r00000000
2r00000000]
!
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]
!
dither3in64
"return a pattern for dithering"
^ #[2r10000000
2r00000000
2r00000000
2r00000000
2r10001000
2r00000000
2r00000000
2r00000000]
!
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]
!
dither4in64
"return a pattern for dithering"
^ #[2r10001000
2r00000000
2r00000000
2r00000000
2r10001000
2r00000000
2r00000000
2r00000000]
!
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]
!
dither5in64
"return a pattern for dithering"
^ #[2r10001000
2r00000000
2r00000000
2r00000000
2r10001000
2r00000000
2r00000010
2r00000000]
!
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]
!
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]
!
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
!
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)
!
grey6Bits
"return a pattern with 6% grey, usable for dithering"
^ #(2r00000001
2r00000000
2r00010000
2r00000000)
!
greyFormBits
"return a pattern usable to simulate gray on monochrome device"
^ #(2r01010101
2r10101010
2r01010101
2r10101010)
!
lightGreyFormBits
"return a pattern usable to simulate lightGray on monochrome device"
^ #(2r01000100
2r00010001
2r01000100
2r00010001
2r01000100)
!
veryDarkGreyFormBits
"return a pattern usable to simulate veryDarkGray on monochrome device"
^ #(2r01110111
2r11111111
2r11011101
2r11111111)
!
veryLightGreyFormBits
"return a pattern usable to simulate veryDarkGray on monochrome device"
^ #(2r10001000
2r00000000
2r00100010
2r00000000)
! !
!Form class methodsFor:'private instance creation'!
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
!
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
!
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
!
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
!
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
!
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
! !
!Form methodsFor:'ST-80 compatibility'!
displayOn:aGC at:aPoint
"draw in aGC.
Smalltalk-80 (2.x) compatibility"
^ self displayOn:aGC at:aPoint rule:#copy
!
displayOn:aGC at:aPoint rule:rule
"draw in aGC.
Smalltalk-80 (2.x) compatibility"
|f|
f := aGC function.
aGC function:rule.
aGC displayOpaqueForm:self x:aPoint x y:aPoint y.
aGC function:f.
!
displayOn:aGC rule:rule
"draw in aGC.
Smalltalk-80 (2.x) compatibility"
^ self displayOn:aGC at:0@0 rule:rule
!
offset
"set the offset.
Smalltalk-80 compatibility"
^ offset
!
offset:org
"set the offset.
Smalltalk-80 compatibility"
offset := org
! !
!Form methodsFor:'accessing'!
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. for width==13 and depth==1 it will return 2 bytes per scanline)"
|bytesPerLine "{ Class: SmallInteger }"
bytesPerLineIn "{ Class: SmallInteger }"
inData tmpData info
srcIndex "{ Class: SmallInteger }"
dstIndex "{ Class: SmallInteger }"
buffer|
data notNil ifTrue:[
^ data
].
drawableId isNil ifTrue:[
fileName notNil ifTrue:[
^ (self on:Screen current) 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:#bytesPerLine). "what I got"
bytesPerLine := (width * depth + 7) // 8. "what I want"
(bytesPerLine ~~ bytesPerLineIn) ifTrue:[
"
different padding - have to copy over row-wise
"
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:[
"
same padding - copy over all in one chunk
"
(bytesPerLine * height) ~~ inData size ifTrue:[
tmpData := inData.
inData := ByteArray uninitializedNew:(bytesPerLine * height).
inData replaceFrom:1 to:bytesPerLine * height with:tmpData startingAt:1
]
].
"
have to reverse bytes, if not msbFirst ?
"
(info at:#bitOrder) ~~ #msbFirst ifTrue:[
buffer := ByteArray new:bytesPerLine.
dstIndex := 1.
1 to:height do:[:hi |
buffer replaceFrom:1 to:bytesPerLine with:inData startingAt:dstIndex.
buffer reverse.
inData replaceFrom:dstIndex to:dstIndex+bytesPerLine-1 with:buffer startingAt:1.
dstIndex := dstIndex + bytesPerLine
]
].
^ inData.
!
bits:anArray
data := anArray
!
bitsPerSample
"for compatibility with Image class ..."
^ Array with:depth
!
colorMap
"return the receivers colormap"
^ localColorMap
!
colorMap:anArray
"set the receivers colormap"
localColorMap := anArray
!
depth
"return the receivers depth"
^ depth
!
filename
"return the filename, from which the receiver was created,
or nil, if it was not read from a file"
^ fileName
!
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
!
valueAt:aPoint
^ self at:aPoint
!
valueAt:aPoint put:value
^ self at:aPoint put:value
! !
!Form methodsFor:'binary storage'!
readBinaryContentsFrom: stream manager: manager
"tell the newly restored Form about restoration"
super readBinaryContentsFrom: stream manager: manager.
device := Screen current.
fileName := nil.
self restored.
self recreate.
Lobby register:self.
"
|f|
f := Form fromFile:'bitmaps/SBrowser.xbm'.
f storeBinaryOn:'foo.bos'.
(Form readBinaryFrom:'foo.bos') inspect
"
!
storeBinaryDefinitionOn: stream manager: manager
"store a binary representation of the receiver on stream.
Redefined to store the actual bits, even if I have been loaded
from a file."
data isNil ifTrue:[
data := self bits.
super storeBinaryDefinitionOn: stream manager: manager.
data := nil.
^ self
].
super storeBinaryDefinitionOn: stream manager: manager
! !
!Form methodsFor:'converting'!
asForm
^ self
!
asImage
^ Image fromForm:self
! !
!Form methodsFor:'copying'!
postCopy
super postCopy.
localColorMap := localColorMap copy.
data := data copy
!
shallowCopyForFinalization
"redefined for faster creation of finalization copies
(only device, gcId and drawableId are needed)"
|aCopy|
aCopy := DeviceFormHandle basicNew.
aCopy setDevice:device id:drawableId gcId:gcId.
^ aCopy
! !
!Form methodsFor:'editing'!
edit
ImageEditView openOnImage:self
"
(Form fromFile:'bitmaps/SBrowser.xbm') edit
"
!
show
ImageView openOnImage:self
"
(Form fromFile:'bitmaps/SBrowser.xbm') show
"
! !
!Form methodsFor:'getting a device form'!
asFormOn:aDevice
aDevice == device ifTrue:[
^ self
].
^ self on:aDevice
!
asMonochromeFormOn:aDevice
aDevice == device ifTrue:[
depth == 1 ifTrue:[
^ self
].
].
(depth == 1) ifTrue:[
^ self on:aDevice
].
^ nil
!
on:aDevice
aDevice == device ifTrue:[
^ self
].
"create a new form ..."
data notNil ifTrue:[
^ self class width:width height:height fromArray:data on:aDevice
].
fileName notNil ifTrue:[
^ self class fromFile:fileName on:aDevice
].
^ self width:width height:height on:aDevice
! !
!Form methodsFor:'image manipulations'!
darkened
"kludge - actually should return a darkened image ..
(or Color black ?)"
^ self
!
flipHorizontal
"return a new form flipped horizontally"
|dstY newForm nRows "{ Class: SmallInteger }" |
newForm := ((self class) on:device)
width:width
height:height
depth:depth.
"expand rows"
dstY := height - 1.
nRows := dstY // 2.
0 to:nRows do:[:srcY |
newForm copyFrom:self
x:0 y:srcY
toX:0 y:dstY
width:width height:1.
dstY := dstY - 1
].
newForm colorMap:localColorMap.
^ newForm
!
flipVertical
"return a new form flipped vertically"
|dstX newForm nCols "{ Class: SmallInteger }" |
newForm := ((self class) on:device)
width:width
height:height
depth:depth.
"expand cols"
dstX := width - 1.
nCols := dstX // 2.
0 to:nCols do:[:srcX |
newForm copyFrom:self
x:srcX y:0
toX:dstX y:0
width:1 height:height.
dstX := dstX - 1
].
newForm colorMap:localColorMap.
^ newForm
!
hardMagnifiedBy:extent
"return a new form magnified by extent, aPoint.
This method handles non-integral factors."
"
since Form will be replaced by Image in the long run,
and this operation is slow anyway, use the implementation
in Image for this."
^ ((Image fromForm:self) magnifiedBy:extent) asFormOn:device.
"
(Form fromFile:'OutputOn.64') magnifiedBy:0.5@0.5
(Form fromFile:'OutputOn.64') magnifiedBy:1.5@1.5
"
!
lightened
"kludge - actually should return a lightened image ..
(or Color white ?)"
^ self
!
magnifiedBy:extent
"return a new form magnified by extent, aPoint.
If non-integral magnify is asked for, pass the work on to 'hardMagnifiedBy:'"
|mX mY dstX dstY newForm ext
factor "{ Class: SmallInteger }"
n "{ Class: SmallInteger }" |
ext := extent asPoint.
mX := ext x.
mY := ext y.
((mX = 1) and:[mY = 1]) ifTrue:[^ self].
((mX isMemberOf:SmallInteger) and:[mY isMemberOf:SmallInteger]) ifFalse:[
^ self hardMagnifiedBy:ext
].
newForm := ((self class) on:device)
width:(width * mX)
height:(height * mY)
depth:depth.
"expand rows"
(mY > 1) ifTrue:[
dstY := 0.
n := height.
factor := mY.
0 to:(n - 1) do:[:srcY |
1 to:factor 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:[
n := width.
factor := mX.
dstX := (n * factor) - 1.
(n - 1) to:0 by:-1 do:[:srcX |
1 to:factor 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
"
(ArrowButton upArrowButtonForm:#iris on:Display) magnifiedBy:(2 @ 2)
(Form fromFile:'bitmaps/SBrowser.xbm') magnifiedBy:(2 @ 2)
(Form fromFile:'bitmaps/SBrowser.xbm') magnifiedBy:(0.4 @ 0.4)
"
!
magnifyBy:scale
"obsolete: has been renamed to magnifiedBy: for ST-80 compatibility
and name consistency ..."
self obsoleteMethodWarning.
^ self magnifiedBy:scale
! !
!Form methodsFor:'initialization'!
initGC
"stop server from sending exposure events for Forms -
(will fill up stream-queue on some stupid (i.e. sco) systems"
super initGC.
"/ self createGC.
"/ Lobby registerChange:self.
self setGraphicsExposures:false
!
initialize
super initialize.
depth := 1.
foreground := paint := Color colorId:1.
background := bgPaint := Color colorId:0
!
recreate
"reconstruct the form after a snapin"
data notNil ifTrue:[
"
create one from data
"
(depth == 1 or:[depth == device depth]) ifTrue:[
drawableId := device createBitmapFromArray:data width:width height:height.
Lobby registerChange:self.
^ self
].
data := nil.
].
fileName notNil ifTrue:[
"
create one from a file (mhmh - this seems X-specific and will vanish)
"
drawableId := device createBitmapFromFile:fileName for:self.
Lobby registerChange:self.
^ self
].
'FORM: cannot recreate form' errorPrintNL.
"
create an empty one
"
depth == 1 ifTrue:[
drawableId := device createBitmapWidth:width height:height
] ifFalse:[
drawableId := device createPixmapWidth:width height:height depth:device depth
].
Lobby registerChange:self
! !
!Form methodsFor:'inspecting'!
inspectorClass
"redefined to launch an ImageInspector
(instead of the default InspectorView)."
^ ImageInspectorView
! !
!Form methodsFor:'instance release'!
XXdisposed
"some Form has been collected - tell it to the x-server"
drawableId notNil ifTrue:[
gcId notNil ifTrue:[
device destroyGC:gcId.
gcId := nil
].
device destroyPixmap:drawableId.
drawableId := nil
]
! !
!Form methodsFor:'printing & 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:'private'!
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
]
!
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 registerChange: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 dev|
(self readFromFile:filename) isNil ifTrue:[^ nil].
"if the device is within +- 50% of dpi, no magnify is needed"
dev := device.
dev isNil ifTrue:[
"should not happen ..."
dev := Screen current
].
dpiH := dev horizontalPixelPerInch.
((dpi >= (dpiH * 0.75)) and:[dpi <= (dpiH * 1.5)]) ifTrue:[^ self].
mag := (dpiH / dpi) rounded.
mag == 0 ifTrue:[
^ self
].
^ self magnifiedBy:(mag @ mag)
"Form fromFile:'SBrowser.icn' resolution:50"
!
restored
"flush device data, when restored
(sent after snapin or binaryLoad)"
drawableId := nil.
gcId := nil.
!
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 registerChange: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 registerChange: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 "{ Class: SmallInteger }"
dstPerRow "{ Class: SmallInteger }"
srcStart "{ Class: SmallInteger }"
srcIndex "{ Class: SmallInteger }"
dstIndex "{ Class: SmallInteger }"
hi "{ Class: SmallInteger }" |
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.
hi := h.
1 to:hi 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 registerChange: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
! !
!Form methodsFor:'queries '!
isForm
"return true, if the receiver is some kind of form;
true is returned here - the method is redefined from Object."
^ true
!
isImageOrForm
"return true, if the receiver is some kind of image or form;
true is returned here - the method is redefined from Object."
^ true
! !
!Form class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libview/Form.st,v 1.33 1996-02-04 17:12:49 cg Exp $'
! !
Form initialize!