--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/DObject.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,317 @@
+"
+ COPYRIGHT (c) 1989-92 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.
+"
+
+Object subclass:#DisplayObject
+ instanceVariableNames:'frame'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Graphics-Display Objects'
+!
+
+DisplayObject comment:'
+
+COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+generic superclass for Display Objects held in ObjectViews
+see DrawObject/LogicObject/DeskTopObject and subclasses for example use
+
+%W% %E%
+written fall/winter 89 by claus
+'!
+
+!DisplayObject class methodsFor:'instance creation'!
+
+new
+ ^ self basicNew initialize
+! !
+
+!DisplayObject class methodsFor:'behavior'!
+
+dragOutline
+ "if true, dragging is done by drawing outline only;
+ if false, dragging is done by full draw (fast servers only)
+ - can be redefined in subclasses"
+
+ ^ true
+! !
+
+!DisplayObject methodsFor:'initialization'!
+
+initialize
+ ^ self
+! !
+
+!DisplayObject methodsFor:'queries'!
+
+canBeMoved
+ "return true, if the receiver can be moved around"
+
+ ^ true
+!
+
+hasFixedSize
+ "return true, if the receiver has fixed size i.e. cannot be
+ resized
+ - by default, we do not allow resizing"
+
+ ^ true
+!
+
+isContainedIn:aRectangle
+ "object must decide, if its within a rectangle"
+
+ ^ aRectangle contains:frame
+!
+
+containsPoint: aPoint
+ ^ frame containsPoint: aPoint
+!
+
+intersects:aRectangle
+ "object must decide, if its intersecting a rectangle"
+
+ ^ frame intersects:aRectangle
+! !
+
+!DisplayObject methodsFor:'accessing'!
+
+frame
+ "object must return a frame boundary rectangle"
+
+ frame isNil ifTrue:[
+ frame := self computeBoundingBox
+ ].
+ ^ frame
+!
+
+width
+ "return the width of the frame"
+
+ frame isNil ifTrue:[
+ frame := self computeBoundingBox
+ ].
+ ^ frame width
+!
+
+height
+ "return the height of the frame"
+
+ frame isNil ifTrue:[
+ frame := self computeBoundingBox
+ ].
+ ^ frame height
+!
+
+extent
+ "return the extent of the frame"
+
+ frame isNil ifTrue:[
+ frame := self computeBoundingBox
+ ].
+ ^ frame extent
+!
+
+origin
+ "return the frame origin"
+
+ frame isNil ifTrue:[
+ frame := self computeBoundingBox
+ ].
+ ^ frame origin
+!
+
+corner
+ "return the frame corner"
+
+ frame isNil ifTrue:[
+ frame := self computeBoundingBox
+ ].
+ ^ frame corner
+!
+
+origin:origin
+ "object must calculate its dimension from outline"
+
+ ^ self subclassResponsibility
+!
+
+origin:origin corner:corner
+ "object must calculate its dimension from outline"
+
+ ^ self subclassResponsibility
+! !
+
+!DisplayObject methodsFor:'users actions'!
+
+moveTo:aPoint
+ "object must move to new origin
+ - default is to stay; ought to be redefined in subclass"
+
+ ^ self
+!
+
+keyInput:akey
+ ^ self
+! !
+
+!DisplayObject methodsFor:'queries'!
+
+isHitBy:aPoint withDelta:delta
+ "object must decide, if hit by a click at aPoint;
+ usually this method is redefined in subclasses for a more complete
+ check (i.e. if objects boundary is not rectangular)"
+
+ |org left right top bott px py d2|
+
+ (delta == 0) ifTrue:[
+ ^ frame containsPoint:aPoint
+ ].
+
+ "its quicker to not create a new rectangle for the test"
+ org := frame origin.
+ left := org x - delta.
+
+ px := aPoint x.
+ (px < left) ifTrue:[^ false].
+
+ d2 := delta * 2.
+ right := left + frame width + d2.
+ (px > right) ifTrue:[^ false].
+
+ top := org y - delta.
+ py := aPoint y.
+ (py < top) ifTrue:[^ false].
+
+ bott := top + frame height + d2.
+ (py > bott) ifTrue:[^ false].
+
+ ^ true
+!
+
+isHitBy:aPoint
+ "object must decide, if hit by a click at aPoint"
+
+ ^ self isHitBy:aPoint withDelta:0
+! !
+
+!DisplayObject methodsFor:'ST-80 drawing'!
+
+displayOn: aDisplayMedium
+ self drawIn:aDisplayMedium offset:0@0
+"
+ self displayOn:aDisplayMedium
+ at:0@0
+ clippingBox:nil
+ rule:#copy
+ mask:nil
+"
+!
+
+displayOn:aDisplayMedium at:aPoint clippingBox:clipRectangle
+ ^ self displayOn:aDisplayMedium
+ at:aPoint
+ clippingBox:clipRectangle
+ rule:#copy
+ mask:nil
+!
+
+displayOn:aDisplayMedium at:aPoint clippingBox:clip rule:rule mask: aForm
+ aDisplayMedium function:rule.
+ ^ self drawIn:aDisplayMedium
+ at:(aPoint + self origin)
+!
+
+displayOn:aDisplayMedium at:aPoint
+ ^ self drawIn:aDisplayMedium
+ at:(aPoint + self origin)
+! !
+
+!DisplayObject methodsFor:'drawing'!
+
+drawIn:aView offset:anOffset
+ "draw the receiver at its origin offset by anOffset, aPoint"
+
+ ^ self subclassResponsiblitity
+!
+
+drawIn:aView
+ "draw the receiver at its origin"
+
+ self drawIn:aView offset:(0@0)
+!
+
+drawIn:aView at:drawOrigin
+ "draw the receiver at drawOrigin, aPoint"
+
+ self drawIn:aView offset:(drawOrigin - (self origin))
+!
+
+drawSelectedIn:aView offset:anOffset
+ "draw the receiver highlighted - this is usually redefined"
+
+ self drawIn:aView offset:anOffset.
+ self drawOutlineIn:aView offset:anOffset
+!
+
+drawSelectedIn:aView
+ "draw the receiver highlighted at its position"
+
+ self drawSelectedIn:aView offset:(0@0)
+!
+
+drawOutlineIn:aView offset:anOffset
+ "draw the receivers outline at its origin offset by anOffset, aPoint"
+
+ |org|
+ org := self origin + anOffset - aView viewOrigin.
+ aView drawRectangleX:(org x) y:(org y)
+ width:(frame width) height:(frame height)
+!
+
+drawOutlineIn:aView
+ "draw the receivers outline at its origin"
+
+ self drawOutlineIn:aView offset:(0@0)
+!
+
+drawOutlineIn:aView at:drawOrigin
+ "draw the receivers outline at drawOrigin, aPoint"
+
+ self drawOutlineIn:aView offset:(drawOrigin - (self origin))
+!
+
+drawDragIn:aView at:drawOrigin
+ "draw the receiver for dragging"
+
+ self class dragOutline ifTrue:[
+ self drawOutlineIn:aView offset:(drawOrigin - (self origin))
+ ] ifFalse: [
+ self drawIn:aView offset:(drawOrigin - (self origin))
+ ]
+!
+
+drawDragIn:aView offset:drawOrigin
+ self class dragOutline ifTrue:[
+ self drawOutlineIn:aView offset:drawOrigin
+ ] ifFalse: [
+ self drawIn:aView offset:drawOrigin
+ ]
+!
+
+drawDragIn:aView
+ self class dragOutline ifTrue:[
+ self drawOutlineIn:aView offset:(0 @ 0)
+ ] ifFalse: [
+ self drawIn:aView offset:(0 @ 0)
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/DisplayObject.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,317 @@
+"
+ COPYRIGHT (c) 1989-92 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.
+"
+
+Object subclass:#DisplayObject
+ instanceVariableNames:'frame'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Graphics-Display Objects'
+!
+
+DisplayObject comment:'
+
+COPYRIGHT (c) 1989-92 by Claus Gittinger
+ All Rights Reserved
+
+generic superclass for Display Objects held in ObjectViews
+see DrawObject/LogicObject/DeskTopObject and subclasses for example use
+
+%W% %E%
+written fall/winter 89 by claus
+'!
+
+!DisplayObject class methodsFor:'instance creation'!
+
+new
+ ^ self basicNew initialize
+! !
+
+!DisplayObject class methodsFor:'behavior'!
+
+dragOutline
+ "if true, dragging is done by drawing outline only;
+ if false, dragging is done by full draw (fast servers only)
+ - can be redefined in subclasses"
+
+ ^ true
+! !
+
+!DisplayObject methodsFor:'initialization'!
+
+initialize
+ ^ self
+! !
+
+!DisplayObject methodsFor:'queries'!
+
+canBeMoved
+ "return true, if the receiver can be moved around"
+
+ ^ true
+!
+
+hasFixedSize
+ "return true, if the receiver has fixed size i.e. cannot be
+ resized
+ - by default, we do not allow resizing"
+
+ ^ true
+!
+
+isContainedIn:aRectangle
+ "object must decide, if its within a rectangle"
+
+ ^ aRectangle contains:frame
+!
+
+containsPoint: aPoint
+ ^ frame containsPoint: aPoint
+!
+
+intersects:aRectangle
+ "object must decide, if its intersecting a rectangle"
+
+ ^ frame intersects:aRectangle
+! !
+
+!DisplayObject methodsFor:'accessing'!
+
+frame
+ "object must return a frame boundary rectangle"
+
+ frame isNil ifTrue:[
+ frame := self computeBoundingBox
+ ].
+ ^ frame
+!
+
+width
+ "return the width of the frame"
+
+ frame isNil ifTrue:[
+ frame := self computeBoundingBox
+ ].
+ ^ frame width
+!
+
+height
+ "return the height of the frame"
+
+ frame isNil ifTrue:[
+ frame := self computeBoundingBox
+ ].
+ ^ frame height
+!
+
+extent
+ "return the extent of the frame"
+
+ frame isNil ifTrue:[
+ frame := self computeBoundingBox
+ ].
+ ^ frame extent
+!
+
+origin
+ "return the frame origin"
+
+ frame isNil ifTrue:[
+ frame := self computeBoundingBox
+ ].
+ ^ frame origin
+!
+
+corner
+ "return the frame corner"
+
+ frame isNil ifTrue:[
+ frame := self computeBoundingBox
+ ].
+ ^ frame corner
+!
+
+origin:origin
+ "object must calculate its dimension from outline"
+
+ ^ self subclassResponsibility
+!
+
+origin:origin corner:corner
+ "object must calculate its dimension from outline"
+
+ ^ self subclassResponsibility
+! !
+
+!DisplayObject methodsFor:'users actions'!
+
+moveTo:aPoint
+ "object must move to new origin
+ - default is to stay; ought to be redefined in subclass"
+
+ ^ self
+!
+
+keyInput:akey
+ ^ self
+! !
+
+!DisplayObject methodsFor:'queries'!
+
+isHitBy:aPoint withDelta:delta
+ "object must decide, if hit by a click at aPoint;
+ usually this method is redefined in subclasses for a more complete
+ check (i.e. if objects boundary is not rectangular)"
+
+ |org left right top bott px py d2|
+
+ (delta == 0) ifTrue:[
+ ^ frame containsPoint:aPoint
+ ].
+
+ "its quicker to not create a new rectangle for the test"
+ org := frame origin.
+ left := org x - delta.
+
+ px := aPoint x.
+ (px < left) ifTrue:[^ false].
+
+ d2 := delta * 2.
+ right := left + frame width + d2.
+ (px > right) ifTrue:[^ false].
+
+ top := org y - delta.
+ py := aPoint y.
+ (py < top) ifTrue:[^ false].
+
+ bott := top + frame height + d2.
+ (py > bott) ifTrue:[^ false].
+
+ ^ true
+!
+
+isHitBy:aPoint
+ "object must decide, if hit by a click at aPoint"
+
+ ^ self isHitBy:aPoint withDelta:0
+! !
+
+!DisplayObject methodsFor:'ST-80 drawing'!
+
+displayOn: aDisplayMedium
+ self drawIn:aDisplayMedium offset:0@0
+"
+ self displayOn:aDisplayMedium
+ at:0@0
+ clippingBox:nil
+ rule:#copy
+ mask:nil
+"
+!
+
+displayOn:aDisplayMedium at:aPoint clippingBox:clipRectangle
+ ^ self displayOn:aDisplayMedium
+ at:aPoint
+ clippingBox:clipRectangle
+ rule:#copy
+ mask:nil
+!
+
+displayOn:aDisplayMedium at:aPoint clippingBox:clip rule:rule mask: aForm
+ aDisplayMedium function:rule.
+ ^ self drawIn:aDisplayMedium
+ at:(aPoint + self origin)
+!
+
+displayOn:aDisplayMedium at:aPoint
+ ^ self drawIn:aDisplayMedium
+ at:(aPoint + self origin)
+! !
+
+!DisplayObject methodsFor:'drawing'!
+
+drawIn:aView offset:anOffset
+ "draw the receiver at its origin offset by anOffset, aPoint"
+
+ ^ self subclassResponsiblitity
+!
+
+drawIn:aView
+ "draw the receiver at its origin"
+
+ self drawIn:aView offset:(0@0)
+!
+
+drawIn:aView at:drawOrigin
+ "draw the receiver at drawOrigin, aPoint"
+
+ self drawIn:aView offset:(drawOrigin - (self origin))
+!
+
+drawSelectedIn:aView offset:anOffset
+ "draw the receiver highlighted - this is usually redefined"
+
+ self drawIn:aView offset:anOffset.
+ self drawOutlineIn:aView offset:anOffset
+!
+
+drawSelectedIn:aView
+ "draw the receiver highlighted at its position"
+
+ self drawSelectedIn:aView offset:(0@0)
+!
+
+drawOutlineIn:aView offset:anOffset
+ "draw the receivers outline at its origin offset by anOffset, aPoint"
+
+ |org|
+ org := self origin + anOffset - aView viewOrigin.
+ aView drawRectangleX:(org x) y:(org y)
+ width:(frame width) height:(frame height)
+!
+
+drawOutlineIn:aView
+ "draw the receivers outline at its origin"
+
+ self drawOutlineIn:aView offset:(0@0)
+!
+
+drawOutlineIn:aView at:drawOrigin
+ "draw the receivers outline at drawOrigin, aPoint"
+
+ self drawOutlineIn:aView offset:(drawOrigin - (self origin))
+!
+
+drawDragIn:aView at:drawOrigin
+ "draw the receiver for dragging"
+
+ self class dragOutline ifTrue:[
+ self drawOutlineIn:aView offset:(drawOrigin - (self origin))
+ ] ifFalse: [
+ self drawIn:aView offset:(drawOrigin - (self origin))
+ ]
+!
+
+drawDragIn:aView offset:drawOrigin
+ self class dragOutline ifTrue:[
+ self drawOutlineIn:aView offset:drawOrigin
+ ] ifFalse: [
+ self drawIn:aView offset:drawOrigin
+ ]
+!
+
+drawDragIn:aView
+ self class dragOutline ifTrue:[
+ self drawOutlineIn:aView offset:(0 @ 0)
+ ] ifFalse: [
+ self drawIn:aView offset:(0 @ 0)
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/FaceReader.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,80 @@
+'From Smalltalk/X, Version:2.6.4 on 30-Apr-1993 at 18:40:58'!
+
+ImageReader subclass:#FaceReader
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Graphics-Support'
+!
+
+!FaceReader methodsFor:'reading from file'!
+
+fromFile:aFileName
+ |line
+ index "{ Class: SmallInteger }"
+ dstIndex "{ Class: SmallInteger }"
+ bytesPerRow
+ lo "{ Class: SmallInteger }"
+ hi "{ Class: SmallInteger }"
+ val "{ Class: SmallInteger }"
+ inHeader s depth|
+
+ inStream := FileStream readonlyFileNamed:aFileName.
+ inStream isNil ifTrue:[
+ 'open error' printNewline.
+ ^ nil
+ ].
+
+ line := inStream nextLine.
+ line isNil ifTrue:[
+ inStream close.
+ ^ nil
+ ].
+
+ inHeader := true.
+ [inHeader] whileTrue:[
+ (line startsWith:'Image:') ifTrue:[
+ s := ReadStream on:line.
+ s position:7.
+ width := Number readFrom:s.
+ height := Number readFrom:s.
+ depth := Number readFrom:s.
+ inHeader := false.
+ ].
+ line := inStream nextLine
+ ].
+
+ depth == 8 ifFalse:[
+ self error:'only depth 8 supported'
+ ].
+
+ [line isEmpty] whileTrue:[
+ line := inStream nextLine.
+ ].
+
+
+ bytesPerRow := width * depth // 8.
+ ((width * depth \\ 8) ~~ 0) ifTrue:[
+ bytesPerRow := bytesPerRow + 1
+ ].
+
+ data := ByteArray new:(bytesPerRow * height).
+ dstIndex := data size.
+
+ [line notNil] whileTrue:[
+ 1 to:(line size) by:2 do:[:cI |
+ hi := (line at:cI) digitValue.
+ lo := (line at:(cI + 1)) digitValue.
+ val := (hi bitShift:4) bitOr:lo.
+ data at:dstIndex put:val.
+ dstIndex := dstIndex - 1
+ ].
+ line := inStream nextLine
+ ].
+ photometric := #whiteIs0.
+ samplesPerPixel := 1.
+ bitsPerSample := #(8)
+
+ "FaceReader fromFile:'../goodies/faces/next.com/steve.face'"
+ "this is NOT steve jobs :-)"
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/GIFReader.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,229 @@
+"
+ COPYRIGHT (c) 1991-93 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.
+"
+
+ImageReader subclass:#GIFReader
+ instanceVariableNames:'redMap greenMap blueMap'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Graphics-Support'
+!
+
+GIFReader comment:'
+
+COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+
+written Dec 91 by claus
+'!
+
+!GIFReader class methodsFor:'documentation'!
+
+documentation
+"
+ this class provides methods for loading and saving GIF pictures.
+ It has been tested with some different GIF89a pictures, I dont
+ know, if it works with other GIF versions.
+ GIF extension blocks are not handled.
+
+ GIF file writing is not implemented (use TIFF).
+
+ legal stuff extracted from GIF89a documentation:
+
+ CompuServe Incorporated hereby grants a limited, non-exclusive, royalty-free
+ license for the use of the Graphics Interchange Format(sm) in computer
+ software; computer software utilizing GIF(sm) must acknowledge ownership of the
+ Graphics Interchange Format and its Service Mark by CompuServe Incorporated, in
+ User and Technical Documentation.
+
+ The Graphics Interchange Format(c) is the Copyright property of
+ CompuServe Incorporated. GIF(sm) is a Service Mark property of
+ CompuServe Incorporated.
+"
+! !
+
+!GIFReader methodsFor:'reading from file'!
+
+fromFile:aFileName
+ "read a GIF file"
+
+ |byte index
+ colorMapSize bitsPerPixel scrWidth scrHeight
+ hasColorMap hasLocalColorMap interlaced id
+ leftOffs topOffs codeLen
+ compressedData compressedSize
+ tmp srcOffset dstOffset|
+
+ inStream := FileStream readonlyFileNamed:aFileName.
+ inStream isNil ifTrue:[
+ 'open error' printNewline.
+ ^ nil
+ ].
+
+ byteOrder := #lsb.
+
+ id := String new:6.
+ inStream nextBytes:6 into:id.
+
+ "all I had for testing where GIF87a files;
+ I hope later versions work too ..."
+
+ (id ~= 'GIF87a') ifTrue:[
+ (id startsWith:'GIF') ifFalse:[
+ 'not a gif file' printNewline.
+ inStream close.
+ ^ nil
+ ].
+ 'not a gif87a file - hope that works' printNewline.
+ ].
+
+ "get screen dimensions (not used)"
+
+ scrWidth := self readShort.
+ scrHeight := self readShort.
+
+ "get flag byte"
+ byte := inStream nextByte.
+ hasColorMap := (byte bitAnd:2r10000000) ~~ 0.
+ "bitsPerRGB := ((byte bitAnd:2r01110000) bitShift:-4) + 1. "
+ "colorMapSorted := ((byte bitAnd:2r00001000) ~~ 0. "
+ bitsPerPixel := (byte bitAnd:2r00000111) + 1.
+ colorMapSize := 1 bitShift:bitsPerPixel.
+
+ "get background (not used)"
+ byte := inStream nextByte.
+
+ "aspect ratio"
+ byte := inStream nextByte.
+
+ "get colorMap"
+ hasColorMap ifTrue:[
+ self readColorMap:colorMapSize
+ ].
+
+ "image separator"
+ byte := inStream nextByte.
+ (byte ~~ 16r2C) ifTrue:[
+ 'corrupted gif file (no imgSep)' printNewline.
+ ^ nil
+ ].
+
+ "get image data"
+ leftOffs := self readShort.
+ topOffs := self readShort.
+ width := self readShort.
+ height := self readShort.
+
+'width ' print. width printNewline.
+'height ' print. height printNewline.
+
+ byte := inStream nextByte.
+ interlaced := (byte bitAnd:2r01000000) ~~ 0.
+ hasLocalColorMap := (byte bitAnd:2r10000000) ~~ 0.
+ "localColorMapSorted := (byte bitAnd:2r00100000) ~~ 0. "
+
+ hasLocalColorMap ifTrue:[
+ "local descr. overwrites"
+ bitsPerPixel := (byte bitAnd:2r00000111) + 1.
+ colorMapSize := 1 bitShift:bitsPerPixel.
+" 'local colormap' printNewline. "
+ "overwrite colormap"
+ self readColorMap:colorMapSize
+ ].
+
+ codeLen := inStream nextByte.
+
+ compressedData := ByteArray uninitializedNew:(inStream size).
+
+ index := 1.
+ byte := inStream nextByte.
+ [byte notNil and:[byte ~~ 0]] whileTrue:[
+ inStream nextBytes:byte into:compressedData startingAt:index.
+ index := index + byte.
+ byte := inStream nextByte
+ ].
+ compressedSize := index - 1.
+ inStream close.
+
+ data := ByteArray uninitializedNew:((width + 1) * (height + 1)).
+ Transcript showCr:'decompressing'.
+
+ self class decompressGIFFrom:compressedData
+ count:compressedSize
+ into:data
+ startingAt:1
+ codeLen:(codeLen + 1).
+
+ interlaced ifTrue:[
+ tmp := ByteArray uninitializedNew:(data size).
+
+ "phase 1: 0, 8, 16, 24, ..."
+
+ srcOffset := 1.
+ 0 to:(height - 1) by:8 do:[:dstRow |
+ dstOffset := dstRow * width + 1.
+ tmp replaceFrom:dstOffset to:(dstOffset + width - 1)
+ with:data startingAt:srcOffset.
+ srcOffset := srcOffset + width.
+ ].
+
+ "phase 2: 4, 12, 20, 28, ..."
+
+ 4 to:(height - 1) by:8 do:[:dstRow |
+ dstOffset := dstRow * width + 1.
+ tmp replaceFrom:dstOffset to:(dstOffset + width - 1)
+ with:data startingAt:srcOffset.
+ srcOffset := srcOffset + width.
+ ].
+
+ "phase 3: 2, 6, 10, 14, ..."
+
+ 2 to:(height - 1) by:4 do:[:dstRow |
+ dstOffset := dstRow * width + 1.
+ tmp replaceFrom:dstOffset to:(dstOffset + width - 1)
+ with:data startingAt:srcOffset.
+ srcOffset := srcOffset + width.
+ ].
+
+ "phase 4: 1, 3, 5, 7, ..."
+
+ 1 to:(height - 1) by:2 do:[:dstRow |
+ dstOffset := dstRow * width + 1.
+ tmp replaceFrom:dstOffset to:(dstOffset + width - 1)
+ with:data startingAt:srcOffset.
+ srcOffset := srcOffset + width.
+ ].
+
+ data := tmp.
+ tmp := nil
+ ].
+
+ photometric := #palette.
+ samplesPerPixel := 1.
+ bitsPerSample := #(8).
+ colorMap := Array with:redMap with:greenMap with:blueMap.
+
+ "GIFReader fromFile:'../fileIn/bitmaps/claus.gif"
+ "GIFReader fromFile:'../fileIn/bitmaps/garfield.gif'"
+!
+
+readColorMap:colorMapSize
+ redMap := Array new:colorMapSize.
+ greenMap := Array new:colorMapSize.
+ blueMap := Array new:colorMapSize.
+ 1 to:colorMapSize do:[:i |
+ redMap at:i put:(inStream nextByte).
+ greenMap at:i put:(inStream nextByte).
+ blueMap at:i put:(inStream nextByte)
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/HersheyFont.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,540 @@
+'From Smalltalk/X, Version:2.5.1 on 29-Jan-1993 at 12:13:27'!
+
+Font subclass:#HersheyFont
+ instanceVariableNames:'glyphs scale'
+ classVariableNames:'knownFonts glyphData'
+ poolDictionaries:''
+ category:'Graphics-Support'
+!
+
+HersheyFont comment:'Support for hershey fonts is based on a freeware cd-rom distribution
+by DEC. This disk contains the hershey outlines and glyph maps of
+the following fonts:
+
+Fonts:
+ Roman: Plain, Simplex, Duplex, Complex Small, Complex, Triplex
+ Italic: Complex Small, Complex, Triplex
+ Script: Simplex, Complex
+ Gothic: German, English, Italian
+ Greek: Plain, Simplex, Complex Small, Complex
+ Cyrillic: Complex
+
+Symbols:
+ Mathematical
+ Daggers
+ Astronomical
+ Astrological
+ Musical
+ Typesetting (ffl,fl,fi sorts of things)
+ Miscellaneous:
+ - Playing card suits
+ - Meteorology
+ - Graphics (lines, curves)
+ - Electrical
+ - Geometric (shapes)
+ - Cartographic
+ - Naval
+ - Agricultural
+ - Highways
+ - Etc...
+
+Legal notice:
+ This distribution of the Hershey Fonts may be used by anyone for
+ any purpose, commercial or otherwise, providing that:
+ 1. The following acknowledgements must be distributed with
+ the font data:
+ - The Hershey Fonts were originally created by Dr.
+ A. V. Hershey while working at the U. S.
+ National Bureau of Standards.
+ - The format of the Font data in this distribution
+ was originally created by
+ James Hurt
+ Cognition, Inc.
+ 900 Technology Park Drive
+ Billerica, MA 01821
+ (mit-eddie!!ci-dandelion!!hurt)
+ 2. The font data in this distribution may be converted into
+ any other format *EXCEPT* the format distributed by
+ the U.S. NTIS (which organization holds the rights
+ to the distribution and use of the font data in that
+ particular format). Not that anybody would really
+ *want* to use their format... each point is described
+ in eight bytes as "xxx yyy:", where xxx and yyy are
+ the coordinate values as ASCII numbers.
+'!
+
+!HersheyFont class methodsFor:'private'!
+
+readDataFile
+ |inStream b5 b3 chars moves glyphNo nPairs char1 char2 index|
+
+ inStream := FileStream readonlyFileNamed:'/LocalLibrary/Fonts/hershey/data/hersh.oc'.
+
+ glyphData isNil ifTrue:[
+ Transcript showCr:'reading hershey glyphs ...'.
+ glyphData := VariableArray new:4000.
+ b5 := String new:5.
+ b3 := String new:3.
+ [inStream atEnd] whileFalse:[
+ chars := inStream nextBytes:5 into:b5.
+ glyphNo := Number readFromString:b5.
+ chars := inStream nextBytes:3 into:b3.
+ nPairs := Number readFromString:b3.
+ moves := String new:(nPairs * 2).
+ index := 1.
+ 1 to:nPairs do:[:i |
+ char1 := inStream next.
+ char1 == Character nl ifTrue:[
+ char1 := inStream next
+ ].
+ char2 := inStream next.
+ char2 == Character nl ifTrue:[
+ char2 := inStream next
+ ].
+ moves at:index put:char1.
+ index := index + 1.
+ moves at:index put:char2.
+ index := index + 1
+ ].
+ glyphData at:glyphNo put:moves.
+ [inStream peek == Character nl] whileTrue:[inStream next]
+ ].
+ inStream close
+ ]
+
+ "HersheyFont readDataFile"
+!
+
+name:aFileName family:family face:face style:style size:sz
+ "return a font with glyph-data from aFileName"
+
+ |newFont|
+
+ newFont := self basicNew readGlyphsFrom:aFileName.
+ newFont family:family face:face style:style size:sz.
+ ^ newFont
+
+ "HersheyFont name:'gothger'"
+! !
+
+!HersheyFont class methodsFor:'drawing'!
+
+drawGlyph:glyphNo in:aGC x:x y:y scale:aScale
+ |moves c1 c2 xPos yPos nX nY draw w h savedLW|
+
+ moves := glyphData at:glyphNo.
+ moves isNil ifTrue:[
+ Transcript showCr:('no glyph for ' , glyphNo printString).
+ ^ self
+ ].
+ savedLW := aGC lineWidth.
+ aGC lineWidth:(aScale * 2) rounded.
+
+ xPos := 0 "x".
+ yPos := 0 "y".
+ draw := false. "start with a skip"
+ w := ((moves at:1) asciiValue - $R asciiValue)" * aScale".
+ h := ($R asciiValue - (moves at:2) asciiValue)" negated * aScale".
+ w := w negated * aScale * 2.
+ h := h negated * aScale * 2.
+
+ 3 to:(moves size) by:2 do:[:index |
+ c1 := moves at:index.
+ c2 := moves at:(index + 1).
+ c1 == Character space ifTrue:[
+ draw := false
+ ] ifFalse:[
+ nX := "xPos +" ((c1 asciiValue - $R asciiValue) * aScale).
+ nY := "yPos +" (($R asciiValue - c2 asciiValue) negated * aScale).
+ draw ifTrue:[
+ aGC displayLineFromX:((x + xPos) truncated "rounded")
+ y:((y + yPos) truncated "rounded")
+ toX:((x + nX) truncated "rounded")
+ y:((y + nY) truncated "rounded").
+ ].
+ xPos := nX.
+ yPos := nY.
+ draw := true
+ ]
+ ].
+ aGC lineWidth:savedLW
+
+ "Smalltalk at:#v put:nil.
+ Smalltalk at:#f put:nil.
+ v := View new realize.
+
+ v clear.
+ v font:(f := HersheyFont family:'hershey-times' face:'bold' style:'roman' size:12).
+ v displayString:'hello' x:50 y:50"
+!
+
+widthOfGlyph:glyphNo scale:aScale
+ |moves w|
+
+ moves := glyphData at:glyphNo.
+ moves isNil ifTrue:[
+ Transcript showCr:('no glyph for ' , glyphNo printString).
+ ^ 0
+ ].
+
+ w := ((moves at:1) asciiValue - $R asciiValue).
+ w := w negated * aScale * 2.
+ ^ w
+
+ "HersheyFont widthOfGlyph:3401 scale:1"
+!
+
+heightOfGlyph:glyphNo scale:aScale
+ |moves h|
+
+ moves := glyphData at:glyphNo.
+ moves isNil ifTrue:[
+ Transcript showCr:('no glyph for ' , glyphNo printString).
+ ^ 0
+ ].
+
+ h := ($R asciiValue - (moves at:2) asciiValue)" negated * aScale".
+ h := h negated * aScale * 2.
+ ^ h
+! !
+
+!HersheyFont class methodsFor:'instance creation'!
+
+family:family face:face style:style size:sz
+ |fontNames|
+
+ fontNames := #(
+ ('hershey-times' 'bold' 'roman' 'romant')
+ ('hershey-times' 'medium' 'roman' 'romanc')
+ ('hershey-times' 'medium' 'italic' 'italicc')
+ ('hershey-times' 'bold' 'italic' 'italict')
+ ('hershey-times' 'bold' 'greek' 'greekc')
+
+ ('hershey-japan' 'bold' 'normal' 'japan')
+
+ ('hershey-gothic-german' 'bold' 'roman' 'gothger')
+ ('hershey-gothic-english' 'bold' 'roman' 'gotheng')
+ ('hershey-gothic-italian' 'bold' 'roman' 'gothita')
+
+ ('hershey-cursive' 'medium' 'roman' 'scripts')
+ ('hershey-script' 'bold' 'roman' 'scriptc')
+
+ ('hershey-futura' 'medium' 'roman' 'romans')
+ ('hershey-futura' 'bold' 'roman' 'romand')
+
+ ('hershey-markers' 'medium' 'roman' 'marker')
+ ('hershey-math1' 'medium' 'roman' 'lowmat')
+ ('hershey-math2' 'medium' 'roman' 'uppmat')
+ ('hershey-symbol' 'medium' 'roman' 'symbol')
+
+ ('hershey-astrology' 'bold' 'roman' 'astrol')
+ ('hershey-meteorology' 'medium' 'roman' 'meteo')
+ ('hershey-music' 'bold' 'roman' 'music')
+ ).
+
+ fontNames do:[:entry |
+ (entry at:1) = family ifTrue:[
+ (entry at:2) = face ifTrue:[
+ (entry at:3) = style ifTrue:[
+ ^ self name:(entry at:4) family:family face:face style:style size:sz
+ ]
+ ]
+ ]
+ ].
+ ^ nil
+
+ "HersheyFont family:'hershey-gothic-german' face:'medium' style:'roman' size:12"
+! !
+
+!HersheyFont class methodsFor:'examples'!
+
+showFont:f in:aView
+ "
+ Smalltalk at:#aView put:(View new extent:500@200) realize.
+ aView backingStore:true.
+ HersheyFont showFont:(HersheyFont family:'hershey-astrology'
+ face:'bold'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-music'
+ face:'bold'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-meteorology'
+ face:'medium'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-cursive'
+ face:'medium'
+ style:'roman'
+ size:10) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-cursive'
+ face:'medium'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-cursive'
+ face:'medium'
+ style:'roman'
+ size:48) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-script'
+ face:'bold'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-times'
+ face:'medium'
+ style:'roman'
+ size:12) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-times'
+ face:'medium'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-times'
+ face:'medium'
+ style:'roman'
+ size:48) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-times'
+ face:'bold'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-times'
+ face:'medium'
+ style:'italic'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-times'
+ face:'bold'
+ style:'italic'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-futura'
+ face:'medium'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-futura'
+ face:'bold'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-markers'
+ face:'medium'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-math1'
+ face:'medium'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-math2'
+ face:'medium'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-symbol'
+ face:'medium'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-gothic-italian'
+ face:'bold'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-gothic-german'
+ face:'bold'
+ style:'roman'
+ size:24) in:aView
+
+ HersheyFont showFont:(HersheyFont family:'hershey-gothic-english'
+ face:'bold'
+ style:'roman'
+ size:24) in:aView
+ "
+
+ |x y dy|
+
+ dy := f heightOn:aView device.
+ aView clear.
+ x := 100. y := dy.
+ 32 to:47 do:[:i |
+ f drawCharacter:i in:aView x:x y:y.
+ x := x + 30
+ ].
+
+ x := 100. y := y + dy.
+ 48 to:57 do:[:i |
+ f drawCharacter:i in:aView x:x y:y.
+ x := x + 30
+ ].
+
+ x := 100. y := y + dy.
+ 58 to:64 do:[:i |
+ f drawCharacter:i in:aView x:x y:y.
+ x := x + 30
+ ].
+
+ x := 100. y := y + dy.
+ 65 to:90 do:[:i |
+ f drawCharacter:i in:aView x:x y:y.
+ x := x + 30
+ ].
+
+ x := 100. y := y + dy.
+ 91 to:96 do:[:i |
+ f drawCharacter:i in:aView x:x y:y.
+ x := x + 30
+ ].
+
+ x := 100. y := y + dy.
+ 97 to:122 do:[:i |
+ f drawCharacter:i in:aView x:x y:y.
+ x := x + 30
+ ].
+
+ x := 100. y := y + dy.
+ 123 to:127 do:[:i |
+ f drawCharacter:i in:aView x:x y:y.
+ x := x + 30
+ ]
+! !
+
+!HersheyFont methodsFor:'private'!
+
+readGlyphsFrom:aFileName
+ "read glyph definitions from aFileName"
+
+ |inStream ascii index1 index2|
+
+ self class readDataFile.
+ glyphs := Array new:(256 - 32).
+ inStream := FileStream readonlyFileNamed:('/LocalLibrary/Fonts/hershey/fonts/',aFileName,'.hmp').
+ ascii := 32.
+ [inStream atEnd] whileFalse:[
+ index1 := Number readFrom:inStream.
+ index2 := Number readFrom:inStream.
+ index2 == 0 ifTrue:[
+ index2 := index1
+ ].
+ index1 to:index2 do:[:pos |
+ glyphs at:(ascii - 32 + 1) put:pos.
+ ascii := ascii + 1
+ ].
+ inStream skipSeparators
+ ].
+ inStream close.
+ ^ self
+!
+
+scale:aScale
+ scale := aScale
+!
+
+family:fam face:fac style:st size:sz
+ family := fam.
+ face := fac.
+ style := st.
+ size := sz.
+ scale := sz / 24
+! !
+
+!HersheyFont methodsFor:'queries'!
+
+ascentOn:aDevice
+ ^ 0
+!
+
+descentOn:aDevice
+ ^ self heightOn:aDevice
+!
+
+heightOn:aDevice
+ ^ scale * (24 + 12)
+!
+
+widthOfCharacter:ascii
+ |glyphNo|
+
+ (ascii between:32 and:127) ifFalse:[^ 0].
+ glyphNo := glyphs at:(ascii - 32 + 1).
+ glyphNo isNil ifTrue:[^ 0].
+ ^ self class widthOfGlyph:glyphNo scale:scale
+!
+
+heightOfCharacter:ascii
+ |glyphNo|
+
+ (ascii between:32 and:127) ifFalse:[^ 0].
+ glyphNo := glyphs at:(ascii - 32 + 1).
+ glyphNo isNil ifTrue:[^ 0].
+ ^ self class heightOfGlyph:glyphNo scale:scale
+!
+
+widthOf:aString from:start to:stop
+ "return the width of a substring"
+
+ |sumW|
+
+ (stop < start) ifTrue:[^ 0].
+ sumW := 0.
+ start to:stop do:[:index |
+ sumW := sumW + (self widthOfCharacter:(aString at:index) asciiValue)
+ ].
+ ^ sumW
+!
+
+widthOf:aString
+ |sumW|
+
+ sumW := 0.
+ aString do:[:character |
+ sumW := sumW + (self widthOfCharacter:character asciiValue)
+ ].
+ ^ sumW
+!
+
+on:aDevice
+ ^ self
+! !
+
+!HersheyFont methodsFor:'drawing'!
+
+drawCharacter:ascii in:aGC x:x y:y
+ |glyphNo|
+
+ (ascii between:32 and:127) ifFalse:[^ self].
+ glyphNo := glyphs at:(ascii - 32 + 1).
+ glyphNo isNil ifTrue:[^ self].
+ self class drawGlyph:glyphNo in:aGC x:x y:y scale:scale
+!
+
+displayString:aString from:index1 to:index2 x:x0 y:y in:aGC
+ |x|
+
+ x := x0.
+ index1 to:index2 do:[:index |
+ self drawCharacter:(aString at:index) asciiValue in:aGC x:x y:y.
+ x := x + (self widthOfCharacter:(aString at:index) asciiValue)
+ ]
+!
+
+displayString:aString x:x0 y:y in:aGC
+ |x|
+
+ x := x0.
+ aString do:[:character |
+ self drawCharacter:character asciiValue in:aGC x:x y:y.
+ x := x + (self widthOfCharacter:character asciiValue)
+ ]
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/InputView.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,117 @@
+"
+ COPYRIGHT (c) 1990/91 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.
+"
+
+View subclass:#InputView
+ instanceVariableNames:'eventReceiver'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category:'Views-Basic'
+!
+
+InputView comment:'
+
+COPYRIGHT (c) 1990/91 by Claus Gittinger
+ All Rights Reserved
+
+a view for input only - forwarding all events to another object.
+This kind of view can be used to be laid ontop of another view to catch all
+input. (Interface builder)
+
+@(#)InputView.st 3.2 92/07/14
+
+written spring 90 by claus
+'!
+
+!InputView methodsFor:'initialization'!
+
+initialize
+ super initialize.
+ borderWidth := 0
+! !
+
+!InputView methodsFor:'accessing'!
+
+inputOnly
+ ^ true
+!
+
+eventReceiver:aView
+ eventReceiver := aView
+! !
+
+!InputView methodsFor:'event handling'!
+
+exposeX:x y:y width:w height:h
+ "will never be received"
+ ^ self
+!
+
+keyPress:key x:x y:y
+ eventReceiver notNil ifTrue:[
+ eventReceiver keyPress:key x:x y:y
+ ]
+!
+
+keyRelease:key x:x y:y
+ eventReceiver notNil ifTrue:[
+ eventReceiver keyRelease:key x:x y:y
+ ]
+!
+
+buttonShiftPress:button x:x y:y
+ eventReceiver notNil ifTrue:[
+ eventReceiver buttonShiftPress:button x:x y:y
+ ]
+!
+
+buttonPress:button x:x y:y
+ eventReceiver notNil ifTrue:[
+ eventReceiver buttonPress:button x:x y:y
+ ]
+!
+
+buttonRelease:button x:x y:y
+ eventReceiver notNil ifTrue:[
+ eventReceiver buttonRelease:button x:x y:y
+ ]
+!
+
+buttonMotion:state x:x y:y
+ eventReceiver notNil ifTrue:[
+ eventReceiver buttonMotion:state x:x y:y
+ ]
+!
+
+focusIn
+ eventReceiver notNil ifTrue:[
+ eventReceiver focusIn
+ ]
+!
+
+focusOut
+ eventReceiver notNil ifTrue:[
+ eventReceiver focusOut
+ ]
+!
+
+pointerEnter:state x:x y:y
+ eventReceiver notNil ifTrue:[
+ eventReceiver pointerEnter:state x:x y:y
+ ]
+!
+
+pointerLeave:state
+ eventReceiver notNil ifTrue:[
+ eventReceiver pointerLeave:state
+ ]
+! !
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Model.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,107 @@
+"
+ COPYRIGHT (c) 1992-93 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.
+"
+
+Object subclass:#Model
+ instanceVariableNames:'dependents'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Interface-Support'
+!
+
+Model comment:'
+
+COPYRIGHT (c) 1992-93 by Claus Gittinger
+ All Rights Reserved
+
+Model are things that can be displayed in a view. I keep track of
+which views are dependeent of me and inform them of any changes.
+I know how to display myself in a GraphicsContext.
+This was written to be more ST-80 conform.
+
+Instance variables:
+ dependentViews Collection the views knowing me
+
+%W% %E%
+written summer 92 by claus
+'!
+
+!Model methodsFor:'accessing'!
+
+addDependent:aView
+ "make the argument, anObject be dependent of the receiver"
+
+ dependents isNil ifTrue:[
+ dependents := IdentitySet new
+ ].
+ dependents add:aView
+!
+
+removeDependent:anObject
+ "make the argument, anObject be independent of the receiver"
+
+ dependents notNil ifTrue:[
+ dependents remove:anObject ifAbsent:[]
+ ]
+!
+
+dependents
+ "return a Collection of dependents - nil if there is none"
+
+ ^ dependents
+!
+
+release
+ "remove all dependencies from the receiver"
+
+ dependents := nil
+! !
+
+!Model methodsFor:'events'!
+
+changed:something with:arguments
+ dependents notNil ifTrue:[
+ dependents do:[:someOne |
+ someOne update:something with:arguments
+ ]
+ ]
+!
+
+changed:something
+ dependents notNil ifTrue:[
+ dependents do:[:someOne |
+ someOne update:something
+ ]
+ ]
+!
+
+changed
+ dependents notNil ifTrue:[
+ dependents do:[:someOne |
+ someOne update:self
+ ]
+ ]
+! !
+
+!Model methodsFor:'drawing'!
+
+displayOn:aGraphicsContext clippingBox:aRectangle
+ "display a part of me in aGraphicsContext"
+
+ ^ self subclassResponsibility
+!
+
+displayOn:aGraphicsContext
+ "display myself in aGraphicsContext"
+
+ ^ self subclassResponsibility
+
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/StandardSystemController.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,36 @@
+"
+ COPYRIGHT (c) 1993 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.
+"
+
+Controller subclass:#StandardSystemController
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'ST-80 compatibility'!
+
+StandardSystemController comment:'
+
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+COntroller for StandardSystemViews i.e. top views. There is nothing done here
+since all action is done in window manager. This class exists for ST-80 com-
+patibility mainly.
+
+%W% %E%
+written spring 93 by claus
+'!
+
+!StandardSystemController methodsFor:'startup'!
+
+open
+ view realize
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/StdSysC.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,36 @@
+"
+ COPYRIGHT (c) 1993 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.
+"
+
+Controller subclass:#StandardSystemController
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'ST-80 compatibility'!
+
+StandardSystemController comment:'
+
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+COntroller for StandardSystemViews i.e. top views. There is nothing done here
+since all action is done in window manager. This class exists for ST-80 com-
+patibility mainly.
+
+%W% %E%
+written spring 93 by claus
+'!
+
+!StandardSystemController methodsFor:'startup'!
+
+open
+ view realize
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/SunRasterReader.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,135 @@
+"
+ COPYRIGHT (c) 1993 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.
+"
+
+ImageReader subclass:#SunRasterReader
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Graphics-Support'
+!
+
+SunRasterReader comment:'
+
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+this class provides methods for loading Sun Raster file images
+
+%W% %E%
+written Summer 91 by claus
+'!
+
+!SunRasterReader methodsFor:'reading from file'!
+
+fromFile: aFilename
+ | rasterType mapType mapBytes imageWords form depth
+ rMap gMap bMap mapLen
+ bits a b c index|
+
+ inStream := FileStream readonlyFileNamed:aFilename.
+ inStream isNil ifTrue:[
+ 'open error' printNewline.
+ ^ nil
+ ].
+
+ inStream binary.
+
+ ((inStream nextWord = 16r59A6)
+ and:[inStream nextWord = 16r6A95]) ifFalse: [
+"
+ inStream nextLong = 16r59A66A95 ifFalse: [
+"
+ inStream close.
+ self error: 'Not a Sun Raster File (bad magic number)'
+ ].
+
+ width := inStream nextLong.
+ height := inStream nextLong.
+
+ depth := inStream nextLong.
+ inStream nextLong. "Ignore the image length since I can't rely on it anyway."
+ rasterType _ inStream nextLong.
+ mapType := inStream nextLong. "Ignore the raster maptype."
+ mapBytes := inStream nextLong.
+
+ depth = 8 ifTrue: [
+ mapLen := (mapBytes // 3).
+ rMap := ByteArray new:mapLen.
+ gMap := ByteArray new:mapLen.
+ bMap := ByteArray new:mapLen.
+ inStream nextBytes:mapLen into:rMap.
+ inStream nextBytes:mapLen into:gMap.
+ inStream nextBytes:mapLen into:bMap.
+
+ data := ByteArray new:(width * height).
+ inStream nextBytes:(width * height) into:data.
+
+ photometric := #palette.
+ samplesPerPixel := 1.
+ bitsPerSample := #(8).
+ colorMap := Array with:rMap with:gMap with:bMap.
+ inStream close.
+ ^ self
+ ].
+ depth ~~ 1 ifTrue: [
+ inStream close.
+ self error: 'Raster file is not monochrome'
+ ].
+
+ form := nil.
+
+ inStream skip: mapBytes. "Skip the color map."
+ imageWords _ (width / 16) ceiling * height.
+ data := ByteArray new:(imageWords * 2).
+
+ (rasterType between: 0 and: 2) ifFalse: [
+ inStream close.
+ self error: 'Unknown raster file rasterType'
+ ].
+
+ (rasterType = 2) ifFalse: [
+ "no compression of bytes"
+ inStream nextBytes:(imageWords * 2) into:data
+ ] ifTrue: [
+ "run length compression of bytes"
+
+ bits _ ByteArray new: imageWords * 2.
+ index := 1.
+ a _ inStream next.
+ [a notNil] whileTrue: [
+ (a = 128) ifFalse: [
+ bits at:index put: a.
+ index := index + 1
+ ] ifTrue: [
+ b _ inStream next.
+ b = 0 ifTrue: [
+ bits at:index put:128 .
+ index := index + 1
+ ] ifFalse: [
+ c := inStream next.
+ 1 to:(b+1) do:[:i |
+ bits at:index put:c.
+ index := index + 1
+ ]
+ ]
+ ].
+ a _ inStream next
+ ].
+ 1 to: imageWords do: [:i | form bitsWordAt: i put: (bits wordAt: i)]
+ ].
+ photometric := #whiteIs0.
+ samplesPerPixel := 1.
+ bitsPerSample := #(1).
+ inStream close
+
+ "Image fromFile:'../fileIn/bitmaps/founders.im8'"
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/SunReader.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,135 @@
+"
+ COPYRIGHT (c) 1993 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.
+"
+
+ImageReader subclass:#SunRasterReader
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Graphics-Support'
+!
+
+SunRasterReader comment:'
+
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+this class provides methods for loading Sun Raster file images
+
+%W% %E%
+written Summer 91 by claus
+'!
+
+!SunRasterReader methodsFor:'reading from file'!
+
+fromFile: aFilename
+ | rasterType mapType mapBytes imageWords form depth
+ rMap gMap bMap mapLen
+ bits a b c index|
+
+ inStream := FileStream readonlyFileNamed:aFilename.
+ inStream isNil ifTrue:[
+ 'open error' printNewline.
+ ^ nil
+ ].
+
+ inStream binary.
+
+ ((inStream nextWord = 16r59A6)
+ and:[inStream nextWord = 16r6A95]) ifFalse: [
+"
+ inStream nextLong = 16r59A66A95 ifFalse: [
+"
+ inStream close.
+ self error: 'Not a Sun Raster File (bad magic number)'
+ ].
+
+ width := inStream nextLong.
+ height := inStream nextLong.
+
+ depth := inStream nextLong.
+ inStream nextLong. "Ignore the image length since I can't rely on it anyway."
+ rasterType _ inStream nextLong.
+ mapType := inStream nextLong. "Ignore the raster maptype."
+ mapBytes := inStream nextLong.
+
+ depth = 8 ifTrue: [
+ mapLen := (mapBytes // 3).
+ rMap := ByteArray new:mapLen.
+ gMap := ByteArray new:mapLen.
+ bMap := ByteArray new:mapLen.
+ inStream nextBytes:mapLen into:rMap.
+ inStream nextBytes:mapLen into:gMap.
+ inStream nextBytes:mapLen into:bMap.
+
+ data := ByteArray new:(width * height).
+ inStream nextBytes:(width * height) into:data.
+
+ photometric := #palette.
+ samplesPerPixel := 1.
+ bitsPerSample := #(8).
+ colorMap := Array with:rMap with:gMap with:bMap.
+ inStream close.
+ ^ self
+ ].
+ depth ~~ 1 ifTrue: [
+ inStream close.
+ self error: 'Raster file is not monochrome'
+ ].
+
+ form := nil.
+
+ inStream skip: mapBytes. "Skip the color map."
+ imageWords _ (width / 16) ceiling * height.
+ data := ByteArray new:(imageWords * 2).
+
+ (rasterType between: 0 and: 2) ifFalse: [
+ inStream close.
+ self error: 'Unknown raster file rasterType'
+ ].
+
+ (rasterType = 2) ifFalse: [
+ "no compression of bytes"
+ inStream nextBytes:(imageWords * 2) into:data
+ ] ifTrue: [
+ "run length compression of bytes"
+
+ bits _ ByteArray new: imageWords * 2.
+ index := 1.
+ a _ inStream next.
+ [a notNil] whileTrue: [
+ (a = 128) ifFalse: [
+ bits at:index put: a.
+ index := index + 1
+ ] ifTrue: [
+ b _ inStream next.
+ b = 0 ifTrue: [
+ bits at:index put:128 .
+ index := index + 1
+ ] ifFalse: [
+ c := inStream next.
+ 1 to:(b+1) do:[:i |
+ bits at:index put:c.
+ index := index + 1
+ ]
+ ]
+ ].
+ a _ inStream next
+ ].
+ 1 to: imageWords do: [:i | form bitsWordAt: i put: (bits wordAt: i)]
+ ].
+ photometric := #whiteIs0.
+ samplesPerPixel := 1.
+ bitsPerSample := #(1).
+ inStream close
+
+ "Image fromFile:'../fileIn/bitmaps/founders.im8'"
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/TIFFRdr.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,1250 @@
+"
+ COPYRIGHT (c) 1991-93 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.
+"
+
+ImageReader subclass:#TIFFReader
+ instanceVariableNames:'planarConfiguration
+ subFileType stripOffsets rowsPerStrip
+ fillOrder compression group3options predictor
+ stripByteCounts
+ currentOffset
+ stripOffsetsPos stripByteCountsPos bitsPerSamplePos
+ colorMapPos'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Graphics-Support'
+!
+
+TIFFReader comment:'
+
+COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+written Summer 91 by claus
+'!
+
+!TIFFReader class methodsFor:'documentation'!
+
+documentation
+"
+ This class knows how to read TIFF files (and will
+ learn sometime in the future how to write them).
+ Currently, not all formats are implemented and of
+ those that are, not all are tested.
+ It should work with most rgb, mono and 2-plane greyscale
+ images, since this is what I have as test material on
+ the NeXT.
+ It supports uncompressed, LZW and G3 compressed images;
+ JPEG is currently not implemented.
+ More formats and compressions will come ...
+"
+! !
+
+!TIFFReader methodsFor:'reading from file'!
+
+fromFile:aFileName
+ |char1 char2 version
+ numberOfTags "{ Class: SmallInteger }"
+ tagType "{ Class: SmallInteger }"
+ numberType "{ Class: SmallInteger }"
+ length "{ Class: SmallInteger }"
+ result offset ok|
+
+ inStream := FileStream readonlyFileNamed:aFileName.
+ inStream isNil ifTrue:[
+ 'open error' printNewline.
+ ^ nil
+ ].
+
+ char1 := inStream next.
+ char2 := inStream next.
+ (char1 ~~ char2) ifTrue:[
+ 'not a tiff file' printNewline.
+ inStream close.
+ ^ nil
+ ].
+ (char1 == $I) ifTrue:[
+ byteOrder := #lsb
+ ] ifFalse:[
+ (char1 == $M) ifTrue:[
+ byteOrder := #msb
+ ] ifFalse:[
+ 'not a tiff file' printNewline.
+ inStream close.
+ ^ nil
+ ]
+ ].
+
+ version := self readShort.
+ (version ~~ 42) ifTrue:[
+ 'version of tiff-file not supported' printNewline.
+ inStream close.
+ ^ nil
+ ].
+
+ "setup default values"
+
+ compression := 1. "none"
+ fillOrder := #msb.
+ planarConfiguration := 1.
+ photometric := nil.
+ bitsPerSample := 1.
+ samplesPerPixel := 1.
+ width := nil.
+ height := nil.
+ stripOffsets := nil.
+ rowsPerStrip := nil.
+ "resolutionUnit := 2."
+ predictor := 1.
+
+ offset := self readLong + 1.
+ inStream position:offset.
+
+ numberOfTags := self readShort.
+ 1 to:(numberOfTags) do:[:index |
+ tagType := self readShort.
+ numberType := self readShort.
+ length := self readLong.
+ self decodeTiffTag:tagType numberType:numberType
+ length:length
+ ].
+
+ offset := self readLong.
+ (offset ~~ 0) ifTrue:[
+ 'more tags ignored' printNewline
+ ].
+
+ ok := true.
+ width isNil ifTrue:[
+ 'missing width tag' printNewline.
+ ok := false
+ ].
+
+ height isNil ifTrue:[
+ 'missing length tag' printNewline.
+ ok := false
+ ].
+
+ photometric isNil ifTrue:[
+ 'missing photometric tag' printNewline.
+ ok := false
+ ].
+
+ stripOffsets isNil ifTrue:[
+ 'missing stripOffsets tag' printNewline.
+ ok := false
+ ].
+
+ ok ifFalse:[
+ inStream close.
+ ^ nil
+ ].
+
+ "given all the information, read the bits"
+
+ rowsPerStrip isNil ifTrue:[
+ rowsPerStrip := height
+ ].
+
+ (compression == 1) ifTrue:[
+ result := self readUncompressedTiffImageData
+ ] ifFalse:[
+ (compression == 5) ifTrue:[
+ result := self readLZWTiffImageData
+ ] ifFalse:[
+ (compression == 2) ifTrue:[
+ "result := self readCCITT3ModHuffmanTiffImageData"
+ 'ccitt mod Huffman compression not implemented' printNewline
+ ] ifFalse:[
+ (compression == 3) ifTrue:[
+ result := self readCCITTGroup3TiffImageData
+ ] ifFalse:[
+ (compression == 4) ifTrue:[
+ "result := self readCCITTGroup4TiffImageData"
+ 'ccitt group4 fax compression not implemented' printNewline
+ ] ifFalse:[
+ (compression == 32773) ifTrue:[
+ result := self readPackbitsTiffImageData
+ ] ifFalse:[
+ (compression == 32865) ifTrue:[
+ result := self readJPEGTiffImageData
+ ] ifFalse:[
+ 'compression type not known' printNewline
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ inStream close.
+ ^ result
+! !
+
+!TIFFReader methodsFor:'writing to file'!
+
+save:image onFile:aFileName
+ "save image as TIFF file on aFileName"
+
+ |pos1 pos|
+
+ outStream := FileStream newFileNamed:aFileName.
+ outStream isNil ifTrue:[
+ 'create error' printNewline.
+ ^ nil
+ ].
+
+ byteOrder := #msb.
+ fillOrder := #msb.
+ width := image width.
+ height := image height.
+ photometric := image photometric.
+ samplesPerPixel := image samplesPerPixel.
+ bitsPerSample := image bitsPerSample.
+ colorMap := image colorMap.
+ planarConfiguration := 1.
+ compression := 1. "none"
+ data := image bits.
+
+ "save as msb"
+
+ currentOffset := 0.
+
+ outStream nextPut:$M.
+ outStream nextPut:$M.
+ currentOffset := currentOffset + 2.
+
+ outStream binary.
+
+ self writeShort:42. "version"
+ currentOffset := currentOffset + 2.
+
+ pos1 := outStream position.
+ self writeLong:0. "start of commands - filled in later"
+ currentOffset := currentOffset + 4.
+
+ "output strips"
+
+ self writeBits. "this outputs bits as strips, sets stripOffsets and stripByteCounts"
+ self writeStripOffsets. "this outputs strip offsets, sets stripOffsetsPos"
+ self writeStripByteCounts. "this outputs strip bytecounts, sets stripByteCountPos"
+ self writeBitsPerSample. "this outputs bitsPerSample, sets bitsPerSamplePos"
+ photometric == #palette ifTrue:[
+ self writeColorMap "this outputs colorMap, sets colorMapPos"
+ ].
+
+ pos := outStream position. "backpatch tag offset"
+ outStream position:pos1.
+ self writeLong:(pos - 1).
+ outStream position:pos.
+('patch tag offset at: ', (pos1 printStringRadix:16) , ' to ',
+ (pos printStringRadix:16)) printNewline.
+
+ "output tag data"
+
+ photometric == #palette ifTrue:[
+ self writeShort:9
+ ] ifFalse:[
+ self writeShort:8. "8 tags"
+ ].
+ self writeTag:256. "image width"
+ self writeTag:257. "image height"
+ self writeTag:258. "bits per sample"
+ self writeTag:259. "compression"
+ self writeTag:262. "photometric"
+ self writeTag:273. "strip offsets"
+ self writeTag:279. "strip byte counts"
+ self writeTag:284. "planarconfig"
+ photometric == #palette ifTrue:[
+ self writeTag:320 "colorMap"
+ ].
+ self writeLong:0.
+
+ outStream close
+! !
+
+!TIFFReader methodsFor:'private'!
+
+readLongs:n
+ |oldPos offset values|
+
+ values := Array new:n.
+ (n == 1) ifTrue:[
+ values at:1 put:(self readLong)
+ ] ifFalse:[
+ offset := self readLong.
+ oldPos := inStream position.
+ inStream position:(offset + 1).
+ 1 to:n do:[:index |
+ values at:index put:(self readLong)
+ ].
+ inStream position:oldPos
+ ].
+ ^ values
+!
+
+writeLongs:longs
+ 1 to:longs size do:[:l |
+ self writeLong:l
+ ]
+!
+
+readShorts:n
+ |oldPos offset values|
+
+ values := Array new:n.
+ (n <= 2) ifTrue:[
+ values at:1 put:(self readShort).
+ (n == 2) ifTrue:[
+ values at:2 put:(self readShort)
+ ] ifFalse:[
+ self readShort
+ ]
+ ] ifFalse:[
+ offset := self readLong.
+ oldPos := inStream position.
+ inStream position:(offset + 1).
+ 1 to:n do:[:index |
+ values at:index put:(self readShort)
+ ].
+ inStream position:oldPos
+ ].
+ ^ values
+!
+
+readChars:n
+ |oldPos offset string|
+
+ string := String new:(n - 1).
+ (n <= 4) ifTrue:[
+ inStream nextBytes:(n - 1) into:string
+ ] ifFalse:[
+ offset := self readLong.
+ oldPos := inStream position.
+ inStream position:(offset + 1).
+ inStream nextBytes:(n - 1) into:string.
+ inStream position:oldPos
+ ].
+ ^ string
+!
+
+readFracts:cnt
+ |oldPos offset values n d|
+
+ values := Array new:cnt.
+ offset := self readLong.
+ oldPos := inStream position.
+ inStream position:(offset + 1).
+ 1 to:cnt do:[:index |
+ n := self readLong.
+ d := self readLong.
+ values at:index put:(Fraction numerator:n denominator:d)
+ ].
+ inStream position:oldPos.
+ ^ values
+!
+
+decodeTiffTag:tagType numberType:numberType length:length
+ |offset value valueArray
+ val
+ n "{ Class: SmallInteger }" |
+
+ (numberType == 3) ifTrue:[
+ "short"
+ valueArray := self readShorts:length.
+ value := valueArray at:1
+ ] ifFalse:[
+ (numberType == 4) ifTrue:[
+ "integer"
+ valueArray := self readLongs:length.
+ value := valueArray at:1
+ ] ifFalse:[
+ (numberType == 2) ifTrue:[
+ "character"
+ value := self readChars:length
+ ] ifFalse:[
+ (numberType == 5) ifTrue:[
+ "fraction"
+ valueArray := self readFracts:length.
+ value := valueArray at:1
+ ] ifFalse:[
+ offset := self readLong
+ ]
+ ]
+ ]
+ ].
+
+ (tagType == 254) ifTrue:[
+ "NewSubfileType"
+ "newSubFileType := value."
+ 'newSubfiletype ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 255) ifTrue:[
+ "SubfileType"
+ subFileType := value.
+ 'subfiletype ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 256) ifTrue:[
+ "ImageWidth"
+ width := value.
+ 'width ' print. width printNewline.
+ ^ self
+ ].
+ (tagType == 257) ifTrue:[
+ "ImageHeight"
+ height := value.
+ 'height ' print. height printNewline.
+ ^ self
+ ].
+ (tagType == 258) ifTrue:[
+ "bitspersample"
+ bitsPerSample := valueArray.
+ 'bitspersample ' print. bitsPerSample printNewline.
+ ^ self
+ ].
+ (tagType == 259) ifTrue:[
+ "compression"
+ compression := value.
+ 'compression ' print. compression printNewline.
+ ^ self
+ ].
+ (tagType == 262) ifTrue:[
+ "photometric"
+ (value == 0) ifTrue:[
+ photometric := #whiteIs0
+ ] ifFalse:[
+ (value == 1) ifTrue:[
+ photometric := #blackIs0
+ ] ifFalse:[
+ (value == 2) ifTrue:[
+ photometric := #rgb
+ ] ifFalse:[
+ (value == 3) ifTrue:[
+ photometric := #palette
+ ] ifFalse:[
+ (value == 4) ifTrue:[
+ photometric := #transparency
+ ] ifFalse:[
+ photometric := nil
+ ]
+ ]
+ ]
+ ]
+ ].
+ 'photometric ' print. photometric printNewline.
+ ^ self
+ ].
+ (tagType == 263) ifTrue:[
+ "Treshholding"
+ "threshholding := value."
+ 'treshholding ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 264) ifTrue:[
+ "CellWidth"
+ "cellWidth:= value."
+ 'cellWidth ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 265) ifTrue:[
+ "CellLength"
+ "cellLength:= value."
+ 'cellLength ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 266) ifTrue:[
+ "fillOrder"
+ (value == 1) ifTrue:[
+ fillOrder := #msb
+ ] ifFalse:[
+ (value == 2) ifTrue:[
+ fillOrder := #lsb
+ ] ifFalse:[
+ fillOrder := nil
+ ]
+ ].
+ 'fillorder ' print. fillOrder printNewline.
+ ^ self
+ ].
+ (tagType == 269) ifTrue:[
+ "documentName"
+ 'documentName ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 270) ifTrue:[
+ "imageDescription"
+ 'imageDescription ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 271) ifTrue:[
+ "make"
+ 'make ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 272) ifTrue:[
+ "model"
+ 'model ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 273) ifTrue:[
+ "stripoffsets"
+ stripOffsets := valueArray.
+ 'stripOffsets Array(' print. stripOffsets size print. ')' printNewline.
+ ^ self
+ ].
+ (tagType == 274) ifTrue:[
+ "Orientation"
+ "orientation:= value."
+ 'orientation ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 277) ifTrue:[
+ "samplesPerPixel"
+ samplesPerPixel := value.
+ 'samplesperpixel ' print. samplesPerPixel printNewline.
+ ^ self
+ ].
+ (tagType == 278) ifTrue:[
+ "rowsperstrip"
+ rowsPerStrip := value.
+ 'rowsperstrip ' print. rowsPerStrip printNewline.
+ ^ self
+ ].
+ (tagType == 279) ifTrue:[
+ "stripbytecount"
+ stripByteCounts := valueArray.
+ 'stripByteCounts Array(' print.
+ stripByteCounts size print.
+ ')' printNewline.
+ ^ self
+ ].
+ (tagType == 280) ifTrue:[
+ "MinSampleValue"
+ "minSampleValue:= value."
+ 'minSampleValue ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 281) ifTrue:[
+ "MaxSampleValue"
+ "maxSampleValue:= value."
+ 'maxSampleValue ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 282) ifTrue:[
+ "xResolution"
+ 'xres ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 283) ifTrue:[
+ "yResolution"
+ 'yres ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 284) ifTrue:[
+ "planarconfig"
+ (value == 1) ifTrue:[
+ planarConfiguration := 1
+ ] ifFalse:[
+ (value == 2) ifTrue:[
+ planarConfiguration := 2
+ ] ifFalse:[
+ planarConfiguration := nil
+ ]
+ ].
+ 'planarconfig ' print. planarConfiguration printNewline.
+ ^ self
+ ].
+ (tagType == 285) ifTrue:[
+ "pageName"
+ 'pageName ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 286) ifTrue:[
+ "xPosition"
+ 'xPos ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 287) ifTrue:[
+ "yPosition"
+ 'yPos ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 288) ifTrue:[
+ "freeOffsets"
+ 'freeOffsets ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 289) ifTrue:[
+ "freeByteCounts"
+ 'freeByteCounts ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 290) ifTrue:[
+ "grayResponceUnit"
+ 'grayResponceUnit' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 291) ifTrue:[
+ "grayResponceCurve"
+ 'grayResponceCurve' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 292) ifTrue:[
+ "group3options"
+ group3options := value.
+ 'group3options ' print. group3options printNewline.
+ ^ self
+ ].
+ (tagType == 293) ifTrue:[
+ "group4options"
+ "group4options := value."
+ 'group4options ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 296) ifTrue:[
+ "resolutionunit"
+ (value == 1) ifTrue:[
+ 'res-unit pixel' printNewline
+ ] ifFalse:[
+ (value == 2) ifTrue:[
+ 'res-unit inch' printNewline
+ ] ifFalse:[
+ (value == 3) ifTrue:[
+ 'res-unit mm' printNewline
+ ] ifFalse:[
+ 'res-unit invalid' printNewline
+ ]
+ ]
+ ].
+ "resolutionUnit := value."
+ ^ self
+ ].
+ (tagType == 297) ifTrue:[
+ "pageNumber"
+ "pageNumber := value."
+ 'pageNumber ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 300) ifTrue:[
+ "colorResponceUnit"
+ 'colorResponceUnit' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 301) ifTrue:[
+ "colorResponceCurve"
+ 'colorResponceCurve' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 306) ifTrue:[
+ "dateTime"
+ 'dateTime ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 315) ifTrue:[
+ "artist"
+ 'artist ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 317) ifTrue:[
+ "predictor"
+ predictor := value.
+ 'predictor ' print. predictor printNewline.
+ ^ self
+ ].
+ (tagType == 320) ifTrue:[
+ "colorMap"
+ 'colorMap (size=' print. valueArray size print. ')' printNewline.
+ n := valueArray size // 3.
+ colorMap := Array new:3.
+ colorMap at:1 put:(valueArray copyFrom:1 to:n).
+ colorMap at:2 put:(valueArray copyFrom:n+1 to:2*n).
+ colorMap at:3 put:(valueArray copyFrom:2*n+1 to:3*n).
+ 1 to:3 do:[:c |
+ 1 to:n do:[:e |
+ val := (colorMap at:c) at:e.
+ val := (val * 255.0 / 16rFFFF) rounded.
+ (colorMap at:c) at:e put:val
+ ]
+ ].
+ ^ self
+ ].
+
+'tag:' print. tagType print. ' typ:' print. numberType print.
+' len:' print. length print. ' offs:' print. offset print.
+' val:' print. value print. ' valArr:' print. valueArray printNewline.
+
+ 'unknown type ' print. tagType printNewline
+!
+
+writeBits
+ "write bits as one strip"
+
+ |offs bytesPerRow|
+
+ data size < 16rFFFF ifTrue:[
+ stripOffsets := Array with:(outStream position - 1).
+ stripByteCounts := Array with:(data size).
+ outStream nextPutBytes:data size from:data.
+ rowsPerStrip := height
+ ] ifFalse:[
+ stripOffsets := Array new:height.
+ bytesPerRow := data size // height.
+ stripByteCounts := (Array new:height) atAllPut:bytesPerRow.
+
+ offs := 1.
+ 1 to:height do:[:row |
+ stripOffsets at:row put:(outStream position - 1).
+ outStream nextPutBytes:data size from:data startingAt:offs.
+ offs := offs + bytesPerRow
+ ].
+ rowsPerStrip := 1
+ ].
+ 'stripOffsets: ' print. stripOffsets printNewline.
+ 'stripByteCounts: ' print. stripByteCounts printNewline.
+!
+
+writeColorMap
+ colorMapPos := outStream position.
+ colorMap do:[:subMap |
+ subMap do:[:entry |
+ "my maps are 8 bit - tiff map is 16 bit"
+
+ self writeShort:(entry / 255 * 16rFFFF) rounded
+ ]
+ ]
+!
+
+writeStripOffsets
+'stripOffsets: ' print. stripOffsets printNewline.
+'store stripoffsets at: ' print. outStream position printNewline.
+ stripOffsetsPos := outStream position.
+ stripOffsets do:[:o |
+ self writeLong:o
+ ]
+!
+
+writeStripByteCounts
+'stripByteCounts: ' print. stripByteCounts printNewline.
+'store stripbytecounts at: ' print. outStream position printNewline.
+ stripByteCountsPos := outStream position.
+ stripByteCounts do:[:c |
+ self writeShort:c
+ ]
+!
+
+writeBitsPerSample
+'bitsPerSample: ' print. bitsPerSample printNewline.
+'store bitspersample at: ' print. outStream position printNewline.
+ bitsPerSamplePos := outStream position.
+ bitsPerSample do:[:n |
+ self writeShort:n
+ ]
+!
+
+writeTag:tagType
+ self writeTiffTag:tagType.
+!
+
+writeTiffTag:tagType
+ |value valueArray numberType count address|
+
+ count := 1.
+ address := nil.
+ (tagType == 253) ifTrue:[
+ "tiff class"
+ ].
+ (tagType == 254) ifTrue:[
+ ].
+ (tagType == 255) ifTrue:[
+ "SubfileType"
+ value := subFileType.
+ numberType := #long.
+ ].
+ (tagType == 256) ifTrue:[
+ "ImageWidth"
+ value := width.
+ numberType := #short.
+ ].
+ (tagType == 257) ifTrue:[
+ "ImageHeight"
+ value := height.
+ numberType := #short.
+ ].
+ (tagType == 258) ifTrue:[
+ "bitspersample"
+ address := bitsPerSamplePos - 1.
+ numberType := #short.
+ count := bitsPerSample size.
+ valueArray := bitsPerSample
+ ].
+ (tagType == 259) ifTrue:[
+ "compression"
+ value := compression.
+ numberType := #short.
+ ].
+ (tagType == 262) ifTrue:[
+ "photometric"
+ (photometric == #whiteIs0) ifTrue:[
+ value := 0
+ ] ifFalse:[
+ (photometric == #blackIs0) ifTrue:[
+ value := 1
+ ] ifFalse:[
+ (photometric == #rgb) ifTrue:[
+ value := 2
+ ] ifFalse:[
+ (photometric == #palette) ifTrue:[
+ value := 3
+ ] ifFalse:[
+ (photometric == #transparency) ifTrue:[
+ value := 4
+ ] ifFalse:[
+ self error:'bad photometric'
+ ]
+ ]
+ ]
+ ]
+ ].
+ numberType := #short.
+ ].
+ (tagType == 263) ifTrue:[
+ ].
+ (tagType == 264) ifTrue:[
+ ].
+ (tagType == 265) ifTrue:[
+ ].
+ (tagType == 266) ifTrue:[
+ "fillOrder"
+ (fillOrder == #msb) ifTrue:[
+ value := 1
+ ] ifFalse:[
+ (fillOrder == #lsb) ifTrue:[
+ value := 2
+ ] ifFalse:[
+ self error:'bad fillOrder'
+ ]
+ ].
+ numberType := #short.
+ ].
+ (tagType == 269) ifTrue:[
+ ].
+ (tagType == 270) ifTrue:[
+ ].
+ (tagType == 271) ifTrue:[
+ ].
+ (tagType == 272) ifTrue:[
+ ].
+ (tagType == 273) ifTrue:[
+ "stripoffsets"
+ address := stripOffsetsPos - 1.
+ numberType := #long.
+ count := stripOffsets size.
+ valueArray := stripOffsets
+ ].
+ (tagType == 274) ifTrue:[
+ ].
+ (tagType == 277) ifTrue:[
+ "samplesPerPixel"
+ value := samplesPerPixel.
+ numberType := #short.
+ ].
+ (tagType == 278) ifTrue:[
+ "rowsperstrip"
+ value := rowsPerStrip.
+ numberType := #short.
+ ].
+ (tagType == 279) ifTrue:[
+ "stripbytecount"
+ address := stripByteCountsPos - 1.
+ numberType := #short.
+ count := stripByteCounts size.
+ valueArray := stripByteCounts
+ ].
+ (tagType == 280) ifTrue:[
+ "min sample value"
+ ].
+ (tagType == 281) ifTrue:[
+ "max sample value"
+ ].
+ (tagType == 282) ifTrue:[
+ "x resolution"
+ ].
+ (tagType == 283) ifTrue:[
+ "y resolution"
+ ].
+ (tagType == 284) ifTrue:[
+ "planarconfig"
+ value := planarConfiguration.
+ numberType := #short.
+ ].
+ (tagType == 285) ifTrue:[
+ "pageName"
+ ].
+ (tagType == 286) ifTrue:[
+ "xPosition"
+ ].
+ (tagType == 287) ifTrue:[
+ "yPosition"
+ ].
+ (tagType == 288) ifTrue:[
+ "freeOffsets"
+ ].
+ (tagType == 289) ifTrue:[
+ "freeByteCounts"
+ ].
+ (tagType == 290) ifTrue:[
+ "grayResponceUnit"
+ ].
+ (tagType == 291) ifTrue:[
+ "grayResponceCurve"
+ ].
+ (tagType == 292) ifTrue:[
+ "group3options"
+ value := group3options.
+ numberType := #long.
+ ].
+ (tagType == 293) ifTrue:[
+ "group4options"
+ ].
+ (tagType == 296) ifTrue:[
+ "resolutionunit"
+ ^ self
+ ].
+ (tagType == 297) ifTrue:[
+ "pageNumber"
+ ].
+ (tagType == 300) ifTrue:[
+ "colorResponceUnit"
+ ].
+ (tagType == 301) ifTrue:[
+ "colorResponceCurve"
+ ].
+ (tagType == 306) ifTrue:[
+ "dateTime"
+ ].
+ (tagType == 315) ifTrue:[
+ "artist"
+ ].
+ (tagType == 317) ifTrue:[
+ "predictor"
+ ].
+ (tagType == 320) ifTrue:[
+ "colormap"
+ address := colorMapPos - 1.
+ numberType := #short.
+ count := (colorMap at:1) size * 3.
+ ].
+
+ (value isNil and:[address isNil]) ifTrue:[
+ self error:'unhandled tag'.
+ ^ self
+ ].
+
+'tag:' print. tagType print. ' typ:' print. numberType print.
+' len:' print. count print.
+' val:' print. value printNewline.
+
+ self writeShort:tagType.
+ numberType == #short ifTrue:[
+ self writeShort:3.
+ self writeLong:count.
+ ] ifFalse:[
+ numberType == #long ifTrue:[
+ self writeShort:4.
+ self writeLong:count.
+ ] ifFalse:[
+ numberType == #byte ifTrue:[
+ self writeShort:1.
+ self writeLong:count.
+ ] ifFalse:[
+ self error:'bad numbertype'
+ ]
+ ]
+ ].
+ address notNil ifTrue:[
+ (numberType == #long and:[count == 1]) ifTrue:[
+ self writeLong:(valueArray at:1).
+ ^ self
+ ].
+ (numberType == #short and:[count <= 2]) ifTrue:[
+ self writeShort:(valueArray at:1).
+ count == 2 ifTrue:[
+ self writeShort:(valueArray at:2).
+ ] ifFalse:[
+ self writeShort:0
+ ].
+ ^ self
+ ].
+ (numberType == #byte and:[count <= 4]) ifTrue:[
+ outStream nextPut:(valueArray at:1).
+ count > 1 ifTrue:[
+ outStream nextPut:(valueArray at:2).
+ count > 2 ifTrue:[
+ outStream nextPut:(valueArray at:3).
+ count > 3 ifTrue:[
+ outStream nextPut:(valueArray at:4).
+ ] ifFalse:[
+ outStream nextPut:0
+ ].
+ ] ifFalse:[
+ outStream nextPut:0
+ ].
+ ] ifFalse:[
+ outStream nextPut:0
+ ].
+ ^ self
+ ].
+ self writeLong:address.
+ ^ self
+ ].
+ numberType == #short ifTrue:[
+ self writeShort:value.
+ self writeShort:0
+ ] ifFalse:[
+ numberType == #long ifTrue:[
+ self writeLong:value
+ ] ifFalse:[
+ numberType == #byte ifTrue:[
+ outStream nextPut:value.
+ outStream nextPut:0.
+ outStream nextPut:0.
+ outStream nextPut:0.
+ ] ifFalse:[
+ self error:'bad numbertype'
+ ]
+ ]
+ ].
+!
+
+readUncompressedTiffImageData
+ |bytesPerRow bitsPerRow nPlanes
+ stripNr "{ Class: SmallInteger }"
+ offset "{ Class: SmallInteger }"
+ row "{ Class: SmallInteger }"
+ bytesPerStrip "{ Class: SmallInteger }"
+ bitsPerPixel |
+
+ nPlanes := samplesPerPixel.
+
+ "only support 1-sample/pixel,
+ with alpha - if separate planes,
+ or rgb - if non separate planes and no alpha"
+
+ (nPlanes == 2) ifTrue:[
+ (planarConfiguration ~~ 2) ifTrue:[
+ self error:'with alpha, only separate planes supported'.
+ ^ nil
+ ].
+ 'ignoring alpha plane' printNewline.
+ nPlanes := 1.
+ bitsPerPixel := bitsPerSample at:1
+ ] ifFalse:[
+ (nPlanes == 3) ifTrue:[
+ (planarConfiguration ~~ 1) ifTrue:[
+ self error:'only non separate planes supported'.
+ ^ nil
+ ].
+ bitsPerSample ~= #(8 8 8) ifTrue:[
+ self error:'only 8/8/8 rgb images supported'.
+ ^ nil
+ ].
+ bitsPerPixel := 24
+ ] ifFalse:[
+ (nPlanes ~~ 1) ifTrue:[
+ self error:'format not supported'.
+ ^ nil
+ ].
+ bitsPerPixel := bitsPerSample at:1
+ ]
+ ].
+
+ bitsPerRow := width * bitsPerPixel.
+ bytesPerRow := bitsPerRow // 8.
+ ((bitsPerRow \\ 8) ~~ 0) ifTrue:[
+ bytesPerRow := bytesPerRow + 1
+ ].
+
+ data := ByteArray uninitializedNew:(bytesPerRow * height).
+
+ offset := 1.
+ stripNr := 0.
+
+ row := 1.
+ bytesPerStrip := bytesPerRow * rowsPerStrip.
+ [row <= height] whileTrue:[
+ stripNr := stripNr + 1.
+ inStream position:((stripOffsets at:stripNr) + 1).
+
+ inStream nextBytes:(bytesPerRow * rowsPerStrip)
+ into:data
+ startingAt:offset.
+
+ offset := offset + bytesPerStrip.
+ row := row + rowsPerStrip
+ ]
+!
+
+readLZWTiffImageData
+ "read LZW compressed tiff data; this method only
+ handles 3x8 rgb and 1x2 or 2x2 greyscale images.
+ For 2x2 greyscale images, the alpha plane is ignored.
+ (maybe other formats work also - its simply not
+ tested)"
+
+ |bytesPerRow compressedStrip nPlanes
+ bytesPerStrip "{ Class: SmallInteger }"
+ nBytes "{ Class: SmallInteger }"
+ prevSize "{ Class: SmallInteger }"
+ stripNr "{ Class: SmallInteger }"
+ offset "{ Class: SmallInteger }"
+ row "{ Class: SmallInteger }" |
+
+ nPlanes := samplesPerPixel.
+
+ (nPlanes == 3) ifTrue:[
+ ((bitsPerSample at:1) ~~ 8) ifTrue:[
+ self error:'only 8 bit/sample supported'.
+ ^ nil
+ ].
+ ((bitsPerSample at:2) ~~ 8) ifTrue:[
+ self error:'only 8 bit/sample supported'.
+ ^ nil
+ ].
+ ((bitsPerSample at:3) ~~ 8) ifTrue:[
+ self error:'only 8 bit/sample supported'.
+ ^ nil
+ ].
+ bytesPerRow := width * samplesPerPixel.
+ ] ifFalse:[
+ (nPlanes == 2) ifTrue:[
+ (planarConfiguration ~~ 2) ifTrue:[
+ self error:'only separate planes supported'.
+ ^ nil
+ ].
+ 'ignoring alpha plane' printNewline.
+ nPlanes := 1
+ ].
+ (nPlanes == 1) ifFalse:[
+ self error:'only 3-sample rgb / monochrome supported'.
+ ^ nil
+ ].
+ bytesPerRow := (width * (bitsPerSample at:1) + 7) // 8.
+ ].
+
+ stripByteCounts isNil ifTrue:[
+ self error:'currently require stripByteCounts'.
+ ^ nil
+ ].
+
+ data := ByteArray uninitializedNew:(bytesPerRow * height).
+
+ offset := 1.
+ stripNr := 0.
+
+ row := 1.
+ bytesPerStrip := bytesPerRow * rowsPerStrip.
+ prevSize := 0.
+ [row <= height] whileTrue:[
+ stripNr := stripNr + 1.
+ inStream position:((stripOffsets at:stripNr) + 1).
+ nBytes := stripByteCounts at:stripNr.
+ (nBytes > prevSize) ifTrue:[
+ compressedStrip := ByteArray uninitializedNew:nBytes.
+ prevSize := nBytes
+ ].
+ inStream nextBytes:nBytes
+ into:compressedStrip.
+ self class decompressLZWFrom:compressedStrip
+ count:nBytes
+ into:data
+ startingAt:offset.
+ offset := offset + bytesPerStrip.
+ row := row + rowsPerStrip
+ ].
+
+ (predictor == 2) ifTrue:[
+ self class decodeDelta:3 in:data width:width height:height
+ ]
+!
+
+readCCITTGroup3TiffImageData
+ "not really tested - all I got is a single
+ fax from NeXT step"
+
+ |bytesPerRow bitsPerRow compressedStrip nPlanes
+ stripNr "{ Class: SmallInteger }"
+ offset "{ Class: SmallInteger }"
+ row "{ Class: SmallInteger }"
+ bytesPerStrip "{ Class: SmallInteger }" |
+
+ nPlanes := samplesPerPixel.
+ (nPlanes == 2) ifTrue:[
+ 'ignoring alpha plane' printNewline.
+ nPlanes := 1
+ ].
+
+ (nPlanes ~~ 1) ifTrue:[
+ self error:'only monochrome/greyscale supported'.
+ ^ nil
+ ].
+
+ stripByteCounts isNil ifTrue:[
+ self error:'currently require stripByteCounts'.
+ ^ nil
+ ].
+ (rowsPerStrip ~~ 1) isNil ifTrue:[
+ self error:'currently require rowsPerStrip to be 1'.
+ ^ nil
+ ].
+
+
+ bitsPerRow := width * (bitsPerSample at:1).
+ bytesPerRow := bitsPerRow // 8.
+ ((bitsPerRow \\ 8) ~~ 0) ifTrue:[
+ bytesPerRow := bytesPerRow + 1
+ ].
+
+ data := ByteArray uninitializedNew:(bytesPerRow * height).
+ compressedStrip := ByteArray uninitializedNew:bytesPerRow.
+
+ offset := 1.
+ stripNr := 0.
+
+ row := 1.
+ bytesPerStrip := bytesPerRow * rowsPerStrip.
+ [row <= height] whileTrue:[
+ stripNr := stripNr + 1.
+ inStream position:((stripOffsets at:stripNr) + 1).
+ inStream nextBytes:(stripByteCounts at:stripNr)
+ into:compressedStrip.
+ self class decompressCCITT3From:compressedStrip
+ into:data
+ startingAt:offset
+ count:width.
+ offset := offset + bytesPerStrip.
+ row := row + rowsPerStrip
+ ]
+!
+
+readJPEGTiffImageData
+ 'jpeg compression not implemented' printNewline
+!
+
+readPackbitsTiffImageData
+ "had no samples yet - however, packbits decompression
+ is rather trivial to add ..."
+
+ 'packbits compression not implemented' printNewline
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/TIFFReader.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,1250 @@
+"
+ COPYRIGHT (c) 1991-93 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.
+"
+
+ImageReader subclass:#TIFFReader
+ instanceVariableNames:'planarConfiguration
+ subFileType stripOffsets rowsPerStrip
+ fillOrder compression group3options predictor
+ stripByteCounts
+ currentOffset
+ stripOffsetsPos stripByteCountsPos bitsPerSamplePos
+ colorMapPos'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Graphics-Support'
+!
+
+TIFFReader comment:'
+
+COPYRIGHT (c) 1991-93 by Claus Gittinger
+ All Rights Reserved
+
+%W% %E%
+written Summer 91 by claus
+'!
+
+!TIFFReader class methodsFor:'documentation'!
+
+documentation
+"
+ This class knows how to read TIFF files (and will
+ learn sometime in the future how to write them).
+ Currently, not all formats are implemented and of
+ those that are, not all are tested.
+ It should work with most rgb, mono and 2-plane greyscale
+ images, since this is what I have as test material on
+ the NeXT.
+ It supports uncompressed, LZW and G3 compressed images;
+ JPEG is currently not implemented.
+ More formats and compressions will come ...
+"
+! !
+
+!TIFFReader methodsFor:'reading from file'!
+
+fromFile:aFileName
+ |char1 char2 version
+ numberOfTags "{ Class: SmallInteger }"
+ tagType "{ Class: SmallInteger }"
+ numberType "{ Class: SmallInteger }"
+ length "{ Class: SmallInteger }"
+ result offset ok|
+
+ inStream := FileStream readonlyFileNamed:aFileName.
+ inStream isNil ifTrue:[
+ 'open error' printNewline.
+ ^ nil
+ ].
+
+ char1 := inStream next.
+ char2 := inStream next.
+ (char1 ~~ char2) ifTrue:[
+ 'not a tiff file' printNewline.
+ inStream close.
+ ^ nil
+ ].
+ (char1 == $I) ifTrue:[
+ byteOrder := #lsb
+ ] ifFalse:[
+ (char1 == $M) ifTrue:[
+ byteOrder := #msb
+ ] ifFalse:[
+ 'not a tiff file' printNewline.
+ inStream close.
+ ^ nil
+ ]
+ ].
+
+ version := self readShort.
+ (version ~~ 42) ifTrue:[
+ 'version of tiff-file not supported' printNewline.
+ inStream close.
+ ^ nil
+ ].
+
+ "setup default values"
+
+ compression := 1. "none"
+ fillOrder := #msb.
+ planarConfiguration := 1.
+ photometric := nil.
+ bitsPerSample := 1.
+ samplesPerPixel := 1.
+ width := nil.
+ height := nil.
+ stripOffsets := nil.
+ rowsPerStrip := nil.
+ "resolutionUnit := 2."
+ predictor := 1.
+
+ offset := self readLong + 1.
+ inStream position:offset.
+
+ numberOfTags := self readShort.
+ 1 to:(numberOfTags) do:[:index |
+ tagType := self readShort.
+ numberType := self readShort.
+ length := self readLong.
+ self decodeTiffTag:tagType numberType:numberType
+ length:length
+ ].
+
+ offset := self readLong.
+ (offset ~~ 0) ifTrue:[
+ 'more tags ignored' printNewline
+ ].
+
+ ok := true.
+ width isNil ifTrue:[
+ 'missing width tag' printNewline.
+ ok := false
+ ].
+
+ height isNil ifTrue:[
+ 'missing length tag' printNewline.
+ ok := false
+ ].
+
+ photometric isNil ifTrue:[
+ 'missing photometric tag' printNewline.
+ ok := false
+ ].
+
+ stripOffsets isNil ifTrue:[
+ 'missing stripOffsets tag' printNewline.
+ ok := false
+ ].
+
+ ok ifFalse:[
+ inStream close.
+ ^ nil
+ ].
+
+ "given all the information, read the bits"
+
+ rowsPerStrip isNil ifTrue:[
+ rowsPerStrip := height
+ ].
+
+ (compression == 1) ifTrue:[
+ result := self readUncompressedTiffImageData
+ ] ifFalse:[
+ (compression == 5) ifTrue:[
+ result := self readLZWTiffImageData
+ ] ifFalse:[
+ (compression == 2) ifTrue:[
+ "result := self readCCITT3ModHuffmanTiffImageData"
+ 'ccitt mod Huffman compression not implemented' printNewline
+ ] ifFalse:[
+ (compression == 3) ifTrue:[
+ result := self readCCITTGroup3TiffImageData
+ ] ifFalse:[
+ (compression == 4) ifTrue:[
+ "result := self readCCITTGroup4TiffImageData"
+ 'ccitt group4 fax compression not implemented' printNewline
+ ] ifFalse:[
+ (compression == 32773) ifTrue:[
+ result := self readPackbitsTiffImageData
+ ] ifFalse:[
+ (compression == 32865) ifTrue:[
+ result := self readJPEGTiffImageData
+ ] ifFalse:[
+ 'compression type not known' printNewline
+ ]
+ ]
+ ]
+ ]
+ ]
+ ]
+ ].
+
+ inStream close.
+ ^ result
+! !
+
+!TIFFReader methodsFor:'writing to file'!
+
+save:image onFile:aFileName
+ "save image as TIFF file on aFileName"
+
+ |pos1 pos|
+
+ outStream := FileStream newFileNamed:aFileName.
+ outStream isNil ifTrue:[
+ 'create error' printNewline.
+ ^ nil
+ ].
+
+ byteOrder := #msb.
+ fillOrder := #msb.
+ width := image width.
+ height := image height.
+ photometric := image photometric.
+ samplesPerPixel := image samplesPerPixel.
+ bitsPerSample := image bitsPerSample.
+ colorMap := image colorMap.
+ planarConfiguration := 1.
+ compression := 1. "none"
+ data := image bits.
+
+ "save as msb"
+
+ currentOffset := 0.
+
+ outStream nextPut:$M.
+ outStream nextPut:$M.
+ currentOffset := currentOffset + 2.
+
+ outStream binary.
+
+ self writeShort:42. "version"
+ currentOffset := currentOffset + 2.
+
+ pos1 := outStream position.
+ self writeLong:0. "start of commands - filled in later"
+ currentOffset := currentOffset + 4.
+
+ "output strips"
+
+ self writeBits. "this outputs bits as strips, sets stripOffsets and stripByteCounts"
+ self writeStripOffsets. "this outputs strip offsets, sets stripOffsetsPos"
+ self writeStripByteCounts. "this outputs strip bytecounts, sets stripByteCountPos"
+ self writeBitsPerSample. "this outputs bitsPerSample, sets bitsPerSamplePos"
+ photometric == #palette ifTrue:[
+ self writeColorMap "this outputs colorMap, sets colorMapPos"
+ ].
+
+ pos := outStream position. "backpatch tag offset"
+ outStream position:pos1.
+ self writeLong:(pos - 1).
+ outStream position:pos.
+('patch tag offset at: ', (pos1 printStringRadix:16) , ' to ',
+ (pos printStringRadix:16)) printNewline.
+
+ "output tag data"
+
+ photometric == #palette ifTrue:[
+ self writeShort:9
+ ] ifFalse:[
+ self writeShort:8. "8 tags"
+ ].
+ self writeTag:256. "image width"
+ self writeTag:257. "image height"
+ self writeTag:258. "bits per sample"
+ self writeTag:259. "compression"
+ self writeTag:262. "photometric"
+ self writeTag:273. "strip offsets"
+ self writeTag:279. "strip byte counts"
+ self writeTag:284. "planarconfig"
+ photometric == #palette ifTrue:[
+ self writeTag:320 "colorMap"
+ ].
+ self writeLong:0.
+
+ outStream close
+! !
+
+!TIFFReader methodsFor:'private'!
+
+readLongs:n
+ |oldPos offset values|
+
+ values := Array new:n.
+ (n == 1) ifTrue:[
+ values at:1 put:(self readLong)
+ ] ifFalse:[
+ offset := self readLong.
+ oldPos := inStream position.
+ inStream position:(offset + 1).
+ 1 to:n do:[:index |
+ values at:index put:(self readLong)
+ ].
+ inStream position:oldPos
+ ].
+ ^ values
+!
+
+writeLongs:longs
+ 1 to:longs size do:[:l |
+ self writeLong:l
+ ]
+!
+
+readShorts:n
+ |oldPos offset values|
+
+ values := Array new:n.
+ (n <= 2) ifTrue:[
+ values at:1 put:(self readShort).
+ (n == 2) ifTrue:[
+ values at:2 put:(self readShort)
+ ] ifFalse:[
+ self readShort
+ ]
+ ] ifFalse:[
+ offset := self readLong.
+ oldPos := inStream position.
+ inStream position:(offset + 1).
+ 1 to:n do:[:index |
+ values at:index put:(self readShort)
+ ].
+ inStream position:oldPos
+ ].
+ ^ values
+!
+
+readChars:n
+ |oldPos offset string|
+
+ string := String new:(n - 1).
+ (n <= 4) ifTrue:[
+ inStream nextBytes:(n - 1) into:string
+ ] ifFalse:[
+ offset := self readLong.
+ oldPos := inStream position.
+ inStream position:(offset + 1).
+ inStream nextBytes:(n - 1) into:string.
+ inStream position:oldPos
+ ].
+ ^ string
+!
+
+readFracts:cnt
+ |oldPos offset values n d|
+
+ values := Array new:cnt.
+ offset := self readLong.
+ oldPos := inStream position.
+ inStream position:(offset + 1).
+ 1 to:cnt do:[:index |
+ n := self readLong.
+ d := self readLong.
+ values at:index put:(Fraction numerator:n denominator:d)
+ ].
+ inStream position:oldPos.
+ ^ values
+!
+
+decodeTiffTag:tagType numberType:numberType length:length
+ |offset value valueArray
+ val
+ n "{ Class: SmallInteger }" |
+
+ (numberType == 3) ifTrue:[
+ "short"
+ valueArray := self readShorts:length.
+ value := valueArray at:1
+ ] ifFalse:[
+ (numberType == 4) ifTrue:[
+ "integer"
+ valueArray := self readLongs:length.
+ value := valueArray at:1
+ ] ifFalse:[
+ (numberType == 2) ifTrue:[
+ "character"
+ value := self readChars:length
+ ] ifFalse:[
+ (numberType == 5) ifTrue:[
+ "fraction"
+ valueArray := self readFracts:length.
+ value := valueArray at:1
+ ] ifFalse:[
+ offset := self readLong
+ ]
+ ]
+ ]
+ ].
+
+ (tagType == 254) ifTrue:[
+ "NewSubfileType"
+ "newSubFileType := value."
+ 'newSubfiletype ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 255) ifTrue:[
+ "SubfileType"
+ subFileType := value.
+ 'subfiletype ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 256) ifTrue:[
+ "ImageWidth"
+ width := value.
+ 'width ' print. width printNewline.
+ ^ self
+ ].
+ (tagType == 257) ifTrue:[
+ "ImageHeight"
+ height := value.
+ 'height ' print. height printNewline.
+ ^ self
+ ].
+ (tagType == 258) ifTrue:[
+ "bitspersample"
+ bitsPerSample := valueArray.
+ 'bitspersample ' print. bitsPerSample printNewline.
+ ^ self
+ ].
+ (tagType == 259) ifTrue:[
+ "compression"
+ compression := value.
+ 'compression ' print. compression printNewline.
+ ^ self
+ ].
+ (tagType == 262) ifTrue:[
+ "photometric"
+ (value == 0) ifTrue:[
+ photometric := #whiteIs0
+ ] ifFalse:[
+ (value == 1) ifTrue:[
+ photometric := #blackIs0
+ ] ifFalse:[
+ (value == 2) ifTrue:[
+ photometric := #rgb
+ ] ifFalse:[
+ (value == 3) ifTrue:[
+ photometric := #palette
+ ] ifFalse:[
+ (value == 4) ifTrue:[
+ photometric := #transparency
+ ] ifFalse:[
+ photometric := nil
+ ]
+ ]
+ ]
+ ]
+ ].
+ 'photometric ' print. photometric printNewline.
+ ^ self
+ ].
+ (tagType == 263) ifTrue:[
+ "Treshholding"
+ "threshholding := value."
+ 'treshholding ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 264) ifTrue:[
+ "CellWidth"
+ "cellWidth:= value."
+ 'cellWidth ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 265) ifTrue:[
+ "CellLength"
+ "cellLength:= value."
+ 'cellLength ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 266) ifTrue:[
+ "fillOrder"
+ (value == 1) ifTrue:[
+ fillOrder := #msb
+ ] ifFalse:[
+ (value == 2) ifTrue:[
+ fillOrder := #lsb
+ ] ifFalse:[
+ fillOrder := nil
+ ]
+ ].
+ 'fillorder ' print. fillOrder printNewline.
+ ^ self
+ ].
+ (tagType == 269) ifTrue:[
+ "documentName"
+ 'documentName ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 270) ifTrue:[
+ "imageDescription"
+ 'imageDescription ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 271) ifTrue:[
+ "make"
+ 'make ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 272) ifTrue:[
+ "model"
+ 'model ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 273) ifTrue:[
+ "stripoffsets"
+ stripOffsets := valueArray.
+ 'stripOffsets Array(' print. stripOffsets size print. ')' printNewline.
+ ^ self
+ ].
+ (tagType == 274) ifTrue:[
+ "Orientation"
+ "orientation:= value."
+ 'orientation ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 277) ifTrue:[
+ "samplesPerPixel"
+ samplesPerPixel := value.
+ 'samplesperpixel ' print. samplesPerPixel printNewline.
+ ^ self
+ ].
+ (tagType == 278) ifTrue:[
+ "rowsperstrip"
+ rowsPerStrip := value.
+ 'rowsperstrip ' print. rowsPerStrip printNewline.
+ ^ self
+ ].
+ (tagType == 279) ifTrue:[
+ "stripbytecount"
+ stripByteCounts := valueArray.
+ 'stripByteCounts Array(' print.
+ stripByteCounts size print.
+ ')' printNewline.
+ ^ self
+ ].
+ (tagType == 280) ifTrue:[
+ "MinSampleValue"
+ "minSampleValue:= value."
+ 'minSampleValue ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 281) ifTrue:[
+ "MaxSampleValue"
+ "maxSampleValue:= value."
+ 'maxSampleValue ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 282) ifTrue:[
+ "xResolution"
+ 'xres ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 283) ifTrue:[
+ "yResolution"
+ 'yres ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 284) ifTrue:[
+ "planarconfig"
+ (value == 1) ifTrue:[
+ planarConfiguration := 1
+ ] ifFalse:[
+ (value == 2) ifTrue:[
+ planarConfiguration := 2
+ ] ifFalse:[
+ planarConfiguration := nil
+ ]
+ ].
+ 'planarconfig ' print. planarConfiguration printNewline.
+ ^ self
+ ].
+ (tagType == 285) ifTrue:[
+ "pageName"
+ 'pageName ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 286) ifTrue:[
+ "xPosition"
+ 'xPos ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 287) ifTrue:[
+ "yPosition"
+ 'yPos ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 288) ifTrue:[
+ "freeOffsets"
+ 'freeOffsets ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 289) ifTrue:[
+ "freeByteCounts"
+ 'freeByteCounts ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 290) ifTrue:[
+ "grayResponceUnit"
+ 'grayResponceUnit' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 291) ifTrue:[
+ "grayResponceCurve"
+ 'grayResponceCurve' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 292) ifTrue:[
+ "group3options"
+ group3options := value.
+ 'group3options ' print. group3options printNewline.
+ ^ self
+ ].
+ (tagType == 293) ifTrue:[
+ "group4options"
+ "group4options := value."
+ 'group4options ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 296) ifTrue:[
+ "resolutionunit"
+ (value == 1) ifTrue:[
+ 'res-unit pixel' printNewline
+ ] ifFalse:[
+ (value == 2) ifTrue:[
+ 'res-unit inch' printNewline
+ ] ifFalse:[
+ (value == 3) ifTrue:[
+ 'res-unit mm' printNewline
+ ] ifFalse:[
+ 'res-unit invalid' printNewline
+ ]
+ ]
+ ].
+ "resolutionUnit := value."
+ ^ self
+ ].
+ (tagType == 297) ifTrue:[
+ "pageNumber"
+ "pageNumber := value."
+ 'pageNumber ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 300) ifTrue:[
+ "colorResponceUnit"
+ 'colorResponceUnit' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 301) ifTrue:[
+ "colorResponceCurve"
+ 'colorResponceCurve' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 306) ifTrue:[
+ "dateTime"
+ 'dateTime ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 315) ifTrue:[
+ "artist"
+ 'artist ' print. value printNewline.
+ ^ self
+ ].
+ (tagType == 317) ifTrue:[
+ "predictor"
+ predictor := value.
+ 'predictor ' print. predictor printNewline.
+ ^ self
+ ].
+ (tagType == 320) ifTrue:[
+ "colorMap"
+ 'colorMap (size=' print. valueArray size print. ')' printNewline.
+ n := valueArray size // 3.
+ colorMap := Array new:3.
+ colorMap at:1 put:(valueArray copyFrom:1 to:n).
+ colorMap at:2 put:(valueArray copyFrom:n+1 to:2*n).
+ colorMap at:3 put:(valueArray copyFrom:2*n+1 to:3*n).
+ 1 to:3 do:[:c |
+ 1 to:n do:[:e |
+ val := (colorMap at:c) at:e.
+ val := (val * 255.0 / 16rFFFF) rounded.
+ (colorMap at:c) at:e put:val
+ ]
+ ].
+ ^ self
+ ].
+
+'tag:' print. tagType print. ' typ:' print. numberType print.
+' len:' print. length print. ' offs:' print. offset print.
+' val:' print. value print. ' valArr:' print. valueArray printNewline.
+
+ 'unknown type ' print. tagType printNewline
+!
+
+writeBits
+ "write bits as one strip"
+
+ |offs bytesPerRow|
+
+ data size < 16rFFFF ifTrue:[
+ stripOffsets := Array with:(outStream position - 1).
+ stripByteCounts := Array with:(data size).
+ outStream nextPutBytes:data size from:data.
+ rowsPerStrip := height
+ ] ifFalse:[
+ stripOffsets := Array new:height.
+ bytesPerRow := data size // height.
+ stripByteCounts := (Array new:height) atAllPut:bytesPerRow.
+
+ offs := 1.
+ 1 to:height do:[:row |
+ stripOffsets at:row put:(outStream position - 1).
+ outStream nextPutBytes:data size from:data startingAt:offs.
+ offs := offs + bytesPerRow
+ ].
+ rowsPerStrip := 1
+ ].
+ 'stripOffsets: ' print. stripOffsets printNewline.
+ 'stripByteCounts: ' print. stripByteCounts printNewline.
+!
+
+writeColorMap
+ colorMapPos := outStream position.
+ colorMap do:[:subMap |
+ subMap do:[:entry |
+ "my maps are 8 bit - tiff map is 16 bit"
+
+ self writeShort:(entry / 255 * 16rFFFF) rounded
+ ]
+ ]
+!
+
+writeStripOffsets
+'stripOffsets: ' print. stripOffsets printNewline.
+'store stripoffsets at: ' print. outStream position printNewline.
+ stripOffsetsPos := outStream position.
+ stripOffsets do:[:o |
+ self writeLong:o
+ ]
+!
+
+writeStripByteCounts
+'stripByteCounts: ' print. stripByteCounts printNewline.
+'store stripbytecounts at: ' print. outStream position printNewline.
+ stripByteCountsPos := outStream position.
+ stripByteCounts do:[:c |
+ self writeShort:c
+ ]
+!
+
+writeBitsPerSample
+'bitsPerSample: ' print. bitsPerSample printNewline.
+'store bitspersample at: ' print. outStream position printNewline.
+ bitsPerSamplePos := outStream position.
+ bitsPerSample do:[:n |
+ self writeShort:n
+ ]
+!
+
+writeTag:tagType
+ self writeTiffTag:tagType.
+!
+
+writeTiffTag:tagType
+ |value valueArray numberType count address|
+
+ count := 1.
+ address := nil.
+ (tagType == 253) ifTrue:[
+ "tiff class"
+ ].
+ (tagType == 254) ifTrue:[
+ ].
+ (tagType == 255) ifTrue:[
+ "SubfileType"
+ value := subFileType.
+ numberType := #long.
+ ].
+ (tagType == 256) ifTrue:[
+ "ImageWidth"
+ value := width.
+ numberType := #short.
+ ].
+ (tagType == 257) ifTrue:[
+ "ImageHeight"
+ value := height.
+ numberType := #short.
+ ].
+ (tagType == 258) ifTrue:[
+ "bitspersample"
+ address := bitsPerSamplePos - 1.
+ numberType := #short.
+ count := bitsPerSample size.
+ valueArray := bitsPerSample
+ ].
+ (tagType == 259) ifTrue:[
+ "compression"
+ value := compression.
+ numberType := #short.
+ ].
+ (tagType == 262) ifTrue:[
+ "photometric"
+ (photometric == #whiteIs0) ifTrue:[
+ value := 0
+ ] ifFalse:[
+ (photometric == #blackIs0) ifTrue:[
+ value := 1
+ ] ifFalse:[
+ (photometric == #rgb) ifTrue:[
+ value := 2
+ ] ifFalse:[
+ (photometric == #palette) ifTrue:[
+ value := 3
+ ] ifFalse:[
+ (photometric == #transparency) ifTrue:[
+ value := 4
+ ] ifFalse:[
+ self error:'bad photometric'
+ ]
+ ]
+ ]
+ ]
+ ].
+ numberType := #short.
+ ].
+ (tagType == 263) ifTrue:[
+ ].
+ (tagType == 264) ifTrue:[
+ ].
+ (tagType == 265) ifTrue:[
+ ].
+ (tagType == 266) ifTrue:[
+ "fillOrder"
+ (fillOrder == #msb) ifTrue:[
+ value := 1
+ ] ifFalse:[
+ (fillOrder == #lsb) ifTrue:[
+ value := 2
+ ] ifFalse:[
+ self error:'bad fillOrder'
+ ]
+ ].
+ numberType := #short.
+ ].
+ (tagType == 269) ifTrue:[
+ ].
+ (tagType == 270) ifTrue:[
+ ].
+ (tagType == 271) ifTrue:[
+ ].
+ (tagType == 272) ifTrue:[
+ ].
+ (tagType == 273) ifTrue:[
+ "stripoffsets"
+ address := stripOffsetsPos - 1.
+ numberType := #long.
+ count := stripOffsets size.
+ valueArray := stripOffsets
+ ].
+ (tagType == 274) ifTrue:[
+ ].
+ (tagType == 277) ifTrue:[
+ "samplesPerPixel"
+ value := samplesPerPixel.
+ numberType := #short.
+ ].
+ (tagType == 278) ifTrue:[
+ "rowsperstrip"
+ value := rowsPerStrip.
+ numberType := #short.
+ ].
+ (tagType == 279) ifTrue:[
+ "stripbytecount"
+ address := stripByteCountsPos - 1.
+ numberType := #short.
+ count := stripByteCounts size.
+ valueArray := stripByteCounts
+ ].
+ (tagType == 280) ifTrue:[
+ "min sample value"
+ ].
+ (tagType == 281) ifTrue:[
+ "max sample value"
+ ].
+ (tagType == 282) ifTrue:[
+ "x resolution"
+ ].
+ (tagType == 283) ifTrue:[
+ "y resolution"
+ ].
+ (tagType == 284) ifTrue:[
+ "planarconfig"
+ value := planarConfiguration.
+ numberType := #short.
+ ].
+ (tagType == 285) ifTrue:[
+ "pageName"
+ ].
+ (tagType == 286) ifTrue:[
+ "xPosition"
+ ].
+ (tagType == 287) ifTrue:[
+ "yPosition"
+ ].
+ (tagType == 288) ifTrue:[
+ "freeOffsets"
+ ].
+ (tagType == 289) ifTrue:[
+ "freeByteCounts"
+ ].
+ (tagType == 290) ifTrue:[
+ "grayResponceUnit"
+ ].
+ (tagType == 291) ifTrue:[
+ "grayResponceCurve"
+ ].
+ (tagType == 292) ifTrue:[
+ "group3options"
+ value := group3options.
+ numberType := #long.
+ ].
+ (tagType == 293) ifTrue:[
+ "group4options"
+ ].
+ (tagType == 296) ifTrue:[
+ "resolutionunit"
+ ^ self
+ ].
+ (tagType == 297) ifTrue:[
+ "pageNumber"
+ ].
+ (tagType == 300) ifTrue:[
+ "colorResponceUnit"
+ ].
+ (tagType == 301) ifTrue:[
+ "colorResponceCurve"
+ ].
+ (tagType == 306) ifTrue:[
+ "dateTime"
+ ].
+ (tagType == 315) ifTrue:[
+ "artist"
+ ].
+ (tagType == 317) ifTrue:[
+ "predictor"
+ ].
+ (tagType == 320) ifTrue:[
+ "colormap"
+ address := colorMapPos - 1.
+ numberType := #short.
+ count := (colorMap at:1) size * 3.
+ ].
+
+ (value isNil and:[address isNil]) ifTrue:[
+ self error:'unhandled tag'.
+ ^ self
+ ].
+
+'tag:' print. tagType print. ' typ:' print. numberType print.
+' len:' print. count print.
+' val:' print. value printNewline.
+
+ self writeShort:tagType.
+ numberType == #short ifTrue:[
+ self writeShort:3.
+ self writeLong:count.
+ ] ifFalse:[
+ numberType == #long ifTrue:[
+ self writeShort:4.
+ self writeLong:count.
+ ] ifFalse:[
+ numberType == #byte ifTrue:[
+ self writeShort:1.
+ self writeLong:count.
+ ] ifFalse:[
+ self error:'bad numbertype'
+ ]
+ ]
+ ].
+ address notNil ifTrue:[
+ (numberType == #long and:[count == 1]) ifTrue:[
+ self writeLong:(valueArray at:1).
+ ^ self
+ ].
+ (numberType == #short and:[count <= 2]) ifTrue:[
+ self writeShort:(valueArray at:1).
+ count == 2 ifTrue:[
+ self writeShort:(valueArray at:2).
+ ] ifFalse:[
+ self writeShort:0
+ ].
+ ^ self
+ ].
+ (numberType == #byte and:[count <= 4]) ifTrue:[
+ outStream nextPut:(valueArray at:1).
+ count > 1 ifTrue:[
+ outStream nextPut:(valueArray at:2).
+ count > 2 ifTrue:[
+ outStream nextPut:(valueArray at:3).
+ count > 3 ifTrue:[
+ outStream nextPut:(valueArray at:4).
+ ] ifFalse:[
+ outStream nextPut:0
+ ].
+ ] ifFalse:[
+ outStream nextPut:0
+ ].
+ ] ifFalse:[
+ outStream nextPut:0
+ ].
+ ^ self
+ ].
+ self writeLong:address.
+ ^ self
+ ].
+ numberType == #short ifTrue:[
+ self writeShort:value.
+ self writeShort:0
+ ] ifFalse:[
+ numberType == #long ifTrue:[
+ self writeLong:value
+ ] ifFalse:[
+ numberType == #byte ifTrue:[
+ outStream nextPut:value.
+ outStream nextPut:0.
+ outStream nextPut:0.
+ outStream nextPut:0.
+ ] ifFalse:[
+ self error:'bad numbertype'
+ ]
+ ]
+ ].
+!
+
+readUncompressedTiffImageData
+ |bytesPerRow bitsPerRow nPlanes
+ stripNr "{ Class: SmallInteger }"
+ offset "{ Class: SmallInteger }"
+ row "{ Class: SmallInteger }"
+ bytesPerStrip "{ Class: SmallInteger }"
+ bitsPerPixel |
+
+ nPlanes := samplesPerPixel.
+
+ "only support 1-sample/pixel,
+ with alpha - if separate planes,
+ or rgb - if non separate planes and no alpha"
+
+ (nPlanes == 2) ifTrue:[
+ (planarConfiguration ~~ 2) ifTrue:[
+ self error:'with alpha, only separate planes supported'.
+ ^ nil
+ ].
+ 'ignoring alpha plane' printNewline.
+ nPlanes := 1.
+ bitsPerPixel := bitsPerSample at:1
+ ] ifFalse:[
+ (nPlanes == 3) ifTrue:[
+ (planarConfiguration ~~ 1) ifTrue:[
+ self error:'only non separate planes supported'.
+ ^ nil
+ ].
+ bitsPerSample ~= #(8 8 8) ifTrue:[
+ self error:'only 8/8/8 rgb images supported'.
+ ^ nil
+ ].
+ bitsPerPixel := 24
+ ] ifFalse:[
+ (nPlanes ~~ 1) ifTrue:[
+ self error:'format not supported'.
+ ^ nil
+ ].
+ bitsPerPixel := bitsPerSample at:1
+ ]
+ ].
+
+ bitsPerRow := width * bitsPerPixel.
+ bytesPerRow := bitsPerRow // 8.
+ ((bitsPerRow \\ 8) ~~ 0) ifTrue:[
+ bytesPerRow := bytesPerRow + 1
+ ].
+
+ data := ByteArray uninitializedNew:(bytesPerRow * height).
+
+ offset := 1.
+ stripNr := 0.
+
+ row := 1.
+ bytesPerStrip := bytesPerRow * rowsPerStrip.
+ [row <= height] whileTrue:[
+ stripNr := stripNr + 1.
+ inStream position:((stripOffsets at:stripNr) + 1).
+
+ inStream nextBytes:(bytesPerRow * rowsPerStrip)
+ into:data
+ startingAt:offset.
+
+ offset := offset + bytesPerStrip.
+ row := row + rowsPerStrip
+ ]
+!
+
+readLZWTiffImageData
+ "read LZW compressed tiff data; this method only
+ handles 3x8 rgb and 1x2 or 2x2 greyscale images.
+ For 2x2 greyscale images, the alpha plane is ignored.
+ (maybe other formats work also - its simply not
+ tested)"
+
+ |bytesPerRow compressedStrip nPlanes
+ bytesPerStrip "{ Class: SmallInteger }"
+ nBytes "{ Class: SmallInteger }"
+ prevSize "{ Class: SmallInteger }"
+ stripNr "{ Class: SmallInteger }"
+ offset "{ Class: SmallInteger }"
+ row "{ Class: SmallInteger }" |
+
+ nPlanes := samplesPerPixel.
+
+ (nPlanes == 3) ifTrue:[
+ ((bitsPerSample at:1) ~~ 8) ifTrue:[
+ self error:'only 8 bit/sample supported'.
+ ^ nil
+ ].
+ ((bitsPerSample at:2) ~~ 8) ifTrue:[
+ self error:'only 8 bit/sample supported'.
+ ^ nil
+ ].
+ ((bitsPerSample at:3) ~~ 8) ifTrue:[
+ self error:'only 8 bit/sample supported'.
+ ^ nil
+ ].
+ bytesPerRow := width * samplesPerPixel.
+ ] ifFalse:[
+ (nPlanes == 2) ifTrue:[
+ (planarConfiguration ~~ 2) ifTrue:[
+ self error:'only separate planes supported'.
+ ^ nil
+ ].
+ 'ignoring alpha plane' printNewline.
+ nPlanes := 1
+ ].
+ (nPlanes == 1) ifFalse:[
+ self error:'only 3-sample rgb / monochrome supported'.
+ ^ nil
+ ].
+ bytesPerRow := (width * (bitsPerSample at:1) + 7) // 8.
+ ].
+
+ stripByteCounts isNil ifTrue:[
+ self error:'currently require stripByteCounts'.
+ ^ nil
+ ].
+
+ data := ByteArray uninitializedNew:(bytesPerRow * height).
+
+ offset := 1.
+ stripNr := 0.
+
+ row := 1.
+ bytesPerStrip := bytesPerRow * rowsPerStrip.
+ prevSize := 0.
+ [row <= height] whileTrue:[
+ stripNr := stripNr + 1.
+ inStream position:((stripOffsets at:stripNr) + 1).
+ nBytes := stripByteCounts at:stripNr.
+ (nBytes > prevSize) ifTrue:[
+ compressedStrip := ByteArray uninitializedNew:nBytes.
+ prevSize := nBytes
+ ].
+ inStream nextBytes:nBytes
+ into:compressedStrip.
+ self class decompressLZWFrom:compressedStrip
+ count:nBytes
+ into:data
+ startingAt:offset.
+ offset := offset + bytesPerStrip.
+ row := row + rowsPerStrip
+ ].
+
+ (predictor == 2) ifTrue:[
+ self class decodeDelta:3 in:data width:width height:height
+ ]
+!
+
+readCCITTGroup3TiffImageData
+ "not really tested - all I got is a single
+ fax from NeXT step"
+
+ |bytesPerRow bitsPerRow compressedStrip nPlanes
+ stripNr "{ Class: SmallInteger }"
+ offset "{ Class: SmallInteger }"
+ row "{ Class: SmallInteger }"
+ bytesPerStrip "{ Class: SmallInteger }" |
+
+ nPlanes := samplesPerPixel.
+ (nPlanes == 2) ifTrue:[
+ 'ignoring alpha plane' printNewline.
+ nPlanes := 1
+ ].
+
+ (nPlanes ~~ 1) ifTrue:[
+ self error:'only monochrome/greyscale supported'.
+ ^ nil
+ ].
+
+ stripByteCounts isNil ifTrue:[
+ self error:'currently require stripByteCounts'.
+ ^ nil
+ ].
+ (rowsPerStrip ~~ 1) isNil ifTrue:[
+ self error:'currently require rowsPerStrip to be 1'.
+ ^ nil
+ ].
+
+
+ bitsPerRow := width * (bitsPerSample at:1).
+ bytesPerRow := bitsPerRow // 8.
+ ((bitsPerRow \\ 8) ~~ 0) ifTrue:[
+ bytesPerRow := bytesPerRow + 1
+ ].
+
+ data := ByteArray uninitializedNew:(bytesPerRow * height).
+ compressedStrip := ByteArray uninitializedNew:bytesPerRow.
+
+ offset := 1.
+ stripNr := 0.
+
+ row := 1.
+ bytesPerStrip := bytesPerRow * rowsPerStrip.
+ [row <= height] whileTrue:[
+ stripNr := stripNr + 1.
+ inStream position:((stripOffsets at:stripNr) + 1).
+ inStream nextBytes:(stripByteCounts at:stripNr)
+ into:compressedStrip.
+ self class decompressCCITT3From:compressedStrip
+ into:data
+ startingAt:offset
+ count:width.
+ offset := offset + bytesPerStrip.
+ row := row + rowsPerStrip
+ ]
+!
+
+readJPEGTiffImageData
+ 'jpeg compression not implemented' printNewline
+!
+
+readPackbitsTiffImageData
+ "had no samples yet - however, packbits decompression
+ is rather trivial to add ..."
+
+ 'packbits compression not implemented' printNewline
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/WinIconRdr.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,257 @@
+"
+ COPYRIGHT (c) 1993 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.
+"
+
+ImageReader subclass:#WindowsIconReader
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Graphics-Support'
+!
+
+WindowsIconReader comment:'
+
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+this class provides methods for loading and saving Windows and OS2
+icon files..
+
+%W% %E%
+written Jun 93 by claus
+'!
+
+!WindowsIconReader methodsFor:'reading from file'!
+
+fromWindowsFile: aFilename
+ | fileSize header inDepth
+ rawMap rMap gMap bMap srcIndex dstIndex
+ data4 mask tmp bytesPerRow|
+
+ inStream := FileStream readonlyFileNamed:aFilename.
+ inStream isNil ifTrue:[
+ 'open error' printNewline.
+ ^ nil
+ ].
+
+ inStream binary.
+ fileSize := inStream size.
+
+ "read the header"
+
+ header := ByteArray new:16r50.
+ inStream nextBytes:16r50 into:header.
+ width := header at:7.
+ height := header at:8.
+ inDepth := header at:16r25.
+
+ "read the colormap"
+
+ rawMap := ByteArray new:(16*3).
+ inStream nextBytes:(16*3) into:rawMap.
+ rMap := Array new:16.
+ gMap := Array new:16.
+ bMap := Array new:16.
+ srcIndex := 1.
+ 1 to:16 do:[:i |
+ rMap at:i put:(rawMap at:srcIndex).
+ srcIndex := srcIndex + 1.
+ gMap at:i put:(rawMap at:srcIndex).
+ srcIndex := srcIndex + 1.
+ bMap at:i put:(rawMap at:srcIndex).
+ srcIndex := srcIndex + 1.
+ ].
+
+ inStream position:16r7F.
+
+ "read the data bits"
+
+ bytesPerRow := width * inDepth / 8.
+ data4 := ByteArray new:(height * bytesPerRow).
+ inStream nextBytes:(height * bytesPerRow) into:data4.
+
+ "read mask"
+
+"
+ mask := ByteArray new:(width * height / 8).
+ inStream nextBytes:(width * height / 8) into:mask.
+"
+
+ "stupid: last row first"
+
+ tmp := ByteArray new:(height * bytesPerRow).
+ srcIndex := 1.
+ dstIndex := (height - 1) * bytesPerRow + 1.
+ 1 to:height do:[:row |
+ tmp replaceFrom:dstIndex to:(dstIndex + bytesPerRow - 1)
+ with:data4 startingAt:srcIndex.
+ srcIndex := srcIndex + bytesPerRow.
+ dstIndex := dstIndex - bytesPerRow.
+ ].
+ data4 := tmp.
+
+ "expand into bytes"
+
+ data := ByteArray new:(width * height).
+ data4 expandPixels:inDepth width:width height:height
+ into:data mapping:nil.
+
+ photometric := #palette.
+ samplesPerPixel := 1.
+ bitsPerSample := #(8).
+ colorMap := Array with:rMap with:gMap with:bMap.
+ inStream close.
+
+ "
+ |i f|
+ i := Image fromFile:'/LocalLibrary/Images/WIN_icons/ibm.ico'.
+ f := i asFormOn:Display.
+ v drawOpaqueForm:(f ) x:5 y:5.
+ v drawOpaqueForm:(f magnifyBy:2@2) x:45 y:5
+ "
+!
+
+fromOS2File: aFilename
+ | fileSize header inDepth
+ rawMap rMap gMap bMap srcIndex dstIndex
+ data4 mask tmp bytesPerRow nColors|
+
+ inStream := FileStream readonlyFileNamed:aFilename.
+ inStream isNil ifTrue:[
+ 'open error' printNewline.
+ ^ nil
+ ].
+
+ inStream binary.
+ fileSize := inStream size.
+
+ "read the header"
+
+ header := ByteArray new:8r110.
+ inStream nextBytes:16 into:header.
+ (header startsWith:#(73 67)) ifTrue:[
+ "IC format"
+ inStream nextBytes:10 into:header startingAt:17.
+ width := header at:7.
+ height := header at:9.
+ inDepth := 2 "header at:11". "where is it"
+ ] ifFalse:[
+ inStream nextBytes:(8r110-16) into:header startingAt:17.
+ width := header at:8r101.
+ height := header at:8r103.
+ inDepth := header at:8r107.
+ ].
+
+ "read the colormap"
+
+ nColors := 1 bitShift:inDepth.
+
+ rawMap := ByteArray new:(nColors*3).
+ inStream nextBytes:(nColors*3) into:rawMap.
+ rMap := Array new:nColors.
+ gMap := Array new:nColors.
+ bMap := Array new:nColors.
+ srcIndex := 1.
+ 1 to:nColors do:[:i |
+ bMap at:i put:(rawMap at:srcIndex).
+ srcIndex := srcIndex + 1.
+ gMap at:i put:(rawMap at:srcIndex).
+ srcIndex := srcIndex + 1.
+ rMap at:i put:(rawMap at:srcIndex).
+ srcIndex := srcIndex + 1.
+ ].
+
+ "read mask"
+
+ mask := ByteArray new:(width * height / 8).
+ inStream nextBytes:(width * height / 8) into:mask.
+
+ "what is this"
+
+ inStream nextBytes:(width * height / 8) into:mask.
+
+ "read the data bits"
+
+ bytesPerRow := width * inDepth / 8.
+ data4 := ByteArray new:(height * bytesPerRow).
+ inStream nextBytes:(height * bytesPerRow) into:data4.
+
+ "stupid: last row first"
+
+ tmp := ByteArray new:(height * bytesPerRow).
+ srcIndex := 1.
+ dstIndex := (height - 1) * bytesPerRow + 1.
+ 1 to:height do:[:row |
+ tmp replaceFrom:dstIndex to:(dstIndex + bytesPerRow - 1)
+ with:data4 startingAt:srcIndex.
+ srcIndex := srcIndex + bytesPerRow.
+ dstIndex := dstIndex - bytesPerRow.
+ ].
+ data4 := tmp.
+
+ "expand into bytes"
+
+ data := ByteArray new:(width * height).
+ data4 expandPixels:inDepth width:width height:height
+ into:data mapping:nil.
+
+ photometric := #palette.
+ samplesPerPixel := 1.
+ bitsPerSample := #(8).
+ colorMap := Array with:rMap with:gMap with:bMap.
+ inStream close.
+
+ "
+ |i f|
+ i := Image fromFile:'/LocalLibrary/Images/OS2/dos3.ico'.
+ f := i asFormOn:Display.
+ v drawOpaqueForm:(f magnifyBy:2@2) x:5 y:5
+ "
+!
+
+fromFile: aFilename
+ | fileSize header |
+
+ inStream := FileStream readonlyFileNamed:aFilename.
+ inStream isNil ifTrue:[
+ 'open error' printNewline.
+ ^ nil
+ ].
+
+ inStream binary.
+ fileSize := inStream size.
+
+ fileSize < 16 ifTrue:[
+ inStream close.
+ self error:'short file'.
+ ^ nil
+ ].
+
+ header := ByteArray new:16.
+ inStream nextBytes:16 into:header.
+ (header startsWith:#(66 65)) ifTrue:[ "BA"
+ inStream close.
+ ^ self fromOS2File:aFilename
+ ].
+ (header startsWith:#(73 67)) ifTrue:[ "IC"
+ inStream close.
+ ^ self fromOS2File:aFilename
+ ].
+ (header startsWith:#(0 0 1 0 1 0)) ifTrue:[
+ inStream close.
+ ^ self fromWindowsFile:aFilename
+ ].
+ self error:'format not supported'.
+ inStream close.
+ ^ nil
+
+ "Image fromFile:'/LocalLibrary/Images/OS2_icons/dos.ico'"
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/WindowsIconReader.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,257 @@
+"
+ COPYRIGHT (c) 1993 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.
+"
+
+ImageReader subclass:#WindowsIconReader
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ category:'Graphics-Support'
+!
+
+WindowsIconReader comment:'
+
+COPYRIGHT (c) 1993 by Claus Gittinger
+ All Rights Reserved
+
+this class provides methods for loading and saving Windows and OS2
+icon files..
+
+%W% %E%
+written Jun 93 by claus
+'!
+
+!WindowsIconReader methodsFor:'reading from file'!
+
+fromWindowsFile: aFilename
+ | fileSize header inDepth
+ rawMap rMap gMap bMap srcIndex dstIndex
+ data4 mask tmp bytesPerRow|
+
+ inStream := FileStream readonlyFileNamed:aFilename.
+ inStream isNil ifTrue:[
+ 'open error' printNewline.
+ ^ nil
+ ].
+
+ inStream binary.
+ fileSize := inStream size.
+
+ "read the header"
+
+ header := ByteArray new:16r50.
+ inStream nextBytes:16r50 into:header.
+ width := header at:7.
+ height := header at:8.
+ inDepth := header at:16r25.
+
+ "read the colormap"
+
+ rawMap := ByteArray new:(16*3).
+ inStream nextBytes:(16*3) into:rawMap.
+ rMap := Array new:16.
+ gMap := Array new:16.
+ bMap := Array new:16.
+ srcIndex := 1.
+ 1 to:16 do:[:i |
+ rMap at:i put:(rawMap at:srcIndex).
+ srcIndex := srcIndex + 1.
+ gMap at:i put:(rawMap at:srcIndex).
+ srcIndex := srcIndex + 1.
+ bMap at:i put:(rawMap at:srcIndex).
+ srcIndex := srcIndex + 1.
+ ].
+
+ inStream position:16r7F.
+
+ "read the data bits"
+
+ bytesPerRow := width * inDepth / 8.
+ data4 := ByteArray new:(height * bytesPerRow).
+ inStream nextBytes:(height * bytesPerRow) into:data4.
+
+ "read mask"
+
+"
+ mask := ByteArray new:(width * height / 8).
+ inStream nextBytes:(width * height / 8) into:mask.
+"
+
+ "stupid: last row first"
+
+ tmp := ByteArray new:(height * bytesPerRow).
+ srcIndex := 1.
+ dstIndex := (height - 1) * bytesPerRow + 1.
+ 1 to:height do:[:row |
+ tmp replaceFrom:dstIndex to:(dstIndex + bytesPerRow - 1)
+ with:data4 startingAt:srcIndex.
+ srcIndex := srcIndex + bytesPerRow.
+ dstIndex := dstIndex - bytesPerRow.
+ ].
+ data4 := tmp.
+
+ "expand into bytes"
+
+ data := ByteArray new:(width * height).
+ data4 expandPixels:inDepth width:width height:height
+ into:data mapping:nil.
+
+ photometric := #palette.
+ samplesPerPixel := 1.
+ bitsPerSample := #(8).
+ colorMap := Array with:rMap with:gMap with:bMap.
+ inStream close.
+
+ "
+ |i f|
+ i := Image fromFile:'/LocalLibrary/Images/WIN_icons/ibm.ico'.
+ f := i asFormOn:Display.
+ v drawOpaqueForm:(f ) x:5 y:5.
+ v drawOpaqueForm:(f magnifyBy:2@2) x:45 y:5
+ "
+!
+
+fromOS2File: aFilename
+ | fileSize header inDepth
+ rawMap rMap gMap bMap srcIndex dstIndex
+ data4 mask tmp bytesPerRow nColors|
+
+ inStream := FileStream readonlyFileNamed:aFilename.
+ inStream isNil ifTrue:[
+ 'open error' printNewline.
+ ^ nil
+ ].
+
+ inStream binary.
+ fileSize := inStream size.
+
+ "read the header"
+
+ header := ByteArray new:8r110.
+ inStream nextBytes:16 into:header.
+ (header startsWith:#(73 67)) ifTrue:[
+ "IC format"
+ inStream nextBytes:10 into:header startingAt:17.
+ width := header at:7.
+ height := header at:9.
+ inDepth := 2 "header at:11". "where is it"
+ ] ifFalse:[
+ inStream nextBytes:(8r110-16) into:header startingAt:17.
+ width := header at:8r101.
+ height := header at:8r103.
+ inDepth := header at:8r107.
+ ].
+
+ "read the colormap"
+
+ nColors := 1 bitShift:inDepth.
+
+ rawMap := ByteArray new:(nColors*3).
+ inStream nextBytes:(nColors*3) into:rawMap.
+ rMap := Array new:nColors.
+ gMap := Array new:nColors.
+ bMap := Array new:nColors.
+ srcIndex := 1.
+ 1 to:nColors do:[:i |
+ bMap at:i put:(rawMap at:srcIndex).
+ srcIndex := srcIndex + 1.
+ gMap at:i put:(rawMap at:srcIndex).
+ srcIndex := srcIndex + 1.
+ rMap at:i put:(rawMap at:srcIndex).
+ srcIndex := srcIndex + 1.
+ ].
+
+ "read mask"
+
+ mask := ByteArray new:(width * height / 8).
+ inStream nextBytes:(width * height / 8) into:mask.
+
+ "what is this"
+
+ inStream nextBytes:(width * height / 8) into:mask.
+
+ "read the data bits"
+
+ bytesPerRow := width * inDepth / 8.
+ data4 := ByteArray new:(height * bytesPerRow).
+ inStream nextBytes:(height * bytesPerRow) into:data4.
+
+ "stupid: last row first"
+
+ tmp := ByteArray new:(height * bytesPerRow).
+ srcIndex := 1.
+ dstIndex := (height - 1) * bytesPerRow + 1.
+ 1 to:height do:[:row |
+ tmp replaceFrom:dstIndex to:(dstIndex + bytesPerRow - 1)
+ with:data4 startingAt:srcIndex.
+ srcIndex := srcIndex + bytesPerRow.
+ dstIndex := dstIndex - bytesPerRow.
+ ].
+ data4 := tmp.
+
+ "expand into bytes"
+
+ data := ByteArray new:(width * height).
+ data4 expandPixels:inDepth width:width height:height
+ into:data mapping:nil.
+
+ photometric := #palette.
+ samplesPerPixel := 1.
+ bitsPerSample := #(8).
+ colorMap := Array with:rMap with:gMap with:bMap.
+ inStream close.
+
+ "
+ |i f|
+ i := Image fromFile:'/LocalLibrary/Images/OS2/dos3.ico'.
+ f := i asFormOn:Display.
+ v drawOpaqueForm:(f magnifyBy:2@2) x:5 y:5
+ "
+!
+
+fromFile: aFilename
+ | fileSize header |
+
+ inStream := FileStream readonlyFileNamed:aFilename.
+ inStream isNil ifTrue:[
+ 'open error' printNewline.
+ ^ nil
+ ].
+
+ inStream binary.
+ fileSize := inStream size.
+
+ fileSize < 16 ifTrue:[
+ inStream close.
+ self error:'short file'.
+ ^ nil
+ ].
+
+ header := ByteArray new:16.
+ inStream nextBytes:16 into:header.
+ (header startsWith:#(66 65)) ifTrue:[ "BA"
+ inStream close.
+ ^ self fromOS2File:aFilename
+ ].
+ (header startsWith:#(73 67)) ifTrue:[ "IC"
+ inStream close.
+ ^ self fromOS2File:aFilename
+ ].
+ (header startsWith:#(0 0 1 0 1 0)) ifTrue:[
+ inStream close.
+ ^ self fromWindowsFile:aFilename
+ ].
+ self error:'format not supported'.
+ inStream close.
+ ^ nil
+
+ "Image fromFile:'/LocalLibrary/Images/OS2_icons/dos.ico'"
+! !
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/XBMReader.st Fri Jul 16 11:42:12 1993 +0200
@@ -0,0 +1,131 @@
+"
+ COPYRIGHT (c) 1992-93 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.
+"
+
+ImageReader subclass:#XBMReader
+ instanceVariableNames:''
+ classVariableNames:'reverseBits'
+ poolDictionaries:''
+ category:'Graphics-Support'
+!
+
+XBMReader comment:'
+
+COPYRIGHT (c) 1992-93 by Claus Gittinger
+ All Rights Reserved
+
+this class provides methods for loading and saving xbitmap-file pictures.
+
+%W% %E%
+written Sep 92 by claus
+'!
+
+!XBMReader methodsFor:'reading from file'!
+
+fromFile:aFileName
+ |line
+ index "{ Class: SmallInteger }"
+ dstIndex "{ Class: SmallInteger }"
+ bytesPerRow
+ lo "{ Class: SmallInteger }"
+ hi "{ Class: SmallInteger }"
+ val "{ Class: SmallInteger }"|
+
+ inStream := FileStream readonlyFileNamed:aFileName.
+ inStream isNil ifTrue:[
+ 'open error' printNewline.
+ ^ nil
+ ].
+
+ line := inStream nextLine.
+ line isNil ifTrue:[
+ inStream close.
+ ^ nil
+ ].
+
+ [line startsWith:'#'] whileFalse:[
+ line := inStream nextLine
+ ].
+
+ index := line indexOf:(Character space).
+ index := line indexOf:(Character space) startingAt:(index + 1).
+ (index == 0) ifTrue:[
+ 'format error' prrintNewline.
+ inStream close.
+ ^ nil
+ ].
+ line := line copyFrom:(index + 1).
+ width := Number readFromString:line.
+
+ line := inStream nextLine.
+ index := line indexOf:(Character space).
+ index := line indexOf:(Character space) startingAt:(index + 1).
+ (index == 0) ifTrue:[
+ 'format error' prrintNewline.
+ inStream close.
+ ^ nil
+ ].
+ line := line copyFrom:(index + 1).
+ height := Number readFromString:line.
+
+ bytesPerRow := width // 8.
+ ((width \\ 8) ~~ 0) ifTrue:[
+ bytesPerRow := bytesPerRow + 1
+ ].
+
+ 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
+ ]
+ ].
+
+ data := ByteArray new:(bytesPerRow * height).
+ dstIndex := 1.
+
+ line := inStream nextLine.
+ [line startsWith:'#'] whileTrue:[
+ line := inStream nextLine
+ ].
+
+ line := inStream nextLine.
+ [line notNil] whileTrue:[
+ index := 1.
+ [index ~~ 0] whileTrue:[
+ index := line indexOf:$x startingAt:index.
+ (index ~~ 0) ifTrue:[
+ index := index + 1.
+ hi := (line at:index) digitValue.
+ index := index + 1.
+ lo := (line at:index) digitValue.
+ val := (hi bitShift:4) bitOr:lo.
+ data at:dstIndex put:(reverseBits at:(val + 1)).
+ dstIndex := dstIndex + 1
+ ]
+ ].
+ line := inStream nextLine
+ ].
+ photometric := #whiteIs0.
+ samplesPerPixel := 1.
+ bitsPerSample := #(1)
+
+ "XBMReader fromFile:'bitmaps/globe1.xbm'"
+! !