[squeak-dev] The Trunk: Graphics-nice.492.mczNicolas Cellier nicolas.cellier.aka.nice at gmail.comSun Mar 6 13:58:47 UTC 2022
Sorry, it displayed the many diffs from Graphics-nice.442 rather than the few from Graphics-mt.491... That's only 3 new composition rules. Le dim. 6 mars 2022 à 14:55, <commits at source.squeak.org> a écrit : > Nicolas Cellier uploaded a new version of Graphics to project The Trunk: > http://source.squeak.org/trunk/Graphics-nice.492.mcz > > ==================== Summary ==================== > > Name: Graphics-nice.492 > Author: nice > Time: 6 March 2022, 2:55:01.566363 pm > UUID: 9b341ab2-f970-4afc-a140-d1c255a5ca41 > Ancestors: Graphics-nice.442, Graphics-mt.491 > > Merge: Graphics-nice.442, Graphics-mt.491 > > Note: the new BitBlt rules have been corrected in > VMMaker.oscog-nice.3170/eem.3171, that is in VM generated from 2022 > February 24 and on. > > =============== Diff against Graphics-nice.442 =============== > > Item was added: > + ----- Method: AbstractFont class>>defaultFallbackTextStyle (in category > 'fallback') ----- > + defaultFallbackTextStyle > + "Answer a text style that has fonts that support a lot of > codepoints." > + > + ^ TextConstants at: #DefaultFallbackTextStyle ifAbsent: [TextStyle > default]! > > Item was added: > + ----- Method: AbstractFont class>>localeChanged (in category 'fallback') > ----- > + localeChanged > + self setupDefaultFallbackTextStyle.! > > Item was added: > + ----- Method: AbstractFont class>>setupDefaultFallbackFontTo: (in > category 'fallback') ----- > + setupDefaultFallbackFontTo: aFont > + > + self setupDefaultFallbackTextStyleTo: (TextStyle fontArray: > {aFont}).! > > Item was added: > + ----- Method: AbstractFont class>>setupDefaultFallbackTextStyle (in > category 'fallback') ----- > + setupDefaultFallbackTextStyle > + > + | defaultStyle | > + defaultStyle := self defaultFallbackTextStyle. > + TextStyle knownTextStylesWithoutDefault do: [:styleName | > + (TextStyle named: styleName) fontArray do: [:each | > + each setupDefaultFallbackTextStyleTo: > defaultStyle]].! > > Item was added: > + ----- Method: AbstractFont class>>setupDefaultFallbackTextStyleTo: (in > category 'fallback') ----- > + setupDefaultFallbackTextStyleTo: aTextStyle > + > + TextConstants at: #DefaultFallbackTextStyle put: aTextStyle. > + ! > > Item was added: > + ----- Method: AbstractFont>>asNewTextStyle (in category 'converting') > ----- > + asNewTextStyle > + "Answer a new text style where the receiver is the default font. > Try to lookup the an existing #textStyle so that TextFontChange can be used > in views." > + > + | newTextStyle | > + newTextStyle := self textStyleOrNil > + ifNil: [TextStyle fontArray: {self}] > + ifNotNil: [:style | style copy]. > + newTextStyle defaultFontIndex: (newTextStyle fontIndexOfPointSize: > self pointSize). > + ^ newTextStyle! > > Item was added: > + ----- Method: AbstractFont>>asPointSize: (in category 'converting') ----- > + asPointSize: differentPointSize > + "Convert the receiver into a different point size. Compared to > #pointSize:, this operation does not modify the receiver but tries to > lookup another font object or create one on-the-fly." > + > + self pointSize = differentPointSize ifTrue: [^ self]. > + > + ^ self class > + familyName: self familyName > + pointSize: differentPointSize > + emphasized: self emphasis! > > Item was added: > + ----- Method: AbstractFont>>asRegular (in category 'converting') ----- > + asRegular > + "Try to lookup the receiver with normal emphasis. If the receiver > itself looks bold face, this might be okay. Rely on what is registered on > the font family's text style. Not that this is different from #emphasized: > with 0, which does nothing." > + > + self emphasis = 0 ifTrue: [^ self]. > + ^ self textStyleOrNil > + ifNil: [self] > + ifNotNil: [:style | style fontOfPointSize: self pointSize]! > > Item was added: > + ----- Method: AbstractFont>>emphasis (in category 'accessing') ----- > + emphasis > + > + ^ 0! > > Item was added: > + ----- Method: AbstractFont>>fallbackFont (in category 'accessing') ----- > + fallbackFont > + "Answers the fallbackFont for the receiver. The fallback font must > be some derivative of the receiver since it will not be asked to install > itself properly on the target BitBlt so rendering a completely different > font here is simply not possible. The default implementation uses a > synthetic font that maps all characters to question marks." > + > + ^ FixedFaceFont new errorFont baseFont: self! > > Item was added: > + ----- Method: AbstractFont>>fallbackFont: (in category > 'initialize-release') ----- > + fallbackFont: aFont > + "Reset fallback font. Ignore. See #fallbackFont."! > > Item was added: > + ----- Method: AbstractFont>>hasFixedWidth (in category 'testing') ----- > + hasFixedWidth > + "Answer whether the receiver is a > monospaced/fixed-width/non-proportional font. See TextStyle class >> > #defaultFixed." > + > + ^ (self widthOf: $.) = (self widthOf: $w)! > > Item was added: > + ----- Method: AbstractFont>>isSynthetic (in category 'testing') ----- > + isSynthetic > + ^ false! > > Item was added: > + ----- Method: AbstractFont>>larger (in category 'converting') ----- > + larger > + "Answer a font that is about 20% larger than the receiver but has > the same font family and emphasis. Round to 0.5 points to not yield so many > different font instances." > + > + ^ self asPointSize: ((self pointSize asFloat * 1.2) roundTo: 0.5)! > > Item was added: > + ----- Method: AbstractFont>>lineGap (in category 'accessing') ----- > + lineGap > + > + ^ 2 "pre-rendered legacy fonts"! > > Item was added: > + ----- Method: AbstractFont>>lineGapSlice (in category 'accessing') ----- > + lineGapSlice > + > + ^ 1 "pre-rendered legacy fonts"! > > Item was changed: > ----- Method: AbstractFont>>lineGrid (in category 'accessing') ----- > lineGrid > "Answer the relative space between lines" > > + ^ self height + self lineGap! > - ^self subclassResponsibility! > > Item was added: > + ----- Method: AbstractFont>>maxAscii (in category 'accessing') ----- > + maxAscii > + > + self flag: #deprecated. > + ^ self maxCodePoint! > > Item was added: > + ----- Method: AbstractFont>>maxCodePoint (in category 'accessing') ----- > + maxCodePoint > + "Answer the largest code point that the receiver can translate > into glyphs. Use the range from #minCodePoint to #maxCodePoint to configure > a list of #fallbackFont's. Note that subclasses may insert 'holes' via > #hasGlyphOf: test such as StrikeFont's internal xTable." > + > + ^ 16r10FFFF "Unicode uses 21-bit but 16r110000 to 16r1FFFFF are > not valid code points. See https://www.unicode.org/versions/stats/."! > > Item was added: > + ----- Method: AbstractFont>>minAscii (in category 'accessing') ----- > + minAscii > + > + self flag: #deprecated. > + ^ self minCodePoint! > > Item was added: > + ----- Method: AbstractFont>>minCodePoint (in category 'accessing') ----- > + minCodePoint > + "Answer the smallest code point that the receiver can translate > into glyphs. Use the range from #minCodePoint to #maxCodePoint to configure > a list of #fallbackFont's. Note that subclasses may insert 'holes' via > #hasGlyphOf: test such as StrikeFont's internal xTable." > + > + ^ 0! > > Item was changed: > ----- Method: AbstractFont>>pixelSize (in category 'accessing') ----- > pixelSize > "Make sure that we don't return a Fraction" > + ^ (TextStyle pointsToPixels: self pointSize) rounded! > - ^ TextStyle pointsToPixels: self pointSize! > > Item was added: > + ----- Method: AbstractFont>>pixelsPerInch (in category 'accessing') ----- > + pixelsPerInch > + "Answers the PPI reference for the pre-rendered receiver." > + > + ^ (self height * 72 / self pointSize asFloat) rounded! > > Item was changed: > ----- Method: AbstractFont>>printShortDescriptionOn: (in category > 'printing') ----- > printShortDescriptionOn: aStream > + aStream nextPutAll: self familyName! > - aStream space; nextPutAll: self familyName! > > Item was added: > + ----- Method: AbstractFont>>reset (in category 'initialize-release') > ----- > + reset > + "Clear all caches."! > > Item was changed: > ----- Method: AbstractFont>>sampleText (in category 'example') ----- > sampleText > > | text | > + text := self isSymbolFont > + ifTrue: [self symbolSample asText] > - text := (self isSymbolFont or: [(self basicHasGlyphOf: $a) not]) > - ifTrue: [Text symbolSample] > ifFalse: [Text textSample]. > text addAttribute: (TextFontReference toFont: self). > ^ text! > > Item was added: > + ----- Method: AbstractFont>>setupDefaultFallbackTextStyleTo: (in > category 'initialize-release') ----- > + setupDefaultFallbackTextStyleTo: aTextStyle > + > + " | fonts f | > + fonts := aTextStyle fontArray. > + f := fonts first. > + f familyName = self familyName ifTrue: [^ self]. > + 1 to: fonts size do: [:i | > + self height > (fonts at: i) height ifTrue: [f := fonts at: > i]. > + ]." > + > + self derivativeFonts do: [:each | > + each setupDefaultFallbackTextStyleTo: aTextStyle]. > + > + self flag: #todo. "mt: Figure out a way to lookup useful fallback > fonts." > + > + self fallbackFont: nil. > + self reset.! > > Item was added: > + ----- Method: AbstractFont>>smaller (in category 'converting') ----- > + smaller > + "Answer a font that is about 20% smaller than the receiver but has > the same font family and emphasis. Round to 0.5 points to not yield so many > different font instances." > + > + ^ self asPointSize: ((self pointSize asFloat * 0.8) roundTo: 0.5)! > > Item was added: > + ----- Method: AbstractFont>>symbolSample (in category 'example') ----- > + symbolSample > + "Variation of Text class >> #symbolSample, which uses the > receiver's available code points. This is important for fonts such as > Wingdings." > + > + ^ String streamContents: [:stream | | start lineLength character | > + lineLength := 0. > + (start := self minCodePoint max: 33) to: (self > maxCodePoint min: start + 200) do: [:codePoint | > + (self hasGlyphOf: (character := Character value: > codePoint)) > + ifTrue: [stream nextPut: character. > + ((lineLength := lineLength + 1) > > 30) ifTrue: [ > + lineLength := 0. > + stream cr]]]]! > > Item was changed: > ----- Method: AbstractFont>>textStyle (in category 'accessing') ----- > textStyle > + "Answer an instance of TextStyle that (most likely) includes the > receiver. Note that if the receiver is used in more than one style, only > answer the most prominent one." > + > + ^ self textStyleOrNil ifNil: [TextStyle fontArray: {self}]! > - ^ TextStyle actualTextStyles detect: > - [:aStyle | aStyle fontArray includes: self] ifNone: [ > TextStyle fontArray: { self } ]! > > Item was added: > + ----- Method: AbstractFont>>textStyleOrNil (in category 'accessing') > ----- > + textStyleOrNil > + "Like #textStyle but avoid creating a new style for orphaned > fonts." > + > + ^ TextStyle named: self textStyleName! > > Item was changed: > ----- Method: BMPReadWriter class>>readAllFrom: (in category 'testing') > ----- > readAllFrom: fd > "MessageTally spyOn:[BMPReadWriter readAllFrom: FileDirectory > default]" > fd fileNames do:[:fName| > (fName endsWith: '.bmp') ifTrue:[ > + [Form fromBinaryStream: (fd readOnlyFileNamed: > fName)] ifError: []. > - [Form fromBinaryStream: (fd readOnlyFileNamed: > fName)] on: Error do:[:nix]. > ]. > ]. > fd directoryNames do:[:fdName| > self readAllFrom: (fd directoryNamed: fdName) > ].! > > Item was changed: > ----- Method: BMPReadWriter>>nextPutImage: (in category 'writing') ----- > nextPutImage: aForm > | bhSize rowBytes rgb data colorValues depth image ppw scanLineLen > pixline | > depth := aForm depth. > depth := #(1 4 8 32 ) detect: [ :each | each >= depth]. > image := aForm asFormOfDepth: depth. > image unhibernate. > bhSize := 14. "# bytes in file header" > biSize := 40. "info header size in bytes" > biWidth := image width. > biHeight := image height. > biClrUsed := depth = 32 ifTrue: [0] ifFalse:[1 << depth]. "No. > color table entries" > bfOffBits := biSize + bhSize + (4*biClrUsed). > rowBytes := ((depth min: 24) * biWidth + 31 // 32) * 4. > biSizeImage := biHeight * rowBytes. > > "Write the file header" > stream position: 0. > stream nextLittleEndianNumber: 2 put: 19778. "bfType = BM" > stream nextLittleEndianNumber: 4 put: bfOffBits + biSizeImage. > "Entire file size in bytes" > stream nextLittleEndianNumber: 4 put: 0. "bfReserved" > stream nextLittleEndianNumber: 4 put: bfOffBits. "Offset of > bitmap data from start of hdr (and file)" > > "Write the bitmap info header" > stream position: bhSize. > stream nextLittleEndianNumber: 4 put: biSize. "info header size > in bytes" > stream nextLittleEndianNumber: 4 put: image width. "biWidth" > stream nextLittleEndianNumber: 4 put: image height. "biHeight" > stream nextLittleEndianNumber: 2 put: 1. "biPlanes" > stream nextLittleEndianNumber: 2 put: (depth min: 24). > "biBitCount" > stream nextLittleEndianNumber: 4 put: 0. "biCompression" > stream nextLittleEndianNumber: 4 put: biSizeImage. "size of image > section in bytes" > stream nextLittleEndianNumber: 4 put: 2800. "biXPelsPerMeter" > stream nextLittleEndianNumber: 4 put: 2800. "biYPelsPerMeter" > stream nextLittleEndianNumber: 4 put: biClrUsed. > stream nextLittleEndianNumber: 4 put: 0. "biClrImportant" > biClrUsed > 0 ifTrue: [ > "write color map; this works for ColorForms, too" > colorValues := image colormapIfNeededForDepth: 32. > 1 to: biClrUsed do: [:i | > rgb := colorValues at: i. > 0 to: 24 by: 8 do: [:j | stream nextPut: (rgb >> j > bitAnd: 16rFF)]]]. > > depth < 32 ifTrue: [ > "depth = 1, 4 or 8." > data := image bits asByteArray. > ppw := 32 // depth. > scanLineLen := biWidth + ppw - 1 // ppw * 4. "# of bytes > in line" > 1 to: biHeight do: [:i | > stream next: scanLineLen putAll: data startingAt: > (biHeight-i)*scanLineLen+1. > ]. > ] ifFalse: [ > data := image bits. > pixline := ByteArray new: (((biWidth * 3 + 3) // 4) * 4). > 1 to: biHeight do:[:i | > self store24BitBmpLine: pixline from: data > startingAt: (biHeight-i)*biWidth+1 width: biWidth. > stream nextPutAll: pixline. > ]. > ]. > + stream position = (bfOffBits + biSizeImage) ifFalse: [self error: > 'Write failure' translated]. > - stream position = (bfOffBits + biSizeImage) ifFalse: [self > error:'Write failure']. > stream close.! > > Item was changed: > ----- Method: > CharacterScanner>>primScanCharactersFrom:to:in:rightX:stopConditions:kern: > (in category 'scanning') ----- > primScanCharactersFrom: startIndex to: stopIndex in: sourceString > rightX: rightX stopConditions: stops kern: kernDelta > + "Primitive. This is the inner loop of text display--but see > #scanCharactersFrom:to:in:rightX: which would get the string, > stopConditions and displaying from the instance. March through sourceString > from startIndex to stopIndex. If any character is flagged with a non-nil > entry in stops, then return the corresponding value. Determine width of > each character from xTable, indexed by map. If destX would exceed rightX, > then return stops at: 258. Advance destX by the width of the character. If > stopIndex has been reached, then return stops at: 257. > + > + Optional. See Object documentation whatIsAPrimitive. > + > + NOTE THAT this primitive does only work for our legacy StrikeFont > because #setActualFont: needs #xTable and #characterToGlyphMap, which are > both not available for TTCFont this way and thus we end up calling > #widthOf: manually on the font." > + > - "Primitive. This is the inner loop of text display--but see > - scanCharactersFrom: to:rightX: which would get the string, > - stopConditions and displaying from the instance. March through > source > - String from startIndex to stopIndex. If any character is flagged > with a > - non-nil entry in stops, then return the corresponding value. > Determine > - width of each character from xTable, indexed by map. > - If dextX would exceed rightX, then return stops at: 258. > - Advance destX by the width of the character. If stopIndex has been > - reached, then return stops at: 257. Optional. > - See Object documentation whatIsAPrimitive. > - Historical note: this primitive has been unusable since about > Squeak 2.8 when the shape of the CharracterScanner class changed. It is > left here as a reminder that the actual primitive still needs supporting in > the VM to keep old images such as Scratch1.4 alive - tpr" > <primitive: 103> > + ^self basicScanByteCharactersFrom: startIndex to: stopIndex in: > sourceString rightX: rightX > + > + "Here are some sketchy benchmarks to illustrate the performance issue > regarding the use of TrueType fonts: > + > + 1) TTCFont only; with primitive fail > + '1,160 per second. 865 microseconds per run. 0.44 % GC time.' > + > + 2) TTCFont only; without primitive fail > + '5,730 per second. 175 microseconds per run. 6.12 % GC time.' > + > + 3) StrikeFont only; using primitive 103 > + '29,700 per second. 33.6 microseconds per run. 1.11978 % GC time.' > + > + 4) StrikeFont only; without primitive 103 > + '13,900 per second. 71.7 microseconds per run. 1.17976 % GC time.' > + > + "! > - ^self basicScanByteCharactersFrom: startIndex to: stopIndex in: > sourceString rightX: rightX ! > > Item was changed: > ----- Method: Color>>negated (in category 'transformations') ----- > negated > "Return an RGB inverted color" > ^Color > r: 1.0 - self red > g: 1.0 - self green > + b: 1.0 - self blue > + alpha: self alpha! > - b: 1.0 - self blue! > > Item was added: > + ----- Method: Color>>veryMuchDarker (in category 'transformations') ----- > + veryMuchDarker > + > + ^ self alphaMixed: 0.25 with: Color black > + ! > > Item was changed: > CharacterScanner subclass: #CompositionScanner > + instanceVariableNames: 'spaceX spaceIndex lineHeight baseline > lineGap lineGapSlice topMargin bottomMargin lineHeightAtSpace > baselineAtSpace lastBreakIsNotASpace nextIndexAfterLineBreak' > - instanceVariableNames: 'spaceX spaceIndex lineHeight baseline > lineHeightAtSpace baselineAtSpace lastBreakIsNotASpace > nextIndexAfterLineBreak' > classVariableNames: '' > poolDictionaries: '' > category: 'Graphics-Text'! > > !CompositionScanner commentStamp: 'nice 10/6/2013 23:24' prior: 0! > A CompositionScanner measures text and determines where line breaks. > Given a rectangular zone on input, it is used to split text in > horizontal lines, and produce information about those lines on output (at > which index a line starts/stops, which vertical space does the line > require, which horizontal space if left for adjusting inter-word spacing, > etc...) > > Instance Variables > baseline: <Number> > baselineAtSpace: <Number> > lastBreakIsNotASpace: <Boolean> > lineHeight: <Number> > lineHeightAtSpace: <Number> > nextIndexAfterLineBreak: <Integer> > spaceIndex: <Integer> > spaceX: <Number> > > baseline > - the distance between top of line and the base line (that is the > bottom of latin characters abcdehiklmnorstuvwx in most fonts) > > baselineAtSpace > - memorize the baseline at last encountered space or other > breakable character. > This is necessary because the CompositionScanner wants to break > line at a breakable character. > If a word layout overflows the right margin, the scanner has to > roll back and restore the line state to last encountered breakable > character. > > lastBreakIsNotASpace > - indicates that the last breakable character was not a space. > This is necessary because handling a line break at a space differs > from non space. > If line break occurs on space, the space won't be displayed in > next line. > If it's another breakable character, it has to be displayed on > next line. > > lineHeight > - the total line height from top to bottom, including inter-line > spacing. > > lineHeightAtSpace > - the line height at last encountered space or other breakable > character. > See baselineAtSpace for explanation. > > nextIndexAfterLineBreak > - the index of character after the last line break that was > encountered. > > spaceIndex > - the index of last space or other breakable character that was > encountered > > spaceX > - the distance from left of composition zone to left of last > encountered space or other breakable character > See baselineAtSpace for explanation. > > Note: if a line breaks on a space, a linefeed or a carriage return, then > the space, linefeed or carriage return is integrated in the line. > If there is a carriage return - linefeed pair, the pair is integrated to > the line as if it were a single line break for compatibility with legacy > software.! > > Item was changed: > ----- Method: > CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide: > (in category 'scanning') ----- > composeFrom: startIndex inRectangle: lineRectangle > firstLine: firstLine leftSide: leftSide rightSide: rightSide > "Answer an instance of TextLineInterval that represents the next > line in the paragraph." > + | runLength stopCondition lineSpacing | > - | runLength stopCondition | > "Set up margins" > leftMargin := lineRectangle left. > leftSide ifTrue: [leftMargin := leftMargin + > (firstLine ifTrue: > [textStyle firstIndent] > ifFalse: > [textStyle restIndent])]. > destX := spaceX := leftMargin. > rightMargin := lineRectangle right. > rightSide ifTrue: [rightMargin := rightMargin - textStyle > rightIndent]. > lastIndex := startIndex. "scanning sets last index" > destY := lineRectangle top. > + lineHeight := baseline := 0. "Will be increased by setFont" > + lineGap := lineGapSlice := -9999. "Will be increased by setFont; > allow negative to show all effects of a custom #extraGap value. See > TTFontDescription." > + topMargin := bottomMargin := 0. > - lineHeight := baseline := 0. "Will be increased by setFont" > line := (TextLine start: lastIndex stop: 0 internalSpaces: 0 > paddingWidth: 0) > rectangle: lineRectangle. > self setStopConditions. "also sets font" > runLength := text runLengthFor: startIndex. > runStopIndex := (lastIndex := startIndex) + (runLength - 1). > nextIndexAfterLineBreak := spaceCount := 0. > lastBreakIsNotASpace := false. > self handleIndentation. > leftMargin := destX. > line leftMargin: leftMargin. > > [stopCondition := self scanCharactersFrom: lastIndex to: > runStopIndex > in: text string rightX: rightMargin. > "See setStopConditions for stopping conditions for composing." > self perform: stopCondition] whileFalse. > > + lineHeight := lineHeight + lineGap. > + baseline := baseline + lineGapSlice. > + > + "TODO: Allow special characters or text attributes to accumulate > extra top or bottom margin." > + (lineSpacing := textStyle lineSpacing) = 0.0 > + ifFalse: [bottomMargin := bottomMargin + (lineSpacing * > lineHeight) truncated]. > + > + line lineHeight: lineHeight baseline: baseline. > + line topMargin: topMargin bottomMargin: bottomMargin. > + ^ line! > - ^ line > - lineHeight: lineHeight + textStyle leading > - baseline: baseline + textStyle leading! > > Item was changed: > ----- Method: CompositionScanner>>computeDefaultLineHeight (in category > 'scanning') ----- > computeDefaultLineHeight > "Compute the default line height for a potentially empty text" > rightMargin notNil > ifTrue: [lastIndex := 1. > self setFont. > + ^ lineHeight + lineGap] > - ^ lineHeight + textStyle leading] > ifFalse: [^textStyle lineGrid]! > > Item was changed: > ----- Method: CompositionScanner>>setActualFont: (in category 'text > attributes') ----- > setActualFont: aFont > "Keep track of max height and ascent for auto lineheight" > | descent | > super setActualFont: aFont. > lineHeight == nil > ifTrue: [descent := font descent. > baseline := font ascent. > + lineHeight := baseline + descent. > + lineGap := aFont lineGap. > + lineGapSlice := aFont lineGapSlice] > - lineHeight := baseline + descent] > ifFalse: [descent := lineHeight - baseline max: font > descent. > baseline := baseline max: font ascent. > + lineHeight := lineHeight max: baseline + > descent. > + lineGap := lineGap max: aFont lineGap. > + lineGapSlice := lineGapSlice max: aFont > lineGapSlice]! > - lineHeight := lineHeight max: baseline + > descent]! > > Item was changed: > ----- Method: Cursor class>>currentCursor: (in category 'current > cursor') ----- > currentCursor: aCursor > "Make the instance of cursor, aCursor, be the current cursor. > Display it. > Create an error if the argument is not a Cursor." > > (aCursor isKindOf: self) > + ifTrue: [ | platformCursor | > + CurrentCursor := aCursor. "unscaled" > + platformCursor := aCursor enlargedBy: > RealEstateAgent scaleFactor. > + self useBiggerCursors > + ifTrue: [platformCursor := platformCursor > enlargedBy: 2]. > + platformCursor beCursor] > - ifTrue: [CurrentCursor := aCursor. > - self useBiggerCursors > - ifTrue: [[^ aCursor asBigCursor > beCursor] > - on: Error do: ["fall > through"]]. > - aCursor beCursor] > ifFalse: [self error: 'The new cursor must be an instance > of class Cursor']! > > Item was changed: > ----- Method: Cursor class>>useBiggerCursors (in category 'preferences') > ----- > useBiggerCursors > > <preference: 'Use bigger mouse cursors' > + categoryList: #(mouse Accessibility) > - category: 'mouse' > description: 'If true, mouse cursors are scaled up' > type: #Boolean> > ^ UseBiggerCursors ifNil: [false]! > > Item was changed: > ----- Method: Cursor class>>useBiggerCursors: (in category > 'preferences') ----- > useBiggerCursors: aBool > > + UseBiggerCursors := aBool. > + Cursor currentCursor: Cursor currentCursor.! > - UseBiggerCursors := aBool! > > Item was changed: > Form subclass: #DisplayScreen > instanceVariableNames: 'clippingBox extraRegions' > + classVariableNames: 'DeferringUpdates DisplayChangeSignature > DisplayIsFullScreen PlatformScaleFactor RelativeScaleFactorEnabled' > - classVariableNames: 'DeferringUpdates DisplayChangeSignature > DisplayIsFullScreen' > poolDictionaries: '' > category: 'Graphics-Display Objects'! > > !DisplayScreen commentStamp: '<historical>' prior: 0! > There is only one instance of me, Display. It is a global and is used to > handle general user requests to deal with the whole display screen. > Although I offer no protocol, my name provides a way to > distinguish this special instance from all other Forms. This is useful, for > example, in dealing with saving and restoring the system. > To change the depth of your Display... > Display newDepth: 16. > Display newDepth: 8. > Display newDepth: 1. > Valid display depths are 1, 2, 4, 8, 16 and 32. It is suggested that > you run with your monitors setting the same, for better speed and color > fidelity. Note that this can add up to 4Mb for the Display form. Finally, > note that newDepth: ends by executing a 'ControlManager restore' which > currently terminates the active process, so nothing that follows in the > doit will get executed. > > Depths 1, 2, 4 and 8 bits go through a color map to put color on the > screen, but 16 and 32-bit color use the pixel values directly for RGB color > (5 and 8 bits per, respectivlely). The color choice an be observed by > executing Color fromUser in whatever depth you are using. > ! > > Item was added: > + ----- Method: DisplayScreen class>>actualScreenScaleFactor (in category > 'snapshots') ----- > + actualScreenScaleFactor > + "<primitive: #primitiveScreenScaleFactor>" > + "Once the primitive is ready, you can simply uncomment it. The > system is prepared for changes from 'nil' to actual factors and back." > + > + ^ nil "unknown -- do not default to 1.0 here"! > > Item was added: > + ----- Method: DisplayScreen class>>checkForNewScreenScaleFactor (in > category 'display box access') ----- > + checkForNewScreenScaleFactor > + "Check whether the platform's scale factor has changed and if so > take appropriate actions" > + > + Display platformScaleFactor: DisplayScreen > actualScreenScaleFactor.! > > Item was added: > + ----- Method: DisplayScreen class>>relativeScaleFactor (in category > 'preferences') ----- > + relativeScaleFactor > + <preference: 'Scale Factor' > + categoryList: #(Morphic Tools visuals Accessibility) > + description: 'Set the size of fonts and tools according to > the pixels-per-inch of your display. Can be used to zoom in even further.' > + type: #String> > + > + ^ Display relativeUiScaleFactor! > > Item was added: > + ----- Method: DisplayScreen class>>relativeScaleFactor: (in category > 'preferences') ----- > + relativeScaleFactor: aFloatString > + > + Display relativeUiScaleFactor: (aFloatString ifNotNil: [:s | s > asNumber] ifNil: [1.0]).! > > Item was added: > + ----- Method: DisplayScreen class>>relativeScaleFactorEnabled (in > category 'preferences') ----- > + relativeScaleFactorEnabled > + <preference: 'Show Relative Scale Factor' > + categoryList: #(Morphic Tools visuals) > + description: 'When true, 100% means > as-the-platform/monitor-demands, which is typical for macOS. When false, > 100% means pixel-perfect, which is typical for Windows. Only works if > #platformScaleFactorKnown.' > + type: #Boolean> > + > + "Note that we set the default to 'false' because pixels are very > prominent in the Morphic programming model. So it makes sense to communcate > this kind of pixel scaling openly and thus not hide the > #platformScaleFactor from the user." > + ^ RelativeScaleFactorEnabled ifNil: [false].! > > Item was added: > + ----- Method: DisplayScreen class>>relativeScaleFactorEnabled: (in > category 'preferences') ----- > + relativeScaleFactorEnabled: aBoolean > + > + RelativeScaleFactorEnabled := Display platformScaleFactorKnown > and: [aBoolean ifNil: [false]].! > > Item was added: > + ----- Method: DisplayScreen>>currentScaleError (in category 'scale > factor') ----- > + currentScaleError > + "Documentation and debugging only. The scale error originates in > rounding errors while rendering the standard TTCFont font into pixels or > using a pre-rendered StrikeFont in the first place. > + > + Display currentScaleError > + " > + > + ^ RealEstateAgent scaleFactor - self uiScaleFactor > + > + " > + | errors current | > + errors := OrderedDictionary new. > + current := Display uiScaleFactor. > + 1.0 to: 3.0 by: 0.25 do: [:s | > + Display uiScaleFactor: s. > + errors at: s put: Display currentScaleError]. > + Display uiScaleFactor: current. > + errors explore. > + "! > > Item was added: > + ----- Method: DisplayScreen>>platformScaleFactor (in category 'scale > factor') ----- > + platformScaleFactor > + "Answers the platform's (and thus monitor's) current scale factor > as last reported via VM primitive. See #checkForNewScreenScaleFactor." > + > + ^ PlatformScaleFactor ifNil: [1.0 "Primitive not ready."]! > > Item was added: > + ----- Method: DisplayScreen>>platformScaleFactor: (in category 'scale > factor') ----- > + platformScaleFactor: aFloatOrNil > + "Report a new scale factor from the platform to the image. This > can happen if you move Squeak's window between monitors with different > pixels-per-inch. On some platforms, you can also set a scale factor > independent of monitor PPI. Note that the user might have scaled the image > regardless of the previous platform scale factor." > + > + | old new | > + aFloatOrNil ifNil: [ > + "Ignore. Primitive not ready (anymore)." > + PlatformScaleFactor := nil. > + ^ self]. > + PlatformScaleFactor ifNil: [ > + "First time. Ignore. Assume that the user scaled manually > until now." > + PlatformScaleFactor := aFloatOrNil. > + ^ self]. > + > + (old := self platformScaleFactor) = (new := aFloatOrNil) ifTrue: > [^ self]. > + PlatformScaleFactor := new. > + self uiScaleFactor: self uiScaleFactor * (new/old).! > > Item was added: > + ----- Method: DisplayScreen>>platformScaleFactorKnown (in category > 'scale factor') ----- > + platformScaleFactorKnown > + "Tools can help users understand whether Squeak will adjust the > scale factor automatically or whether they have to scale manually. See > class-side's #actualScreenScaleFactor and also #relativeUiScaleFactor." > + > + ^ PlatformScaleFactor notNil! > > Item was added: > + ----- Method: DisplayScreen>>relativeUiScaleFactor (in category 'scale > factor') ----- > + relativeUiScaleFactor > + "Answers the scale factor as perceived by the user. Note that this > concept might be platform-dependent. On Windows, for example, 100% means > pixel-perfect while on macOS 100% means as-the-monitor-demands. So, Retina > displays are effectively scaled even if the user sees 100% in a > Choose-Your-Scale dialog." > + > + ^ self class relativeScaleFactorEnabled > + ifTrue: [ "macOS" self uiScaleFactor / self > platformScaleFactor ] > + ifFalse: [ "Windows" self uiScaleFactor ]! > > Item was added: > + ----- Method: DisplayScreen>>relativeUiScaleFactor: (in category 'scale > factor') ----- > + relativeUiScaleFactor: aFloat > + > + ^ self class relativeScaleFactorEnabled > + ifTrue: [ "macOS" self uiScaleFactor: aFloat * self > platformScaleFactor ] > + ifFalse: [ "Windows" self uiScaleFactor: aFloat ]! > > Item was added: > + ----- Method: DisplayScreen>>uiScaleFactor (in category 'scale factor') > ----- > + uiScaleFactor > + "Answers the current scale factor used to configure all widgets, > tools, or windows to be prepared for the current rendering system, i.e., > BitBlt. Note that 1.0 means 'pixel perfect'." > + > + ^ UserInterfaceTheme current isTTCBased > + ifTrue: [TextStyle pixelsPerInch / 96.0 "Hide rounding > errors in TTCFont >> #height."] > + ifFalse: [RealEstateAgent scaleFactor roundTo: 0.25 "Force > 25% steps. See, e.g., #doScale150."].! > > Item was added: > + ----- Method: DisplayScreen>>uiScaleFactor: (in category 'scale factor') > ----- > + uiScaleFactor: aFloat > + "Sets the effective scale factor for the user interface, i.e., all > widgets, tools, and windows. The user can override the CurrentScaleFactor > recommended by the platform." > + > + | oldFactor newFactor | > + (UserInterfaceTheme current canFakeScaleFactor: aFloat) ifTrue: [ > + self flag: #isTTCBased. > + ^ UserInterfaceTheme current applyScaled: aFloat]. > + > + aFloat = 0.75 ifTrue: [(Project uiManager confirm: ((('You are > currently using <b>TrueType fonts</b>. Your requested scale factor of > <b>{1}%</b> looks better using pre-rendered <b>pixel fonts</b>.\\Do you > want to switch to pixel fonts now?' translated withCRs format: {(aFloat * > 100) rounded}) withNoLineLongerThan: 60) copyReplaceAll: String cr with: > '<br>') asTextFromHtml title: 'Blurry Fonts Detected' translated) == true > + ifTrue: [UserInterfaceTheme cleanUpAndReset. ^ self > uiScaleFactor: aFloat]]. > + > + oldFactor := RealEstateAgent scaleFactor. "Use effective, > pixel-based factor to account for rounding errors. See #isTTCBased and > #uiScaleFactor." > + newFactor := aFloat max: 0.75. > + newFactor = oldFactor ifTrue: [^ self]. > + > + TextStyle pixelsPerInch: 96.0 * aFloat. > + newFactor := RealEstateAgent resetScaleFactor; scaleFactor. > "Again, account for rounding errors." > + Project current ifNotNil: [:p | p displayScaleChangedFrom: > oldFactor to: newFactor].! > > Item was added: > + ----- Method: DisplayText>>asString (in category 'converting') ----- > + asString > + "See String >> #asDisplayText." > + > + ^ self string! > > Item was added: > + ----- Method: DisplayText>>asText (in category 'converting') ----- > + asText > + "See Text >> #asDisplayText." > + > + ^ self text! > > Item was changed: > ----- Method: FixedFaceFont>>baseFont: (in category 'accessing') ----- > baseFont: aFont > + baseFont := aFont. > + self fixSubstitutionCharacter.! > - baseFont := aFont! > > Item was changed: > + ----- Method: FixedFaceFont>>characterFormAt: (in category 'character > shapes') ----- > - ----- Method: FixedFaceFont>>characterFormAt: (in category 'accessing') > ----- > characterFormAt: character > ^ baseFont characterFormAt: substitutionCharacter! > > Item was added: > + ----- Method: FixedFaceFont>>errorCharacter (in category 'accessing') > ----- > + errorCharacter > + ^$?! > > Item was changed: > ----- Method: FixedFaceFont>>errorFont (in category > 'initialize-release') ----- > errorFont > displaySelector := #displayErrorOn:length:at:kern:baselineY:. > + substitutionCharacter := self errorCharacter. > + self fixSubstitutionCharacter.! > - substitutionCharacter := $?.! > > Item was added: > + ----- Method: FixedFaceFont>>fixSubstitutionCharacter (in category > 'private') ----- > + fixSubstitutionCharacter > + > + substitutionCharacter ifNil: [^ self]. > + baseFont ifNil: [^ self]. > + (baseFont hasGlyphOf: substitutionCharacter) ifTrue: [^ self]. > + > + ((baseFont minCodePoint max: 33) to: baseFont maxCodePoint) > + detect: [:codePoint | baseFont hasGlyphOf: (Character > value: codePoint)] > + ifFound: [:codePoint | substitutionCharacter := Character > value: codePoint] > + ifNone: [ > + baseFont := TextStyle defaultFont. > + substitutionCharacter := $?]. > + self > + assert: [baseFont hasGlyphOf: substitutionCharacter] > + description: 'Could not find a possible substitution > character and font!!'.! > > Item was added: > + ----- Method: FixedFaceFont>>fontPointSize: (in category 'accessing') > ----- > + fontPointSize: aNumber > + self baseFont: (StrikeFont familyName: baseFont familyName > pointSize: aNumber) copy! > > Item was added: > + ----- Method: FixedFaceFont>>formOf: (in category 'private') ----- > + formOf: aCharacter > + "No need to check #hasGlyphOf:." > + > + ^ self characterFormAt: aCharacter! > > Item was changed: > ----- Method: FixedFaceFont>>initialize (in category > 'initialize-release') ----- > initialize > + > + baseFont := TextStyle defaultFont. > + self passwordFont.! > - "This used to be the default textstyle, but it needs to be a > StrikeFont and not a TTCFont and sometimes the default textstyle is a > TTCFont. So, we use a typical StrikeFont as the default fallback font." > - baseFont := StrikeFont defaultSized: 12. > - self passwordFont! > > Item was removed: > - ----- Method: FixedFaceFont>>maxAscii (in category 'accessing') ----- > - maxAscii > - ^ SmallInteger maxVal! > > Item was added: > + ----- Method: FixedFaceFont>>maxCodePoint (in category 'accessing') ----- > + maxCodePoint > + "Overwritten for robustness. The receiver MUST BE a reliable > source of glyphs if all else fails. Font rendering must never stop." > + > + ^ SmallInteger maxVal! > > Item was added: > + ----- Method: FixedFaceFont>>minSubstitutionCharacter (in category > 'private') ----- > + minSubstitutionCharacter > + > + ^ Character value: (baseFont ifNil: [0] ifNotNil: [baseFont > minCodePoint])! > > Item was changed: > ----- Method: FixedFaceFont>>passwordFont (in category > 'initialize-release') ----- > passwordFont > displaySelector := #displayPasswordOn:length:at:kern:baselineY:. > + substitutionCharacter := self passwordCharacter. > + self fixSubstitutionCharacter.! > - substitutionCharacter := $*! > > Item was changed: > ----- Method: FontSet class>>acceptsLoggingOfCompilation (in category > 'compiling') ----- > acceptsLoggingOfCompilation > "Dont log sources for my subclasses, so as not to waste time > and space storing printString versions of the string literals." > > + ^super acceptsLoggingOfCompilation > + and: > + [self == FontSet]! > - ^ self == FontSet! > > Item was changed: > DisplayMedium subclass: #Form > instanceVariableNames: 'bits width height depth offset' > + classVariableNames: 'CompressOnSnapshot' > - classVariableNames: '' > poolDictionaries: '' > category: 'Graphics-Display Objects'! > > !Form commentStamp: 'cbc 5/5/2017 10:07' prior: 0! > A rectangular array of pixels, used for holding images. All pictures, > including character images are Forms. The depth of a Form is how many bits > are used to specify the color at each pixel. The actual bits are held in a > Bitmap, whose internal structure is different at each depth. Class Color > allows you to deal with colors without knowing how they are actually > encoded inside a Bitmap. > The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The > number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 > million. > Forms are indexed starting at 0 instead of 1; thus, the top-left > pixel of a Form has coordinates 0 at 0. > Forms are combined using BitBlt. See the comment in class > BitBlt. Forms that repeat many times to fill a large destination are > InfiniteForms. > > colorAt: x at y Returns the abstract Color at this > location > displayAt: x at y shows this form on the screen > displayOn: aMedium at: x at y shows this form in a Window, a > Form, or other DisplayMedium > fillColor: aColor Set all the pixels to the color. > edit launch an editor to change the bits of this form. > pixelValueAt: x at y The encoded color. The encoding depends > on the depth. > > Note: If you want to hook up other external forms/displayScreens, please > look at the (successful) Graphics-External package in > http://www.squeaksource.com/Balloon3D.! > > Item was added: > + ----- Method: Form class>>compressOnSnapshot (in category 'preferences') > ----- > + compressOnSnapshot > + <preference: 'Always compress graphics data on snapshot' > + categoryList: #(performance Graphics) > + description: 'When enabled, graphics data such as all > instances of Form are compressed during image snapshots -- even when the > image will not quit after the snapshot. This includes cache clean-up such > as the TrueType glyph cache. Disable to avoid render lags after snapshots > at the cost of a bigger footprint of your .image file. Note that > snapshot-and-quit always compresses graphics data.' > + type: #Boolean> > + > + ^ CompressOnSnapshot ifNil: [true]! > > Item was added: > + ----- Method: Form class>>compressOnSnapshot: (in category > 'preferences') ----- > + compressOnSnapshot: aBoolean > + > + CompressOnSnapshot := aBoolean.! > > Item was removed: > - ----- Method: Form class>>shutDown (in category 'shut down') ----- > - shutDown "Form shutDown" > - "Compress all instances in the system. Will decompress on > demand..." > - Form allInstancesDo: [:f | f hibernate]. > - ColorForm allInstancesDo: [:f | f hibernate].! > > Item was added: > + ----- Method: Form class>>shutDown: (in category 'shut down') ----- > + shutDown: quitting > + "When quitting, compress all instances in the system. Will > decompress on demand after start-up. Note that #compressOnShapshot can > avoid hibernating forms during no-quit snapshotting to keep the system as > responsive as possible directly after." > + > + "Form shutDown: true" > + (quitting or: [self compressOnSnapshot]) ifTrue: [ > + Form allInstancesDo: [:f | f hibernate]. > + ColorForm allInstancesDo: [:f | f hibernate]].! > > Item was changed: > ----- Method: Form>>bitsSize (in category 'accessing') ----- > bitsSize > + | pixelsPerWord | > + depth ifNil: [depth := 1]. > + pixelsPerWord := 32 // self depth. > + ^width + pixelsPerWord - 1 // pixelsPerWord * height! > - | pixPerWord | > - depth == nil ifTrue: [depth := 1]. > - pixPerWord := 32 // self depth. > - ^ width + pixPerWord - 1 // pixPerWord * height! > > Item was added: > + ----- Method: Form>>isVirtualScreen (in category 'testing') ----- > + isVirtualScreen > + "Am I a virtual display screen?" > + ^false! > > Item was changed: > ----- Method: Form>>setExtent:depth:bits: (in category 'private') ----- > setExtent: extent depth: bitsPerPixel bits: bitmap > "Create a virtual bit map with the given extent and bitsPerPixel." > + | bitsClass | > + (width := extent x asInteger) < 0 ifTrue: [width := 0]. > + (height := extent y asInteger) < 0 ifTrue: [height := 0]. > - > - width := extent x asInteger. > - width < 0 ifTrue: [width := 0]. > - height := extent y asInteger. > - height < 0 ifTrue: [height := 0]. > depth := bitsPerPixel. > - depth := bitsPerPixel. > (bits isNil > + or: [(bitsClass := bits class) isBits > + and: [self bitsSize * 4 "bytes per pixel" = (bitmap size * > bitsClass elementSize)]]) ifFalse: > + [^self error: 'Bad dimensions and/or bitmap kind']. > - or:[(bitmap class isWords and: [self bitsSize = bitmap > size]) > - or: [bitmap class isBytes and: [self bitsSize * 4 = bitmap > size]]]) > - ifFalse:[^self error:'Bad dimensions']. > bits := bitmap! > > Item was changed: > StrikeFont subclass: #FormSetFont > instanceVariableNames: 'tintable combinationRule' > classVariableNames: '' > poolDictionaries: '' > category: 'Graphics-Fonts'! > > + !FormSetFont commentStamp: 'ct 2/14/2020 16:49' prior: 0! > + FormSetFonts are designed to capture individual images as character > forms for imbedding in normal text. While most often used to insert an > isolated glyph in some text, the code is actually designed to support an > entire user-defined font. The TextAttribute subclass TextFontReference is > specifically designed for such in-line insertion of exceptional fonts in > normal text.! > - !FormSetFont commentStamp: '<historical>' prior: 0! > - FormSetFonts are designed to capture individual images as character > forms for imbedding in normal text. While most often used to insert an > isolated glyph in some text, the code is actually desinged to support an > entire user-defined font. The TextAttribute subclass TextFontReference is > specifically designed for such in-line insertion of exceptional fonts in > normal text.! > > Item was changed: > ----- Method: GIFReadWriter class>>grabScreenAndSaveOnDisk (in category > 'examples') ----- > grabScreenAndSaveOnDisk > "GIFReadWriter grabScreenAndSaveOnDisk" > > | form fileName | > form := Form fromUser. > form bits size = 0 ifTrue: [^Beeper beep]. > fileName := FileDirectory default nextNameFor: 'Squeak' extension: > 'gif'. > + Project uiManager > + informUser: ('Writing {1}' translated format: {fileName}) > + during: [GIFReadWriter putForm: form onFileNamed: > fileName].! > - UIManager default informUser: 'Writing ' , fileName > - during: [GIFReadWriter putForm: form onFileNamed: > fileName]! > > Item was changed: > ----- Method: GIFReadWriter>>nextImage (in category 'accessing') ----- > nextImage > "Read in the next GIF image from the stream." > > | f thisImageColorTable | > > localColorTable := nil. > self readHeader. > f := self readBody. > self close. > + f == nil ifTrue: [^ self error: 'corrupt GIF file' translated]. > - 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 > ! > > Item was changed: > ----- Method: GIFReadWriter>>readBitData (in category > 'private-decoding') ----- > 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 (depth = {1})' translated format: {bitsPerPixel})]. > - 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 ({1})' translated format: {'OutCount'})]. > - 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! > - ^ c > - ! > > Item was changed: > ----- Method: GIFReadWriter>>readHeader (in category 'private-decoding') > ----- > 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' translated]]. > - 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 ({1})' > translated format: {'screen descriptor'})]]. > - 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"].! > > Item was changed: > ----- Method: GIFReadWriter>>updatePixelPosition (in category '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]. > > + ^pass caseError! > - ^self error: 'can''t happen'! > > Item was changed: > ----- Method: ImageReadWriter class>>formFromStream: (in category 'image > reading/writing') ----- > formFromStream: aBinaryStream > "Answer a ColorForm stored on the given stream. closes the stream" > | reader readerClass form | > > readerClass := self withAllSubclasses > detect: [:subclass | > aBinaryStream reset. > subclass understandsImageFormat: aBinaryStream] > ifNone: [ > aBinaryStream close. > + ^self error: 'image format not recognized' > translated]. > - ^self error: 'image format not recognized']. > aBinaryStream reset. > reader := readerClass new on: aBinaryStream. > Cursor read showWhile: [ > form := reader nextImage. > reader close]. > ^ form > ! > > Item was changed: > ----- Method: > ImageReadWriter>>changePadOfBits:width:height:depth:from:to: (in category > '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: {1}' translated > format: {oldPad})]. > - ifFalse: [^self error: 'Invalid pad: ', oldPad > printString]. > (#(8 16 32) includes: newPad) > + ifFalse: [^self error: ('Invalid pad: {1}' translated > format: {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.' > translated]. > - 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! > > Item was changed: > ----- Method: ImageReadWriter>>unpackBits:depthTo8From:with:height:pad: > (in category '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' > translated]. > - 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' > translated]. > - 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 > ! > > Item was changed: > ----- Method: JPEGReadStream>>decodeValueFrom: (in category 'huffman > trees') ----- > decodeValueFrom: table > "Decode the next value in the receiver using the given huffman > table." > | bits bitsNeeded tableIndex value | > bitsNeeded := (table at: 1) bitShift: -24. "Initial bits > needed" > tableIndex := 2. > "First real table" > [bits := self getBits: bitsNeeded. "Get bits" > value := table at: (tableIndex + bits). "Lookup entry in > table" > (value bitAnd: 16r3F000000) = 0] "Check if > it is a non-leaf node" > whileFalse:["Fetch sub table" > tableIndex := value bitAnd: 16rFFFF. "Table > offset in low 16 bit" > bitsNeeded := (value bitShift: -24) bitAnd: 255. > "Additional bits in high 8 bit" > + bitsNeeded > MaxBits ifTrue:[^self error: 'Invalid > huffman table entry' translated]]. > - bitsNeeded > MaxBits ifTrue:[^self error:'Invalid > huffman table entry']]. > ^value! > > Item was changed: > ----- Method: JPEGReadStream>>getBits: (in category 'accessing') ----- > getBits: requestedBits > | value | > requestedBits > bitsInBuffer ifTrue:[ > self fillBuffer. > requestedBits > bitsInBuffer ifTrue:[ > + self error: 'not enough bits available to decode' > translated]]. > - self error: 'not enough bits available to > decode']]. > value := bitBuffer bitShift: (requestedBits - bitsInBuffer). > bitBuffer := bitBuffer bitAnd: (1 bitShift: (bitsInBuffer - > requestedBits)) -1. > bitsInBuffer := bitsInBuffer - requestedBits. > ^ value! > > Item was changed: > ----- Method: JPEGReadWriter>>nextImageDitheredToDepth: (in category > 'public access') ----- > nextImageDitheredToDepth: depth > > | form xStep yStep x y bb | > ditherMask := DitherMasks > at: depth > + ifAbsent: [self error: 'can only dither to display depths' > translated]. > - ifAbsent: [self error: 'can only dither to display > depths']. > residuals := WordArray new: 3. > sosSeen := false. > self parseFirstMarker. > [sosSeen] whileFalse: [self parseNextMarker]. > form := Form extent: (width @ height) depth: depth. > bb := BitBlt toForm: form. > bb sourceForm: mcuImageBuffer. > bb colorMap: (mcuImageBuffer colormapIfNeededFor: form). > bb sourceRect: mcuImageBuffer boundingBox. > bb combinationRule: Form over. > xStep := mcuWidth * DCTSize. > yStep := mcuHeight * DCTSize. > y := 0. > 1 to: mcuRowsInScan do: > [:row | > x := 0. > 1 to: mcusPerRow do: > [:col | > self decodeMCU. > self idctMCU. > self colorConvertMCU. > bb destX: x; destY: y; copyBits. > x := x + xStep]. > y := y + yStep]. > ^ form! > > Item was removed: > - ----- Method: JPEGReadWriter>>notSupported: (in category 'error > handling') ----- > - notSupported: aString > - > - self error: aString , ' is not currently supported'! > > Item was changed: > ----- Method: JPEGReadWriter>>parseAPPn (in category 'marker parsing') > ----- > parseAPPn > > | length buffer thumbnailLength markerStart | > markerStart := self position. > length := self nextWord. > buffer := self next: 4. > (buffer asString = 'JFIF') ifFalse: [ > "Skip APPs that we're not interested in" > stream next: length-6. > ^self]. > self next. > majorVersion := self next. > minorVersion := self next. > densityUnit := self next. > xDensity := self nextWord. > yDensity := self nextWord. > thumbnailLength := self next * self next * 3. > length := length - (self position - markerStart). > + length = thumbnailLength ifFalse: [self error: 'APP0 thumbnail > length is incorrect.' translated]. > - length = thumbnailLength ifFalse: [self error: 'APP0 thumbnail > length is incorrect.']. > self next: length! > > Item was changed: > ----- Method: JPEGReadWriter>>parseDecoderRestartInterval (in category > 'marker parsing') ----- > parseDecoderRestartInterval > > | length | > length := self nextWord. > + length = 4 ifFalse: [self error: 'DRI length is incorrect.' > translated]. > - length = 4 ifFalse: [self error: 'DRI length incorrect']. > restartInterval := self nextWord.! > > Item was changed: > ----- Method: JPEGReadWriter>>parseFirstMarker (in category 'marker > parsing') ----- > parseFirstMarker > > | marker | > + self next = 16rFF ifFalse: [self error: 'JFIF marker expected' > translated]. > - self next = 16rFF ifFalse: [self error: 'JFIF marker expected']. > marker := self next. > marker = 16rD9 > ifTrue: [^self "halt: 'EOI encountered.'"]. > + marker = 16rD8 ifFalse: [self error: 'SOI marker expected' > translated]. > - marker = 16rD8 ifFalse: [self error: 'SOI marker expected']. > self parseStartOfInput. > ! > > Item was changed: > ----- Method: JPEGReadWriter>>parseHuffmanTable (in category 'marker > parsing') ----- > parseHuffmanTable > > | length markerStart index bits count huffVal isACTable hTable | > markerStart := self position. > length := self nextWord. > [self position - markerStart >= length] whileFalse: > [index := self next. > isACTable := (index bitAnd: 16r10) ~= 0. > index := (index bitAnd: 16r0F) + 1. > index > HuffmanTableSize > + ifTrue: [self error: ('image has more than {1} > quantization tables' translated format: {HuffmanTableSize})]. > - ifTrue: [self error: 'image has more than ', > HuffmanTableSize printString, > - ' quantization tables']. > bits := self next: 16. > count := bits sum. > (count > 256 or: [(count > (length - (self position - > markerStart)))]) > + ifTrue: [self error: 'Huffman Table count is > incorrect' translated]. > - ifTrue: [self error: 'Huffman Table count is > incorrect']. > huffVal := self next: count. > hTable := stream buildLookupTable: huffVal counts: bits. > isACTable > ifTrue: > [self hACTable at: index put: hTable] > ifFalse: > [self hDCTable at: index put: hTable]].! > > Item was changed: > ----- Method: JPEGReadWriter>>parseNextMarker (in category 'marker > parsing') ----- > parseNextMarker > "Parse the next marker of the stream" > > | byte discardedBytes | > discardedBytes := 0. > [(byte := self next) = 16rFF] whileFalse: [discardedBytes := > discardedBytes + 1]. > [[(byte := self next) = 16rFF] whileTrue. byte = 16r00] whileTrue: > [discardedBytes := discardedBytes + 2]. > discardedBytes > 0 ifTrue: [self "notifyWithLabel: 'warning: > extraneous data discarded'"]. > self perform: > (JFIFMarkerParser > at: byte > ifAbsent: > [(self okToIgnoreMarker: byte) > ifTrue: [#skipMarker] > + ifFalse: [self error: ('marker {1} > cannot be handled' translated format: {byte printStringHex})]])! > - ifFalse: [self error: 'marker ', > byte printStringHex , ' cannot be handled']])! > > Item was changed: > ----- Method: JPEGReadWriter>>parseQuantizationTable (in category > 'marker parsing') ----- > parseQuantizationTable > > | length markerStart n prec value table | > markerStart := self position. > length := self nextWord. > [self position - markerStart >= length] whileFalse: > [value := self next. > n := (value bitAnd: 16r0F) + 1. > prec := (value >> 4) > 0. > n > QuantizationTableSize > + ifTrue: [self error: ('image has more than {1} > quantization tables' translated format: {QuantizationTableSize})]. > - ifTrue: [self error: 'image has more than ', > - QuantizationTableSize printString, > - ' quantization tables']. > table := IntegerArray new: DCTSize2. > 1 to: DCTSize2 do: > [:i | > value := (prec > ifTrue: [self nextWord] > ifFalse: [self next]). > table at: (JPEGNaturalOrder at: i) put: value]. > self useFloatingPoint ifTrue: [self > scaleQuantizationTable: table]. > self qTable at: n put: table]! > > Item was changed: > ----- Method: JPEGReadWriter>>parseStartOfFile (in category 'marker > parsing') ----- > parseStartOfFile > > | length markerStart value n | > markerStart := self position. > length := self nextWord. > dataPrecision := self next. > dataPrecision = 8 > + ifFalse: [self error: ('cannot handle {1}-bit components' > translated format: {dataPrecision})]. > - ifFalse: [self error: 'cannot handle ', dataPrecision > printString, '-bit components']. > height := self nextWord. > width := self nextWord. > n := self next. > + (height = 0) | (width = 0) | (n = 0) ifTrue: [self error: 'empty > image' translated]. > - (height = 0) | (width = 0) | (n = 0) ifTrue: [self error: 'empty > image']. > (length - (self position - markerStart)) ~= (n * 3) > + ifTrue: [self error: 'component length is incorrect' > translated]. > - ifTrue: [self error: 'component length is incorrect']. > components := Array new: n. > 1 to: components size do: > [:i | > components > at: i > put: > (JPEGColorComponent new > id: self next; > "heightInBlocks: (((value := self > next) >> 4) bitAnd: 16r0F); > widthInBlocks: (value bitAnd: > 16r0F);" > widthInBlocks: (((value := self > next) >> 4) bitAnd: 16r0F); > heightInBlocks: (value bitAnd: > 16r0F); > > qTableIndex: self next + 1)]! > > Item was changed: > ----- Method: JPEGReadWriter>>parseStartOfScan (in category 'marker > parsing') ----- > parseStartOfScan > > | length n id value dcNum acNum comp | > length := self nextWord. > n := self next. > + (length ~= (n*2 + 6)) | (n < 1) ifTrue: [self error: 'SOS length > is incorrect' translated]. > - (length ~= (n*2 + 6)) | (n < 1) ifTrue: [self error: 'SOS length > is incorrect']. > currentComponents := Array new: n. > 1 to: n do: [:i | > id := self next. > value := self next. > dcNum := (value >> 4) bitAnd: 16r0F. > acNum := value bitAnd: 16r0F. > comp := components detect: [:c | c id = id]. > comp > dcTableIndex: dcNum+1; > acTableIndex: acNum+1. > currentComponents at: i put: comp]. > ss := self next. > se := self next. > value := self next. > ah := (value >> 4) bitAnd: 16r0F. > al := value bitAnd: 16r0F. > self initialSOSSetup. > self perScanSetup. > sosSeen := true! > > Item was changed: > ----- Method: JPEGReadWriter>>perScanSetup (in category 'marker > parsing') ----- > perScanSetup > > mcusPerRow := (width / (mcuWidth * DCTSize)) ceiling. > mcuRowsInScan := (height / (mcuHeight * DCTSize)) ceiling. > (currentComponents size = 3 or: [currentComponents size = 1]) > + ifFalse: [self error: 'JPEG color space not recognized' > translated]. > - ifFalse: [self error: 'JPEG color space not recognized']. > mcuMembership := OrderedCollection new. > currentComponents withIndexDo: > [:c :i | > c priorDCValue: 0. > mcuMembership addAll: ((1 to: c totalMcuBlocks) collect: > [:b | i])]. > mcuMembership := mcuMembership asArray. > mcuSampleBuffer := (1 to: mcuMembership size) collect: [:i | > IntegerArray new: DCTSize2]. > currentComponents withIndexDo: > [:c :i | > c initializeSampleStreamBlocks: > ((1 to: mcuMembership size) > select: [:j | i = (mcuMembership > at: j)] > thenCollect: [:j | mcuSampleBuffer > at: j])]. > mcuImageBuffer := Form > extent: (mcuWidth @ mcuHeight) * DCTSize > depth: 32. > restartsToGo := restartInterval.! > > Item was changed: > ----- Method: JPEGReadWriter2>>compress:quality: (in category 'public > access') ----- > compress: aForm quality: quality > "Encode the given Form and answer the compressed ByteArray. > Quality goes from 0 (low) to 100 (high), where -1 means default. > We can only compress: > * 32-bit deep Forms > * -32-bit deep Forms > * 16-bit deep Forms > * -16-bit deep Forms > * GrayScale ColorForms (see #isGrayScale)" > | sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer > byteCount | > > aForm unhibernate. > > sourceForm := self supports8BitGrayscaleJPEGs > ifTrue: [ > (aForm depth = 32) | (aForm depth = 16) | (aForm > isGrayScale) > ifTrue: [aForm] > ifFalse: [aForm asFormOfDepth: 32 ]] > ifFalse: [ > (aForm nativeDepth > 0) & ((aForm depth = 32) | > ((aForm depth = 16) & (aForm width even))) > ifTrue: [aForm] > ifFalse: [aForm asFormOfDepth: 32 ]]. > > jpegCompressStruct := ByteArray new: self > primJPEGCompressStructSize. > jpegErrorMgr2Struct := ByteArray new: self > primJPEGErrorMgr2StructSize. > buffer := ByteArray new: sourceForm width * sourceForm height + > 1024. > byteCount := self primJPEGWriteImage: jpegCompressStruct > onByteArray: buffer > form: sourceForm > quality: quality > progressiveJPEG: false > errorMgr: jpegErrorMgr2Struct. > + byteCount = 0 ifTrue: [self error: 'buffer too small for > compressed data' translated]. > - byteCount = 0 ifTrue: [self error: 'buffer too small for > compressed data']. > ^ buffer copyFrom: 1 to: byteCount > ! > > Item was changed: > ----- Method: JPEGReadWriter2>>nextPutImage:quality:progressiveJPEG: (in > category 'public access') ----- > nextPutImage: aForm quality: quality progressiveJPEG: progressiveFlag > "Encode the given Form on my stream with the given settings. > Quality goes from 0 (low) to 100 (high), where -1 means default. If > progressiveFlag is true, encode as a progressive JPEG. > We can compress: > * 32-bit deep Forms > * -32-bit deep Forms > * 16-bit deep > * -16-bit deep > * GrayScale ColorForms (see #isGrayScale)" > > | sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer > byteCount | > > aForm unhibernate. > > sourceForm := self supports8BitGrayscaleJPEGs > ifTrue: [ > (aForm depth = 32) | (aForm depth = 16) | (aForm > isGrayScale) > ifTrue: [aForm] > ifFalse: [aForm asFormOfDepth: 32 ]] > ifFalse: [ > (aForm nativeDepth > 0) & ((aForm depth = 32) | > ((aForm depth = 16) & (aForm width even))) > ifTrue: [aForm] > ifFalse: [aForm asFormOfDepth: 32 ]]. > > jpegCompressStruct := ByteArray new: self > primJPEGCompressStructSize. > jpegErrorMgr2Struct := ByteArray new: self > primJPEGErrorMgr2StructSize. > buffer := ByteArray new: sourceForm width * sourceForm height + > 1024. > "Try to write the image. Retry with a larger buffer if needed." > [ > byteCount := self primJPEGWriteImage: jpegCompressStruct > onByteArray: buffer > form: sourceForm > quality: quality > progressiveJPEG: progressiveFlag > errorMgr: jpegErrorMgr2Struct. > byteCount = 0 and: [ buffer size < (sourceForm width * > sourceForm height * 3 + 1024) ] ] > whileTrue: [ buffer := ByteArray new: buffer size > * 2 ]. > + byteCount = 0 ifTrue: [ self error: 'buffer too small for > compressed data' translated ]. > - byteCount = 0 ifTrue: [ self error: 'buffer too small for > compressed data' ]. > stream next: byteCount putAll: buffer startingAt: 1. > self close. > ! > > Item was changed: > ----- Method: JPEGReadWriter2>>uncompress:into:doDithering: (in category > 'public access') ----- > uncompress: aByteArray into: aForm doDithering: ditherFlag > "Uncompress an image from the given ByteArray into the given Form. > Fails if the given Form has the wrong dimensions or depth. > We can read RGB JPEGs into: > * 32-bit Forms > * -32-bit Forms > * 16-bit Forms (with or without dithering!!) > * -16-bit Forms (with or without dithering!!) > We can read grayscale JPEGs into: > * 32-bit Forms > * -32-bit Forms > * 16-bit Forms (with or without dithering!!) > * -16-bit Forms (with or without dithering!!) > * 8-bit grayScale ColorForms (see #isGrayScale) > * -8-bit grayScale ColorForms (see #isGrayScale)" > > | jpegDecompressStruct jpegErrorMgr2Struct width height components > | > > aForm unhibernate. > > jpegDecompressStruct := ByteArray new: self > primJPEGDecompressStructSize. > jpegErrorMgr2Struct := ByteArray new: self > primJPEGErrorMgr2StructSize. > self > primJPEGReadHeader: jpegDecompressStruct > fromByteArray: aByteArray > errorMgr: jpegErrorMgr2Struct. > width := self primImageWidth: jpegDecompressStruct. > height := self primImageHeight: jpegDecompressStruct. > components := self primImageNumComponents: jpegDecompressStruct. > > ((aForm width = width) & (aForm height = height)) ifFalse: [ > + ^ self error: 'form dimensions do not match' translated ]. > - ^ self error: 'form dimensions do not match' ]. > self supports8BitGrayscaleJPEGs > ifTrue: [ > components = 3 > ifTrue: [ > aForm depth = 8 > + ifTrue: [ ^ self error: > 'Cannot uncompress multi-channel JPEGs into 8-bit deep forms' translated ]]. > - ifTrue: [ ^ self error: > 'Cannot uncompress multi-channel JPEGs into 8-bit deep forms' ]]. > components = 1 > ifTrue: [ > aForm depth = 8 > ifTrue: [ > aForm isGrayScale > + ifFalse: [ > ^ self error: 'Cannot uncompress single-channel JPEGs into 8-bit deep forms > that are not grayscale' translated ]]]] > - ifFalse: [ > ^ self error: 'Cannot uncompress single-channel JPEGs into 8-bit deep forms > that are not grayscale' ]]]] > > ifFalse: [ > aForm nativeDepth < 0 > + ifTrue: [ ^ self error: 'Current plugin > version doesn''t support uncompressing JPEGs into little-endian forms' > translated ] > - ifTrue: [ ^ self error: 'Current plugin > version doesn''t support uncompressing JPEGs into little-endian forms' ] > ifFalse: [ > aForm depth = 16 > ifTrue: [ > width odd > + ifTrue: [ > ^ self error: 'Current plugin version doesn''t support uncompressing JPEGs > with an odd width into 16-bit deep forms' translated ]]. > - ifTrue: [ > ^ self error: 'Current plugin version doesn''t support uncompressing JPEGs > with an odd width into 16-bit deep forms' ]]. > aForm depth = 8 > + ifTrue: [ ^ self error: > 'Current plugin version doesn''t support uncompressing JPEGs into 8-bit > deep forms' translated ]]]. > - ifTrue: [ ^ self error: > 'Current plugin version doesn''t support uncompressing JPEGs into 8-bit > deep forms' ]]]. > > self primJPEGReadImage: jpegDecompressStruct > fromByteArray: aByteArray > onForm: aForm > doDithering: ditherFlag > + errorMgr: jpegErrorMgr2Struct.! > - errorMgr: jpegErrorMgr2Struct. > - ! > > Item was changed: > ----- Method: LayoutFrame class>>classVersion (in category 'accessing') > ----- > classVersion > + ^ 2 "fractions and offsets are never 'nil' anymore" > - ^1 "changed treatment of bottomOffset and rightOffset" > ! > > Item was added: > + ----- Method: LayoutFrame class>>withClassVersion: (in category 'objects > from disk') ----- > + withClassVersion: aVersion > + > + aVersion <= self classVersion ifTrue: [^ self]. > + ^ super withClassVersion: aVersion! > > Item was changed: > ----- Method: LayoutFrame>>convertToCurrentVersion:refStream: (in > category 'objects from disk') ----- > convertToCurrentVersion: varDict refStream: smartRefStrm > | className oldClassVersion | > > "JW 2/1/2001" > "Since class version isn't passed in varDict, look it up through > smartRefSrm." > className := varDict at: #ClassName. > oldClassVersion := (smartRefStrm structures at: className) first. > + (oldClassVersion = 0) ifTrue: [ self negateBottomRightOffsets; > fixup ]. > + (oldClassVersion = 1) ifTrue: [ self fixup ]. > - (oldClassVersion = 0) ifTrue: [ self negateBottomRightOffsets ]. > ^super convertToCurrentVersion: varDict refStream: smartRefStrm. > ! > > Item was changed: > + ----- Method: LayoutFrame>>fixup (in category 'objects from disk') ----- > - ----- Method: LayoutFrame>>fixup (in category 'initialize-release') ----- > fixup > "Set-up default value for un-initialized layout frames" > > "LayoutFrame allInstancesDo: [:e | e fixup]." > > leftFraction ifNil: [leftFraction := 0]. > leftOffset ifNil: [leftOffset := 0]. > topFraction ifNil: [topFraction := 0]. > topOffset ifNil: [topOffset := 0]. > rightFraction ifNil: [rightFraction := 0]. > rightOffset ifNil: [rightOffset := 0]. > bottomFraction ifNil: [bottomFraction := 0]. > bottomOffset ifNil: [bottomOffset := 0].! > > Item was changed: > ----- Method: PCXReadWriter>>readPalette (in category > 'private-decoding') ----- > readPalette > > | r g b array | > + self next = 12 ifFalse: [self error: 'no Color Palette!!' > translated]. > - self next = 12 ifFalse: [self error: 'no Color Palette!!']. > array := Array new: (1 bitShift: bitsPerPixel). > 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. > ! > > Item was changed: > + ----- Method: PNGReadWriter class>>computeSwizzleMapForDepth: (in > category 'class initialization') ----- > - ----- Method: PNGReadWriter class>>computeSwizzleMapForDepth: (in > category 'as yet unclassified') ----- > computeSwizzleMapForDepth: depth > "Answer a map that maps pixels in a word to their opposite > location. Used for 'middle-endian' forms where the byte-order is different > from the bit order (good joke, eh?)." > | map swizzled | > map := Bitmap new: 256. > depth = 4 ifTrue:[ > 0 to: 255 do:[:pix| > swizzled := 0. > swizzled := swizzled bitOr: (((pix bitShift: 0) > bitAnd: 15) bitShift: 4). > swizzled := swizzled bitOr: (((pix bitShift: -4) > bitAnd: 15) bitShift: 0). > map at: pix+1 put: swizzled. > ]. > ^ColorMap colors: map > ]. > > depth = 2 ifTrue:[ > 0 to: 255 do:[:pix| > swizzled := 0. > swizzled := swizzled bitOr: (((pix bitShift: 0) > bitAnd: 3) bitShift: 6). > swizzled := swizzled bitOr: (((pix bitShift: -2) > bitAnd: 3) bitShift: 4). > swizzled := swizzled bitOr: (((pix bitShift: -4) > bitAnd: 3) bitShift: 2). > swizzled := swizzled bitOr: (((pix bitShift: -6) > bitAnd: 3) bitShift: 0). > map at: pix+1 put: swizzled. > ]. > ^ColorMap colors: map > ]. > > depth = 1 ifTrue:[ > 0 to: 255 do:[:pix| > swizzled := 0. > swizzled := swizzled bitOr: (((pix bitShift: 0) > bitAnd: 1) bitShift: 7). > swizzled := swizzled bitOr: (((pix bitShift: -1) > bitAnd: 1) bitShift: 6). > swizzled := swizzled bitOr: (((pix bitShift: -2) > bitAnd: 1) bitShift: 5). > swizzled := swizzled bitOr: (((pix bitShift: -3) > bitAnd: 1) bitShift: 4). > swizzled := swizzled bitOr: (((pix bitShift: -4) > bitAnd: 1) bitShift: 3). > swizzled := swizzled bitOr: (((pix bitShift: -5) > bitAnd: 1) bitShift: 2). > swizzled := swizzled bitOr: (((pix bitShift: -6) > bitAnd: 1) bitShift: 1). > swizzled := swizzled bitOr: (((pix bitShift: -7) > bitAnd: 1) bitShift: 0). > map at: pix+1 put: swizzled. > ]. > ^ColorMap colors: map > ]. > self error: 'Unrecognized depth'! > > Item was changed: > + ----- Method: PNGReadWriter class>>debugging: (in category 'support') > ----- > - ----- Method: PNGReadWriter class>>debugging: (in category 'as yet > unclassified') ----- > debugging: aBoolean > > Debugging := aBoolean! > > Item was changed: > + ----- Method: PNGReadWriter class>>initialize (in category 'class > initialization') ----- > - ----- Method: PNGReadWriter class>>initialize (in category 'as yet > unclassified') ----- > initialize > " > PNGReadWriter initialize > " > > BPP := { #(1 2 4 8 16). > #(0 0 0 0 0). > #(0 0 0 24 48). > #(1 2 4 8 0). > #(0 0 0 16 32). > #(0 0 0 0 0). > #(0 0 0 32 64). > #(0 0 0 0 0) }. > > BlockHeight := #(8 8 4 4 2 2 1). > BlockWidth := #(8 4 4 2 2 1 1). > > StandardColors := Color indexedColors collect:[:aColor| > Color > r: (aColor red * 255) truncated / 255 > g: (aColor green * 255) truncated / 255 > b: (aColor blue * 255) truncated / 255. > ]. > > StandardSwizzleMaps := Array new: 4. > #(1 2 4) do:[:i| StandardSwizzleMaps at: i put: (self > computeSwizzleMapForDepth: i)].! > > Item was removed: > - ----- Method: PNGReadWriter class>>insertMorph:named:into: (in category > 'as yet unclassified') ----- > - insertMorph: aMorph named: aString into: aBook > - > - | newPage | > - > - aBook ifNil: [^self]. > - newPage := aBook insertPageLabel: aString morphs: {aMorph}. > - newPage color: Color lightYellow. > - newPage extent: ( > - newPage submorphs inject: 10 at 10 into: [ :ex :m | > - m left: 10. > - ex max: m width @ m bottom > - ] > - ) + (20 at 20). > - ! > > Item was changed: > ----- Method: PNGReadWriter>>nextImage (in category 'accessing') ----- > nextImage > bigEndian := Smalltalk isBigEndian. > filtersSeen := Bag new. > idatChunkStream := nil. > transparentPixelValue := nil. > unknownChunks := Set new. > stream reset. > stream binary. > stream skip: 8. > [stream atEnd] whileFalse: [self processNextChunk]. > "Set up our form" > palette ifNotNil: > ["Dump the palette if it's the same as our > standard palette" > > palette = (StandardColors copyFrom: 1 to: palette > size) > ifTrue: [palette := nil]]. > (depth <= 8 and: [palette notNil]) > ifTrue: > [form := ColorForm extent: width @ height depth: > depth. > form colors: palette] > ifFalse: [form := Form extent: width @ height depth: > depth]. > backColor ifNotNil: [form fillColor: backColor]. > idatChunkStream > + ifNil: [ self error: 'image data is missing' translated ] > - ifNil: [ self error: 'image data is missing' ] > ifNotNil: [ self processIDATChunk ]. > unknownChunks isEmpty > ifFalse: > ["Transcript show: ' ',unknownChunks > asSortedCollection asArray printString." > > ]. > self debugging > ifTrue: > [Transcript > cr; > show: 'form = ' , form printString. > Transcript > cr; > show: 'colorType = ' , colorType > printString. > Transcript > cr; > show: 'interlaceMethod = ' , > interlaceMethod printString. > Transcript > cr; > show: 'filters = ' , filtersSeen > sortedCounts asArray printString]. > ^form! > > Item was changed: > ----- Method: PNGReadWriter>>processInterlaced (in category 'chunks') > ----- > processInterlaced > | z startingCol colIncrement rowIncrement startingRow | > startingCol := #(0 4 0 2 0 1 0 ). > colIncrement := #(8 8 4 4 2 2 1 ). > rowIncrement := #(8 8 8 4 4 2 2 ). > startingRow := #(0 0 4 0 2 0 1 ). > z := ZLibReadStream > on: idatChunkStream originalContents > from: 1 > to: idatChunkStream position. > 1 to: 7 do: [:pass | > | cx sc bytesPerPass | > (self doPass: pass) > ifTrue: > [cx := colIncrement at: pass. > sc := startingCol at: pass. > bytesPerPass := width - sc + cx - 1 // cx > * bitsPerPixel + 7 // 8. > prevScanline := ByteArray new: > bytesPerPass. > thisScanline := ByteArray new: > bytesPerScanline. > (startingRow at: pass) > to: height - 1 > by: (rowIncrement at: pass) > do: [:y | > | filter temp | > filter := z next. > filtersSeen add: filter. > (filter isNil or: [(filter > between: 0 and: 4) not]) > ifTrue: [^ self]. > thisScanline := z next: > bytesPerPass into: thisScanline startingAt: 1. > self filterScanline: > filter count: bytesPerPass. > self copyPixels: y at: sc > by: cx. > temp := prevScanline. > prevScanline := > thisScanline. > thisScanline := temp. > ] > ] > ]. > + z atEnd ifFalse:[self error: 'Unexpected data' translated].! > - z atEnd ifFalse:[self error:'Unexpected data'].! > > Item was changed: > ----- Method: PNGReadWriter>>processNextChunk (in category 'chunks') > ----- > processNextChunk > > | length chunkType crc chunkCrc | > > length := self nextLong. > > chunkType := (self next: 4) asString. > (chunk isNil or: [ chunk size ~= length ]) > ifTrue: [ chunk := self next: length ] > ifFalse: [ stream next: length into: chunk startingAt: 1 ]. > chunkCrc := self nextLong bitXor: 16rFFFFFFFF. > crc := self updateCrc: 16rFFFFFFFF from: 1 to: 4 in: chunkType. > crc := self updateCrc: crc from: 1 to: length in: chunk. > crc = chunkCrc ifFalse:[ > + self error: ('PNGReadWriter crc error in chunk {1}' > translated format: {chunkType}). > - self error: 'PNGReadWriter crc error in chunk ', chunkType. > ]. > > chunkType = 'IEND' ifTrue: [stream setToEnd. ^self "*should* > be the last chunk"]. > chunkType = 'sBIT' ifTrue: [^self processSBITChunk "could indicate > unusual sample depth in original"]. > chunkType = 'gAMA' ifTrue: [^self "indicates gamma > correction value"]. > chunkType = 'bKGD' ifTrue: [^self processBackgroundChunk]. > chunkType = 'pHYs' ifTrue: [^self processPhysicalPixelChunk]. > chunkType = 'tRNS' ifTrue: [^self processTransparencyChunk]. > > chunkType = 'IHDR' ifTrue: [^self processIHDRChunk]. > chunkType = 'PLTE' ifTrue: [^self processPLTEChunk]. > chunkType = 'IDAT' ifTrue: [ > "---since the compressed data can span multiple > chunks, stitch them all together first. later, > if memory is an issue, we need to figure out how > to do this on the fly---" > idatChunkStream > ifNil: [ idatChunkStream := WriteStream with: > chunk copy ] > ifNotNil: [ idatChunkStream nextPutAll: chunk ]. > ^self > ]. > unknownChunks add: chunkType. > ! > > Item was changed: > ----- Method: PNGReadWriter>>processPLTEChunk (in category 'chunks') > ----- > processPLTEChunk > > | colorCount i | > > + colorCount := chunk size // 3. > + self flag: #todo. "validate colorCount against depth" > - colorCount := chunk size // 3. "TODO - validate colorCount against > depth" > palette := Array new: colorCount. > 0 to: colorCount-1 do: [ :index | > i := index * 3 + 1. > palette at: index+1 put: > (Color r: (chunk at: i)/255.0 g: (chunk at: > i+1)/255.0 b: (chunk at: i+2)/255.0) > ].! > > Item was changed: > ----- Method: PNGReadWriter>>writeSBITChunkOn: (in category 'writing') > ----- > writeSBITChunkOn: aStream > "Write the IDAT chunk" > aStream nextPutAll: 'sBIT' asByteArray. > + form depth = 16 ifFalse: [self notYetImplemented]. > - form depth = 16 ifFalse:[self error: 'Unimplemented feature']. > aStream nextPut: 5. > aStream nextPut: 5. > aStream nextPut: 5. > aStream nextPut: 1.! > > Item was changed: > ----- Method: PNMReadWriter>>nextImage (in category 'reading') ----- > nextImage > "read one image" > | data p | > first ifNil:[ > first := false. > data := stream contentsOfEntireFile. > stream := (RWBinaryOrTextStream with: data) reset. > ] > ifNotNil:[ > type < 4 ifTrue:[ > + self error: 'Plain PBM, PGM or PPM have only one > image' translated > - self error:'Plain PBM, PGM or PPM have only one > image' > ]. > ]. > stream ascii. > p := stream next. > type := (stream next) asInteger - 48. > (p = $P and:[type > 0 and:[type < 8]]) ifFalse:[ > + self error: 'Not a PNM file' translated > - self error:'Not a PNM file' > ]. > type = 7 ifTrue:[ > self readHeaderPAM > ] > ifFalse: [ > self readHeader > ]. > type caseOf: { > [1] -> [^self readPlainBW]. > [2] -> [^self readPlainGray]. > [3] -> [^self readPlainRGB]. > [4] -> [^self readBWreverse: false]. > [5] -> [^self readGray]. > [6] -> [^self readRGB]. > [7] -> [ "PAM" > (tupleType asUppercase) caseOf: { > ['BLACKANDWHITE'] > -> [^self readBWreverse: true]. > ['GRAYSCALE'] > -> [^self readGray]. > ['RGB'] > -> [^self readRGB]. > + ['RGB_ALPHA'] > -> [^self notYetImplemented]. > + ['GRAYSCALE_ALPHA'] -> > [^self notYetImplemented]. > - ['RGB_ALPHA'] > -> [^self error:'Not implemented']. > - ['GRAYSCALE_ALPHA'] -> > [^self error:'Not implemented']. > } otherwise: [^self readData]. > ] > }! > > Item was changed: > ----- Method: PNMReadWriter>>readGray (in category 'reading') ----- > readGray > "gray form, return ColorForm with gray ramp" > | form poker | > + maxValue > 255 ifTrue:[self error: ('Gray value > {1} bits not > supported in Squeak' translated format: {8})]. > - maxValue > 255 ifTrue:[self error:'Gray value > 8 bits not > supported in Squeak']. > stream binary. > form := ColorForm extent: cols at rows depth: depth. > form colors: nil. > poker := BitBlt bitPokerToForm: form. > 0 to: rows-1 do: [:y | > 0 to: cols-1 do: [:x | > |val| > val := stream next. > poker pixelAt: x at y put: val. > ] > ]. > "a better way is using a gamma corrected palette" > form colors: ((0 to: 255) collect:[:c| > c > maxValue > ifTrue:[Color white] > ifFalse:[Color gray: (c/maxValue) asFloat]]). > form colors at: 1 put: (Color black). > ^form > ! > > Item was changed: > ----- Method: PNMReadWriter>>readHeader (in category 'reading') ----- > readHeader > "read header for pbm, pgm or ppm" > | tokens aux d c | > tokens := OrderedCollection new. > aux := self getTokenPbm: tokens. > cols := aux at: 1. tokens := aux at: 2. > aux := self getTokenPbm: tokens. > rows := aux at: 1. tokens := aux at: 2. > > (type = 1 or:[type = 4]) ifTrue:[ > maxValue := 1 > ] > ifFalse: [ > aux := self getTokenPbm: tokens. > maxValue := aux at: 1. tokens := aux at: 2. > ]. > d := {1 . 2 . 4 . 8 . 16 . 32}. > c := {2 . 4 . 16 . 256 . 32768 . 16777216}. > (type = 3 or:[type = 6]) ifTrue: [ > maxValue >= 65536 ifTrue:[ > + self error: ('Pixmap > {1} bits not supported in > PPM' translated format: {48}) > - self error:'Pixmap > 48 bits not supported in PPM' > ]. > maxValue >= 256 ifTrue:[ > + self error: ('Pixmap > {1} bits are not supported > in Squeak' translated format: {32}) > - self error:'Pixmap > 32 bits are not supported in > Squeak' > ]. > maxValue < 32 ifTrue:[depth := 16] ifFalse:[depth := 32]. > ] > ifFalse: [ > depth := nil. > 1 to: c size do:[:i| ((c at: i) > maxValue and:[depth = > nil]) ifTrue:[depth:=d at: i]]. > ]. > Transcript cr; show: 'PBM file class ', type asString, ' size ', > cols asString, ' x ', > rows asString, ' maxValue =', maxValue asString, ' > depth=', depth asString. > ! > > Item was changed: > ----- Method: PNMReadWriter>>readPlainBW (in category 'reading') ----- > readPlainBW > "plain BW" > | val form poker | > form := Form extent: cols at rows depth: depth. > poker := BitBlt bitPokerToForm: form. > 0 to: rows-1 do: [:y | > 0 to: cols-1 do: [:x | > [val := stream next. (val = $0 or:[val = $1])] > whileFalse:[ > + val ifNil: [self error: 'End of file > reading PBM' translated]. > - val ifNil:[self error:'End of file reading > PBM']. > ]. > poker pixelAt: x at y put: (val asInteger). > ] > ]. > ^form > ! > > Item was changed: > ----- Method: PNMReadWriter>>readPlainRGB (in category 'reading') ----- > readPlainRGB > "RGB form, use 32 bits" > | val form poker tokens aux | > + maxValue > 255 ifTrue:[self error: ('RGB value > {1} bits not > supported in Squeak' translated format: {32})]. > - maxValue > 255 ifTrue:[self error:'RGB value > 32 bits not > supported in Squeak']. > form := Form extent: cols at rows depth: 32. > poker := BitBlt bitPokerToForm: form. > tokens := OrderedCollection new. > 0 to: rows-1 do: [:y | > 0 to: cols-1 do: [:x | | r g b| > aux := self getTokenPbm: tokens. r := aux at: 1. > tokens := aux at: 2. > aux := self getTokenPbm: tokens. g := aux at: 1. > tokens := aux at: 2. > aux := self getTokenPbm: tokens. b := aux at: 1. > tokens := aux at: 2. > val := self r: r g: g b: b for: depth. > poker pixelAt: x at y put: val. > ] > ]. > ^form > ! > > Item was changed: > ----- Method: PNMReadWriter>>readRGB (in category 'reading') ----- > readRGB > "RGB form, use 16/32 bits" > | val form poker sample shift | > + maxValue > 255 ifTrue:[self error: ('RGB value > {1} bits not > supported in Squeak' translated format: {32})]. > - maxValue > 255 ifTrue:[self error:'RGB value > 32 bits not > supported in Squeak']. > stream binary. > form := Form extent: cols at rows depth: depth. > poker := BitBlt bitPokerToForm: form. > depth = 32 ifTrue:[shift := 8] ifFalse:[shift := 5]. > 0 to: rows-1 do: [:y | > 0 to: cols-1 do: [:x | > val := 16rFF. "no transparency" > 1 to: 3 do: [:i | > sample := stream next. > val := val << shift + sample. > ]. > poker pixelAt: x at y put: val. > ] > ]. > ^form > ! > > Item was added: > + ----- Method: Point>>exactCenter: (in category 'converting to > rectangle') ----- > + exactCenter: aPoint > + "Answer a Rectangle whose extent is the receiver and whose center > is exactly aPoint. This is one of the infix ways of expressing the creation > of a rectangle." > + > + ^ Rectangle exactCenter: aPoint extent: self! > > Item was added: > + ----- Method: Rectangle>>pointAtFraction: (in category 'rectangle > functions') ----- > + pointAtFraction: relativePoint > + > + | result | > + result := self origin + (self extent * relativePoint). > + ^ self isIntegerRectangle > + ifTrue: [result rounded] > + ifFalse: [result]! > > Item was added: > + ----- Method: Rectangle>>randomPoint (in category 'random') ----- > + randomPoint > + > + ^ self randomPoint: ThreadSafeRandom value! > > Item was added: > + ----- Method: Rectangle>>randomPoint: (in category 'random') ----- > + randomPoint: aGenerator > + "Answers a random point that lies within the receiver." > + > + ^ self pointAtFraction: aGenerator next @ aGenerator next! > > Item was changed: > AbstractFont subclass: #StrikeFont > + instanceVariableNames: 'characterToGlyphMap xTable glyphs name > type minAscii maxAscii maxWidth strikeLength ascent descent xOffset raster > subscript superscript emphasis derivativeFonts pointSize fallbackFont > charIndexCompatibilitySlot lineGap lineGapSlice' > - instanceVariableNames: 'characterToGlyphMap xTable glyphs name > type minAscii maxAscii maxWidth strikeLength ascent descent xOffset raster > subscript superscript emphasis derivativeFonts pointSize fallbackFont > charIndexCompatibilitySlot' > classVariableNames: 'DefaultStringScanner' > poolDictionaries: 'TextConstants' > category: 'Graphics-Fonts'! > > !StrikeFont commentStamp: 'fbs 11/28/2013 08:50' prior: 0! > I represent a compact encoding of a set of Forms corresponding to > characters in the ASCII character set. All the forms are placed side by > side in a large form whose height is the font height, and whose width is > the sum of all the character widths. The xTable variable gives the left-x > coordinates of the subforms corresponding to the glyphs. Characters are > mapped to glyphs by using the characterToGyphMap. > > Subclasses can have non-trivial mapping rules as well as different > representations for glyphs sizes (e.g., not using an xTable). If so, these > classes should return nil when queried for xTable and/or the > characterToGlyphMap. This will cause the CharacterScanner primitive to fail > and query the font for the width of a character (so that a more > programatical approach can be implemented). > > For display, fonts need to implement two messages: > #installOn: aDisplayContext foregroundColor: foregroundColor > backgroundColor: backgroundColor > This method installs the receiver (a font) on the given DisplayContext > (which may be an instance of BitBlt or Canvas (or any of its subclasses). > The font should take the appropriate action to initialize the display > context so that further display operations can be optimized. > #displayString: aString on: aDisplayContext from: startIndex to: > stopIndex at: aPoint kern: kernDelta > This method is called for each subsequent run of characters in aString > which is to be displayed with the (previously installed) settings. > ! > > Item was removed: > - ----- Method: StrikeFont class>>cleanUp (in category 'class > initialization') ----- > - cleanUp > - "Flush synthesized strike fonts" > - > - self allInstancesDo:[:sf| sf reset].! > > Item was added: > + ----- Method: StrikeFont class>>cleanUp: (in category 'class > initialization') ----- > + cleanUp: aggressive > + > + aggressive ifTrue: [self allInstancesDo: [:sf | sf reset]].! > > Item was changed: > ----- Method: StrikeFont class>>createDejaVu: (in category 'font > creation') ----- > createDejaVu: pointSize > "Warning: Uses the methods in 'dejaVu font data' category, that > will be removed soon (or are already removed) to save space." > > + | base bold oblique boldOblique point actualPointSize | > - | base bold oblique boldOblique point | > point := pointSize asString. > + actualPointSize := self fixDejaVuPointSIze: pointSize. > base := (StrikeFont new > buildFromForm: (self perform: ('dejaVuSansBook', point, > 'Form') asSymbol) > data: (self perform: ('dejaVuSansBook', point, 'Data') > asSymbol) > name: 'Bitmap DejaVu Sans ', point) > + pointSize: actualPointSize. > - pointSize: pointSize. > bold := (StrikeFont new > buildFromForm: (self perform: ('dejaVuSansBold', point, > 'Form') asSymbol) > data: (self perform: ('dejaVuSansBold', point, 'Data') > asSymbol) > name: 'Bitmap DejaVu Sans ', point, 'B') > emphasis: 1; > + pointSize: actualPointSize. > - pointSize: pointSize. > oblique := (StrikeFont new > buildFromForm: (self perform: ('dejaVuSansOblique', point, > 'Form') asSymbol) > data: (self perform: ('dejaVuSansOblique', point, 'Data') > asSymbol) > name: 'Bitmap DejaVu Sans ', point, 'I') > emphasis: 2; > + pointSize: actualPointSize. > - pointSize: pointSize. > boldOblique := (StrikeFont new > buildFromForm: (self perform: ('dejaVuSansBoldOblique', > point, 'Form') asSymbol) > data: (self perform: ('dejaVuSansBoldOblique', point, > 'Data') asSymbol) > name: 'Bitmap DejaVu Sans ', point, 'BI') > emphasis: 3; > + pointSize: actualPointSize. > - pointSize: pointSize. > > base derivativeFont: bold at: 1. > base derivativeFont: oblique at: 2. > base derivativeFont: boldOblique at: 3. > > ^base! > > Item was changed: > ----- Method: StrikeFont class>>createDejaVuDark: (in category 'font > creation') ----- > createDejaVuDark: pointSize > > + | base bold oblique boldOblique point actualPointSize | > - | base bold oblique boldOblique point | > point := pointSize asString. > + actualPointSize := self fixDejaVuPointSIze: pointSize. > base := (StrikeFont new > buildFromForm: (self perform: ('dejaVuSansBookDark', > point, 'Form') asSymbol) > data: (self perform: ('dejaVuSansBookDark', point, 'Data') > asSymbol) > name: 'Darkmap DejaVu Sans', point) > + pointSize: actualPointSize. > - pointSize: pointSize. > bold := (StrikeFont new > buildFromForm: (self perform: ('dejaVuSansBoldDark', > point, 'Form') asSymbol) > data: (self perform: ('dejaVuSansBoldDark', point, 'Data') > asSymbol) > name: 'Darkmap DejaVu Sans', point, 'B') > emphasis: 1; > + pointSize: actualPointSize. > - pointSize: pointSize. > oblique := (StrikeFont new > buildFromForm: (self perform: ('dejaVuSansObliqueDark', > point, 'Form') asSymbol) > data: (self perform: ('dejaVuSansObliqueDark', point, > 'Data') asSymbol) > name: 'Darkmap DejaVu Sans', point, 'I') > emphasis: 2; > + pointSize: actualPointSize. > - pointSize: pointSize. > boldOblique := (StrikeFont new > buildFromForm: (self perform: > ('dejaVuSansBoldObliqueDark', point, 'Form') asSymbol) > data: (self perform: ('dejaVuSansBoldObliqueDark', point, > 'Data') asSymbol) > name: 'Darkmap DejaVu Sans', point, 'BI') > emphasis: 3; > + pointSize: actualPointSize. > - pointSize: pointSize. > > base derivativeFont: bold at: 1. > base derivativeFont: oblique at: 2. > base derivativeFont: boldOblique at: 3. > > ^base! > > Item was removed: > - ----- Method: StrikeFont class>>defaultSized: (in category 'accessing') > ----- > - defaultSized: aNumber > - | fonts f | > - "This used to be the default textstyle, but it needs to be a > StrikeFont and not a TTCFont and sometimes the default textstyle is a > TTCFont. So, we use a typical StrikeFont as the default fallback font." > - fonts := (TextConstants at: #Accuny ifAbsent:[TextStyle default]) > fontArray. > - f := fonts first. > - 1 to: fonts size do: [:i | > - aNumber > (fonts at: i) height ifTrue: [f := fonts at: i]. > - ]. > - ^f > - ! > > Item was added: > + ----- Method: StrikeFont class>>fixDejaVuPointSIze: (in category 'font > creation') ----- > + fixDejaVuPointSIze: pointSize > + "Maps the given pointSize to 96 ppi." > + > + ^ (Dictionary newFrom: { > + 7 -> 7.5. > + 9 -> 10.5. > + 12 -> 14.5. > + 14 -> 16.5. > + 17 -> 19.5. > + 20 -> 23.5}) at: pointSize > + ! > > Item was changed: > ----- Method: StrikeFont class>>generateDejaVuMethods: (in category > 'font creation') ----- > generateDejaVuMethods: directory > "StrikeFont generateDejaVuMethods: 'DejaVu'." > | dir formTemplate dataTemplate methodCategory | > methodCategory := #'dejaVu font data'. > formTemplate := '{1} > <generated> > " Form data for {2}. Generated with StrikeFont > generateDejaVuMethods: ''{3}''" > ^Form fromBinaryStream: ( > ''{4}'' > ) base64Decoded asByteArray readStream > '. > dataTemplate := '{1} > <generated> > " Font meta data for {2}. Generated with StrikeFont > generateDejaVuMethods: ''{3}''" > ^ #({4}) > '. > dir := FileDirectory default / directory. > #('*.txt' 'Data' '*.png' 'Form') pairsDo: > [:match :suffix | (dir fileNamesMatching: match) > do: > [:local | | selector source stringContent| > " .txt and .png have both length 4" > selector := (local allButLast: 4) > asLegalSelector, suffix. > stringContent := dir > readOnlyFileNamed: local do: > [:stream | suffix = 'Data' > ifTrue: [stream > contentsOfEntireFile] > ifFalse: [(stream > binary; contentsOfEntireFile) base64Encoded]]. > source := (suffix = 'Data' ifTrue: > [dataTemplate] ifFalse: [formTemplate]) > format: {selector . (local > allButLast: 4) . directory . stringContent }. > self class compile: source > classified: methodCategory] > + displayingProgress: [:local | 'Generating {1}' > translated format: {local}]].! > - displayingProgress: [:local | 'Generating ', > local]].! > > Item was removed: > - ----- Method: StrikeFont class>>localeChanged (in category 'font > creation') ----- > - localeChanged > - self setupDefaultFallbackFont! > > Item was added: > + ----- Method: StrikeFont class>>passwordFont (in category 'instance > creation') ----- > + passwordFont > + > + ^ self passwordFontPointSize: TextStyle defaultFont pointSize! > > Item was added: > + ----- Method: StrikeFont class>>passwordFontPointSize: (in category > 'instance creation') ----- > + passwordFontPointSize: pointSize > + > + ^ FixedFaceFont new passwordFont fontPointSize: pointSize! > > Item was changed: > + ----- Method: StrikeFont>>basicHasGlyphOf: (in category 'private') ----- > - ----- Method: StrikeFont>>basicHasGlyphOf: (in category 'multibyte > character methods') ----- > basicHasGlyphOf: aCharacter > > ^ self hasGlyphForCode: (self codeForCharacter: aCharacter) > ! > > Item was added: > + ----- Method: StrikeFont>>closeHtmlOn: (in category 'html') ----- > + closeHtmlOn: aStream > + > + aStream nextPutAll: '</font>'.! > > Item was changed: > ----- Method: StrikeFont>>fallbackFont (in category 'accessing') ----- > fallbackFont > + "Overwritten to add a cache." > + > + ^ fallbackFont ifNil: [fallbackFont := super fallbackFont]! > - "Answers the fallbackFont for the receiver. The fallback font must > be some derivative of the receiver since it will not be asked to install > itself properly on the target BitBlt so rendering a completely different > font here is simply not possible. The default implementation uses a > synthetic font that maps all characters to question marks." > - ^ fallbackFont > - ifNil: [fallbackFont := FixedFaceFont new errorFont > baseFont: self]! > > Item was added: > + ----- Method: StrikeFont>>formOf: (in category 'private') ----- > + formOf: aCharacter > + "Like #characterFormAt: but checks for #hasGlyphOf: and supports > #fallbackFont." > + > + (self hasGlyphOf: aCharacter) > + ifFalse: [^ self fallbackFont formOf: aCharacter]. > + > + ^ self characterFormAt: aCharacter! > > Item was changed: > + ----- Method: StrikeFont>>glyphOf: (in category 'private') ----- > - ----- Method: StrikeFont>>glyphOf: (in category 'accessing') ----- > glyphOf: aCharacter > - "Answer the width of the argument as a character in the receiver." > > + self flag: #deprecated. > + ^ self formOf: aCharacter! > - | code | > - (self hasGlyphOf: aCharacter) ifFalse: [ > - fallbackFont ifNotNil: [ > - ^ fallbackFont glyphOf: aCharacter. > - ]. > - ^ (Form extent: 1 at self height) fillColor: Color white > - ]. > - code := self codeForCharacter: aCharacter. > - ^ glyphs copy: (((xTable at: code + 1)@0) corner: (xTable at: code > +2)@self height). > - ! > > Item was changed: > + ----- Method: StrikeFont>>hasGlyphForCode: (in category 'private') ----- > - ----- Method: StrikeFont>>hasGlyphForCode: (in category 'multibyte > character methods') ----- > hasGlyphForCode: aCharacterCode > + "Note that missing glyphs are encoded as -1 in the xTable but to > speed up the #widthOf: check, the next offset must be adjacent and thus be > duplicated. For example: #(-1 -1 0 24 -1 -1 -1 24 48 -1 ...). Since > aCharacterCode is 0-based, that codes offset is at +1 while its width needs > to consult +2, too. See #widthOf:." > > + (aCharacterCode between: self minAscii and: self maxAscii) > + ifFalse: [^ false]. > + (xTable at: aCharacterCode + 1) >= 0 > + ifFalse: [^ false]. > + (xTable at: aCharacterCode + 2) >= 0 > + ifFalse: [^ false]. > + ^ true! > - ((aCharacterCode between: self minAscii and: self maxAscii) not) > ifTrue: [ > - ^ false. > - ]. > - (xTable at: aCharacterCode + 1) < 0 ifTrue: [ > - ^ false. > - ]. > - ^ true. > - ! > > Item was added: > + ----- Method: StrikeFont>>lineGap (in category 'accessing') ----- > + lineGap > + "Historical. The #lineGap has been 2 pixels for all fonts in the > system for a very long time. Since the #referenceHeight is 14 pixels, use > that to compute a #lineGap relative to the receivers #pointSize/#pixelSize. > Also see TTCFont >> #lineGap." > + > + ^ lineGap ifNil: [lineGap := ((self height asFloat / self class > referenceHeight) * 2 "pixels") rounded]! > > Item was added: > + ----- Method: StrikeFont>>lineGapSlice (in category 'accessing') ----- > + lineGapSlice > + "Cached portion of the receiver's #lineGap, which can be used to > center one-liners in text fields. Also see TTCFont >> #lineGapSlice." > + > + ^ lineGapSlice ifNil: [lineGapSlice := (self lineGap asFloat / 2) > rounded]! > > Item was removed: > - ----- Method: StrikeFont>>lineGrid (in category 'accessing') ----- > - lineGrid > - ^ ascent + descent! > > Item was removed: > - ----- Method: StrikeFont>>maxAscii (in category 'accessing') ----- > - maxAscii > - "Answer the integer that is the last Ascii character value of the > receiver." > - > - ^maxAscii! > > Item was added: > + ----- Method: StrikeFont>>maxCodePoint (in category 'accessing') ----- > + maxCodePoint > + "Overwritten to configure ranges of glyphs per pre-rendered font." > + > + ^maxAscii! > > Item was removed: > - ----- Method: StrikeFont>>minAscii (in category 'accessing') ----- > - minAscii > - "Answer the integer that is the first Ascii character value of the > receiver." > - > - ^minAscii! > > Item was added: > + ----- Method: StrikeFont>>minCodePoint (in category 'accessing') ----- > + minCodePoint > + "Overwritten to configure ranges of glyphs per pre-rendered font." > + > + ^minAscii! > > Item was changed: > ----- Method: StrikeFont>>newFromStrike: (in category 'file in/out') > ----- > newFromStrike: fileName > "Build an instance from the strike font file name. The '.strike' > extension > is optional." > > | strike startName raster16 | > name := fileName copyUpTo: $.. "assumes extension (if any) is > '.strike'" > strike := FileStream readOnlyFileNamed: name, '.strike.'. > strike binary. > > "strip off direcory name if any" > startName := name size. > [startName > 0 and: [((name at: startName) ~= $>) & ((name at: > startName) ~= $])]] > whileTrue: [startName := startName - 1]. > name := name copyFrom: startName+1 to: name size. > > type := strike nextWord. > "type is ignored now -- simplest > > assumed. Kept here to make > > writing and consistency more > > straightforward." > minAscii := strike nextWord. > maxAscii := strike nextWord. > maxWidth := strike nextWord. > strikeLength := strike nextWord. > ascent := strike nextWord. > descent := strike nextWord. > "xOffset :=" strike nextWord. > > raster16 := strike nextWord. > > superscript := ascent - descent // 3. > subscript := descent - ascent // 3. > emphasis := 0. > glyphs := Form extent: (raster16 * 16) @ > (self height) > offset: 0 at 0. > glyphs bits fromByteStream: strike. > > xTable := (Array new: maxAscii + 3) atAllPut: 0. > (minAscii + 1 to: maxAscii + 3) do: > [:index | xTable at: index put: strike nextWord]. > > "Set up space character" > ((xTable at: (Space asciiValue + 2)) = 0 or: > [(xTable at: (Space asciiValue + 2)) = (xTable at: > (Space asciiValue + 1))]) > ifTrue: [(Space asciiValue + 2) to: xTable size do: > + [:index | xTable at: index put: > ((xTable at: index) + 4 "DefaultSpace")]]. > - [:index | xTable at: index put: > ((xTable at: index) + DefaultSpace)]]. > strike close. > characterToGlyphMap := nil.! > > Item was added: > + ----- Method: StrikeFont>>openHtmlOn: (in category 'html') ----- > + openHtmlOn: aStream > + > + aStream > + nextPutAll: '<font face="'; > + nextPutAll: self familyName; > + nextPutAll: '" size="'; > + nextPutAll: self pointSize asString; > + nextPutAll: '">'.! > > Item was added: > + ----- Method: StrikeFont>>pixelSize (in category 'accessing') ----- > + pixelSize > + "Overwritten because the receiver is pre-rendered using a fixed > pixels-per-inch (PPI) value, usually 96 PPI. Note that you can change the > #pointSize to match 96 PPI (see TextStyle class >> #pixelsPerInch) as > follows: > + > + self pointSize: ((72 * self pixelSize / 96) roundTo: 0.5). > + self derivativeFonts do: [:d | d pointSize: font pointSize]. > + > + Note that a line gap (similar to a TTCFont's #lineGap) for > pre-rendered fonts is managed via TextStyle's #lineGrid. > + > + Also see StrikeFont class >> #referenceHeight." > + > + ^ self height! > > Item was changed: > ----- Method: StrikeFont>>postCopy (in category 'copying') ----- > postCopy > + "The receiver is a just created shallow copy. This method gives it > the final touch." > + > + glyphs := glyphs copy. > + xTable := xTable copy. > + characterToGlyphMap := characterToGlyphMap copy. > + derivativeFonts := derivativeFonts copy. > + > + self reset. " takes care of the derivative fonts "! > - " the receiver is a just created shallow copy. This method gives it the > final touch. " > - > - glyphs := glyphs copy. > - xTable := xTable copy. > - characterToGlyphMap := characterToGlyphMap copy. > - > - self reset. " takes care of the derivative fonts "! > > Item was changed: > ----- Method: StrikeFont>>printOn: (in category 'file in/out') ----- > printOn: aStream > + > super printOn: aStream. > + > + aStream nextPut: $(. > + self printShortDescriptionOn: aStream. > + aStream nextPut: $).! > - aStream > - nextPut: $(; > - nextPutAll: self name; > - space; > - print: self height; > - nextPut: $)! > > Item was changed: > ----- Method: StrikeFont>>printShortDescriptionOn: (in category > 'printing') ----- > printShortDescriptionOn: aStream > + > + aStream > + nextPutAll: self familyName; > + space; print: self pointSize; nextPutAll: 'pt'; > + space; print: self pixelsPerInch; nextPutAll: 'ppi'; > + space; print: self height; nextPutAll: 'px'; > + space; nextPutAll: self emphasisString.! > - aStream space; nextPutAll: self name! > > Item was changed: > ----- Method: StrikeFont>>readFromStrike2Stream: (in category 'file > in/out') ----- > readFromStrike2Stream: file > "Build an instance from the supplied binary stream on data in > strike2 format" > type := file nextInt32. type = 2 ifFalse: [file close. self > error: 'not strike2 format']. > minAscii := file nextInt32. > maxAscii := file nextInt32. > maxWidth := file nextInt32. > ascent := file nextInt32. > descent := file nextInt32. > pointSize := file nextInt32. > superscript := ascent - descent // 3. > subscript := descent - ascent // 3. > emphasis := file nextInt32. > xTable := (Array new: maxAscii + 3) atAllPut: 0. > (minAscii + 1 to: maxAscii + 3) do: > [:index | xTable at: index put: file nextInt32]. > glyphs := Form new readFrom: file. > > "Set up space character" > ((xTable at: (Space asciiValue + 2)) = 0 or: > [(xTable at: (Space asciiValue + 2)) = (xTable at: > (Space asciiValue + 1))]) > ifTrue: [(Space asciiValue + 2) to: xTable size do: > + [:index | xTable at: index put: > ((xTable at: index) + 4 "DefaultSpace")]]. > - [:index | xTable at: index put: > ((xTable at: index) + DefaultSpace)]]. > characterToGlyphMap := nil.! > > Item was changed: > ----- Method: StrikeFont>>reset (in category 'emphasis') ----- > reset > "Reset the cache of derivative emphasized fonts" > > + lineGap := lineGapSlice := nil. > + > fallbackFont class = FixedFaceFont > ifTrue: [fallbackFont := nil]. > > derivativeFonts notNil ifTrue: [ > derivativeFonts withIndexDo: [ :f :i | > (f notNil and: [f isSynthetic]) ifTrue: > [derivativeFonts at: i put: nil]]]. > " > derivativeFonts := Array new: 32. > #('B' 'I' 'BI') doWithIndex: > [:tag :index | > (style := TextStyle named: self familyName) ifNotNil: > [(font := style fontArray > detect: [:each | each name = (self name , > tag)] > ifNone: [nil]) ifNotNil: [derivativeFonts > at: index put: font]]] > "! > > Item was removed: > - ----- Method: StrikeFont>>setupDefaultFallbackFont (in category > 'emphasis') ----- > - setupDefaultFallbackFont > - "This used to be the default textstyle, but it needs to be a > StrikeFont and not a TTCFont and sometimes the default textstyle is a > TTCFont. So, we use a typical StrikeFont as the default fallback font." > - self fallbackFont: (StrikeFont defaultSized: self height). > - self reset. > - > - ! > > Item was changed: > ----- Method: StrikeFont>>textStyle (in category 'accessing') ----- > textStyle > + "Overwritten to not create a new style for orphaned fonts." > + > + ^ self textStyleOrNil! > - ^ TextStyle actualTextStyles detect: > - [:aStyle | aStyle fontArray includes: self] ifNone: [nil]! > > Item was changed: > ----- Method: TextComposer>>addNullLineWithIndex:andRectangle: (in > category 'private') ----- > addNullLineWithIndex: index andRectangle: r > + "TextEditor has emphasisHere, which encodes the emphasis of future > input. We don't have that info here. Therefore we just use the height of > the last text line if there is any." > + > - > lines addLast: ( > ( > TextLine > start: index > stop: index - 1 > internalSpaces: 0 > paddingWidth: 0 > ) > rectangle: r; > + lineHeight: (lines > + ifEmpty: [defaultLineHeight] > + ifNotEmpty: [lines last lineHeight]) > + baseline: (lines > + ifEmpty: [theTextStyle baseline] > + ifNotEmpty: [lines last baseline]) > - lineHeight: defaultLineHeight baseline: > theTextStyle baseline > ) > ! > > Item was changed: > ----- Method: TextComposer>>composeAllRectangles: (in category > 'private') ----- > composeAllRectangles: rectangles > > | charIndexBeforeLine numberOfLinesBefore reasonForStopping | > > + actualHeight := 0. > - actualHeight := defaultLineHeight. > charIndexBeforeLine := currCharIndex. > numberOfLinesBefore := lines size. > reasonForStopping := self composeEachRectangleIn: rectangles. > > currentY := currentY + actualHeight. > currentY > theContainer bottom ifTrue: [ > "Oops -- the line is really too high to fit -- back out" > currCharIndex := charIndexBeforeLine. > lines size - numberOfLinesBefore timesRepeat: [lines > removeLast]. > ^self > ]. > > "It's OK -- the line still fits." > maxRightX := maxRightX max: scanner rightX. > 1 to: rectangles size - 1 do: [ :i | |lineIndex| > "Adjust heights across rectangles if necessary" > lineIndex:=lines size - rectangles size + i. > (lines size between: 1 and: lineIndex) ifTrue: > [(lines at: lineIndex) > lineHeight: lines last lineHeight > baseline: lines last baseline] > ]. > isFirstLine := false. > reasonForStopping == #columnBreak ifTrue: [^nil]. > currCharIndex > theText size ifTrue: [ > ^nil "we are finished composing" > ]. > ! > > Item was changed: > ----- Method: TextComposer>>composeEachRectangleIn: (in category > 'private') ----- > composeEachRectangleIn: rectangles > > | myLine lastChar | > > 1 to: rectangles size do: [:i | > currCharIndex <= theText size ifFalse: [^false]. > myLine := scanner > composeFrom: currCharIndex > inRectangle: (rectangles at: i) > > firstLine: isFirstLine > leftSide: i=1 > rightSide: i=rectangles size. > lines addLast: myLine. > + myLine moveByTopMargin. > + actualHeight := actualHeight max: myLine > lineHeightWithMargins. "includes font changes and text style's > #lineSpacing" > - actualHeight := actualHeight max: myLine lineHeight. > "includes font changes" > currCharIndex := myLine last + 1. > lastChar := theText at: myLine last. > (CharacterSet crlf includes: lastChar) ifTrue: [^#cr]. > wantsColumnBreaks ifTrue: [ > lastChar = Character characterForColumnBreak > ifTrue: [^#columnBreak]. > ]. > ]. > ^false! > > Item was changed: > Object subclass: #TextLine > + instanceVariableNames: 'left right top bottom firstIndex lastIndex > internalSpaces paddingWidth baseline leftMargin topMargin bottomMargin' > - instanceVariableNames: 'left right top bottom firstIndex lastIndex > internalSpaces paddingWidth baseline leftMargin' > classVariableNames: '' > poolDictionaries: 'TextConstants' > category: 'Graphics-Text'! > > !TextLine commentStamp: '<historical>' prior: 0! > A TextLine embodies the layout of a line of composed text. > left right top bottom The full line rectangle > firstIndex lastIndex Starting and stopping indices in > the full text > internalSpaces Number of spaces to share paddingWidth > paddingWidth Number of pixels of extra space in full > line > baseline Distance of baseline below > the top of the line > leftMargin Left margin due to paragraph > indentation > TextLine's rather verbose message protocol is required for compatibility > with the old CharacterScanners.! > > Item was added: > + ----- Method: TextLine>>bottomMargin (in category 'accessing') ----- > + bottomMargin > + > + ^ bottomMargin! > > Item was added: > + ----- Method: TextLine>>lineHeightWithMargins (in category 'accessing') > ----- > + lineHeightWithMargins > + > + ^ bottom - top + topMargin + bottomMargin! > > Item was added: > + ----- Method: TextLine>>moveByTopMargin (in category 'updating') ----- > + moveByTopMargin > + > + top := top + topMargin. > + bottom := bottom + topMargin. > + ! > > Item was added: > + ----- Method: TextLine>>topMargin (in category 'accessing') ----- > + topMargin > + > + ^ topMargin! > > Item was added: > + ----- Method: TextLine>>topMargin:bottomMargin: (in category 'private') > ----- > + topMargin: tm bottomMargin: bm > + topMargin := tm. > + bottomMargin := bm.! > > Item was changed: > Object subclass: #TextStyle > + instanceVariableNames: 'fontArray alignment firstIndent restIndent > rightIndent tabsArray marginTabsArray defaultFontIndex lineSpacing' > + classVariableNames: 'NumSpacesPerTab' > - instanceVariableNames: 'fontArray fontFamilySize lineGrid baseline > alignment firstIndent restIndent rightIndent tabsArray marginTabsArray > leading defaultFontIndex' > - classVariableNames: '' > poolDictionaries: 'TextConstants' > category: 'Graphics-Text'! > > + !TextStyle commentStamp: 'mt 2/21/2022 10:55' prior: 0! > + A text style comprises the formatting information for composing and > displaying a unit (usually a paragraph) of text. It provides a #defaultFont > to use, but text attributes can change that per character (see > CompositionScanner and DisplayScanner). It also has a default #alignment > that attributes can override. Those defaults make it possible to compose > and display (unformatted) strings in paragraphs without having to style > them first as texts (i.e., string+attributes). > - !TextStyle commentStamp: '<historical>' prior: 0! > - A textStyle comprises the formatting information for composing and > displaying a unit (usually a paragraph) of text. Typically one makes a > copy of a master textStyle (such as TextStyle default), and then that copy > may get altered in the process of editing. Bad things can happen if you do > not copy first. > > + NOTE THAT for each use you *must* make a copy of a font's master text > style (e.g., "TextStyle default copy") or create a fresh one with at least > a single font (see TextStyle class >> #fontArray: and AbstractFont >> > #asNewTextStyle). That specific instance is typically altered in the > process of editing: change default font size, change default alignment, ... > and you wouldn't want to change that properties for other applications by > accident. > - Each of my instances consists of... > - fontArray An array of StrikeFonts > - fontFamilySize unused > - lineGrid An integer; default line spacing > for paragraphs > - baseline An integer; default baseline (dist > from line top to bottom of an 'a') > - alignment An integer; text alignment, see TextStyle > alignment: > - firstIndent An integer; indent of first line in pixels > - restIndent An integer; indent of remaining lines in > pixels > - rightIndent An integer; indent of right margin rel to > section > - tabsArray An array of integers giving tab offsets in > pixels > - marginTabsArray An array of margin tabs > - leading An integer giving default vertical line > separation > > + A text style also drives the interpretation of Character tab. Both > tabsArray and marginTabsArray are initialized for the #defaultFont(Index:). > When you change a style's default font size, those "tab positions" will be > recomputed for fast access during composition. See the preference > #numSpacesPerTab(:). > + > + While each text style looks like it could handle an arbitrary array of > fonts, it is *best practice* to only store fonts of the same font family. A > font's master style thus collects all known point sizes at a single place > (i.e. "TextStyle named: aFamilyName"). Copies will share that array. The > attribute TextFontChange makes it possible to switch to any index in that > array, but this is not portable and hence discouraged. TextFontReference > adds an explicit reference to font, which is also not good. (February 2022: > We plan to add TextFont(Point)Size and TextFontFamily as a portable way to > change the font per character.). > + > + There are some legacy information, which should no longer be used: > + - #baseline: ... used to prescribe baseline info but is now > completely derived from #defaultFont > + - #lineGrid: ... same as #baseLine: > + - #leading(:) ... is replaced by #lineSpacing(:) and denotes the > extra spacing relative to the respective line's height in the composition > + > + The #lineSpacing is noticeable in a paragraph's text selection. Line > spacing < 0.0 will appear as overlaps between (translucent) selection > rectangles. Lince spacing > 0.0 will appear as gaps between selection > rectangles. > + > + Here are some example styles to explore: > + - TextStyle default > + - TextStyle defaultFixes! > - For a concrete example, look at TextStyle default copy inspect! > > Item was changed: > ----- Method: TextStyle class>>actualTextStyles (in category > 'TextConstants access') ----- > actualTextStyles > | aDict | > "TextStyle actualTextStyles" > > "Answer dictionary whose keys are the names of styles in the > system and whose values are the actual styles" > > aDict := TextConstants select: [:thang | thang isKindOf: self ]. > + self defaultFamilyNames do: [ :sym | aDict removeKey: sym > ifAbsent: [] ]. > - self defaultFamilyNames do: [ :sym | aDict removeKey: sym ]. > ^ aDict! > > Item was changed: > ----- Method: TextStyle class>>defaultFamilyNames (in category > 'TextConstants access') ----- > defaultFamilyNames > + ^#(DefaultTextStyle DefaultFixedTextStyle DefaultMultiStyle > DefaultFallbackTextStyle)! > - ^#(DefaultTextStyle DefaultFixedTextStyle DefaultMultiStyle)! > > Item was added: > + ----- Method: TextStyle class>>defaultTT (in category 'constants') ----- > + defaultTT > + "Answer the default TrueType text style." > + > + ^ self default isTTCStyle > + ifTrue: [self default] > + ifFalse: [self named: #BitstreamVeraSans]! > > Item was added: > + ----- Method: TextStyle class>>defaultTTFont (in category 'constants') > ----- > + defaultTTFont > + > + ^ self defaultTT defaultFont! > > Item was changed: > ----- Method: TextStyle class>>fontSizeSummaryContents (in category > 'utilities') ----- > fontSizeSummaryContents > > + ^ Text streamContents: [:aStream | > + | knownStyles knownTTCStyles knownLegacyStyles > defaultStyles printBlock | > + knownStyles := self knownTextStylesWithoutDefault > sorted. > + defaultStyles := self defaultFamilyNames sorted. > + > + aStream nextPutAll: ('This page lists all known > text styles and for each style''s font the available point sizes. Most text > fields offer the {1} where you can choose a different font or point size. > Note that you can use any new point size for TrueType fonts. This is, > however, not possible for our pre-rendred legacy fonts. If you need more > fonts, use the {2} to import TrueType fonts from your current platform. > Click {3} to browse all styles by example.\\' > + translated withCRs asText format: { > + 'FontChooserTool' asText > + addAttribute: > (PluggableTextAttribute evalBlock: [FontChooserTool open]); yourself. > + 'FontImporterTool' asText > + addAttribute: > (PluggableTextAttribute evalBlock: [FontImporterTool open]); yourself. > + 'here' asText > + addAttribute: > (PluggableTextAttribute evalBlock: [TextStyle browseAllStyles])}). > + > + defaultStyles do: [:styleName | > + | style prefix | > + style := self named: styleName. > + prefix := (style isNil or: [(self named: > style defaultFamilyName) == style]) ifTrue: [''] ifFalse: [' !! ']. > + aStream > + nextPutAll: (((styleName padded: > #left to: 24 with: Character space), ': ', prefix) asText addAttribute: > (TextFontReference toFont: TextStyle defaultFixedFont); yourself); > + nextPutAll: (style ifNil: ['-'] > ifNotNil: [(style defaultFamilyName asText addAttribute: (TextFontReference > toFont: style defaultFont); addAttribute: (PluggableTextAttribute > evalBlock: [style explore]); yourself)]); > + cr]. > + > + printBlock := [:styleName | > + | style defaultFont > preferredPointSize exampleFont | > + style := self named: styleName. > + preferredPointSize := TextStyle > defaultFont pointSize. "system's current default" > + defaultFont := style defaultFont. > "style's current default" > + exampleFont := defaultFont > isSymbolFont > + ifTrue: [TextStyle > defaultFont "famiyl name should be legible"] > + ifFalse: [defaultFont > asPointSize: preferredPointSize]. > + aStream > + nextPutAll: (styleName > asText addAttribute: (TextFontReference toFont: exampleFont)). > + styleName ~= style > defaultFamilyName ifTrue: ["style alias" > + aStream nextPutAll: ' (', > style defaultFamilyName, ')']. > + aStream > + nextPutAll: ((Text new, > + ((style isTTCStyle > ifFalse: [''] ifTrue: [' TrueType', (defaultFont isRemoteFont ifFalse: [''] > ifTrue: [' (remote)']), (defaultFont isSymbolFont ifFalse: [''] ifTrue: [' > (symbols)'])]) > + asText > addAttribute: (TextColor color: ((self userInterfaceTheme get: > #balloonTextColor for: #PluggableTextMorphPlus) ifNil: [Color gray])); > yourself), > + (style isTTCStyle > ifFalse: [''] ifTrue: [ | eg | > + ' ... ' > asText, > + ((' ', > (defaultFont extraGlyphScale * 100) rounded asString, '%') asText > addAttribute: (PluggableTextAttribute evalBlock: [style chooseExtraScale]); > yourself), > + ((' ', > ((eg := defaultFont extraLineGap) >= 0 ifTrue: ['+', eg asString] ifFalse: > [eg asString])) asText addAttribute: (PluggableTextAttribute evalBlock: > [style chooseExtraGap]); yourself) ]), > + ' ... ', > + ('explore' > translated asText addAttribute: (PluggableTextAttribute evalBlock: [style > explore]); yourself), > + ' ', > + ('browse' > translated asText addAttribute: (PluggableTextAttribute evalBlock: > [defaultFont browseAllGlyphs; browseAllGlyphsByCategory]); yourself), > + > + ' ') > addAttribute: (TextFontReference toFont: Preferences standardButtonFont); > yourself); > + cr. > + aStream nextPutAll: (((self > fontPointSizesFor: styleName) inject: ' ' asText into: [:text :pointSize > | > + pointSize = > defaultFont pointSize > + ifFalse: > [text, ((pointSize asFloat printShowingDecimalPlaces: 1) padded: #left to: > 5 with: Character space)] > + ifTrue: > [text, (((pointSize asFloat printShowingDecimalPlaces: 1) padded: #left to: > 5 with: Character space) asText addAttribute: TextEmphasis bold; > yourself)]]) addAttribute: (TextFontReference toFont: TextStyle > defaultFixedFont); yourself). > + aStream cr; cr]. > + > + knownTTCStyles := knownStyles select: [:ea | (self > named: ea) isTTCStyle]. > + knownLegacyStyles := knownStyles reject: [:ea | > (self named: ea) isTTCStyle]. > + > + aStream cr. > + knownTTCStyles do: printBlock. > + aStream nextPutAll: ('The following pre-rendered > legacy fonts are still available. Note that you can only choose from the > point sizes that are listed here. Each point size has a pixel size for 96 > PPI. The system scales currently for {1} PPI.' translated format: > {TextStyle pixelsPerInch}) ; cr; cr. > + knownLegacyStyles do: printBlock. > + ].! > - ^ Text streamContents: > - [:aStream | > - self knownTextStyles do: [:aStyleName | > - aStream nextPutAll: > - (aStyleName asText addAttribute: > (TextFontReference toFont: (TextStyle named: aStyleName) defaultFont)), ' > ', > - (self fontPointSizesFor: > aStyleName) asArray storeString. > - aStream cr]].! > > Item was removed: > - ----- Method: TextStyle class>>new (in category 'instance creation') > ----- > - new > - ^ super new leading: 2! > > Item was added: > + ----- Method: TextStyle class>>numSpacesPerTab (in category > 'preferences') ----- > + numSpacesPerTab > + <preference: 'Tab width (i.e., number of spaces)' > + categoryList: #(tools visuals Accessibility) > + description: 'Amount of spaces to be used when calculating > the width of a tab character for a specific font face and point size.' > + type: #Number> > + ^ NumSpacesPerTab ifNil: [6]! > > Item was added: > + ----- Method: TextStyle class>>numSpacesPerTab: (in category > 'preferences') ----- > + numSpacesPerTab: anInteger > + > + anInteger = NumSpacesPerTab ifTrue: [^ self]. > + NumSpacesPerTab := anInteger ifNotNil: [anInteger truncated max: > 1]. > + TextStyle allInstancesDo: [:ea | ea initializeTabsArray]. > + > + "Avoid dependency to Morphic project..." > + (self environment classNamed: #TextMorph) > + ifNotNil: [:tmClass | tmClass allSubInstancesDo: [:tm | > + tm releaseParagraph; changed]].! > > Item was changed: > ----- Method: TextStyle class>>pixelsPerInch: (in category 'utilities') > ----- > pixelsPerInch: aNumber > "Set the nominal number of pixels per inch to aNumber." > + > + self pixelsPerInch = aNumber ifTrue: [^ self]. > + TextConstants at: #pixelsPerInch put: aNumber. > - TextConstants at: #pixelsPerInch put: aNumber asFloat. > AbstractFont allSubInstancesDo: [ :font | font > pixelsPerInchChanged ]. > + TextStyle allInstancesDo: [ :style | style pixelsPerInchChanged ].! > - Display restore.! > > Item was added: > + ----- Method: TextStyle class>>referenceHeight (in category 'utilities') > ----- > + referenceHeight > + "See commentary in RealEstateAgent class >> #scaleFactor." > + > + ^ self default isTTCStyle > + ifTrue: [self pointsToPixels: TTCFont referencePointSize] > + ifFalse: [self defaultFont height]! > > Item was changed: > + ----- Method: TextStyle>>baseline (in category 'accessing - default > font') ----- > - ----- Method: TextStyle>>baseline (in category 'accessing') ----- > baseline > "Answer the distance from the top of the line to the bottom of > most of the > characters (by convention, bottom of the letter 'A')." > > + ^ self defaultFont ascent! > - ^baseline! > > Item was changed: > + ----- Method: TextStyle>>baseline: (in category 'accessing - default > font') ----- > - ----- Method: TextStyle>>baseline: (in category 'accessing') ----- > baseline: anInteger > - "Set the distance from the top of the line to the bottom of most > of the > - characters." > > + self flag: #deprecated. "Either change #defaultFont in this style > or use custom fonts via text attributes."! > - baseline := anInteger! > > Item was changed: > ----- Method: TextStyle>>consistOnlyOf: (in category 'fonts and font > indexes') ----- > consistOnlyOf: aFont > + > + self deprecated. > + ^ self newFontArray: {aFont}! > - fontArray := Array with: aFont. > - defaultFontIndex := 1! > > Item was added: > + ----- Method: TextStyle>>defaultFamilyName (in category 'accessing - > default font') ----- > + defaultFamilyName > + ^ self defaultFont familyName! > > Item was changed: > + ----- Method: TextStyle>>defaultFont (in category 'accessing - default > font') ----- > - ----- Method: TextStyle>>defaultFont (in category 'accessing') ----- > defaultFont > ^ fontArray at: self defaultFontIndex! > > Item was changed: > + ----- Method: TextStyle>>defaultFontIndex (in category 'accessing - > default font') ----- > - ----- Method: TextStyle>>defaultFontIndex (in category 'default font') > ----- > defaultFontIndex > ^ defaultFontIndex ifNil: [defaultFontIndex := 1]! > > Item was changed: > + ----- Method: TextStyle>>defaultFontIndex: (in category 'accessing - > default font') ----- > - ----- Method: TextStyle>>defaultFontIndex: (in category 'default font') > ----- > defaultFontIndex: anIndex > + > + defaultFontIndex := anIndex. > + self initializeTabsArray.! > - defaultFontIndex := anIndex! > > Item was changed: > ----- Method: TextStyle>>gridForFont:withLead: (in category 'private') > ----- > gridForFont: fontIndex withLead: leadInteger > "Force whole style to suit one of its fonts. Assumes only one font > referred > to by runs." > + > + self flag: #deprecated. > + self defaultFontIndex: fontIndex.! > - | font | > - font := self fontAt: fontIndex. > - self lineGrid: font height + leadInteger. > - self baseline: font ascent. > - self leading: leadInteger! > > Item was added: > + ----- Method: TextStyle>>initializeTabsArray (in category > 'initialize-release') ----- > + initializeTabsArray > + > + | fontToUse numSpacesPerTab tabWidth maxWidth | > + self flag: #discuss. "mt: Add cache per font and pointSize? Maybe > it is not worth it..." > + > + numSpacesPerTab := self class numSpacesPerTab. > + fontToUse := self defaultFont. > + maxWidth := Display width max: 3840. > + tabWidth := ((fontToUse widthOf: Character space) max: 1 "For tiny > point sizes...") * numSpacesPerTab. > + > + "Note that using Interval via #to:by: and #asArray would be about > 4x slower." > + tabsArray := Array new: maxWidth // tabWidth. > + 1 to: tabsArray size do: [:i | tabsArray at: i put: tabWidth * i]. > + > + marginTabsArray := Array new: (maxWidth // tabWidth) // 2. > + 1 to: marginTabsArray size do: [:i | | offset | > + marginTabsArray at: i put: (Array with: (offset := > tabWidth * i) with: offset)].! > > Item was changed: > + ----- Method: TextStyle>>leading (in category 'accessing - default > font') ----- > - ----- Method: TextStyle>>leading (in category 'accessing') ----- > leading > "Leading (from typographers historical use of extra lead (type > metal)) > is the extra spacing above and beyond that needed just to > accomodate > the various font heights in the set." > + > + self flag: #deprecated. "mt: Fonts provide their #lineGap (and > #lineGapSlice) in the CompositionScanner to accommodate various font > heights in a set. Use #lineSpacing to define a factor that moves the lines > further apart." > + ^ 0! > - ^ leading! > > Item was changed: > + ----- Method: TextStyle>>leading: (in category 'accessing - default > font') ----- > - ----- Method: TextStyle>>leading: (in category 'accessing') ----- > leading: yDelta > > + self flag: #deprecated. "See commentary in #leading."! > - leading := yDelta! > > Item was changed: > + ----- Method: TextStyle>>lineGrid (in category 'accessing - default > font') ----- > - ----- Method: TextStyle>>lineGrid (in category 'accessing') ----- > lineGrid > "Answer the relative space between lines of a paragraph in the > style of > the receiver." > > + ^ self defaultFont lineGrid! > - ^lineGrid! > > Item was changed: > + ----- Method: TextStyle>>lineGrid: (in category 'accessing - default > font') ----- > - ----- Method: TextStyle>>lineGrid: (in category 'accessing') ----- > lineGrid: anInteger > - "Set the relative space between lines of a paragraph in the style > of the > - receiver to be the argument, anInteger." > > + self flag: #deprecated. "Either change #defaultFont in this style > or use custom fonts via text attributes."! > - lineGrid := anInteger! > > Item was added: > + ----- Method: TextStyle>>lineSpacing (in category 'accessing') ----- > + lineSpacing > + "Answer the factor that is used to compute extra spacing between > text lines. The default is 0.0, which means that the CompositionScanner > will just rely on the various font metrics in a line. There will be 0% of > extra spacing. Use the current line height as blank space with a factor of > 1.0 and so on (i.e. the common misnomer 'double line space')." > + > + ^ lineSpacing ifNil: [0.0]! > > Item was added: > + ----- Method: TextStyle>>lineSpacing: (in category 'accessing') ----- > + lineSpacing: aFactor > + > + lineSpacing := aFactor.! > > Item was changed: > ----- Method: TextStyle>>newFontArray: (in category 'private') ----- > newFontArray: anArray > "Currently there is no supporting protocol for changing these > arrays. If an editor wishes to implement margin setting, then a copy of the > default should be stored with these instance variables. > , Make size depend on first font." > > fontArray := anArray. > + self defaultFontIndex: 1. > - lineGrid := (fontArray at: 1) height + leading. "For whole family" > - baseline := (fontArray at: 1) ascent + leading. > alignment := 0. > firstIndent := 0. > restIndent := 0. > rightIndent := 0. > - tabsArray := DefaultTabsArray. > - marginTabsArray := DefaultMarginTabsArray > " > TextStyle allInstancesDo: [:ts | ts newFontArray: TextStyle default > fontArray]. > "! > > Item was added: > + ----- Method: TextStyle>>pixelsPerInchChanged (in category > 'notifications') ----- > + pixelsPerInchChanged > + > + self reset.! > > Item was changed: > ----- Method: TextStyle>>printOn: (in category 'printing') ----- > printOn: aStream > > super printOn: aStream. > + aStream nextPut: $(. > + aStream print: fontArray size. > + aStream nextPut: $). > + aStream space. > + self defaultFont printShortDescriptionOn: aStream. > - self defaultFont printShortDescriptionOn: aStream > ! > > Item was added: > + ----- Method: TextStyle>>reset (in category 'initialize-release') ----- > + reset > + "Reset values cached from the receiver's default font." > + > + self defaultFontIndex: self defaultFontIndex.! > > Item was changed: > ----- Method: TextStyle>>tabWidth (in category 'tabs and margins') ----- > tabWidth > "Answer the width of a tab." > > + ^ tabsArray at: 1 ifAbsent: [24]! > - ^DefaultTab! > > Item was changed: > + ----- Method: TranslucentColor>>isOpaque (in category 'testing') ----- > - ----- Method: TranslucentColor>>isOpaque (in category 'queries') ----- > isOpaque > ^alpha = 255! > > Item was changed: > + ----- Method: TranslucentColor>>isTranslucent (in category 'testing') > ----- > - ----- Method: TranslucentColor>>isTranslucent (in category 'queries') > ----- > isTranslucent > ^ alpha < 255! > > Item was changed: > + ----- Method: TranslucentColor>>isTranslucentColor (in category > 'testing') ----- > - ----- Method: TranslucentColor>>isTranslucentColor (in category > 'queries') ----- > isTranslucentColor > "This means: self isTranslucent, but isTransparent not" > ^ alpha > 0! > > Item was changed: > + ----- Method: TranslucentColor>>isTransparent (in category 'testing') > ----- > - ----- Method: TranslucentColor>>isTransparent (in category 'queries') > ----- > isTransparent > ^ alpha = 0! > > Item was added: > + ----- Method: TranslucentColor>>printOn: (in category 'printing') ----- > + printOn: aStream > + | name | > + self isTransparent ifTrue: [^ aStream nextPutAll: 'Color > transparent']. > + (name := self asNontranslucentColor name) ifNil: [^self storeOn: > aStream]. > + aStream > + nextPutAll: '(Color '; > + nextPutAll: name; > + nextPutAll: ' alpha: '; > + print: self alpha maxDecimalPlaces: 3; > + nextPut: $) > + ! > > Item was changed: > ----- Method: TranslucentColor>>storeOn: (in category 'printing') ----- > storeOn: aStream > > + self isTransparent ifTrue: [^ aStream nextPutAll: 'Color > transparent']. > - self isTransparent ifTrue: [^ aStream nextPutAll: '(Color > transparent)']. > super storeOn: aStream. > aStream > skip: -1; "get rid of trailing )" > nextPutAll: ' alpha: '; > print: self alpha maxDecimalPlaces: 3; > nextPutAll: ')'. > ! > > Item was changed: > + (PackageInfo named: 'Graphics') postscript: '"Compute the correct tab > widths per style using its current default font." > + TextStyle allInstancesDo: [:ea | ea initializeTabsArray].'! > - (PackageInfo named: 'Graphics') postscript: 'Smalltalk > removeFromStartUpList: DisplayScreen. "see Project class >> #startUp" > - Smalltalk removeFromShutDownList: DisplayScreen. "see Project class >> > #shutDown"'! > > > > -------------- next part -------------- An HTML attachment was scrubbed... URL: <http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20220306/1fd09f09/attachment-0001.html>
More information about the Squeak-dev mailing list |