Squeak-dev March 2022

squeak-dev@lists.squeakfoundation.org

33 participants
304 discussions

The Trunk: Multilingual-mt.265.mcz
by commits＠source.squeak.org 08 Mar '22

08 Mar '22

Marcel Taeumel uploaded a new version of Multilingual to project The Trunk: http://source.squeak.org/trunk/Multilingual-mt.265.mcz ==================== Summary ==================== Name: Multilingual-mt.265 Author: mt Time: 8 March 2022, 4:46:32.314437 pm UUID: 73f40056-c2a2-3e4b-8d3a-9a1d7595945d Ancestors: Multilingual-mt.263 Fixes Latin-1 ByteString encoding for ShiftJISTextConverter. =============== Diff against Multilingual-mt.263 =============== Item was added: + ----- Method: ShiftJISTextConverter class>>initializeLatin1MapAndEncodings (in category 'class initialization') ----- + initializeLatin1MapAndEncodings + "Initialize the latin1Map and latin1Encodings. + These variables ensure that conversions from latin1 ByteString is reasonably fast." + + latin1Map := ByteArray new: 256 withAll: 1. + latin1Encodings := Array new: 256 withAll: nil. + + 0 to: 127 do: [:i | latin1Map at: i+1 put: 0]. + latin1Map at: 16r5C + 1 put: 1. "$\ ... cannot be encoded" + latin1Map at: 16r7E + 1 put: 1. "$~ ... cannot be encoded" + + latin1Encodings at: 16rA5 "YEN SIGN" + 1 put: { 16r5C } asByteArray asString.! Item was changed: ----- Method: ShiftJISTextConverter>>nextFromStream: (in category 'conversion') ----- nextFromStream: aStream | character1 character2 value1 value2 char1Value result | aStream isBinary ifTrue: [^ aStream basicNext]. character1 := aStream basicNext. character1 isNil ifTrue: [^ nil]. char1Value := character1 asciiValue. + (char1Value < 16r81) ifTrue: [ + char1Value = 16r5C "$\" ifTrue: [^ 16rA5 "YEN SIGN"]. + char1Value = 16r7E "$~" ifTrue: [^ Character leadingChar: self leadingChar code: 16r203E "OVERLINE"]. + ^ character1]. - (char1Value < 16r81) ifTrue: [^ character1]. (char1Value > 16rA0 and: [char1Value < 16rE0]) ifTrue: [^ self katakanaValue: char1Value]. character2 := aStream basicNext. character2 = nil ifTrue: [^ nil "self errorMalformedInput"]. value1 := character1 asciiValue. character1 asciiValue >= 224 ifTrue: [value1 := value1 - 64]. value1 := value1 - 129 bitShift: 1. value2 := character2 asciiValue. character2 asciiValue >= 128 ifTrue: [value2 := value2 - 1]. character2 asciiValue >= 158 ifTrue: [ value1 := value1 + 1. value2 := value2 - 158 ] ifFalse: [value2 := value2 - 64]. result := Character leadingChar: self leadingChar code: value1 * 94 + value2. ^ self toUnicode: result ! Item was changed: ----- Method: ShiftJISTextConverter>>nextPut:toStream: (in category 'conversion') ----- nextPut: aCharacter toStream: aStream | charCode leadingChar aChar | aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream]. aChar := aCharacter. charCode := aCharacter charCode. aChar isTraditionalDomestic ifFalse: [ (16rFF61 <= charCode and: [charCode <= 16rFF9F]) ifTrue: [ ^aStream basicNextPut: (self sjisKatakanaFor: charCode) ]. + aChar := (JISX0208 charFromUnicode: charCode) ifNil: [ - aChar := (JISX0208 charFromUnicode: charCode) ifNil: [ ^aCharacter "an error or nil may be better" ]. charCode := aChar charCode ]. + charCode = 16r203E "OVERLINE" ifTrue: [ + aStream basicNextPut: $~. "16r7E" + ^ aChar]. (leadingChar := aChar leadingChar) = 0 ifTrue: [ charCode < 256 ifTrue: [ (latin1Encodings at: charCode + 1) + ifNil: [ (latin1Map at: charCode + 1) = 0 "Really no translation needed." + ifTrue: [ aStream basicNextPut: aChar ] + ifFalse: [ UndefinedConversion signalFor: charCode toEncoding: self ] ] - ifNil: [ aStream basicNextPut: aChar ] ifNotNil: [ :encodedString | aStream basicNextPutAll: encodedString ]. ^aChar ]. ^aStream basicNextPut: aChar ]. leadingChar = self leadingChar ifTrue: [ | upper lower | upper := charCode // 94 + 33. lower := charCode \\ 94 + 33. upper \\ 2 = 1 ifTrue: [ upper := upper + 1 / 2 + 112. lower := lower + 31 ] ifFalse: [ upper := upper / 2 + 112. lower := lower + 125 ]. upper >= 160 ifTrue: [upper := upper + 64]. lower >= 127 ifTrue: [lower := lower + 1]. aStream basicNextPut: (Character value: upper); basicNextPut: (Character value: lower) ]. ^aChar ! Item was changed: + (PackageInfo named: 'Multilingual') postscript: 'ShiftJISTextConverter initializeLatin1MapAndEncodings.'! - (PackageInfo named: 'Multilingual') postscript: 'LanguageEnvironment clearDefault. - HandMorph clearInterpreters.'!

