Packages July 2013

packages@lists.squeakfoundation.org

1 participants
522 discussions

The Trunk: Multilingual-fbs.163.mcz
by commits＠source.squeak.org 02 Jul '13

02 Jul '13

Frank Shearar uploaded a new version of Multilingual to project The Trunk: http://source.squeak.org/trunk/Multilingual-fbs.163.mcz ==================== Summary ==================== Name: Multilingual-fbs.163 Author: fbs Time: 2 July 2013, 8:21:22.262 pm UUID: 9f8b3b97-0255-d848-8146-56a618db9aa2 Ancestors: Multilingual-fbs.162 Break the Multilingual <-> TrueType cyclic dependency by moving TTC (TrueType Collection) classes to TrueType and FixedFaceFont to Graphics-Fonts (because this concerns displaying fonts). =============== Diff against Multilingual-fbs.162 =============== Item was removed: - AbstractFont subclass: #FixedFaceFont - instanceVariableNames: 'baseFont substitutionCharacter displaySelector' - classVariableNames: '' - poolDictionaries: '' - category: 'Multilingual-Display'! - - !FixedFaceFont commentStamp: 'tak 12/22/2004 01:45' prior: 0! - I am a font for special purpose like password or fallback. - I can show same form whenever someone requests any character. - - Variable displaySelector is future use to show a form dynamically. - (Although it would be unnecessary...)! Item was removed: - ----- Method: FixedFaceFont>>ascent (in category 'accessing') ----- - ascent - ^baseFont ascent! Item was removed: - ----- Method: FixedFaceFont>>ascentOf: (in category 'accessing') ----- - ascentOf: aCharacter - ^ self ascent! Item was removed: - ----- Method: FixedFaceFont>>baseFont (in category 'accessing') ----- - baseFont - ^baseFont! Item was removed: - ----- Method: FixedFaceFont>>baseFont: (in category 'accessing') ----- - baseFont: aFont - baseFont := aFont! Item was removed: - ----- Method: FixedFaceFont>>baseKern (in category 'accessing') ----- - baseKern - ^baseFont baseKern! Item was removed: - ----- Method: FixedFaceFont>>characterFormAt: (in category 'accessing') ----- - characterFormAt: character - ^ baseFont characterFormAt: substitutionCharacter! Item was removed: - ----- Method: FixedFaceFont>>descent (in category 'accessing') ----- - descent - ^baseFont descent! Item was removed: - ----- Method: FixedFaceFont>>descentKern (in category 'accessing') ----- - descentKern - ^baseFont descentKern! Item was removed: - ----- Method: FixedFaceFont>>descentOf: (in category 'accessing') ----- - descentOf: aCharacter - ^ self descent! Item was removed: - ----- Method: FixedFaceFont>>displayErrorOn:length:at:kern: (in category 'displaying') ----- - displayErrorOn: aCanvas length: length at: aPoint kern: kernDelta - | maskedString | - maskedString := String new: length. - maskedString atAllPut: substitutionCharacter. - ^ baseFont - displayString: maskedString - on: aCanvas - from: 1 - to: length - at: aPoint - kern: kernDelta! Item was removed: - ----- Method: FixedFaceFont>>displayErrorOn:length:at:kern:baselineY: (in category 'displaying') ----- - displayErrorOn: aCanvas length: length at: aPoint kern: kernDelta baselineY: baselineY - | maskedString | - maskedString := String new: length. - maskedString atAllPut: substitutionCharacter. - ^ baseFont - displayString: maskedString - on: aCanvas - from: 1 - to: length - at: aPoint - kern: kernDelta - baselineY: baselineY! Item was removed: - ----- Method: FixedFaceFont>>displayPasswordOn:length:at:kern: (in category 'displaying') ----- - displayPasswordOn: aCanvas length: length at: aPoint kern: kernDelta - | maskedString | - maskedString := String new: length. - maskedString atAllPut: substitutionCharacter. - ^ baseFont - displayString: maskedString - on: aCanvas - from: 1 - to: length - at: aPoint - kern: kernDelta! Item was removed: - ----- Method: FixedFaceFont>>displayPasswordOn:length:at:kern:baselineY: (in category 'displaying') ----- - displayPasswordOn: aCanvas length: length at: aPoint kern: kernDelta baselineY: baselineY - | maskedString | - maskedString := String new: length. - maskedString atAllPut: substitutionCharacter. - ^ baseFont - displayString: maskedString - on: aCanvas - from: 1 - to: length - at: aPoint - kern: kernDelta - baselineY: baselineY! Item was removed: - ----- Method: FixedFaceFont>>displayString:on:from:to:at:kern: (in category 'displaying') ----- - displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta - | size | - size := stopIndex - startIndex + 1. - ^ self perform: displaySelector withArguments: (Array with: aDisplayContext with: size with: aPoint with: kernDelta with: aPoint y + self ascent).! Item was removed: - ----- Method: FixedFaceFont>>displayString:on:from:to:at:kern:baselineY: (in category 'displaying') ----- - displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY - | size | - size := stopIndex - startIndex + 1. - ^ self perform: displaySelector withArguments: (Array with: aDisplayContext with: size with: aPoint with: kernDelta with: baselineY).! Item was removed: - ----- Method: FixedFaceFont>>displayString:on:from:to:at:kern:from: (in category 'displaying') ----- - displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont - | destPoint | - destPoint := self - displayString: aString - on: aBitBlt - from: startIndex - to: stopIndex - at: aPoint - kern: kernDelta. - ^ Array with: stopIndex + 1 with: destPoint! Item was removed: - ----- Method: FixedFaceFont>>displayString:on:from:to:at:kern:from:baselineY: (in category 'displaying') ----- - displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont baselineY: baselineY - | destPoint | - destPoint := self - displayString: aString - on: aBitBlt - from: startIndex - to: stopIndex - at: aPoint - kern: kernDelta - baselineY: baselineY. - ^destPoint! Item was removed: - ----- Method: FixedFaceFont>>emphasized: (in category 'accessing') ----- - emphasized: emph - ^self class new baseFont: (baseFont emphasized: emph)! Item was removed: - ----- Method: FixedFaceFont>>errorFont (in category 'initialize-release') ----- - errorFont - displaySelector := #displayErrorOn:length:at:kern:baselineY:. - substitutionCharacter := $?.! Item was removed: - ----- Method: FixedFaceFont>>familyName (in category 'accessing') ----- - familyName - ^baseFont familyName, '-pw'! Item was removed: - ----- Method: FixedFaceFont>>fontSize: (in category 'accessing') ----- - fontSize: aNumber - self baseFont: (StrikeFont familyName: baseFont familyName size: aNumber) copy! Item was removed: - ----- Method: FixedFaceFont>>glyphInfoOf:into: (in category 'private') ----- - glyphInfoOf: aCharacter into: glyphInfoArray - - ^ baseFont glyphInfoOf: substitutionCharacter into: glyphInfoArray. - ! Item was removed: - ----- Method: FixedFaceFont>>height (in category 'accessing') ----- - height - ^baseFont height! Item was removed: - ----- Method: FixedFaceFont>>initialize (in category 'initialize-release') ----- - initialize - "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>>installOn:foregroundColor:backgroundColor: (in category 'displaying') ----- - installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor - ^baseFont installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor! Item was removed: - ----- Method: FixedFaceFont>>lineGrid (in category 'accessing') ----- - lineGrid - ^baseFont lineGrid! Item was removed: - ----- Method: FixedFaceFont>>maxAscii (in category 'accessing') ----- - maxAscii - ^ SmallInteger maxVal! Item was removed: - ----- Method: FixedFaceFont>>passwordCharacter (in category 'accessing') ----- - passwordCharacter - ^$*! Item was removed: - ----- Method: FixedFaceFont>>passwordFont (in category 'initialize-release') ----- - passwordFont - displaySelector := #displayPasswordOn:length:at:kern:baselineY:. - substitutionCharacter := $*! Item was removed: - ----- Method: FixedFaceFont>>pointSize (in category 'accessing') ----- - pointSize - ^baseFont pointSize! Item was removed: - ----- Method: FixedFaceFont>>releaseCachedState (in category 'caching') ----- - releaseCachedState - baseFont releaseCachedState.! Item was removed: - ----- Method: FixedFaceFont>>widthOf: (in category 'measuring') ----- - widthOf: aCharacter - ^ baseFont widthOf: substitutionCharacter! Item was removed: - TTCFont subclass: #LinedTTCFont - instanceVariableNames: 'emphasis lineGlyph contourWidth' - classVariableNames: '' - poolDictionaries: '' - category: 'Multilingual-Display'! Item was removed: - ----- Method: LinedTTCFont class>>fromTTCFont:emphasis: (in category 'as yet unclassified') ----- - fromTTCFont: aTTCFont emphasis: code - - | inst | - inst := self new. - inst ttcDescription: aTTCFont ttcDescription. - inst pointSize: aTTCFont pointSize. - inst emphasis: (aTTCFont emphasis bitOr: code). - inst lineGlyph: (aTTCFont ttcDescription at: $_). - - ^ inst. - ! Item was removed: - ----- Method: LinedTTCFont>>computeForm: (in category 'as yet unclassified') ----- - computeForm: char - - | ttGlyph scale | - - char = Character tab ifTrue: [^ super computeForm: char]. - - "char = $U ifTrue: [self doOnlyOnce: [self halt]]." - scale := self pixelSize asFloat / (ttcDescription ascender - ttcDescription descender). - ttGlyph := ttcDescription at: char. - ^ ttGlyph asFormWithScale: scale ascender: ttcDescription ascender descender: ttcDescription descender fgColor: foregroundColor bgColor: Color transparent depth: self depth replaceColor: false lineGlyph: lineGlyph lingGlyphWidth: contourWidth emphasis: emphasis! Item was removed: - ----- Method: LinedTTCFont>>emphasis (in category 'as yet unclassified') ----- - emphasis - - ^ emphasis. - ! Item was removed: - ----- Method: LinedTTCFont>>emphasis: (in category 'as yet unclassified') ----- - emphasis: code - - emphasis := code. - ! Item was removed: - ----- Method: LinedTTCFont>>lineGlyph: (in category 'as yet unclassified') ----- - lineGlyph: aGlyph - - lineGlyph := aGlyph. - contourWidth := aGlyph calculateWidth. - ! Item was removed: - TTCFont subclass: #MultiTTCFont - instanceVariableNames: '' - classVariableNames: '' - poolDictionaries: '' - category: 'Multilingual-Display'! Item was removed: - ----- Method: MultiTTCFont class>>cacheAllNil (in category 'as yet unclassified') ----- - cacheAllNil - " - self cacheAllNil - " - self allInstances do: [:inst | - inst cache do: [:e | - e third ifNotNil: [^ false]. - ]. - ]. - - ^ true. - ! Item was removed: - ----- Method: MultiTTCFont>>access:at: (in category 'as yet unclassified') ----- - access: char at: index - - | wcache entry | - wcache := self cache. - entry := wcache at: index. - wcache replaceFrom: index to: wcache size - 1 with: wcache startingAt: index + 1. - wcache at: wcache size put: entry. - ! Item was removed: - ----- Method: MultiTTCFont>>at:put: (in category 'as yet unclassified') ----- - at: char put: form - - | wcache | - wcache := self cache. - wcache replaceFrom: 1 to: wcache size - 1 with: wcache startingAt: 2. - wcache at: wcache size - put: (Array with: char asciiValue with: foregroundColor with: form). - ^form - ! Item was removed: - ----- Method: MultiTTCFont>>formOf: (in category 'as yet unclassified') ----- - formOf: char - - | newForm | - self hasCached: char ifTrue: [:form :index | - self access: char at: index. - ^ form. - ]. - - newForm := self computeForm: char. - self at: char put: newForm. - ^ newForm. - ! Item was removed: - ----- Method: MultiTTCFont>>glyphInfoOf:into: (in category 'as yet unclassified') ----- - glyphInfoOf: char into: glyphInfoArray - - | newForm | - self hasCached: char ifTrue: [:form :index | - self access: char at: index. - glyphInfoArray at: 1 put: form; - at: 2 put: 0; - at: 3 put: form width; - at: 4 put: (self ascentOf: char); - at: 5 put: self. - ^ glyphInfoArray. - ]. - - newForm := self computeForm: char. - self at: char put: newForm. - - glyphInfoArray at: 1 put: newForm; - at: 2 put: 0; - at: 3 put: newForm width; - at: 4 put: (self ascentOf: char); - at: 5 put: self. - ^ glyphInfoArray. - ! Item was removed: - ----- Method: MultiTTCFont>>hasCached:ifTrue: (in category 'as yet unclassified') ----- - hasCached: char ifTrue: twoArgBlock - - | value elem | - value := char asciiValue. - - self cache size to: 1 by: -1 do: [:i | - elem := self cache at: i. - (elem first = value and: [elem second = foregroundColor]) ifTrue: [ - ^ twoArgBlock value: elem third value: i. - ]. - ]. - ^ false. - ! Item was removed: - ----- Method: MultiTTCFont>>isTTCFont (in category 'as yet unclassified') ----- - isTTCFont - ^true! Item was removed: - ----- Method: MultiTTCFont>>widthOf: (in category 'as yet unclassified') ----- - widthOf: char - - "This method cannot use #formOf: because formOf: discriminates the color and causes unnecessary bitmap creation." - - | newForm | - self hasCached: char ifTrue: [:form :index | - self access: char at: index. - ^ form width. - ]. - - newForm := self computeForm: char. - self at: char put: newForm. - ^ newForm width. - - ! Item was removed: - AbstractFont subclass: #TTCFont - instanceVariableNames: 'ttcDescription pointSize foregroundColor cache derivatives fallbackFont height ascent descent maxAscii colorToCacheMap' - classVariableNames: 'GlyphCacheData GlyphCacheIndex GlyphCacheReady GlyphCacheSize NamesToIndexes Registry Scale ShutdownList' - poolDictionaries: '' - category: 'Multilingual-Display'! - - !TTCFont commentStamp: 'nk 4/2/2004 11:32' prior: 0! - I represent a font that uses TrueType derived glyph. Upon a request for glyph for a character through a call to #formOf: (or #widthOf:), I first search corresponding glyph in the cache. If there is not, it creates a 32bit depth form with the glyph. - - The cache is weakly held. The entries are zapped at full GC. - - Structure: - ttcDescription TTFontDescription -- The Squeak data structure for a TrueType font data file. - pointSize Number -- Nominal Em size in points. Conversion to pixel sizes depends on the definition of TextStyle class>>pixelsPerInch. - foregroundColor Color -- So far, this font need to know the glyph color in cache. - cache WeakArray of <Color -> <Array(256) of glyph>> - derivatives Array -- stores the fonts in the same family but different emphasis. - ! Item was removed: - ----- Method: TTCFont class>>classVersion (in category 'objects from disk') ----- - classVersion - "Version 0 had pixelSize; version 1 changed it to pointSize" - ^1! Item was removed: - ----- Method: TTCFont class>>family:size: (in category 'instance creation') ----- - family: f size: s - - ^ self allInstances detect: [:a | a familyName = f and: [a pointSize = s]] ifNone: [nil]. - ! Item was removed: - ----- Method: TTCFont class>>familyName:pointSize:emphasis: (in category 'instance creation') ----- - familyName: n pointSize: s emphasis: code - - "(TTCFont familyName: 'BitstreamVeraSans' pointSize: 12 emphasis: 0)" - | t ret index | - t := self registry at: n asSymbol ifAbsent: [#()]. - t isEmpty ifTrue: [ - t := (TextConstants at: #DefaultTextStyle) fontArray. - ret := t first. - ret pointSize >= s ifTrue: [^ ret emphasis: code]. - index := 2. - [index <= t size and: [(t at: index) pointSize <= s]] whileTrue: [ - ret := t at: index. - index := index + 1. - ]. - ^ ret emphasis: code. - ]. - ^ ((TextStyle named: n) addNewFontSize: s) emphasis: code. - ! Item was removed: - ----- Method: TTCFont class>>fileReaderServicesForFile:suffix: (in category 'file list services') ----- - fileReaderServicesForFile: fullName suffix: suffix - ^(suffix = 'ttf') | (suffix = '*') - ifTrue: [ self services ] - ifFalse: [ #() ]! Item was removed: - ----- Method: TTCFont class>>getExistings: (in category 'instance creation') ----- - getExistings: fontArray - - | result em | - result := OrderedCollection new. - result add: fontArray. - 1 to: 3 do: [:i | - em := (fontArray collect: [:f | f emphasized: i]). - (em at: 1) ~= (fontArray at: 1) ifTrue: [ - result add: em. - ]. - ]. - ^ result asArray. - ! Item was removed: - ----- Method: TTCFont class>>initialize (in category 'class initialization') ----- - initialize - " - self initialize - " - - | tt | - self allSubInstancesDo:[:fnt| fnt flushCache]. - GlyphCacheSize := 512. - GlyphCacheData := Array new: GlyphCacheSize. - GlyphCacheIndex := 0. - GlyphCacheReady := true. - - tt := TTFontDescription default. - tt ifNotNil: [self newTextStyleFromTT: tt]. - FileServices registerFileReader: self. - - Smalltalk addToShutDownList: self.! Item was removed: - ----- Method: TTCFont class>>isCacheAllNil (in category 'other') ----- - isCacheAllNil - " - self cacheAllNil - " - self allInstances do: [:inst | - inst cache do: [:e | - e ifNotNil: [^ false]. - ]. - ]. - - ^ true. - ! Item was removed: - ----- Method: TTCFont class>>newTextStyleFromTT: (in category 'instance creation') ----- - newTextStyleFromTT: description - "Create a new TextStyle from specified TTFontDescription instance." - - | array | - array := self pointSizes collect: - [:pt | | f | - f := self new. - f ttcDescription: description. - f pointSize: pt]. - ^self reorganizeForNewFontArray: array name: array first name asSymbol! Item was removed: - ----- Method: TTCFont class>>newTextStyleFromTTFile: (in category 'instance creation') ----- - newTextStyleFromTTFile: fileName - "Create a new TextStyle from specified file name. On certain versions of Windows, you can evaluate following to get Arial font into the image. On other platforms, wait and see someone implements the support code for FontPlugin then we can start relying on the generic font lookup mechanism. - TTCFontReader encodingTag: 0. - self newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\symbol.TTF'. - " - - | description | - description := TTFontDescription addFromTTFile: fileName. - ^ self newTextStyleFromTT: description. - ! Item was removed: - ----- Method: TTCFont class>>newTextStyleFromTTStream: (in category 'instance creation') ----- - newTextStyleFromTTStream: readStream - " - " - - | description | - description := TTFontDescription addFromTTStream: readStream. - ^ self newTextStyleFromTT: description. - ! Item was removed: - ----- Method: TTCFont class>>pointSizes (in category 'other') ----- - pointSizes - - "The default sizes that are created when a TextStyle is created. You can add new sizes by the new-size feature." - ^ #(9 12 15 24 36). - ! Item was removed: - ----- Method: TTCFont class>>recreateCache (in category 'other') ----- - recreateCache - " - self recreateCache. - " - self allSubInstances do: [:inst | inst flushCache]. - Smalltalk garbageCollect. - ! Item was removed: - ----- Method: TTCFont class>>register:at: (in category 'other') ----- - register: anObject at: symbolName - - self registry at: symbolName put: anObject. - ! Item was removed: - ----- Method: TTCFont class>>registerAll (in category 'other') ----- - registerAll - " - TTCFont registerAll - " - - TextStyle allInstancesDo: [:e | - (e fontArray first isMemberOf: TTCFont) ifTrue: [ - self register: e fontArray at: e fontArray first familyName asSymbol. - ]. - ]. - ! Item was removed: - ----- Method: TTCFont class>>registry (in category 'other') ----- - registry - ^ Registry - ifNil: [Registry := IdentityDictionary new] - ! Item was removed: - ----- Method: TTCFont class>>removeAllDerivatives (in category 'other') ----- - removeAllDerivatives - " - self removeAllDerivatives - " - - self allInstances do: [:s | - s textStyle ifNotNil: [ - s textStyle fontArray do: [:f | - f derivativeFont: nil at: 0. - ]. - ]. - ]. - ! Item was removed: - ----- Method: TTCFont class>>removeStyleName: (in category 'other') ----- - removeStyleName: aString - - TextConstants removeKey: aString asSymbol ifAbsent: []. - TTFontDescription removeDescriptionNamed: aString asString. - ! Item was removed: - ----- Method: TTCFont class>>reorganizeForNewFontArray:name: (in category 'instance creation') ----- - reorganizeForNewFontArray: array name: styleName - - | style existings regular altName | - (TextConstants includesKey: styleName) ifFalse: [ - TextConstants at: styleName put: (TextStyle fontArray: array). - ^ TextConstants at: styleName. - ]. - - "There is a text style with the name I want to use. See if it is a TTC font..." - style := TextConstants at: styleName. - style isTTCStyle ifFalse: [ - altName := ((array at: 1) name, 'TT') asSymbol. - ^ self reorganizeForNewFontArray: array name: altName. - ]. - - existings := (self getExistings: style fontArray), (Array with: array). - regular := existings detect: [:e | (e at: 1) isRegular] ifNone: [existings at: 1]. - - regular do: [:r | - r addLined: r. - ]. - - "The existing array may be different in size than the new one." - existings do: [:e | - (e at: 1) isRegular ifFalse: [ - regular do: [ :r | | f | - f := e detect: [ :ea | ea pointSize = r pointSize ] ifNone: [ ]. - f ifNotNil: [ r derivativeFont: f ]. - ]. - ]. - ]. - - style newFontArray: regular. - self register: regular at: styleName. - self recreateCache. - ^ style. - ! Item was removed: - ----- Method: TTCFont class>>repairDerivativeFonts (in category 'other') ----- - repairDerivativeFonts - "Fix the cases where the derivatives are a different size than the originals." - - " - TTCFont repairDerivativeFonts. - " - self allInstancesDo: [ :font | font pointSize: font pointSize ]. - Preferences refreshFontSettings.! Item was removed: - ----- Method: TTCFont class>>serviceInstallTrueTypeFontStyle (in category 'file list services') ----- - serviceInstallTrueTypeFontStyle - "Return a service to install a true type font as a text style" - - ^ SimpleServiceEntry - provider: self - label: 'install ttf style' - selector: #newTextStyleFromTTFile: - description: 'install a true type font as a text style' - buttonLabel: 'install ttf'! Item was removed: - ----- Method: TTCFont class>>services (in category 'file list services') ----- - services - "Return a set of services for use in FileList" - - ^ Array with: self serviceInstallTrueTypeFontStyle! Item was removed: - ----- Method: TTCFont class>>shutDown (in category 'class initialization') ----- - shutDown - "Flush the glyph cache" - GlyphCacheData atAllPut: nil. - GlyphCacheIndex := 0. - ShutdownList ifNotNil:[ShutdownList do:[:fnt| fnt flushCache]]. - ShutdownList := WeakSet new. - ! Item was removed: - ----- Method: TTCFont class>>unload (in category 'class initialization') ----- - unload - - FileServices unregisterFileReader: self! Item was removed: - ----- Method: TTCFont class>>unregister: (in category 'other') ----- - unregister: symbolName - - self registry removeKey: symbolName ifAbsent: []. - ! Item was removed: - ----- Method: TTCFont class>>version (in category 'other') ----- - version - - ^ '6.0'. - ! Item was removed: - ----- Method: TTCFont>>addLined (in category 'private') ----- - addLined - - self addLined: self. - self derivativeFonts do: [:e | - e ifNotNil: [self addLined: e]. - ]. - ! Item was removed: - ----- Method: TTCFont>>addLined: (in category 'private') ----- - addLined: aTTCFont - - | l | - l := LinedTTCFont fromTTCFont: aTTCFont emphasis: 4. - self derivativeFont: l at: l emphasis. - - l := LinedTTCFont fromTTCFont: aTTCFont emphasis: 16. - self derivativeFont: l at: l emphasis. - - l := LinedTTCFont fromTTCFont: aTTCFont emphasis: 20. - self derivativeFont: l at: l emphasis. - ! Item was removed: - ----- Method: TTCFont>>ascent (in category 'accessing') ----- - ascent - ^ascent ifNil:[ascent := (ttcDescription typographicAscender * self pixelScale) truncated].! Item was removed: - ----- Method: TTCFont>>ascentOf: (in category 'accessing') ----- - ascentOf: aCharacter - - " (self hasGlyphFor: aCharacter) ifFalse: [ - fallbackFont ifNotNil: [ - ^ fallbackFont ascentOf: aCharacter. - ]. - ]. - " - ^ self ascent. - ! Item was removed: - ----- Method: TTCFont>>at:put: (in category 'private') ----- - at: char put: form - | assoc | - assoc := foregroundColor -> form. - GlyphCacheData at: (GlyphCacheIndex := GlyphCacheIndex \\ GlyphCacheSize + 1) put: assoc. - cache at: (char asInteger + 1) put: assoc. - ^form! Item was removed: - ----- Method: TTCFont>>cache (in category 'friend') ----- - cache - ^cache! Item was removed: - ----- Method: TTCFont>>characterFormAt: (in category 'character shapes') ----- - characterFormAt: character - "Answer a Form copied out of the glyphs for the argument, - character. Use a cached copy if possible." - - ^self formOf: character! Item was removed: - ----- Method: TTCFont>>closeHtmlOn: (in category 'html') ----- - closeHtmlOn: aStream - "put on the given stream the tag to close the html - representation of the receiver" - self htmlSize isZero - ifFalse: [aStream nextPutAll: '</font>']! Item was removed: - ----- Method: TTCFont>>computeForm: (in category 'private') ----- - computeForm: char - "Compute the glyph form for the given character" - ^ttcDescription renderGlyph: char height: self height fgColor: foregroundColor bgColor: Color transparent depth: self depth! Item was removed: - ----- Method: TTCFont>>convertToCurrentVersion:refStream: (in category 'objects from disk') ----- - convertToCurrentVersion: varDict refStream: smartRefStrm - "If we're reading in an old version with a pixelSize instance variable, convert it to a point size." - - "Deal with the change from pixelSize to pointSize, assuming the current monitor dpi." - varDict at: 'pixelSize' ifPresent: [ :x | - pointSize := (TextStyle pixelsToPoints: x) rounded. - ]. - ^super convertToCurrentVersion: varDict refStream: smartRefStrm.! Item was removed: - ----- Method: TTCFont>>copy (in category 'copying') ----- - copy - - ^ self. - ! Item was removed: - ----- Method: TTCFont>>deepCopy (in category 'copying') ----- - deepCopy - - ^ self. - ! Item was removed: - ----- Method: TTCFont>>depth (in category 'public') ----- - depth - - ^ 32. - ! Item was removed: - ----- Method: TTCFont>>derivativeFont: (in category 'friend') ----- - derivativeFont: aTTCFont - - | index | - index := self indexOfSubfamilyName: (aTTCFont subfamilyName). - index < 1 ifTrue: [ - ^ self "inform: 'unknown sub family name. This font will be skipped'". - ]. - - self derivativeFont: aTTCFont at: index. - - self addLined: aTTCFont. - ! Item was removed: - ----- Method: TTCFont>>derivativeFont:at: (in category 'friend') ----- - derivativeFont: aTTCFont at: index - - | newDeriv | - aTTCFont ifNil: [derivatives := nil. ^ self]. - derivatives ifNil: [derivatives := Array new: 32]. - derivatives size < 32 ifTrue: [ - newDeriv := Array new: 32. - newDeriv replaceFrom: 1 to: derivatives size with: derivatives. - derivatives := newDeriv. - ]. - derivatives at: index put: aTTCFont. - ! Item was removed: - ----- Method: TTCFont>>derivativeFont:mainFont: (in category 'initialize') ----- - derivativeFont: aNewlyCreatedDerivativeFont mainFont: aMainFont - - self derivativeFont: aNewlyCreatedDerivativeFont at: aMainFont emphasis. - aNewlyCreatedDerivativeFont emphasis: aMainFont emphasis. - aNewlyCreatedDerivativeFont lineGlyph: (aMainFont ttcDescription at: $_).! Item was removed: - ----- Method: TTCFont>>derivativeFontArray (in category 'friend') ----- - derivativeFontArray - - ^ derivatives. - ! Item was removed: - ----- Method: TTCFont>>derivativeFonts (in category 'friend') ----- - derivativeFonts - - derivatives ifNil: [^ #()]. - ^derivatives copyWithout: nil! Item was removed: - ----- Method: TTCFont>>descent (in category 'accessing') ----- - descent - "One is added to make sure the gap between lines is filled. If we don't add, multi line selection in a text pane look ugly." - ^descent ifNil:[descent := self height - self ascent]. - ! Item was removed: - ----- Method: TTCFont>>descentKern (in category 'accessing') ----- - descentKern - - ^ 0. - ! Item was removed: - ----- Method: TTCFont>>descentOf: (in category 'accessing') ----- - descentOf: aCharacter - - " (self hasGlyphFor: aCharacter) ifFalse: [ - fallbackFont ifNotNil: [ - ^ fallbackFont descentOf: aCharacter. - ]. - ]." - ^ self descent. - ! Item was removed: - ----- Method: TTCFont>>displayString:on:from:to:at:kern: (in category 'friend') ----- - displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta - - ^ self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent. - ! Item was removed: - ----- Method: TTCFont>>displayString:on:from:to:at:kern:baselineY: (in category 'friend') ----- - displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY - - | form glyphInfo destX destY hereX nextX actualFont | - destX := aPoint x. - glyphInfo := Array new: 5. - startIndex to: stopIndex do: [:charIndex | - self glyphInfoOf: (aString at: charIndex) into: glyphInfo. - form := glyphInfo at: 1. - hereX := glyphInfo at: 2. - nextX := glyphInfo at: 3. - (actualFont := glyphInfo at: 5) == aBitBlt lastFont - ifFalse: [actualFont installOn: aBitBlt]. - destY := baselineY - (glyphInfo at: 4). - aBitBlt sourceForm: form. - aBitBlt destX: destX. - aBitBlt destY: destY. - aBitBlt sourceX: hereX; sourceY: 0. - aBitBlt width: nextX - hereX. - aBitBlt height: form height. - aBitBlt copyBits. - destX := destX + (nextX - hereX) + kernDelta. - ]. - ^ destX @ destY - ! Item was removed: - ----- Method: TTCFont>>emphasis (in category 'accessing') ----- - emphasis - "Answer the emphasis code (0 to 3) corresponding to my subfamily name" - ^self indexOfSubfamilyName: self subfamilyName - - ! Item was removed: - ----- Method: TTCFont>>emphasis: (in category 'accessing') ----- - emphasis: code - - code > 3 ifTrue: [^ self]. - code = 0 ifTrue: [^ self]. - derivatives ifNil: [^ self]. - ^ (derivatives at: code) ifNil: [self]. - ! Item was removed: - ----- Method: TTCFont>>emphasized: (in category 'accessing') ----- - emphasized: code - - code = 0 ifTrue: [^ self]. - derivatives ifNil: [^ self]. - (((code bitAnd: 20) ~= 0) and: [ - derivatives size < code or: [(derivatives at: code) isNil]]) ifTrue: [ - self addLined. - ]. - ^ (derivatives at: code) ifNil: [self]. - ! Item was removed: - ----- Method: TTCFont>>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." - ^ fallbackFont - ifNil: [fallbackFont := FixedFaceFont new errorFont baseFont: self]! Item was removed: - ----- Method: TTCFont>>fallbackFont: (in category 'accessing') ----- - fallbackFont: aFontSetOrNil - - aFontSetOrNil == self - ifTrue:[^ self error: 'Invalid fallback font']. - - fallbackFont := aFontSetOrNil. - ! Item was removed: - ----- Method: TTCFont>>familyName (in category 'accessing') ----- - familyName - - ^ ttcDescription name. - ! Item was removed: - ----- Method: TTCFont>>familySizeFace (in category 'accessing') ----- - familySizeFace - - ^ Array - with: self familyName - with: self height - with: 0. - ! Item was removed: - ----- Method: TTCFont>>flushCache (in category 'initialize') ----- - flushCache - "Flush the cache of this font" - cache := foregroundColor := colorToCacheMap := nil.! Item was removed: - ----- Method: TTCFont>>flushCachedValues (in category 'private') ----- - flushCachedValues - "Flush all values computed from ttcDescription and cached for speed" - "TTCFont allInstancesDo:[:font| font flushCachedValues]" - height := ascent := descent := nil.! Item was removed: - ----- Method: TTCFont>>fontNameWithPointSize (in category 'accessing') ----- - fontNameWithPointSize - ^ self name withoutTrailingDigits , ' ' , self pointSize printString! Item was removed: - ----- Method: TTCFont>>foregroundColor (in category 'public') ----- - foregroundColor - - ^ foregroundColor. - ! Item was removed: - ----- Method: TTCFont>>foregroundColor: (in category 'initialize') ----- - foregroundColor: fgColor - "Install the given foreground color" - foregroundColor = fgColor ifFalse:[ - foregroundColor := fgColor. - colorToCacheMap ifNil:[colorToCacheMap := Dictionary new]. - cache := colorToCacheMap at: fgColor ifAbsentPut:[WeakArray new: self maxAscii+1]. - ShutdownList ifNotNil:[ShutdownList add: self]. - ]. - ! Item was removed: - ----- Method: TTCFont>>formOf: (in category 'private') ----- - formOf: char - - | code form | - char charCode > self maxAscii - ifTrue: [^ self fallbackFont formOf: char]. - - cache ifNil:[self foregroundColor: Color black]. "make sure we have a cache" - - code := char charCode. - form := cache at: (code + 1). - form class == Association ifTrue:[^self computeForm: code]. "in midst of loading" - form ifNil:[ - form := self computeForm: code. - form ifNil:[^nil]. - cache at: code+1 put: form. - GlyphCacheData at: (GlyphCacheIndex := GlyphCacheIndex \\ GlyphCacheSize + 1) put: form. - ]. - ^form - ! Item was removed: - ----- Method: TTCFont>>glyphInfoOf:into: (in category 'private') ----- - glyphInfoOf: aCharacter into: glyphInfoArray - "Answer the width of the argument as a character in the receiver." - - | form | - (self hasGlyphOf: aCharacter) ifFalse: [ - ^ self fallbackFont glyphInfoOf: aCharacter into: glyphInfoArray. - ]. - form := self formOf: aCharacter. - glyphInfoArray at: 1 put: form; - at: 2 put: 0; - at: 3 put: form width; - at: 4 put: ascent "(self ascentOf: aCharacter)"; - at: 5 put: self. - ^ glyphInfoArray. - ! Item was removed: - ----- Method: TTCFont>>hasGlyphOf: (in category 'private') ----- - hasGlyphOf: aCharacter - "Answer whether this font includes a glyph for the given character" - ^ aCharacter charCode <= self maxAscii - and:[(self formOf: aCharacter) notNil]! Item was removed: - ----- Method: TTCFont>>height (in category 'accessing') ----- - height - "Answer my height in pixels. This will answer a Float." - ^height ifNil:[height := self pixelSize + self lineGap]! Item was removed: - ----- Method: TTCFont>>htmlSize (in category 'html') ----- - htmlSize - "private - answer the size in html form, assumes 12 as default size" - ^ (self pointSize - 12 / 3) rounded! Item was removed: - ----- Method: TTCFont>>indexOfSubfamilyName: (in category 'private') ----- - indexOfSubfamilyName: aName - | decoded | - - "decodeStyleName will consume all the modifiers and leave nothing if everything was recognized." - decoded := TextStyle decodeStyleName: aName. - decoded second isEmpty ifTrue: [ ^decoded first ]. - - "If you get a halt here - please add the missing synonym to the lookup table in TextStyle>>decodeStyleName: ." - - self error: 'please add the missing synonym ', aName, ' to the lookup table in TextStyle>>decodeStyleName:'. - - ^0.! Item was removed: - ----- Method: TTCFont>>initialize (in category 'friend') ----- - initialize - - foregroundColor := Color black. - ! Item was removed: - ----- Method: TTCFont>>initialize: (in category 'initialize') ----- - initialize: aFont - - self initialize. - self ttcDescription: aFont ttcDescription. - ! Item was removed: - ----- Method: TTCFont>>installOn: (in category 'friend') ----- - installOn: aDisplayContext - - ^aDisplayContext installTTCFont: self. - ! Item was removed: - ----- Method: TTCFont>>installOn:foregroundColor:backgroundColor: (in category 'friend') ----- - installOn: aDisplayContext foregroundColor: fgColor backgroundColor: bgColor - self foregroundColor: fgColor. "install color" - aDisplayContext installTTCFont: self foregroundColor: foregroundColor backgroundColor: bgColor - ! Item was removed: - ----- Method: TTCFont>>isRegular (in category 'testing') ----- - isRegular - "Answer true if I am a Regular/Roman font (i.e. not bold, etc.)" - ^ (self indexOfSubfamilyName: (self subfamilyName)) = 0. - ! Item was removed: - ----- Method: TTCFont>>isTTCFont (in category 'testing') ----- - isTTCFont - ^true! Item was removed: - ----- Method: TTCFont>>lineGap (in category 'accessing') ----- - lineGap - "Answer the line gap from the ttf description" - ^self pixelSize * ttcDescription typographicLineGap // - (ttcDescription typographicAscender - ttcDescription typographicDescender)! Item was removed: - ----- Method: TTCFont>>lineGlyph: (in category 'initialize') ----- - lineGlyph: ignore - ^self! Item was removed: - ----- Method: TTCFont>>lineGrid (in category 'accessing') ----- - lineGrid - "Answer the relative space between lines" - ^ self ascent + self descent! Item was removed: - ----- Method: TTCFont>>maxAscii (in category 'accessing') ----- - maxAscii - "Answer the max. code point in this font. The name of this method is historical." - ^maxAscii ifNil:[ttcDescription size].! Item was removed: - ----- Method: TTCFont>>minAscii (in category 'accessing') ----- - minAscii - "Answer the min. code point in this font. The name of this method is historical." - ^ 0. - ! Item was removed: - ----- Method: TTCFont>>name (in category 'accessing') ----- - name - - ^ ttcDescription name. - ! Item was removed: - ----- Method: TTCFont>>objectForDataStream: (in category 'objects from disk') ----- - objectForDataStream: refStrm - | dp | - "I am about to be written on an object file. Write a - reference to a known FontSet in the other system instead." - - "a path to me" - dp := DiskProxy global: #TTCFont selector: #familyName:pointSize:emphasis: - args: {self familyName. self pointSize. self emphasis}. - refStrm replace: self with: dp. - ^ dp. - ! Item was removed: - ----- Method: TTCFont>>openHtmlOn: (in category 'html') ----- - openHtmlOn: aStream - "put on the given stream the tag to open the html - representation of the receiver" - | size | - size := self htmlSize. - size isZero - ifFalse: [aStream nextPutAll: '<font size="' , size asString , '">']! Item was removed: - ----- Method: TTCFont>>pixelScale (in category 'accessing') ----- - pixelScale - "Answer the scale factor to convert from the truetype's units into the receiver's pixel size. The scale for a font is computed by *excluding* the linegap (leading) in the font. Consequently, the height of the font (including linegap/leading) will be larger than the pixel size." - ^self pixelSize asFloat / - (ttcDescription typographicAscender - - ttcDescription typographicLineGap - - ttcDescription typographicDescender)! Item was removed: - ----- Method: TTCFont>>pixelSize (in category 'accessing') ----- - pixelSize - "Make sure that we don't return a Fraction" - ^(TextStyle pointsToPixels: pointSize) truncated! Item was removed: - ----- Method: TTCFont>>pixelSize: (in category 'accessing') ----- - pixelSize: aNumber - "Make sure that we don't return a Fraction" - self pointSize: (TextStyle pixelsToPoints: aNumber) rounded. - ! Item was removed: - ----- Method: TTCFont>>pointSize (in category 'accessing') ----- - pointSize - - ^ pointSize. - ! Item was removed: - ----- Method: TTCFont>>pointSize: (in category 'accessing') ----- - pointSize: aNumber - - self privatePointSize: aNumber. - derivatives ifNotNil: [ derivatives do: [ :f | f ifNotNil: [ f privatePointSize: aNumber ]]]. - ! Item was removed: - ----- Method: TTCFont>>printOn: (in category 'printing') ----- - printOn: aStream - aStream nextPutAll: 'TTCFont('; - nextPutAll: self familyName; space; - print: self pointSize; space; - nextPutAll: self subfamilyName; - nextPut: $)! Item was removed: - ----- Method: TTCFont>>privatePointSize: (in category 'accessing') ----- - privatePointSize: aNumber - pointSize = aNumber - ifFalse: [pointSize := aNumber. - self flushCache]! Item was removed: - ----- Method: TTCFont>>releaseCachedState (in category 'caching') ----- - releaseCachedState - self flushCache.! Item was removed: - ----- Method: TTCFont>>reset (in category 'caching') ----- - reset - ! Item was removed: - ----- Method: TTCFont>>scale (in category 'private') ----- - scale - - ^ self pixelSize / ttcDescription unitsPerEm - ! Item was removed: - ----- Method: TTCFont>>setupDefaultFallbackFont (in category 'emphasis') ----- - setupDefaultFallbackFont - - | fonts f | - fonts := TextStyle default fontArray. - f := fonts first. - 1 to: fonts size do: [:i | - self height > (fonts at: i) height ifTrue: [f := fonts at: i]. - ]. - (f == self) - ifFalse:[ self fallbackFont: f ]. - self reset. - ! Item was removed: - ----- Method: TTCFont>>setupDefaultFallbackFontTo: (in category 'friend') ----- - setupDefaultFallbackFontTo: aTextStyleOrNil - " - TTCFont allInstances do: [:i | i setupDefaultFallbackFontTo: (TextStyle named: 'MultiMSMincho')]. - " - - | fonts f | - aTextStyleOrNil ifNil: [ - self fallbackFont: nil. - ^ self. - ]. - fonts := aTextStyleOrNil fontArray. - (aTextStyleOrNil defaultFont familyName endsWith: self familyName) ifTrue: [fallbackFont := nil. ^ self]. - - f := fonts first. - 1 to: fonts size do: [:i | - self height >= (fonts at: i) height ifTrue: [f := fonts at: i]. - ]. - self fallbackFont: f. - self reset. - - ! Item was removed: - ----- Method: TTCFont>>size (in category 'public') ----- - size - - ^ ttcDescription size. - ! Item was removed: - ----- Method: TTCFont>>subfamilyName (in category 'private') ----- - subfamilyName - - ^ ttcDescription subfamilyName. - ! Item was removed: - ----- Method: TTCFont>>textStyle (in category 'accessing') ----- - textStyle - ^ TextStyle actualTextStyles detect: - [:aStyle | aStyle fontArray includes: self] ifNone: [nil]! Item was removed: - ----- Method: TTCFont>>ttcDescription (in category 'friend') ----- - ttcDescription - - ^ ttcDescription. - ! Item was removed: - ----- Method: TTCFont>>ttcDescription: (in category 'friend') ----- - ttcDescription: aTTCDescription - - ttcDescription := aTTCDescription. - self flushCache. - ! Item was removed: - ----- Method: TTCFont>>veryDeepCopyWith: (in category 'copying') ----- - veryDeepCopyWith: deepCopier - - self flushCache. - ^ self. - ! Item was removed: - ----- Method: TTCFont>>widthOf: (in category 'public') ----- - widthOf: aCharacter - "This method cannot use #formOf: because formOf: discriminates the color and causes unnecessary bitmap creation." - (self hasGlyphOf: aCharacter) ifFalse: [ - fallbackFont ifNotNil: [^ fallbackFont widthOf: aCharacter]. - ^ 1 - ]. - ^(self formOf: aCharacter) width! Item was removed: - TTFontDescription subclass: #TTCFontDescription - instanceVariableNames: '' - classVariableNames: 'TTCDefault TTCDescriptions' - poolDictionaries: '' - category: 'Multilingual-Display'! Item was removed: - ----- Method: TTCFontDescription class>>addFromTTFile: (in category 'as yet unclassified') ----- - addFromTTFile: fileName - " - Execute the following only if you know what you are doing. - self addFromTTFile: 'C:\WINDOWS\Fonts\msgothic.TTC' - " - - | tt old | - (fileName asLowercase endsWith: 'ttf') ifTrue: [ - tt := TTCFontReader readTTFFrom: (FileStream readOnlyFileNamed: fileName). - ] ifFalse: [ - tt := TTCFontReader readFrom: (FileStream readOnlyFileNamed: fileName). - ]. - - old := TTCDescriptions detect: [:f | f first name = tt first name] ifNone: [nil]. - old ifNotNil: [TTCDescriptions remove: old]. - TTCDescriptions add: tt. - ^ tt. - ! Item was removed: - ----- Method: TTCFontDescription class>>clearDefault (in category 'as yet unclassified') ----- - clearDefault - " - self clearDefault - " - - TTCDefault := nil. - ! Item was removed: - ----- Method: TTCFontDescription class>>clearDescriptions (in category 'as yet unclassified') ----- - clearDescriptions - " - self clearDescriptions - " - - TTCDescriptions := Set new. - TTCDefault ifNotNil: [TTCDescriptions add: TTCDefault]. - ! Item was removed: - ----- Method: TTCFontDescription class>>default (in category 'as yet unclassified') ----- - default - - ^ TTCDefault. - ! Item was removed: - ----- Method: TTCFontDescription class>>descriptionNamed: (in category 'as yet unclassified') ----- - descriptionNamed: descriptionName - - ^ TTCDescriptions detect: [:f | f first name = descriptionName] ifNone: [TTCDefault]. - ! Item was removed: - ----- Method: TTCFontDescription class>>descriptionNamed:at: (in category 'as yet unclassified') ----- - descriptionNamed: descriptionName at: index - - | array | - (array := self descriptionNamed: descriptionName) ifNil: [^ nil]. - ^ array at: index. - ! Item was removed: - ----- Method: TTCFontDescription class>>initialize (in category 'as yet unclassified') ----- - initialize - " - self initialize - " - - self clearDescriptions. - ! Item was removed: - ----- Method: TTCFontDescription class>>removeDescriptionNamed: (in category 'as yet unclassified') ----- - removeDescriptionNamed: descriptionName - - | tt | - TTCDescriptions ifNil: [^ self]. - [(tt := TTCDescriptions detect: [:f | ('Multi', f first name) = descriptionName] ifNone: [nil]) notNil] whileTrue:[ - TTCDescriptions remove: tt - ]. - ! Item was removed: - ----- Method: TTCFontDescription class>>setDefault (in category 'as yet unclassified') ----- - setDefault - " - self setDefault - " - - TTCDefault := TTCFontReader readFrom: (FileStream readOnlyFileNamed: 'C:\WINDOWS\Fonts\msgothic.ttc'). - self clearDescriptions. - - ! Item was removed: - ----- Method: TTCFontDescription>>at: (in category 'accessing') ----- - at: aCharOrInteger - - | char | - char := aCharOrInteger asCharacter. - ^ glyphs at: (char charCode) + 1. - ! Item was removed: - ----- Method: TTCFontDescription>>deepCopy (in category 'copying') ----- - deepCopy - - ^ self. - ! Item was removed: - ----- Method: TTCFontDescription>>name (in category 'accessing') ----- - name - - ^ self familyName copyWithout: Character space. - ! Item was removed: - ----- Method: TTCFontDescription>>objectForDataStream: (in category 'objects from disk') ----- - objectForDataStream: refStrm - | dp | - "I am about to be written on an object file. Write a reference to a known Font in the other system instead. " - - "A path to me" - (TextConstants at: #forceFontWriting ifAbsent: [false]) ifTrue: [^ self]. - "special case for saving the default fonts on the disk. See collectionFromFileNamed:" - - dp := DiskProxy global: #TTCFontDescription selector: #descriptionNamed:at: - args: {self name. ((TTCFontDescription descriptionNamed: self name) indexOf: self)}. - refStrm replace: self with: dp. - ^ dp. - ! Item was removed: - ----- Method: TTCFontDescription>>size (in category 'accessing') ----- - size - - ^ glyphs size. - ! Item was removed: - ----- Method: TTCFontDescription>>veryDeepCopyWith: (in category 'copying') ----- - veryDeepCopyWith: deepCopier - "Return self. I am shared. Do not record me." - ! Item was removed: - TTFontReader subclass: #TTCFontReader - instanceVariableNames: 'fonts' - classVariableNames: 'EncodingTag' - poolDictionaries: '' - category: 'Multilingual-Display'! Item was removed: - ----- Method: TTCFontReader class>>encodingTag: (in category 'as yet unclassified') ----- - encodingTag: aNumber - " - TTCFontReader encodingTag: 6 - " - - EncodingTag := aNumber. - ! Item was removed: - ----- Method: TTCFontReader>>decodeCmapFmtTable: (in category 'as yet unclassified') ----- - decodeCmapFmtTable: entry - | cmapFmt length entryCount segCount segments offset cmap firstCode | - cmapFmt := entry nextUShort. - length := entry nextUShort. - entry skip: 2. "skip version" - - cmapFmt = 0 ifTrue: "byte encoded table" - [length := length - 6. "should be always 256" - length <= 0 ifTrue: [^ nil]. "but sometimes, this table is empty" - cmap := Array new: length. - entry nextBytes: length into: cmap startingAt: entry offset. - ^ cmap]. - - cmapFmt = 4 ifTrue: "segment mapping to deltavalues" - [segCount := entry nextUShort // 2. - entry skip: 6. "skip searchRange, entrySelector, rangeShift" - segments := Array new: segCount. - segments := (1 to: segCount) collect: [:e | Array new: 4]. - 1 to: segCount do: [:i | (segments at: i) at: 2 put: entry nextUShort]. "endCount" - entry skip: 2. "skip reservedPad" - 1 to: segCount do: [:i | (segments at: i) at: 1 put: entry nextUShort]. "startCount" - 1 to: segCount do: [:i | (segments at: i) at: 3 put: entry nextShort]. "idDelta" - offset := entry offset. - 1 to: segCount do: [:i | (segments at: i) at: 4 put: entry nextUShort]. "idRangeOffset" - cmap := Array new: 65536 withAll: 0. - segments withIndexDo: - [:seg :si | | code | - seg first to: seg second do: - [:i | - seg last > 0 ifTrue: - ["offset to glypthIdArray - this is really C-magic!!" - entry offset: i - seg first - 1 * 2 + seg last + si + si + offset. - code := entry nextUShort. - code > 0 ifTrue: [code := code + seg third]] - ifFalse: - ["simple offset" - code := i + seg third]. - cmap at: i + 1 put: (code \\ 16r10000)]]. - ^ cmap]. - - cmapFmt = 6 ifTrue: "trimmed table" - [firstCode := entry nextUShort. - entryCount := entry nextUShort. - cmap := Array new: entryCount + firstCode withAll: 0. - entryCount timesRepeat: - [cmap at: (firstCode := firstCode + 1) put: entry nextUShort]. - ^ cmap]. - ^ nil! Item was removed: - ----- Method: TTCFontReader>>getTableDirEntry:from:offset: (in category 'as yet unclassified') ----- - getTableDirEntry: tagString from: fontData offset: offset - "Find the table named tagString in fontData and return a table directory entry for it." - - | nTables pos currentTag tag | - nTables := fontData shortAt: 5 + offset bigEndian: true. - tag := ByteArray new: 4. - 1 to: 4 do:[:i| tag byteAt: i put: (tagString at: i) asInteger]. - tag := tag longAt: 1 bigEndian: true. - pos := 13 + offset. - 1 to: nTables do:[:i| - currentTag := fontData longAt: pos bigEndian: true. - currentTag = tag ifTrue:[^TTFontTableDirEntry on: fontData at: pos]. - pos := pos+16]. - ^nil! Item was removed: - ----- Method: TTCFontReader>>parseTTCHeaderFrom: (in category 'as yet unclassified') ----- - parseTTCHeaderFrom: fontData - - | pos nTables | - nTables := fontData longAt: 9 bigEndian: true. - fonts := Array new: nTables. - pos := 13. - 1 to: nTables do: [:i | - fonts at: i put: (fontData longAt: pos bigEndian: true). - pos := pos + 4. - ]. - - ^ fonts - ! Item was removed: - ----- Method: TTCFontReader>>processCharMap: (in category 'as yet unclassified') ----- - processCharMap: assoc - "Process the given character map" - - | glyph cmap encode0 encode1 char value null | - cmap := assoc value. - null := (glyphs at: (cmap at: Character space asUnicode + 1) + 1) copy. - null contours: #(). - - encode0 := Array new: 256 withAll: glyphs first. - encode1 := Array new: 65536 withAll: glyphs first. - - 0 to: 255 do: [:i | - char := Character value: i. - glyph := glyphs at: (cmap at: char asUnicode + 1) + 1. - encode0 at: i+1 put: glyph. - ]. - Character separators do: [:c | - encode0 at: (c asciiValue + 1) put: null. - ]. - 0 to: 65536 - 1 do: [:i | - value := cmap at: i+1. - value = 65535 ifFalse: [ "???" - encode1 at: i+1 put: (glyphs at: value+1). - ] - ]. - - ^ {encode0. encode1}. - ! Item was removed: - ----- Method: TTCFontReader>>processCharacterMappingTable: (in category 'as yet unclassified') ----- - processCharacterMappingTable: entry - "Read the font's character to glyph index mapping table. - If an appropriate mapping can be found then return an association - with the format identifier and the contents of the table" - | copy initialOffset nSubTables pID sID offset cmap assoc | - initialOffset := entry offset. - entry skip: 2. "Skip table version" - nSubTables := entry nextUShort. - 1 to: nSubTables do:[:i| - pID := entry nextUShort. - sID := entry nextUShort. - offset := entry nextULong. - "Check if this is either a Macintosh encoded table - or a Windows encoded table" - (pID = 1 or:[pID = 3]) ifTrue:[ - "Go to the beginning of the table" - copy := entry copy. - copy offset: initialOffset + offset. - cmap := self decodeCmapFmtTable: copy. - "(pID = 1 and: [cmap notNil])" "Prefer Macintosh encoding over everything else" - "ifTrue: [pID -> cmap]." - assoc := pID -> cmap. "Keep it in case we don't find a Mac encoded table" - ]. - ]. - ^assoc! Item was removed: - ----- Method: TTCFontReader>>readFrom: (in category 'as yet unclassified') ----- - readFrom: aStream - - "Read the raw font byte data" - | fontData | - (aStream respondsTo: #binary) ifTrue:[aStream binary]. - fontData := aStream contents asByteArray. - - fonts := self parseTTCHeaderFrom: fontData. - ^ ((Array with: fonts first) collect: [:offset | - fontDescription := TTCFontDescription new. - self readFrom: fontData fromOffset: offset at: EncodingTag. - ]) at: 1. - ! Item was removed: - ----- Method: TTCFontReader>>readFrom:fromOffset:at: (in category 'as yet unclassified') ----- - readFrom: fontData fromOffset: offset at: encodingTag - - | headerEntry maxProfileEntry nameEntry indexLocEntry charMapEntry glyphEntry horzHeaderEntry horzMetricsEntry kerningEntry glyphOffset cmap numHMetrics indexToLocFormat fontDescription0 fontDescription1 array result | - - "Search the tables required to build the font" - (headerEntry := self getTableDirEntry: 'head' from: fontData offset: offset) == nil ifTrue:[ - ^self error:'This font does not have a header table']. - (maxProfileEntry := self getTableDirEntry: 'maxp' from: fontData offset: offset) == nil ifTrue:[ - ^self error:'This font does not have a maximum profile table']. - (nameEntry := self getTableDirEntry: 'name' from: fontData offset: offset) == nil ifTrue:[ - ^self error:'This font does not have a name table']. - (indexLocEntry := self getTableDirEntry: 'loca' from: fontData offset: offset) == nil ifTrue:[ - ^self error:'This font does not have a relocation table']. - (charMapEntry := self getTableDirEntry: 'cmap' from: fontData offset: offset) == nil ifTrue:[ - ^self error:'This font does not have a character map table']. - (glyphEntry := self getTableDirEntry: 'glyf' from: fontData offset: offset) == nil ifTrue:[ - ^self error:'This font does not have a glyph table']. - (horzHeaderEntry := self getTableDirEntry: 'hhea' from: fontData offset: offset) == nil ifTrue:[ - ^self error:'This font does not have a horizontal header table']. - (horzMetricsEntry := self getTableDirEntry: 'hmtx' from: fontData offset: offset) == nil ifTrue:[ - ^self error:'This font does not have a horizontal metrics table']. - (kerningEntry := self getTableDirEntry: 'kern' from: fontData offset: offset) == nil ifTrue:[ - Transcript cr; show:'This font does not have a kerning table';endEntry]. - - - "Process the data" - indexToLocFormat := self processFontHeaderTable: headerEntry. - self processMaximumProfileTable: maxProfileEntry. - self processNamingTable: nameEntry. - glyphOffset := self processIndexToLocationTable: indexLocEntry format: indexToLocFormat. - cmap := self processCharacterMappingTable: charMapEntry. - (cmap == nil or:[cmap value == nil]) - ifTrue:[^self error:'This font has no suitable character mappings']. - self processGlyphDataTable: glyphEntry offsets: glyphOffset. - numHMetrics := self processHorizontalHeaderTable: horzHeaderEntry. - self processHorizontalMetricsTable: horzMetricsEntry length: numHMetrics. - kerningEntry isNil - ifTrue:[kernPairs := #()] - ifFalse:[self processKerningTable: kerningEntry]. - array := self processCharMap: cmap. - fontDescription0 := fontDescription clone. - fontDescription1 := fontDescription clone. - fontDescription0 setGlyphs: (array at: 1) mapping: nil. - fontDescription1 setGlyphs: (array at: 2) mapping: nil. - "fontDescription setKernPairs: kernPairs." - result := OrderedCollection new. - (encodingTag = nil or: [encodingTag = 0]) ifTrue: [^ Array with: fontDescription1]. - result add: fontDescription0. - encodingTag -1 timesRepeat: [result add: nil]. - result add: fontDescription1. - ^ result asArray. - - ! Item was removed: - ----- Method: TTCFontReader>>readTTFFrom: (in category 'as yet unclassified') ----- - readTTFFrom: aStream - - "Read the raw font byte data" - | fontData | - (aStream respondsTo: #binary) ifTrue:[aStream binary]. - fontData := aStream contents asByteArray. - fontDescription := TTCFontDescription new. - - ^ self readFrom: fontData fromOffset: 0 at: EncodingTag. - ! Item was removed: - AbstractFont subclass: #TTCFontSet - instanceVariableNames: 'name fontArray foregroundColor' - classVariableNames: 'Registry' - poolDictionaries: '' - category: 'Multilingual-Display'! Item was removed: - ----- Method: TTCFontSet class>>discardDefault (in category 'as yet unclassified') ----- - discardDefault - " - self discardDefault - " - | ttc | - ttc := TTCFontDescription default. - ttc ifNotNil: [ - TextConstants removeKey: ttc name asSymbol ifAbsent: []. - ].! Item was removed: - ----- Method: TTCFontSet class>>familyName:pointSize: (in category 'as yet unclassified') ----- - familyName: n pointSize: s - - "(self familyName: 'MultiMSGothic' pointSize: 14) pointSize" - | t ret index | - t := self registry at: n asSymbol ifAbsent: [#()]. - t isEmpty ifTrue: [ - t := (TextConstants at: #DefaultTextStyle) fontArray. - ret := t first. - ret pointSize >= s ifTrue: [^ ret]. - index := 2. - [index <= t size and: [(t at: index) pointSize <= s]] whileTrue: [ - ret := t at: index. - index := index + 1. - ]. - ^ ret. - ]. - ^ (TextStyle named: n) addNewFontSize: s.! Item was removed: - ----- Method: TTCFontSet class>>initialize (in category 'as yet unclassified') ----- - initialize - " - self initialize - " - - | tt | - tt := TTCFontDescription default. - tt ifNotNil: [self newTextStyleFromTT: tt]. - ! Item was removed: - ----- Method: TTCFontSet class>>newFontArray: (in category 'as yet unclassified') ----- - newFontArray: anArray - - ^super new initializeWithFontArray: anArray - ! Item was removed: - ----- Method: TTCFontSet class>>newTextStyleFromTT: (in category 'as yet unclassified') ----- - newTextStyleFromTT: descriptionArray - - | array textStyle styleName arrayOfArray | - - arrayOfArray := self pointSizes collect: [:pt | - descriptionArray collect: [:ttc | | f | - ttc ifNil: [nil] ifNotNil: [ - f := (ttc size > 256) - ifTrue: [MultiTTCFont new initialize] - ifFalse: [TTCFont new initialize]. - f ttcDescription: ttc. - f pointSize: pt. - ]. - ]. - ]. - - array := arrayOfArray collect: [:fonts | - self newFontArray: fonts. - ]. - - styleName := (array at: 1) familyName asSymbol. - textStyle := TextStyle fontArray: array. - TextConstants at: styleName put: textStyle. - - self register: array at: styleName. - - ^ TextConstants at: styleName. - ! Item was removed: - ----- Method: TTCFontSet class>>newTextStyleFromTTFile: (in category 'as yet unclassified') ----- - newTextStyleFromTTFile: fileName - " - TTCFontReader encodingTag: JapaneseEnvironment leadingChar. - self newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\msmincho.TTC' - - TTCFontReader encodingTag: 0. - self newTextStyleFromTTFile: 'C:\WINDOWS\Fonts\symbol.ttf' - " - - | description | - description := TTCFontDescription addFromTTFile: fileName. - ^ self newTextStyleFromTT: description. - ! Item was removed: - ----- Method: TTCFontSet class>>pointSizes (in category 'as yet unclassified') ----- - pointSizes - - ^ TTCFont pointSizes. - ! Item was removed: - ----- Method: TTCFontSet class>>register:at: (in category 'as yet unclassified') ----- - register: anObject at: symbolName - - self registry at: symbolName put: anObject. - ! Item was removed: - ----- Method: TTCFontSet class>>registry (in category 'as yet unclassified') ----- - registry - ^ Registry - ifNil: [Registry := IdentityDictionary new]! Item was removed: - ----- Method: TTCFontSet class>>removeStyleName: (in category 'as yet unclassified') ----- - removeStyleName: aString - - | style symName | - symName := aString asSymbol. - style := TextConstants removeKey: symName ifAbsent: []. - style ifNotNil: [self unregister: symName]. - TTCFontDescription removeDescriptionNamed: aString asString. - ! Item was removed: - ----- Method: TTCFontSet class>>setDefault (in category 'as yet unclassified') ----- - setDefault - " - self setDefault - " - | tt | - tt := TTCFontDescription default. - tt ifNil: [TTCFontDescription setDefault]. - tt := TTCFontDescription default. - tt ifNotNil: [self newTextStyleFromTT: tt]. - ! Item was removed: - ----- Method: TTCFontSet class>>unregister: (in category 'as yet unclassified') ----- - unregister: symbolName - - self registry removeKey: symbolName ifAbsent: []. - ! Item was removed: - ----- Method: TTCFontSet>>ascent (in category 'accessing') ----- - ascent - - ^ (fontArray at: 1) ascent. - ! Item was removed: - ----- Method: TTCFontSet>>ascentOf: (in category 'accessing') ----- - ascentOf: aCharacter - - ^ fontArray first ascentOf: aCharacter. - ! Item was removed: - ----- Method: TTCFontSet>>baseKern (in category 'accessing') ----- - baseKern - - ^ 0. - ! Item was removed: - ----- Method: TTCFontSet>>depth (in category 'accessing') ----- - depth - - ^ (fontArray at: 1) depth. - ! Item was removed: - ----- Method: TTCFontSet>>descent (in category 'accessing') ----- - descent - - ^ (fontArray at: 1) descent. - ! Item was removed: - ----- Method: TTCFontSet>>descentKern (in category 'accessing') ----- - descentKern - - ^ 0. - ! Item was removed: - ----- Method: TTCFontSet>>descentOf: (in category 'accessing') ----- - descentOf: aChar - - ^ fontArray first descentOf: aChar - ! Item was removed: - ----- Method: TTCFontSet>>displayString:on:from:to:at:kern: (in category 'displaying') ----- - displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta - - ^ self displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: aPoint y + self ascent. - ! Item was removed: - ----- Method: TTCFontSet>>displayString:on:from:to:at:kern:baselineY: (in category 'displaying') ----- - displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY - - | destPoint font form encoding glyphInfo char charCode destY | - destPoint := aPoint. - glyphInfo := Array new: 5. - startIndex to: stopIndex do: [:charIndex | - char := aString at: charIndex. - encoding := char leadingChar + 1. - charCode := char charCode. - font := fontArray at: encoding. - ((charCode between: font minAscii and: font maxAscii) not) ifTrue: [ - charCode := font maxAscii]. - self glyphInfoOf: char into: glyphInfo. - form := glyphInfo first. - (glyphInfo fifth ~= aBitBlt lastFont) ifTrue: [ - glyphInfo fifth installOn: aBitBlt. - ]. - destY := baselineY - glyphInfo fourth. - aBitBlt - sourceForm: form; - destX: destPoint x; - destY: destY; - sourceOrigin: 0 @ 0; - width: form width; - height: form height; - copyBits. - destPoint := destPoint x + (form width + kernDelta) @ destPoint y. - ]. - ^ destPoint. - ! Item was removed: - ----- Method: TTCFontSet>>displayStringR2L:on:from:to:at:kern: (in category 'displaying') ----- - displayStringR2L: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta - - | destPoint font form encoding char charCode glyphInfo | - destPoint := aPoint. - glyphInfo := Array new: 5. - startIndex to: stopIndex do: [:charIndex | - char := aString at: charIndex. - encoding := char leadingChar + 1. - charCode := char charCode. - font := fontArray at: encoding. - ((charCode between: font minAscii and: font maxAscii) not) ifTrue: [ - charCode := font maxAscii]. - self glyphInfoOf: char into: glyphInfo. - form := glyphInfo first. - (glyphInfo size > 4 and: [glyphInfo fifth notNil and: [glyphInfo fifth ~= aBitBlt lastFont]]) ifTrue: [ - glyphInfo fifth installOn: aBitBlt. - ]. - aBitBlt - sourceForm: form; - destX: destPoint x - form width; - destY: destPoint y; - sourceOrigin: 0 @ 0; - width: form width; - height: form height; - copyBits. - destPoint := destPoint x - (form width + kernDelta) @ destPoint y. - ]. - ! Item was removed: - ----- Method: TTCFontSet>>emphasis (in category 'accessing') ----- - emphasis - ^ fontArray first emphasis! Item was removed: - ----- Method: TTCFontSet>>emphasized: (in category 'accessing') ----- - emphasized: code - - ! Item was removed: - ----- Method: TTCFontSet>>familyName (in category 'accessing') ----- - familyName - - ^ 'Multi', (fontArray at: 1) familyName. - ! Item was removed: - ----- Method: TTCFontSet>>familySizeFace (in category 'accessing') ----- - familySizeFace - - ^ Array - with: fontArray first name - with: self height - with: 0. - ! Item was removed: - ----- Method: TTCFontSet>>fontArray (in category 'accessing') ----- - fontArray - - ^ fontArray - ! Item was removed: - ----- Method: TTCFontSet>>glyphInfoOf:into: (in category 'private') ----- - glyphInfoOf: aCharacter into: glyphInfoArray - - | index f code | - index := aCharacter leadingChar + 1. - fontArray size < index ifTrue: [^ self questionGlyphInfoInto: glyphInfoArray]. - (f := fontArray at: index) ifNil: [^ self questionGlyphInfoInto: glyphInfoArray]. - - code := aCharacter charCode. - ((code between: f minAscii and: f maxAscii) not) ifTrue: [ - ^ self questionGlyphInfoInto: glyphInfoArray. - ]. - f glyphInfoOf: aCharacter into: glyphInfoArray. - glyphInfoArray at: 5 put: self. - ^ glyphInfoArray. - ! Item was removed: - ----- Method: TTCFontSet>>height (in category 'accessing') ----- - height - - ^fontArray first pixelSize. - ! Item was removed: - ----- Method: TTCFontSet>>initializeWithFontArray: (in category 'as yet unclassified') ----- - initializeWithFontArray: anArray - - fontArray := anArray. - "name := anArray first name." - ! Item was removed: - ----- Method: TTCFontSet>>installOn: (in category 'as yet unclassified') ----- - installOn: aDisplayContext - - ^aDisplayContext installTTCFont: self. - ! Item was removed: - ----- Method: TTCFontSet>>installOn:foregroundColor:backgroundColor: (in category 'as yet unclassified') ----- - installOn: aDisplayContext foregroundColor: fgColor backgroundColor: bgColor - - foregroundColor := fgColor. - fontArray do: [:s | s ifNotNil: [s installOn: aDisplayContext foregroundColor: fgColor backgroundColor: bgColor]]. - ! Item was removed: - ----- Method: TTCFontSet>>isFontSet (in category 'testing') ----- - isFontSet - - ^ true. - ! Item was removed: - ----- Method: TTCFontSet>>isTTCFont (in category 'testing') ----- - isTTCFont - ^true! Item was removed: - ----- Method: TTCFontSet>>lineGrid (in category 'accessing') ----- - lineGrid - - ^ fontArray first lineGrid. - ! Item was removed: - ----- Method: TTCFontSet>>maxAsciiFor: (in category 'accessing') ----- - maxAsciiFor: encoding - - | f | - f := (fontArray at: encoding+1). - f ifNotNil: [^ f maxAscii]. - ^ 0. - ! Item was removed: - ----- Method: TTCFontSet>>objectForDataStream: (in category 'objects from disk') ----- - objectForDataStream: refStrm - | dp | - "I am about to be written on an object file. Write a - reference to a known FontSet in the other system instead." - - "a path to me" - dp := DiskProxy global: #TTCFontSet selector: #familyName:pointSize: - args: {self familyName. self pointSize}. - refStrm replace: self with: dp. - ^ dp. - ! Item was removed: - ----- Method: TTCFontSet>>pointSize (in category 'accessing') ----- - pointSize - - ^ fontArray first pixelSize * 72 // 96. - ! Item was removed: - ----- Method: TTCFontSet>>pointSizes (in category 'accessing') ----- - pointSizes - - ^ self class pointSizes. - ! Item was removed: - ----- Method: TTCFontSet>>questionGlyphInfoInto: (in category 'private') ----- - questionGlyphInfoInto: glyphInfoArray - - | f form | - f := fontArray at: 1. - form := f formOf: $?. - glyphInfoArray at: 1 put: form; - at: 2 put: 0; - at: 3 put: form width; - at: 4 put: self. - ^ glyphInfoArray. - ! Item was removed: - ----- Method: TTCFontSet>>textStyle (in category 'accessing') ----- - textStyle - - ^ TextStyle actualTextStyles - detect: [:aStyle | (aStyle fontArray collect: [:s | s name]) includes: self name] - ifNone: []. - ! Item was removed: - ----- Method: TTCFontSet>>ttcDescription (in category 'as yet unclassified') ----- - ttcDescription - ^ fontArray first ttcDescription! Item was removed: - ----- Method: TTCFontSet>>widthOf: (in category 'measuring') ----- - widthOf: aCharacter - - | encoding | - encoding := aCharacter leadingChar. - ^ (fontArray at: encoding + 1) widthOf: aCharacter. - !

1 0

The Trunk: Multilingual-fbs.163.mcz
by commits＠source.squeak.org 02 Jul '13

02 Jul '13

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

Packages July 2013