Another Small 3.7 image (3.6mb)Lic. Edgar J. De Cleene edgardec2001 at yahoo.com.arTue Feb 22 21:02:46 UTC 2005
On 19/02/05 17:32, "Steven Swerling" <sswerling at yahoo.com> wrote: Steven: Here is the last fixes to your original work. I include all 3.7 original basic missed/ripped for have LuciaEnJaipur.image working. (real Morph app working). Very thanks for doing clever pass for me do a goal! Waiting picts !!! Cheers and hope see soon in the race. Edgar -------------- next part -------------- 'From Squeak3.7 of ''4 September 2004'' [latest update: #5989] on 22 February 2005 at 5:54:11 pm'! "Change Set: QuiteSmallFixex Date: 20 February 2005 Author: Edgar J. De Cleene I using all I lean about stripping here, fixing what IMHO are missed in Pavel/Steven image"! !FileUrl commentStamp: '<historical>' prior: 0! This class models a file URL according to (somewhat) RFC1738, see http://www.w3.org/Addressing/rfc1738.txt Here is the relevant part of the RFC: 3.10 FILES The file URL scheme is used to designate files accessible on a particular host computer. This scheme, unlike most other URL schemes, does not designate a resource that is universally accessible over the Internet. A file URL takes the form: file://<host>/<path> where <host> is the fully qualified domain name of the system on which the <path> is accessible, and <path> is a hierarchical directory path of the form <directory>/<directory>/.../<name>. For example, a VMS file DISK$USER:[MY.NOTES]NOTE123456.TXT might become <URL:file://vms.host.edu/disk$user/my/notes/note12345.txt> As a special case, <host> can be the string "localhost" or the empty string; this is interpreted as `the machine from which the URL is being interpreted'. The file URL scheme is unusual in that it does not specify an Internet protocol or access method for such files; as such, its utility in network protocols between hosts is limited. From the above we can conclude that the RFC says that the <path> part never starts or ends with a slash and is always absolute. If the last name can be a directory instead of a file is not specified clearly. The path is stored as a SequenceableCollection of path parts. Notes regarding non RFC features in this class: - If the last path part is the empty string, then the FileUrl is referring to a directory. This is also shown when sent #toText with a trailing slash. - The FileUrl has an attribute isAbsolute which refers to if the path should be considered absolute or relative to the current directory. This distinction is not visible in the String representation of FileUrl, since the RFC does not have that. - Fragment is supported (kept for historical reasons) ! Object subclass: #ImageReadWriter instanceVariableNames: 'stream' classVariableNames: 'ImageNotStoredSignal MagicNumberErrorSignal' poolDictionaries: '' category: 'Graphics-Files'! !ImageReadWriter commentStamp: '<historical>' prior: 0! Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved. I am an abstract class to provide for encoding and/or decoding an image on a stream. Instance Variables: stream <ReadStream | WriteStream> stream for image storages Class Variables: ImageNotStoredSignal <Signal> image not stored error signal MagicNumberErrorSignal <Signal> magic number error signal Subclasses must implement the following messages: accessing nextImage nextPutImage: testing canUnderstand (added tao 10/26/97)! ImageReadWriter subclass: #GIFReadWriter instanceVariableNames: 'width height bitsPerPixel colorPalette rowByteSize xpos ypos pass interlace codeSize clearCode eoiCode freeCode maxCode prefixTable suffixTable remainBitCount bufByte bufStream transparentIndex mapOf32 localColorTable delay loopCount offset' classVariableNames: 'Extension ImageSeparator Terminator' poolDictionaries: '' category: 'Graphics-Files'! !GIFReadWriter commentStamp: '<historical>' prior: 0! Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved. Used with permission. Modified for use in Squeak.! ImageMorph subclass: #AnimatedImageMorph instanceVariableNames: 'images offsets delays stepTime nextTime imageIndex previousOffset' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Basic'! !AnimatedImageMorph commentStamp: '<historical>' prior: 0! I am an ImageMorph that can hold more than one image. Each image has its own delay time.! SystemWindow subclass: #CollapsedMorph instanceVariableNames: 'uncollapsedMorph' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! !ProcessBrowser commentStamp: '<historical>' prior: 0! Change Set: ProcessBrowser Date: 14 March 2000 Author: Ned Konz email: ned at bike-nomad.com This is distributed under the Squeak License. Added 14 March: CPUWatcher integration automatically start and stop CPUWatcher added CPUWatcher to process list menu Added 29 October: MVC version 2.8, 2.7 compatibility rearranged menus added pointer inspection and chasing added suspend/resume recognized more well-known processes misc. bug fixes Added 26 October: highlight pc in source code Added 27 October: added 'signal semaphore' added 'inspect receiver', 'explore receiver', 'message tally' to stack list menu added 'find context', 'next context' to process list menu added 'change priority' and 'debug' choices to process list menu 27 October mods by Bob Arning: alters process display in Ned's ProcessBrowser to - show process priority - drop 'a Process in' that appears on each line - show in priority order - prettier names for known processes - fix to Utilities to forget update downloading process when it ends (1 less dead process) - correct stack dump for the active process ! PluggableTextMorphWithModel subclass: #ScrollableField instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Stacks'! SketchMorph subclass: #StickySketchMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Scripting Support'! ThreePhaseButtonMorph subclass: #TrashCanMorph instanceVariableNames: '' classVariableNames: 'TrashPic TrashPicOn' poolDictionaries: '' category: 'Morphic-Widgets'! TrashCanMorph subclass: #SmartTrashCanMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Puzzle'! !ChangeSorter methodsFor: 'class list' stamp: 'nb 6/17/2003 12:25'! copyClassToOther "Place these changes in the other changeSet also" | otherSorter otherChangeSet | self checkThatSidesDiffer: [^ self]. self okToChange ifFalse: [^ Beeper beep]. currentClassName ifNil: [^ Beeper beep]. otherSorter _ parent other: self. otherChangeSet _ otherSorter changeSet. otherChangeSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet. otherSorter showChangeSet: otherChangeSet.! ! !ChangeSorter methodsFor: 'class list' stamp: 'nb 6/17/2003 12:25'! moveClassToOther "Place class changes in the other changeSet and remove them from this one" self checkThatSidesDiffer: [^ self]. (self okToChange and: [currentClassName notNil]) ifFalse: [^ Beeper beep]. self copyClassToOther. self forgetClass! ! !FileUrl methodsFor: 'printing' stamp: 'gk 2/10/2004 10:49'! toText "Return the FileUrl according to RFC1738 plus supporting fragments: 'file://<host>/<path>#<fragment>' Note that <host> being '' is equivalent to 'localhost'. Note: The pathString can not start with a leading $/ to indicate an 'absolute' file path. This is not according to RFC1738 where the path should have no leading or trailing slashes, and always be considered absolute relative to the filesystem." ^String streamContents: [:s | s nextPutAll: self schemeName, '://'. host ifNotNil: [s nextPutAll: host]. s nextPut: $/; nextPutAll: self pathString. fragment ifNotNil: [ s nextPut: $#; nextPutAll: fragment encodeForHTTP ]]! ! !FileUrl methodsFor: 'testing' stamp: 'gk 2/9/2004 20:32'! firstPartIsDriveLetter "Return true if the first part of the path is a letter followed by a $: like 'C:' " | firstPart | path isEmpty ifTrue: [^false]. firstPart _ path first. ^firstPart size = 2 and: [ firstPart first isLetter and: [firstPart last = $:]]! ! !FileUrl methodsFor: 'paths' stamp: 'gk 2/10/2004 00:19'! pathDirString "Path to directory as url, using slash as delimiter. Filename is left out." ^String streamContents: [ :s | isAbsolute ifTrue: [ s nextPut: $/ ]. 1 to: self path size - 1 do: [ :ii | s nextPutAll: (path at: ii); nextPut: $/]]! ! !FileUrl methodsFor: 'paths' stamp: 'gk 2/10/2004 00:19'! pathForDirectory "Path using local file system's delimiter. $\ or $: DOS paths with drive letters should not be prepended with a pathNameDelimiter even though they are absolute. Filename is left out." ^String streamContents: [ :s | (self isAbsolute and: [self firstPartIsDriveLetter not]) ifTrue: [ s nextPut: $/ ]. 1 to: self path size - 1 do: [ :ii | s nextPutAll: (path at: ii); nextPut: FileDirectory default pathNameDelimiter]]! ! !FileUrl methodsFor: 'paths' stamp: 'gk 2/9/2004 20:24'! pathForFile "Path using local file system's delimiter. $\ or $: DOS paths with drive letters should not be prepended with a pathNameDelimiter even though they are absolute." | first | ^String streamContents: [ :s | first _ self isAbsolute and: [self firstPartIsDriveLetter not]. self path do: [ :p | first ifTrue: [ s nextPut: FileDirectory default pathNameDelimiter ]. first _ true. s nextPutAll: p ] ]! ! !FileUrl methodsFor: 'paths' stamp: 'gk 2/10/2004 10:22'! pathString "Path as it appears in a URL with $/ as delimiter." | first | ^String streamContents: [ :s | "isAbsolute ifTrue:[ s nextPut: $/ ]." first _ true. self path do: [ :p | first ifFalse: [ s nextPut: $/ ]. first _ false. s nextPutAll: p encodeForHTTP ] ]! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 10:16'! host "Return the host name, either 'localhost', '', or a fully qualified domain name." ^host ifNil: ['']! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 2/12/2004 16:22'! host: hostName "Set the host name, either 'localhost', '', or a fully qualified domain name." host _ hostName! ! !FileUrl methodsFor: 'accessing' stamp: 'ls 8/2/1998 05:39'! isAbsolute ^isAbsolute! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 10:50'! isAbsolute: aBoolean isAbsolute _ aBoolean! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 00:15'! path "Return an ordered collection of the path elements." ^path! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 2/10/2004 00:16'! path: anArray "Set the collection of path elements." path _ anArray! ! !FileUrl methodsFor: 'downloading' stamp: 'gk 2/10/2004 13:06'! default "Use the default local Squeak file directory." | local | local _ self class pathParts: (FileDirectory default pathParts), #('') isAbsolute: true. self privateInitializeFromText: self pathString relativeTo: local. "sets absolute also"! ! !FileUrl methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:42'! hasContents ^true! ! !FileUrl methodsFor: 'downloading' stamp: 'gk 2/10/2004 00:50'! retrieveContents | file pathString s type entries | pathString _ self pathForFile. file _ [FileStream readOnlyFileNamed: pathString] on: FileDoesNotExistException do:[:ex| ex return: nil]. file ifNotNil: [ type _ file mimeTypes. type ifNotNil:[type _ type first]. type ifNil:[MIMEDocument guessTypeFromName: self path last]. ^MIMELocalFileDocument contentType: type contentStream: file]. "see if it's a directory..." entries _ [(FileDirectory on: pathString) entries] on: InvalidDirectoryError do:[:ex| ex return: nil]. entries ifNil:[^nil]. s _ WriteStream on: String new. (pathString endsWith: '/') ifFalse: [ pathString _ pathString, '/' ]. s nextPutAll: '<title>Directory Listing for ', pathString, '</title>'. s nextPutAll: '<h1>Directory Listing for ', pathString, '</h1>'. s nextPutAll: '<ul>'. s cr. entries do: [ :entry | s nextPutAll: '<li><a href="'. s nextPutAll: entry name. s nextPutAll: '">'. s nextPutAll: entry name. s nextPutAll: '</a>'. s cr. ]. s nextPutAll: '</ul>'. ^MIMEDocument contentType: 'text/html' content: s contents url: ('file://', pathString)! ! !FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/10/2004 13:05'! host: aHostString pathParts: aCollection isAbsolute: aBoolean host _ aHostString. path _ aCollection. isAbsolute _ aBoolean! ! !FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/12/2004 16:01'! initializeFromPathString: aPathString "<aPathString> is a file path as a String. We construct a path collection using various heuristics." | pathString hasDriveLetter | pathString _ aPathString. pathString isEmpty ifTrue: [pathString _ '/']. path _ (pathString findTokens: '/') collect: [:token | token unescapePercents]. "A path like 'C:' refers in practice to 'c:/'" ((pathString endsWith: '/') or: [(hasDriveLetter _ self firstPartIsDriveLetter) and: [path size = 1]]) ifTrue: [path add: '']. "Decide if we are absolute by checking for leading $/ or beginning with drive letter. Smarts for other OSes?" self isAbsolute: ((pathString beginsWith: '/') or: [hasDriveLetter ifNil: [self firstPartIsDriveLetter]])! ! !FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/10/2004 13:04'! pathParts: aCollection isAbsolute: aBoolean ^self host: nil pathParts: aCollection isAbsolute: aBoolean! ! !FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/12/2004 16:11'! privateInitializeFromText: aString "Calculate host and path from a file URL in String format. Some malformed formats are allowed and interpreted by guessing." | schemeName pathString bare hasDriveLetter stream char i | bare _ aString withBlanksTrimmed. schemeName _ Url schemeNameForString: bare. (schemeName isNil or: [schemeName ~= self schemeName]) ifTrue: [ host _ ''. pathString _ bare] ifFalse: [ "First remove schemeName and colon" bare _ bare copyFrom: (schemeName size + 2) to: bare size. "A proper file URL then has two slashes before host, A malformed URL is interpreted as using syntax file:<path>." (bare beginsWith: '//') ifTrue: [i _ bare indexOf: $/ startingAt: 3. i=0 ifTrue: [ host _ bare copyFrom: 3 to: bare size. pathString _ ''] ifFalse: [ host _ bare copyFrom: 3 to: i-1. pathString _ bare copyFrom: host size + 3 to: bare size]] ifFalse: [host _ ''. pathString _ bare]]. self initializeFromPathString: pathString ! ! !FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/12/2004 16:29'! privateInitializeFromText: pathString relativeTo: aUrl "<pathString> should be a filesystem path. This url is adjusted to be aUrl + the path." | bare newPath | self host: aUrl host. self initializeFromPathString: pathString. self isAbsolute: aUrl isAbsolute. newPath _ aUrl path copy. newPath removeLast. "empty string that says its a directory" path do: [ :token | ((token ~= '..') and: [token ~= '.']) ifTrue: [ newPath addLast: token unescapePercents ]. token = '..' ifTrue: [ newPath isEmpty ifFalse: [ newPath last = '..' ifFalse: [ newPath removeLast ] ] ]. "token = '.' do nothing" ]. path _ newPath ! ! !FileUrl methodsFor: 'classification' stamp: 'gk 2/10/2004 10:34'! scheme ^self class schemeName! ! !FileUrl methodsFor: 'classification' stamp: 'gk 2/10/2004 10:34'! schemeName ^self class schemeName! ! !FileUrl methodsFor: 'copying' stamp: 'gk 2/10/2004 09:52'! copy "Be sure not to share the path with the copy" ^(self clone) path: path copy! ! !GradientFillStyle class methodsFor: 'nil' stamp: 'edc 2/20/2005 06:01'! sample "GradientFill sample" ^(self ramp: { 0.0 -> Color red. 0.5 -> Color green. 1.0 -> Color blue}) origin: 300 @ 300; direction: 400 at 0; normal: 0 at 400; radial: true; yourself! ! !ImageReadWriter methodsFor: 'accessing'! nextImage "Dencoding an image on stream and answer the image." ^self subclassResponsibility! ! !ImageReadWriter methodsFor: 'accessing'! nextPutImage: anImage "Encoding anImage on stream." ^self subclassResponsibility! ! !ImageReadWriter methodsFor: 'stream access'! atEnd ^stream atEnd! ! !ImageReadWriter methodsFor: 'stream access' stamp: 'sd 1/30/2004 15:18'! close stream close! ! !ImageReadWriter methodsFor: 'stream access'! contents ^stream contents! ! !ImageReadWriter methodsFor: 'stream access'! cr ^stream nextPut: Character cr asInteger! ! !ImageReadWriter methodsFor: 'stream access'! lf "PPM and PBM are used LF as CR." ^stream nextPut: Character lf asInteger! ! !ImageReadWriter methodsFor: 'stream access'! next ^stream next! ! !ImageReadWriter methodsFor: 'stream access'! next: size ^stream next: size! ! !ImageReadWriter methodsFor: 'stream access'! nextLong "Read a 32-bit quantity from the input stream." ^(stream next bitShift: 24) + (stream next bitShift: 16) + (stream next bitShift: 8) + stream next! ! !ImageReadWriter methodsFor: 'stream access'! nextLongPut: a32BitW "Write out a 32-bit integer as 32 bits." stream nextPut: ((a32BitW bitShift: -24) bitAnd: 16rFF). stream nextPut: ((a32BitW bitShift: -16) bitAnd: 16rFF). stream nextPut: ((a32BitW bitShift: -8) bitAnd: 16rFF). stream nextPut: (a32BitW bitAnd: 16rFF). ^a32BitW! ! !ImageReadWriter methodsFor: 'stream access'! nextPut: aByte ^stream nextPut: aByte! ! !ImageReadWriter methodsFor: 'stream access'! nextPutAll: aByteArray ^stream nextPutAll: aByteArray! ! !ImageReadWriter methodsFor: 'stream access'! nextWord "Read a 16-bit quantity from the input stream." ^(stream next bitShift: 8) + stream next! ! !ImageReadWriter methodsFor: 'stream access'! nextWordPut: a16BitW "Write out a 16-bit integer as 16 bits." stream nextPut: ((a16BitW bitShift: -8) bitAnd: 16rFF). stream nextPut: (a16BitW bitAnd: 16rFF). ^a16BitW! ! !ImageReadWriter methodsFor: 'stream access' stamp: 'tao 10/23/97 18:00'! peekFor: aValue ^stream peekFor: aValue! ! !ImageReadWriter methodsFor: 'stream access'! position ^stream position! ! !ImageReadWriter methodsFor: 'stream access'! position: anInteger ^stream position: anInteger! ! !ImageReadWriter methodsFor: 'stream access'! size ^stream size! ! !ImageReadWriter methodsFor: 'stream access'! skip: anInteger ^stream skip: anInteger! ! !ImageReadWriter methodsFor: 'stream access'! space ^stream nextPut: Character space asInteger! ! !ImageReadWriter methodsFor: 'stream access'! tab ^stream nextPut: Character tab asInteger! ! !ImageReadWriter methodsFor: 'private'! changePadOfBits: bits width: width height: height depth: depth from: oldPad to: newPad "Change padding size of bits." | srcRowByteSize dstRowByteSize newBits srcRowBase rowEndOffset | (#(8 16 32) includes: oldPad) ifFalse: [^self error: 'Invalid pad: ', oldPad printString]. (#(8 16 32) includes: newPad) ifFalse: [^self error: 'Invalid pad: ', newPad printString]. srcRowByteSize _ width * depth + oldPad - 1 // oldPad * (oldPad / 8). srcRowByteSize * height = bits size ifFalse: [^self error: 'Incorrect bitmap array size.']. dstRowByteSize _ width * depth + newPad - 1 // newPad * (newPad / 8). newBits _ ByteArray new: dstRowByteSize * height. srcRowBase _ 1. rowEndOffset _ dstRowByteSize - 1. 1 to: newBits size by: dstRowByteSize do: [:dstRowBase | newBits replaceFrom: dstRowBase to: dstRowBase + rowEndOffset with: bits startingAt: srcRowBase. srcRowBase _ srcRowBase + srcRowByteSize]. ^newBits! ! !ImageReadWriter methodsFor: 'private'! hasMagicNumber: aByteArray | position | position _ stream position. ((stream size - position) >= aByteArray size and: [(stream next: aByteArray size) = aByteArray]) ifTrue: [^true]. stream position: position. ^false! ! !ImageReadWriter methodsFor: 'private' stamp: 'sd 1/30/2004 15:18'! on: aStream (stream _ aStream) reset. stream binary. "Note that 'reset' makes a file be text. Must do this after."! ! !ImageReadWriter methodsFor: 'private'! unpackBits: bits depthTo8From: depth with: width height: height pad: pad "Unpack bits of depth 1, 2, or 4 image to it of depth 8 image." | bitMask pixelInByte bitsWidth upBitsWidth stopWidth trailingSize upBits bitIndex upBitIndex val | (#(1 2 4) includes: depth) ifFalse: [^self error: 'depth must be 1, 2, or 4']. (#(8 16 32) includes: pad) ifFalse: [^self error: 'pad must be 8, 16, or 32']. bitMask _ (1 bitShift: depth) - 1. pixelInByte _ 8 / depth. bitsWidth _ width * depth + pad - 1 // pad * (pad / 8). upBitsWidth _ width * 8 + pad - 1 // pad * (pad / 8). stopWidth _ width * depth + 7 // 8. trailingSize _ width - (stopWidth - 1 * pixelInByte). upBits _ ByteArray new: upBitsWidth * height. 1 to: height do: [:i | bitIndex _ i - 1 * bitsWidth. upBitIndex _ i - 1 * upBitsWidth. 1 to: stopWidth - 1 do: [:j | val _ bits at: (bitIndex _ bitIndex + 1). upBitIndex _ upBitIndex + pixelInByte. 1 to: pixelInByte do: [:k | upBits at: (upBitIndex - k + 1) put: (val bitAnd: bitMask). val _ val bitShift: depth negated]]. val _ (bits at: (bitIndex _ bitIndex + 1)) bitShift: depth negated * (pixelInByte - trailingSize). upBitIndex _ upBitIndex + trailingSize. 1 to: trailingSize do: [:k | upBits at: (upBitIndex - k + 1) put: (val bitAnd: bitMask). val _ val bitShift: depth negated]]. ^ upBits ! ! !ImageReadWriter methodsFor: 'testing' stamp: 'tao 10/27/97 09:26'! understandsImageFormat "Test to see if the image stream format is understood by this decoder. This should be implemented in each subclass of ImageReadWriter so that a proper decoder can be selected without ImageReadWriter having to know about all possible image file types." ^ false! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'bf 5/29/2003 01:43'! delay: aNumberOrNil "Set delay for next image in hundredth (1/100) of seconds" delay := aNumberOrNil! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'bf 5/29/2003 01:39'! loopCount: aNumber "Set looping. This must be done before any image is written!!" loopCount := aNumber! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'sd 1/30/2004 15:18'! nextImage "Read in the next GIF image from the stream. Read it all into memory first for speed." | f thisImageColorTable | stream class == ReadWriteStream ifFalse: [ stream binary. self on: (ReadWriteStream with: (stream contentsOfEntireFile))]. localColorTable _ nil. self readHeader. f _ self readBody. self close. f == nil ifTrue: [^ self error: 'corrupt GIF file']. thisImageColorTable _ localColorTable ifNil: [colorPalette]. transparentIndex ifNotNil: [ transparentIndex + 1 > thisImageColorTable size ifTrue: [ thisImageColorTable _ thisImageColorTable forceTo: transparentIndex + 1 paddingWith: Color white ]. thisImageColorTable at: transparentIndex + 1 put: Color transparent ]. f colors: thisImageColorTable. ^ f ! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'nk 4/17/2004 19:44'! nextPutImage: aForm | f newF | aForm unhibernate. f _ aForm colorReduced. "minimize depth" f depth > 8 ifTrue: [ "Not enough color space; do it the hard way." f _ f asFormOfDepth: 8]. f depth < 8 ifTrue: [ "writeBitData: expects depth of 8" newF _ f class extent: f extent depth: 8. (f isColorForm) ifTrue: [ newF copyBits: f boundingBox from: f at: 0 at 0 clippingBox: f boundingBox rule: Form over fillColor: nil map: nil. newF colors: f colors] ifFalse: [f displayOn: newF]. f _ newF]. (f isColorForm) ifTrue: [ (f colorsUsed includes: Color transparent) ifTrue: [ transparentIndex _ (f colors indexOf: Color transparent) - 1]] ifFalse: [transparentIndex _ nil]. width _ f width. height _ f height. bitsPerPixel _ f depth. colorPalette _ f colormapIfNeededForDepth: 32. interlace _ false. self writeHeader. self writeBitData: f bits. ! ! !GIFReadWriter methodsFor: 'accessing' stamp: '6/18/97 13:18 '! setStream: aStream "Feed it in from an existing source" stream _ aStream! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'di 9/15/1998 09:53'! understandsImageFormat ^('abc' collect: [:x | stream next asCharacter]) = 'GIF'! ! !GIFReadWriter methodsFor: 'private-encoding'! flushCode self flushBits! ! !GIFReadWriter methodsFor: 'private-encoding' stamp: 'tk 9/14/97 16:25'! readPixelFrom: bits "Since bits is a Bitmap with 32 bit values, watch out for the padding at the end of each row. But, GIF format already wants padding to 32 bit boundary!! OK as is. tk 9/14/97" | pixel | ypos >= height ifTrue: [^nil]. pixel _ bits byteAt: (ypos * rowByteSize + xpos + 1). self updatePixelPosition. ^pixel! ! !GIFReadWriter methodsFor: 'private-encoding' stamp: 'bf 5/29/2003 01:21'! writeBitData: bits "using modified Lempel-Ziv Welch algorithm." | maxBits maxMaxCode tSize initCodeSize ent tShift fCode pixel index disp nomatch | pass _ 0. xpos _ 0. ypos _ 0. rowByteSize _ width * 8 + 31 // 32 * 4. remainBitCount _ 0. bufByte _ 0. bufStream _ WriteStream on: (ByteArray new: 256). maxBits _ 12. maxMaxCode _ 1 bitShift: maxBits. tSize _ 5003. prefixTable _ Array new: tSize. suffixTable _ Array new: tSize. initCodeSize _ bitsPerPixel <= 1 ifTrue: [2] ifFalse: [bitsPerPixel]. self nextPut: initCodeSize. self setParameters: initCodeSize. tShift _ 0. fCode _ tSize. [fCode < 65536] whileTrue: [tShift _ tShift + 1. fCode _ fCode * 2]. tShift _ 8 - tShift. 1 to: tSize do: [:i | suffixTable at: i put: -1]. self writeCodeAndCheckCodeSize: clearCode. ent _ self readPixelFrom: bits. [(pixel _ self readPixelFrom: bits) == nil] whileFalse: [ fCode _ (pixel bitShift: maxBits) + ent. index _ ((pixel bitShift: tShift) bitXor: ent) + 1. (suffixTable at: index) = fCode ifTrue: [ent _ prefixTable at: index] ifFalse: [nomatch _ true. (suffixTable at: index) >= 0 ifTrue: [disp _ tSize - index + 1. index = 1 ifTrue: [disp _ 1]. "probe" [(index _ index - disp) < 1 ifTrue: [index _ index + tSize]. (suffixTable at: index) = fCode ifTrue: [ent _ prefixTable at: index. nomatch _ false. "continue whileFalse:"]. nomatch and: [(suffixTable at: index) > 0]] whileTrue: ["probe"]]. "nomatch" nomatch ifTrue: [self writeCodeAndCheckCodeSize: ent. ent _ pixel. freeCode < maxMaxCode ifTrue: [prefixTable at: index put: freeCode. suffixTable at: index put: fCode. freeCode _ freeCode + 1] ifFalse: [self writeCodeAndCheckCodeSize: clearCode. 1 to: tSize do: [:i | suffixTable at: i put: -1]. self setParameters: initCodeSize]]]]. prefixTable _ suffixTable _ nil. self writeCodeAndCheckCodeSize: ent. self writeCodeAndCheckCodeSize: eoiCode. self flushCode. self nextPut: 0. "zero-length packet" ! ! !GIFReadWriter methodsFor: 'private-encoding'! writeCode: aCode self nextBitsPut: aCode! ! !GIFReadWriter methodsFor: 'private-encoding'! writeCodeAndCheckCodeSize: aCode self writeCode: aCode. self checkCodeSize! ! !GIFReadWriter methodsFor: 'private-encoding' stamp: 'bf 5/29/2003 01:38'! writeHeader | byte | stream position = 0 ifTrue: [ "For first image only" self nextPutAll: 'GIF89a' asByteArray. self writeWord: width. "Screen Width" self writeWord: height. "Screen Height" byte _ 16r80. "has color map" byte _ byte bitOr: ((bitsPerPixel - 1) bitShift: 5). "color resolution" byte _ byte bitOr: bitsPerPixel - 1. "bits per pixel" self nextPut: byte. self nextPut: 0. "background color." self nextPut: 0. "reserved" colorPalette do: [:pixelValue | self nextPut: ((pixelValue bitShift: -16) bitAnd: 255); nextPut: ((pixelValue bitShift: -8) bitAnd: 255); nextPut: (pixelValue bitAnd: 255)]. loopCount notNil ifTrue: [ "Write a Netscape loop chunk" self nextPut: Extension. self nextPutAll: #(255 11 78 69 84 83 67 65 80 69 50 46 48 3 1) asByteArray. self writeWord: loopCount. self nextPut: 0]]. delay notNil | transparentIndex notNil ifTrue: [ self nextPut: Extension; nextPutAll: #(16rF9 4) asByteArray; nextPut: (transparentIndex isNil ifTrue: [0] ifFalse: [9]); writeWord: (delay isNil ifTrue: [0] ifFalse: [delay]); nextPut: (transparentIndex isNil ifTrue: [0] ifFalse: [transparentIndex]); nextPut: 0]. self nextPut: ImageSeparator. self writeWord: 0. "Image Left" self writeWord: 0. "Image Top" self writeWord: width. "Image Width" self writeWord: height. "Image Height" byte _ interlace ifTrue: [16r40] ifFalse: [0]. self nextPut: byte. ! ! !GIFReadWriter methodsFor: 'private-encoding'! writeWord: aWord self nextPut: (aWord bitAnd: 255). self nextPut: ((aWord bitShift: -8) bitAnd: 255). ^aWord! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'mir 11/19/2003 12:19'! readBitData "using modified Lempel-Ziv Welch algorithm." | outCodes outCount bitMask initCodeSize code curCode oldCode inCode finChar i bytes f c packedBits hasLocalColor localColorSize maxOutCodes | maxOutCodes _ 4096. offset := self readWord at self readWord. "Image Left at Image Top" width _ self readWord. height _ self readWord. "--- Local Color Table Flag 1 Bit Interlace Flag 1 Bit Sort Flag 1 Bit Reserved 2 Bits Size of Local Color Table 3 Bits ----" packedBits _ self next. interlace _ (packedBits bitAnd: 16r40) ~= 0. hasLocalColor _ (packedBits bitAnd: 16r80) ~= 0. localColorSize _ 1 bitShift: ((packedBits bitAnd: 16r7) + 1). hasLocalColor ifTrue: [localColorTable _ self readColorTable: localColorSize]. pass _ 0. xpos _ 0. ypos _ 0. rowByteSize _ ((width + 3) // 4) * 4. remainBitCount _ 0. bufByte _ 0. bufStream _ ReadStream on: ByteArray new. outCodes _ ByteArray new: maxOutCodes + 1. outCount _ 0. bitMask _ (1 bitShift: bitsPerPixel) - 1. prefixTable _ Array new: 4096. suffixTable _ Array new: 4096. initCodeSize _ self next. self setParameters: initCodeSize. bitsPerPixel > 8 ifTrue: [^self error: 'never heard of a GIF that deep']. bytes _ ByteArray new: rowByteSize * height. [(code _ self readCode) = eoiCode] whileFalse: [code = clearCode ifTrue: [self setParameters: initCodeSize. curCode _ oldCode _ code _ self readCode. finChar _ curCode bitAnd: bitMask. "Horrible hack to avoid running off the end of the bitmap. Seems to cure problem reading some gifs!!? tk 6/24/97 20:16" xpos = 0 ifTrue: [ ypos < height ifTrue: [ bytes at: (ypos * rowByteSize) + xpos + 1 put: finChar]] ifFalse: [bytes at: (ypos * rowByteSize) + xpos + 1 put: finChar]. self updatePixelPosition] ifFalse: [curCode _ inCode _ code. curCode >= freeCode ifTrue: [curCode _ oldCode. outCodes at: (outCount _ outCount + 1) put: finChar]. [curCode > bitMask] whileTrue: [outCount > maxOutCodes ifTrue: [^self error: 'corrupt GIF file (OutCount)']. outCodes at: (outCount _ outCount + 1) put: (suffixTable at: curCode + 1). curCode _ prefixTable at: curCode + 1]. finChar _ curCode bitAnd: bitMask. outCodes at: (outCount _ outCount + 1) put: finChar. i _ outCount. [i > 0] whileTrue: ["self writePixel: (outCodes at: i) to: bits" bytes at: (ypos * rowByteSize) + xpos + 1 put: (outCodes at: i). self updatePixelPosition. i _ i - 1]. outCount _ 0. prefixTable at: freeCode + 1 put: oldCode. suffixTable at: freeCode + 1 put: finChar. oldCode _ inCode. freeCode _ freeCode + 1. self checkCodeSize]]. prefixTable _ suffixTable _ nil. f _ ColorForm extent: width at height depth: 8. f bits copyFromByteArray: bytes. "Squeak can handle depths 1, 2, 4, and 8" bitsPerPixel > 4 ifTrue: [^ f]. "reduce depth to save space" c _ ColorForm extent: width at height depth: (bitsPerPixel = 3 ifTrue: [4] ifFalse: [bitsPerPixel]). f displayOn: c. ^ c ! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'KLC 1/25/2004 14:04'! readBody "Read the GIF blocks. Modified to return a form. " | form extype block blocksize packedFields delay1 | form _ nil. [stream atEnd] whileFalse: [ block _ self next. block = Terminator ifTrue: [^ form]. block = ImageSeparator ifTrue: [ form isNil ifTrue: [form _ self readBitData] ifFalse: [self skipBitData]. ] ifFalse: [ block = Extension ifFalse: [^ form "^ self error: 'Unknown block type'"]. "Extension block" extype _ self next. "extension type" extype = 16rF9 ifTrue: [ "graphics control" self next = 4 ifFalse: [^ form "^ self error: 'corrupt GIF file'"]. "==== Reserved 3 Bits Disposal Method 3 Bits User Input Flag 1 Bit Transparent Color Flag 1 Bit ===" packedFields _ self next. delay1 := self next. "delay time 1" delay := (self next*256 + delay1) *10. "delay time 2" transparentIndex _ self next. (packedFields bitAnd: 1) = 0 ifTrue: [transparentIndex _ nil]. self next = 0 ifFalse: [^ form "^ self error: 'corrupt GIF file'"]. ] ifFalse: [ "Skip blocks" [(blocksize _ self next) > 0] whileTrue: [ "Read the block and ignore it and eat the block terminator" self next: blocksize]]]]! ! !GIFReadWriter methodsFor: 'private-decoding'! readCode ^self nextBits! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'RAA 4/25/2001 08:48'! readColorTable: numberOfEntries | array r g b | array _ Array new: numberOfEntries. 1 to: array size do: [ :i | r _ self next. g _ self next. b _ self next. array at: i put: (Color r: r g: g b: b range: 255) ]. ^array! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'RAA 4/25/2001 08:49'! readHeader | is89 byte hasColorMap | (self hasMagicNumber: 'GIF87a' asByteArray) ifTrue: [is89 _ false] ifFalse: [(self hasMagicNumber: 'GIF89a' asByteArray) ifTrue: [is89 _ true] ifFalse: [^ self error: 'This does not appear to be a GIF file']]. self readWord. "skip Screen Width" self readWord. "skip Screen Height" byte _ self next. hasColorMap _ (byte bitAnd: 16r80) ~= 0. bitsPerPixel _ (byte bitAnd: 7) + 1. byte _ self next. "skip background color." self next ~= 0 ifTrue: [is89 ifFalse: [^self error: 'corrupt GIF file (screen descriptor)']]. hasColorMap ifTrue: [colorPalette _ self readColorTable: (1 bitShift: bitsPerPixel)] ifFalse: ["Transcript cr; show: 'GIF file does not have a color map.'." colorPalette _ nil "Palette monochromeDefault"].! ! !GIFReadWriter methodsFor: 'private-decoding'! readWord ^self next + (self next bitShift: 8)! ! !GIFReadWriter methodsFor: 'private-decoding'! skipBitData | misc blocksize | self readWord. "skip Image Left" self readWord. "skip Image Top" self readWord. "width" self readWord. "height" misc _ self next. (misc bitAnd: 16r80) = 0 ifFalse: [ "skip colormap" 1 to: (1 bitShift: (misc bitAnd: 7) + 1) do: [:i | self next; next; next]]. self next. "minimum code size" [(blocksize _ self next) > 0] whileTrue: [self next: blocksize]! ! !GIFReadWriter methodsFor: 'private-bits access'! flushBits remainBitCount = 0 ifFalse: [self nextBytePut: bufByte. remainBitCount _ 0]. self flushBuffer! ! !GIFReadWriter methodsFor: 'private-bits access'! nextBits | integer readBitCount shiftCount byte | integer _ 0. remainBitCount = 0 ifTrue: [readBitCount _ 8. shiftCount _ 0] ifFalse: [readBitCount _ remainBitCount. shiftCount _ remainBitCount - 8]. [readBitCount < codeSize] whileTrue: [byte _ self nextByte. byte == nil ifTrue: [^eoiCode]. integer _ integer + (byte bitShift: shiftCount). shiftCount _ shiftCount + 8. readBitCount _ readBitCount + 8]. (remainBitCount _ readBitCount - codeSize) = 0 ifTrue: [byte _ self nextByte] ifFalse: [byte _ self peekByte]. byte == nil ifTrue: [^eoiCode]. ^(integer + (byte bitShift: shiftCount)) bitAnd: maxCode! ! !GIFReadWriter methodsFor: 'private-bits access'! nextBitsPut: anInteger | integer writeBitCount shiftCount | shiftCount _ 0. remainBitCount = 0 ifTrue: [writeBitCount _ 8. integer _ anInteger] ifFalse: [writeBitCount _ remainBitCount. integer _ bufByte + (anInteger bitShift: 8 - remainBitCount)]. [writeBitCount < codeSize] whileTrue: [self nextBytePut: ((integer bitShift: shiftCount) bitAnd: 255). shiftCount _ shiftCount - 8. writeBitCount _ writeBitCount + 8]. (remainBitCount _ writeBitCount - codeSize) = 0 ifTrue: [self nextBytePut: (integer bitShift: shiftCount)] ifFalse: [bufByte _ integer bitShift: shiftCount]. ^anInteger! ! !GIFReadWriter methodsFor: 'private-packing'! fillBuffer | packSize | packSize _ self next. bufStream _ ReadStream on: (self next: packSize)! ! !GIFReadWriter methodsFor: 'private-packing'! flushBuffer bufStream isEmpty ifTrue: [^self]. self nextPut: bufStream size. self nextPutAll: bufStream contents. bufStream _ WriteStream on: (ByteArray new: 256)! ! !GIFReadWriter methodsFor: 'private-packing'! nextByte bufStream atEnd ifTrue: [self atEnd ifTrue: [^nil]. self fillBuffer]. ^bufStream next! ! !GIFReadWriter methodsFor: 'private-packing'! nextBytePut: aByte bufStream nextPut: aByte. bufStream size >= 254 ifTrue: [self flushBuffer]! ! !GIFReadWriter methodsFor: 'private-packing'! peekByte bufStream atEnd ifTrue: [self atEnd ifTrue: [^nil]. self fillBuffer]. ^bufStream peek! ! !GIFReadWriter methodsFor: 'private'! checkCodeSize (freeCode > maxCode and: [codeSize < 12]) ifTrue: [codeSize _ codeSize + 1. maxCode _ (1 bitShift: codeSize) - 1]! ! !GIFReadWriter methodsFor: 'private'! setParameters: initCodeSize clearCode _ 1 bitShift: initCodeSize. eoiCode _ clearCode + 1. freeCode _ clearCode + 2. codeSize _ initCodeSize + 1. maxCode _ (1 bitShift: codeSize) - 1! ! !GIFReadWriter methodsFor: 'private'! updatePixelPosition (xpos _ xpos + 1) >= width ifFalse: [^self]. xpos _ 0. interlace ifFalse: [ypos _ ypos + 1. ^self]. pass = 0 ifTrue: [(ypos _ ypos + 8) >= height ifTrue: [pass _ pass + 1. ypos _ 4]. ^self]. pass = 1 ifTrue: [(ypos _ ypos + 8) >= height ifTrue: [pass _ pass + 1. ypos _ 2]. ^self]. pass = 2 ifTrue: [(ypos _ ypos + 4) >= height ifTrue: [pass _ pass + 1. ypos _ 1]. ^self]. pass = 3 ifTrue: [ypos _ ypos + 2. ^self]. ^self error: 'can''t happen'! ! !GIFReadWriter methodsFor: 'stream access' stamp: 'bf 5/29/2003 01:23'! close "Write terminator" self nextPut: Terminator. ^super close! ! !ImageReadWriter class methodsFor: 'instance creation'! on: aStream "Answer an instance of the receiver for encoding and/or decoding images on the given." ^ self new on: aStream ! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:59'! allTypicalFileExtensions "Answer a collection of file extensions (lowercase) which files that my subclasses can read might commonly have" "ImageReadWriter allTypicalFileExtensions" | extensions | extensions _ Set new. self allSubclassesDo: [ :cls | extensions addAll: cls typicalFileExtensions ]. ^extensions! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'ls 9/15/1998 19:08'! formFromFileNamed: fileName "Answer a ColorForm stored on the file with the given name." | stream | stream _ FileStream readOnlyFileNamed: fileName. ^self formFromStream: stream! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'tk 5/7/1998 17:35'! formFromServerFile: fileName "Answer a ColorForm stored on the file with the given name. Meant to be called from during the getting of updates from the server. That assures that (Utilities serverUrls) returns the right group of servers." | form urls doc | urls _ Utilities serverUrls collect: [:url | url, fileName]. " fileName starts with: 'updates/' " urls do: [:aURL | (fileName findTokens: '.') last asLowercase = 'gif' ifTrue: [ form _ HTTPSocket httpGif: aURL. form = (ColorForm extent: 20 at 20 depth: 8) ifTrue: [self inform: 'The file ',aURL,' is ill formed.']. ^ form]. (fileName findTokens: '.') last asLowercase = 'bmp' ifTrue: [ doc _ HTTPSocket httpGet: aURL accept: 'image/bmp'. form _ Form fromBMPFile: doc. doc close. form ifNil: [self inform: 'The file ',aURL,' is ill formed.'. ^ Form new] ifNotNil: [^ form]]. self inform: 'File ', fileName, 'does not end with .gif or .bmp']. self inform: 'That file not found on any server we know'.! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'sd 1/30/2004 15:18'! formFromStream: aBinaryStream "Answer a ColorForm stored on the given stream. closes the stream" | reader readerClass form | readerClass _ self withAllSubclasses detect: [:subclass | subclass understandsImageFormat: aBinaryStream] ifNone: [ aBinaryStream close. ^self error: 'image format not recognized']. reader _ readerClass new on: aBinaryStream reset. Cursor read showWhile: [ form _ reader nextImage. reader close]. ^ form ! ! !ImageReadWriter class methodsFor: 'image reading/writing'! putForm: aForm onFileNamed: fileName "Store the given form on a file of
More information about the Squeak-dev mailing list |