1 0

The Trunk: Graphics-nice.492.mcz
by commits＠source.squeak.org 08 Mar '22

08 Mar '22

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 TrueType fonts. Your requested scale factor of {1}% looks better using pre-rendered pixel fonts.\\Do you want to switch to pixel fonts now?' translated withCRs format: {(aFloat * 100) rounded}) withNoLineLongerThan: 60) copyReplaceAll: String cr with: ' ') 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@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@y Returns the abstract Color at this location displayAt: x@y shows this form on the screen displayOn: aMedium at: x@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@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@self readWord. "Image Left@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@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@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@10 into: [ :ex :m | - m left: 10. - ex max: m width @ m bottom - ] - ) + (20@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@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@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@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@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@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@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@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@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: ''.! 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@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@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: ''.! 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"'!

4 4

The Trunk: Morphic-mt.1928.mcz
by commits＠source.squeak.org 07 Mar '22

07 Mar '22

Marcel Taeumel uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-mt.1928.mcz ==================== Summary ==================== Name: Morphic-mt.1928 Author: mt Time: 7 March 2022, 11:32:59.261569 am UUID: b744f763-6518-bf43-8ffb-3324ea8141c3 Ancestors: Morphic-mt.1927 In the font chooser, inform the user why a custom point size is not available for pre-rendered fonts. Thanks to Lauren (lrnp) for the tip! =============== Diff against Morphic-mt.1927 =============== Item was changed: ----- Method: FontChooserTool>>selectedFont (in category 'font list') ----- selectedFont "Generate missing pointSIze only if TrueType font." | style | ^ (style := self selectedTextStyle) isTTCStyle ifTrue: [ style fontArray size = 1 "Font not yet installed..." ifTrue: [style defaultFont] ifFalse: [TTCFont familyName: self selectedFontFamily pointSize: pointSize emphasized: emphasis]] ifFalse: [ | font | font := (style fontOfPointSize: pointSize) emphasized: emphasis. + pointSize ~= font pointSize ifTrue: [ + self inform: ('The point size you requested is not available for this pre-rendered font. Please choose a TrueType font, where you can add custom point sizes.' translated withNoLineLongerThan: 45). + pointSize := font pointSize]. - pointSize := font pointSize. "Can be different for StrikeFont." self changed: #selectedPointSizeIndex. font]!

1 0

The Trunk: TrueType-mt.85.mcz
by commits＠source.squeak.org 07 Mar '22

07 Mar '22

Marcel Taeumel uploaded a new version of TrueType to project The Trunk: http://source.squeak.org/trunk/TrueType-mt.85.mcz ==================== Summary ==================== Name: TrueType-mt.85 Author: mt Time: 7 March 2022, 11:21:05.458334 am UUID: 07fedf8c-3448-7d4d-9ef2-1c8f78da250c Ancestors: TrueType-mt.84 When listing all the font that can be found in a platform, ignore hidden/cache files, that is, the ones starting with a dot (e.g., '.SomeFont.ttf'). =============== Diff against TrueType-mt.84 =============== Item was changed: ----- Method: TTFontFileHandle class>>allHandlesFromFontPaths: (in category 'instance creation') ----- allHandlesFromFontPaths: somePaths ^ self allHandlesFromFontFileNames: (Array streamContents: [:fileNames | somePaths do: [:path | | fileDirectory | fileDirectory := FileDirectory on: path. (fileDirectory fileNamesMatching: self fileNamePattern) do: [:baseName | + (baseName first ~= $.) ifTrue: [ "No cache files from macOS or Linux" + fileNames nextPut: (fileDirectory fullNameFor: baseName)]] ]]) - fileNames nextPut: (fileDirectory fullNameFor: baseName)]]]) !

1 0

The Trunk: Morphic-mt.1927.mcz
by commits＠source.squeak.org 07 Mar '22

07 Mar '22

Marcel Taeumel uploaded a new version of Morphic to project The Trunk: http://source.squeak.org/trunk/Morphic-mt.1927.mcz ==================== Summary ==================== Name: Morphic-mt.1927 Author: mt Time: 7 March 2022, 11:16:21.167204 am UUID: c193033d-9ac4-4f4e-a26d-9d0875cdb34e Ancestors: Morphic-mt.1926 FontImporterTool: - Select the default TrueType font when opening the tool - Rely on #selectedFont never being 'nil' - Auto-select parent when collapsing a subtree of subfamilies in font tree on the left. =============== Diff against Morphic-mt.1926 =============== Item was changed: ----- Method: FontImporterTool>>currentSelection: (in category 'font list/tree') ----- currentSelection: fontHandleOrNil + fontHandleOrNil = currentSelection ifTrue: [ + ^ self]. - fontHandleOrNil = currentSelection ifTrue: [^ self]. - currentSelection := fontHandleOrNil. - self changed: #currentSelection. fontHandleOrNil + ifNil: [ + "User probably collapsed subtree with prior selection." + self selectTextStyleNamed: self selectedFont textStyleName] + ifNotNil: [ + currentSelection := fontHandleOrNil. + self changed: #currentSelection]. + + fontHandleOrNil ifNotNil: [self editModeEnabled: self currentSelection isModified]. + self selectedFont: nil. "Refresh preview" + + ! - self selectedFont: nil. "Refresh preview"! Item was changed: ----- Method: FontImporterTool>>initialize (in category 'initialize') ----- initialize super initialize. + previewTextSelector := #textSample. + self selectTextStyleNamed: self selectedFont textStyleName.! - previewTextSelector := #textSample.! Item was changed: ----- Method: FontImporterTool>>previewText (in category 'preview text') ----- previewText "Answer the current preview text. Avoid using a text with font-reference attributes so that any not-yet-installed font does not get spreaded across the system. See #selectedFontTextStyle to learn how the preview is rendered using the selected font." - self selectedFont ifNil: [^ '']. self customPreviewText ifNotEmpty: [:text | ^ text withCRs]. previewTextSelector = #fontSample ifTrue: [ ^ self selectedFont ttcDescription sampleText ifEmpty: [self errorText: 'This font does not provide a sample text.' translated]]. (previewTextSelector ~= #textSample and: [self selectedFont isSymbolFont]) ifTrue: [^ self errorText: 'This symbol font does not support the preview text.\Please use ''Text/Symbol'' or type a custom text.' translated withCRs]. self selectedFont isSymbolFont ifTrue: [^ self selectedFont symbolSample asString]. (Text respondsTo: previewTextSelector) ifTrue: [^ (Text perform: previewTextSelector) asString]. previewTextSelector = #widgetSample ifTrue: [^ self widgetSample]. ^ ''! Item was added: + ----- Method: FontImporterTool>>selectTextStyleNamed: (in category 'initialize') ----- + selectTextStyleNamed: textStyleName + + currentSelection := (self allFonts detect: [:handle | handle textStyleName = self selectedFont textStyleName]). + self changed: #currentSelection.! Item was changed: ----- Method: FontImporterTool>>selectedFont (in category 'accessing') ----- selectedFont ^ selectedFont ifNil: [selectedFont := self currentSelection + ifNil: [TextStyle defaultTTFont] - ifNil: [TextStyle defaultFont] ifNotNil: [:o | o fontOfPointSize: self pointSize] ]! Item was changed: ----- Method: FontImporterTool>>selectedFontTextStyle (in category 'accessing') ----- selectedFontTextStyle "Construct a new text style from the #selectedFont." + ^( self currentSelection + ifNil: [TextStyle defaultTT copy] + ifNotNil: [:handle | handle textStyleOfPointSize: self pointSize]) + lineSpacing: ((lineSpacing isNil and: [self selectedFont isSymbolFont]) + ifTrue: [ 0.3 ] + ifFalse: [ self lineSpacing ]); + yourself - ^ (TextStyle fontArray: {self selectedFont}) - lineSpacing: ((lineSpacing isNil and: [self selectedFont isSymbolFont]) - ifTrue: [ 0.3 ] - ifFalse: [ self lineSpacing ]); - yourself ! Item was changed: ----- Method: FontImporterTool>>windowTitle (in category 'ui - building') ----- windowTitle + ^ 'Font Importer: ', self selectedFont familyName! - ^ 'Font Importer', (self currentSelection - ifNil: [''] - ifNotNil: [:desc | ': ', desc familyName])!

1 0

The Trunk: TrueType-mt.84.mcz
by commits＠source.squeak.org 07 Mar '22

07 Mar '22

Marcel Taeumel uploaded a new version of TrueType to project The Trunk: http://source.squeak.org/trunk/TrueType-mt.84.mcz ==================== Summary ==================== Name: TrueType-mt.84 Author: mt Time: 7 March 2022, 11:13:42.347204 am UUID: 07a880d0-6d11-f74c-bc4e-67073a745788 Ancestors: TrueType-mt.83 In font-file handles, complement #font(OfPointSize:) protocol with the usual #textStyle(OfPointSize:) to simplify font preview without installation. =============== Diff against TrueType-mt.83 =============== Item was added: + ----- Method: TTFontFileHandle>>textStyle (in category 'building') ----- + textStyle + "Always create a new font array with a single font to force a specific emphasis in the text where this style will be used." + + ^ TextStyle fontArray: {self font}! Item was added: + ----- Method: TTFontFileHandle>>textStyleOfPointSize: (in category 'building') ----- + textStyleOfPointSize: aPointSize + + ^ TextStyle fontArray: {self fontOfPointSize: aPointSize}!

1 0

The Trunk: Graphics-mt.493.mcz
by commits＠source.squeak.org 07 Mar '22

07 Mar '22

Marcel Taeumel uploaded a new version of Graphics to project The Trunk: http://source.squeak.org/trunk/Graphics-mt.493.mcz ==================== Summary ==================== Name: Graphics-mt.493 Author: mt Time: 7 March 2022, 11:09:49.561204 am UUID: 58a6b0c1-fb17-ba45-86e2-01d6e48c6b2f Ancestors: Graphics-nice.492 Adds #subfamilyName as domain-specific (i.e., the font domain, not Squeak Graphics) variant of #emphasisString. =============== Diff against Graphics-nice.492 =============== Item was added: + ----- Method: AbstractFont>>subfamilyName (in category 'accessing') ----- + subfamilyName + + ^ self emphasisString!

1 0

The Trunk: ToolBuilder-Morphic-mt.306.mcz
by commits＠source.squeak.org 07 Mar '22

07 Mar '22

Marcel Taeumel uploaded a new version of ToolBuilder-Morphic to project The Trunk: http://source.squeak.org/trunk/ToolBuilder-Morphic-mt.306.mcz ==================== Summary ==================== Name: ToolBuilder-Morphic-mt.306 Author: mt Time: 7 March 2022, 11:07:26.542204 am UUID: 5e5f1a8d-a149-6f47-9106-dd98754da77f Ancestors: ToolBuilder-Morphic-mt.305 Fixes the issue where a custom #textStyle was not installed in a pluggable text field after being constructed via ToolBuilder. Note that I think that we need a better strategy for extending pluggable widgets regarding their initialization. All #[get|set]*Selector(:) things are direct instVar-access only, relying on the initializer/constructor to fetch model data for the first time. See :#on:... methods, e.g., in PluggableTextMorph. So, I put that change in MorphicToolBuilder for now while it might be better placed directly in PluggableTextMorph. =============== Diff against ToolBuilder-Morphic-mt.305 =============== Item was changed: ----- Method: MorphicToolBuilder>>buildPluggableText: (in category 'widgets required') ----- buildPluggableText: aSpec | widget | widget := self textPaneClass new. aSpec stylerClass ifNotNil: [:c | widget styler: (c new view: widget)]. widget on: aSpec model text: aSpec getText accept: aSpec setText readSelection: aSpec selection menu: aSpec menu. aSpec textStyle ifNotNil: [:ts | ts isSymbol + ifTrue: [widget getTextStyleSelector: ts; update: ts] - ifTrue: [widget getTextStyleSelector: ts] ifFalse: [widget setTextStyle: ts]] ifNil: [ aSpec font ifNotNil: [:f | f isSymbol ifTrue: [widget getFontSelector: f] ifFalse: [widget setTextStyle: f asNewTextStyle]] ]. widget readOnly: aSpec readOnly. widget plainTextOnly: aSpec plainTextOnly. widget editTextSelector: aSpec editText. widget wantsFrameAdornments: aSpec indicateUnacceptedChanges. widget askBeforeDiscardingEdits: aSpec askBeforeDiscardingEdits. widget setProperty: #alwaysAccept toValue: aSpec askBeforeDiscardingEdits not. widget wrapFlag: (aSpec softLineWrap ifNil: [true]). self register: widget id: aSpec name. widget getColorSelector: aSpec color. widget getTextColorSelector: aSpec textColor. self buildHelpFor: widget spec: aSpec. self setFrame: aSpec frame in: widget. self setLayoutHintsForTextField: widget spec: aSpec. parent ifNotNil:[self add: widget to: parent]. ^widget!

1 0

The Trunk: Graphics-nice.442.mcz
by commits＠source.squeak.org 06 Mar '22

06 Mar '22

Nicolas Cellier uploaded a new version of Graphics to project The Trunk: http://source.squeak.org/trunk/Graphics-nice.442.mcz ==================== Summary ==================== Name: Graphics-nice.442 Author: nice Time: 27 December 2020, 7:10:51.749858 pm UUID: 969b2f75-ff78-444b-a4ff-ec3fd6cd931b Ancestors: Graphics-mt.441 Provide comment and named accessors for new alpha BitBlt compositing combination rules. Those new rules are described here: https://github.com/OpenSmalltalk/opensmalltalk-vm/issues/505 They require a new VM, or at least a new BitBlt plugin posterior to VMMaker.oscog-nice.2909 =============== Diff against Graphics-mt.441 =============== Item was changed: Object subclass: #BitBlt instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight colorMap' classVariableNames: 'CachedFontColorMaps ColorConvertingMaps SubPixelRenderColorFonts SubPixelRenderFonts' poolDictionaries: '' category: 'Graphics-Primitives'! + !BitBlt commentStamp: 'nice 12/27/2020 16:53' prior: 0! - !BitBlt commentStamp: 'tpr 9/17/2013 15:42' prior: 0! WARNING: BitBlt's shape cannot be modified since WarpBlt relies on the exact layout. Important primitives will break if you fail to heed this warning. I represent a block transfer (BLT) of pixels from one Form ( the sourceForm) into a rectangle (destX, destY, width, height) of the destinationForm, as modified by a combination rule, a possible halftoneForm and a possible color map. The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or the halftoneForm, or both. If both are specified, their pixel values are combined by a logical AND function prior to any further combination rule processing. The halftoneForm may be an actual Form or a simple WordArray of 32 bit values usually intended to represent Color values. In either case the 'top' of the form is effectively aligned with the top of the destinationForm and for each scanline the destination y modulo the size of the halftoneForm gives the index of the word to use. This makes it easy to make horizontal stripes, for example. In any case, the pixels from the source (AND'd with the halftone, remember) are combined with those of the destination by as specified by the combinationRules below- name rule result 0 always 0 and 1 src AND dst 2 src AND not(dst) over 3 src only erase 4 not(src) AND& dst 5 dst only reverse 6 src XOR dst under 7 src OR dst 8 not(src) AND not(dst) 9 not(src) XOR dst 10 not(dst) 11 src OR not(dst) 12 not(src) 13 not(src) OR dst 14 not(src) OR not(dst) 15 always 1 (You can find an interesting explanation of how this comes to be in http://dev-docs.atariforge.org/files/BLiTTER_1-25-1990.pdf - which interestingly fails to mention any connection to Smalltalk and PARC.) Forms may be of different depths, see the comment in class Form. In addition to the original 16 combination rules invented for monochrome Forms, this BitBlt supports 16 fails (to simulate paint bits) 17 fails (to simulate erase bits) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord. Sum of color components 21 rgbSub: sourceWord with: destinationWord. Difference of color components 22 OLDrgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components 23 OLDtallyIntoMap: destinationWord. Tallies pixValues into a colorMap these old versions don't do bitwise dest clipping. Use 32 and 33 now. blend 24 alphaBlend: sourceWord with: destinationWord. 32-bit source and dest only. Blend sourceWord with destinationWord, assuming both are 32-bit pixels. The source is assumed to have 255*alpha in the high 8 bits of each pixel, while the high 8 bits of the destinationWord will be ignored. The blend produced is alpha*source + (1-alpha)*dest, with the computation being performed independently on each color component. The high byte of the result will be 0. paint 25 pixPaint: sourceWord with: destinationWord. Wherever the sourceForm is non-zero, it replaces the destination. Can be used with a 1-bit source color mapped to (0, FFFFFFFF), and a fillColor to fill the dest with that color wherever the source is 1. erase1BitShape 26 pixMask: sourceWord with: destinationWord. Like pixPaint, but fills with 0. 27 rgbMax: sourceWord with: destinationWord. Max of each color component. 28 rgbMin: sourceWord with: destinationWord. Min of each color component. 29 rgbMin: sourceWord bitInvert32 with: destinationWord. Min with (max-source) blendAlpha 30 alphaBlendConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. Blend sourceWord with destinationWord using a constant alpha. Alpha is encoded as 0 meaning 0.0, and 255 meaning 1.0. The blend produced is alpha*source + (1.0-alpha)*dest, with the computation being performed independently on each color component. paintAlpha 31 alphaPaintConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. 32 rgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components 33 tallyIntoMap: destinationWord. Tallies pixValues into a colorMap - Those tallied are exactly those in the destination rectangle. Note that the source should be specified == destination, in order for the proper color map checks be performed at setup. blendAlphaScaled 34 alphaBlendScaled: srcWord with: dstWord. Alpha blend of scaled srcWord and destWord. In contrast to alphaBlend:with: the color produced is srcColor + (1-srcAlpha) * dstColor 35 & 36 not used rgbMul 37 rgbMul: srcWord with: dstWord. 38 pixSwap: srcWord with: dstWord. 39 pixClear: srcWord with: dstWord. Clear all pixels in destinationWord for which the pixels of sourceWord have the same values. Used to clear areas of some constant color to zero. 40 fixAlpha: srcWord with: dstWord. For any non-zero pixel value in destinationWord with zero alpha channel take the alpha from sourceWord and fill it in. Intended for fixing alpha channels left at zero during 16->32 bpp conversions. 41 rgbComponentAlpha: srcWord with: dstWord. + 42 alphaScale: srcWord with: dstWord. Pre-scale the destWord (i.e. multiply rgb components by alpha channel) + 43 alphaUncale: srcWord with: dstWord. Un-scale the destWord (i.e. divide rgb components by alpha channel) + 44 alphaBlendUnscaled: srcWord with: dstWord. Alpha blend of unscaled srcWord and destWord. + In contrast to alphaBlendScaled:with: the color produced is (srcAlpha*srcColor + (1-srcAlpha) * dstColor)/resultAlpha + where resultAlpha is srcAlpha + destAlpha*(1-srcAlpha) + This is equivalent to operations 42 + 34 + 43 (aphaScale, alphaBlendScaled, alphaUnscale) Any transfer specified is further clipped by the specified clipping rectangle (clipX, clipY, clipWidth, clipHeight), and also by the bounds of the source and destination forms. To make a small Form repeat and fill a big form, use an InfiniteForm as the source. Pixels copied from a source to a destination whose pixels have a different depth are converted based on the optional colorMap. If colorMap is nil, then conversion to more bits is done by filling the new high-order bits with zero, and conversion to fewer bits is done by truncating the lost high-order bits. The colorMap, if specified, must be a either word array (ie Bitmap) with 2^n elements, where n is the pixel depth of the source, or a fully specified ColorMap which may contain a lookup table (ie Bitmap) and/or four separate masks and shifts which are applied to the pixels. For every source pixel, BitBlt will first perform masking and shifting and then index the lookup table, and select the corresponding pixelValue and mask it to the destination pixel size before storing. When blitting from a 32 or 16 bit deep Form to one 8 bits or less, the default is truncation. This will produce very strange colors, since truncation of the high bits does not produce the nearest encoded color. Supply a 512 long colorMap, and red, green, and blue will be shifted down to 3 bits each, and mapped. The message copybits...stdColors will use the best map to the standard colors for destinations of depths 8, 4, 2 and 1. Two other sized of colorMaps are allowed, 4096 (4 bits per color) and 32786 (five bits per color). Normal blits between 16 and 32 bit forms truncates or pads the colors automatically to provide the best preservation of colors. Colors can be remapped at the same depth. Sometimes a Form is in terms of colors that are not the standard colors for this depth, for example in a GIF file. Convert the Form to a MaskedForm and send colorMap: the list of colors that the picture is in terms of. (Note also that a Form can be copied to itself, and transformed in the process, if a non-nil colorMap is supplied.)! Item was added: + ----- Method: Form class>>alphaScale (in category 'mode constants') ----- + alphaScale + "Answer the integer denoting BitBlt's pre-multiply rgb components by alpha (alphaScale) rule." + + ^ 42! Item was added: + ----- Method: Form class>>alphaUnscale (in category 'mode constants') ----- + alphaUnscale + "Answer the integer denoting BitBlt's post-multiply rgb components by alpha (alphaUnscale) rule." + + ^ 43! Item was added: + ----- Method: Form class>>blendAlphaUnscaled (in category 'mode constants') ----- + blendAlphaUnscaled + "Answer the integer denoting BitBlt's blend-with-alpha-unscaled rule." + + ^ 44!

1 0

[ANN] SyndicatedActors for Squeak
by Tony Garnock-Jones 05 Mar '22

05 Mar '22

Hi all, I'm pleased to announce the release of SyndicatedActors for Squeak. The announcement blog post is here: https://syndicate-lang.org/journal/2022/03/04/syndicated-actors-for-squeak At the moment there's little documentation (unlike my previous Actors package!). The primary client of the package at present is my work on getting a Squeak-based cellphone up and running. If you're interested in progress on that, please follow the project blog: - All posts tagged with #squeak-phone: https://syndicate-lang.org/journal/tag/squeak-phone/ - Atom feed for posts tagged with #squeak-phone: https://syndicate-lang.org/journal/tag/squeak-phone/index.atom and of course the general blog atom feed is https://syndicate-lang.org/journal/index.atom. Cheers, Tony

2 2

← Newer
1
...
24
25
26
27
28
29
30
31
Older →

Jump to page: