The Trunk: TrueType-topa.33.mcz

Tobias Pape uploaded a new version of TrueType to project The Trunk:
http://source.squeak.org/trunk/TrueType-topa.33.mcz

==================== Summary ====================

Name: TrueType-topa.33
Author: topa
Time: 19 March 2015, 11:36:32.936 am
UUID: df5a73e1-3741-40e4-9307-b92b59b3ef52
Ancestors: TrueType-topa.32

Improve TrueType handling, if ever so slightly.

- Pick up some imporvements from Etoys.
- Improves Unicode cmaps
- Unifies TTFontDescription and TTCFontDescription a bit more
- Add support for some newer Apple OS X Font idiosyncracies
  (like Post-Script OpenType in ttc fonts or proprietary kern tables)
- polymorphize (?) TTFileDescription a bit more with TTFontDescription

=============== Diff against TrueType-topa.32 ===============

Item was changed:
+ ----- Method: LinedTTCFont>>emphasis (in category 'accessing') -----
- ----- Method: LinedTTCFont>>emphasis (in category 'as yet unclassified') -----
  emphasis
 
  ^ emphasis.
  !

Item was changed:
+ ----- Method: LinedTTCFont>>emphasis: (in category 'accessing') -----
- ----- Method: LinedTTCFont>>emphasis: (in category 'as yet unclassified') -----
  emphasis: code
 
  emphasis := code.
  !

Item was changed:
+ ----- Method: LinedTTCFont>>lineGlyph: (in category 'initialize') -----
- ----- Method: LinedTTCFont>>lineGlyph: (in category 'as yet unclassified') -----
  lineGlyph: aGlyph
 
  lineGlyph := aGlyph.
  contourWidth := aGlyph calculateWidth.
  !

Item was changed:
  TTCFont subclass: #MultiTTCFont
+ instanceVariableNames: 'map cacheIndex'
- instanceVariableNames: ''
  classVariableNames: ''
  poolDictionaries: ''
  category: 'TrueType-Fonts'!

Item was changed:
+ ----- Method: MultiTTCFont>>at:put: (in category 'all') -----
- ----- Method: MultiTTCFont>>at:put: (in category 'as yet unclassified') -----
  at: char put: form
 
+ | ind triplet |
+ triplet := Array with: char asciiValue with: foregroundColor with: form.
+ GlyphCacheData at: (GlyphCacheIndex := GlyphCacheIndex \\ GlyphCacheSize + 1) put: triplet.
+
+ ind := self indexFor: char.
+ map at: char asciiValue put: ind.
+ self cache at: ind put: triplet.
- | 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 added:
+ ----- Method: MultiTTCFont>>cache (in category 'all') -----
+ cache
+ (cache isNil or: [cache size ~= 512]) ifTrue: [self recreateCache]. "old weak-array caching"
+ ^cache!

Item was added:
+ ----- Method: MultiTTCFont>>flushCache (in category 'all') -----
+ flushCache
+
+ super flushCache.
+ map := IdentityDictionary new: 512.
+ !

Item was added:
+ ----- Method: MultiTTCFont>>foregroundColor: (in category 'all') -----
+ foregroundColor: fgColor
+ "Install the given foreground color"
+ foregroundColor := fgColor.!

Item was changed:
+ ----- Method: MultiTTCFont>>formOf: (in category 'all') -----
- ----- Method: MultiTTCFont>>formOf: (in category 'as yet unclassified') -----
  formOf: char
 
  | newForm |
+ cache ifNil: [ self recreateCache ].
+ foregroundColor ifNil: [ self foregroundColor: Color black ].
+
+ self hasCached: char ifTrue: [:form |
- self hasCached: char ifTrue: [:form :index |
- self access: char at: index.
  ^ form.
  ].
 
  newForm := self computeForm: char.
  self at: char put: newForm.
  ^ newForm.
  !

Item was changed:
+ ----- Method: MultiTTCFont>>glyphInfoOf:into: (in category 'all') -----
- ----- Method: MultiTTCFont>>glyphInfoOf:into: (in category 'as yet unclassified') -----
  glyphInfoOf: char into: glyphInfoArray
+
- "return glyph info for char; I may have cached info to work from"
  | newForm |
+ self hasCached: char ifTrue: [:form |
- 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 changed:
+ ----- Method: MultiTTCFont>>hasCached:ifTrue: (in category 'all') -----
+ hasCached: char ifTrue: aBlock
- ----- Method: MultiTTCFont>>hasCached:ifTrue: (in category 'as yet unclassified') -----
- hasCached: char ifTrue: twoArgBlock
 
+ | value triplet |
- | value elem |
  value := char asciiValue.
+ triplet := cache at: (map at: value ifAbsent: [^ false]).
+ triplet ifNil: [^ false].
+ (triplet at: 1) ~= value ifTrue: [^ false].
+ (triplet at: 2) ~= foregroundColor ifTrue: [^ false].
+ ^ aBlock value: (triplet at: 3).
-
- 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 added:
+ ----- Method: MultiTTCFont>>indexFor: (in category 'all') -----
+ indexFor: char
+
+ | triplet |
+ map size > 511 ifTrue: [
+ cacheIndex _ 512 atRandom.
+ triplet := self cache at: cacheIndex.
+ triplet ifNotNil: [map removeKey: (triplet at: 1) ifAbsent: []].
+ ^ cacheIndex
+ ].
+ ^ (cacheIndex := cacheIndex + 1 \\ 512) + 1.
+ !

Item was added:
+ ----- Method: MultiTTCFont>>initialize (in category 'all') -----
+ initialize
+
+ super initialize.
+ cacheIndex := 511.
+ !

Item was added:
+ ----- Method: MultiTTCFont>>recreateCache (in category 'all') -----
+ recreateCache
+
+ cache := WeakArray new: 512.
+ map := IdentityDictionary new: 512.
+ !

Item was changed:
+ ----- Method: MultiTTCFont>>widthOf: (in category 'all') -----
- ----- Method: MultiTTCFont>>widthOf: (in category 'as yet unclassified') -----
  widthOf: char
 
+ ^ (self formOf: char) width.
- "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 added:
+ ----- Method: TTCFont class>>indexOfSubfamilyName: (in category 'other') -----
+ 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 changed:
  ----- 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 changed:
  ----- 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 class indexOfSubfamilyName: aName!
- self error: 'please add the missing synonym ', aName, ' to the lookup table in TextStyle>>decodeStyleName:'.
-
- ^0.!

Item was changed:
  ----- Method: TTCFont>>installOn:foregroundColor:backgroundColor: (in category 'friend') -----
  installOn: aDisplayContext foregroundColor: fgColor backgroundColor: bgColor
  self foregroundColor: fgColor. "install color"
+ (self fallbackFont notNil and: [ self fallbackFont class = TTCFontSet ]) ifTrue: [
+ self fallbackFont fontArray do: [:font |
+ font ifNotNil: [ font foregroundColor: fgColor ]
+ ]
+ ].  "install color for fallbackFont"
  aDisplayContext installTTCFont: self foregroundColor: foregroundColor backgroundColor: bgColor
  !

Item was added:
+ ----- Method: TTCFont>>recreateCache (in category 'friend') -----
+ recreateCache
+
+ cache := WeakArray new: 256.!

Item was changed:
  ----- Method: TTCFont>>textStyle (in category 'accessing') -----
  textStyle
+
+ ^ TextStyle actualTextStyles
+ detect: [:aStyle | (aStyle fontArray collect: [:s | s name]) includes: self name]
+ ifNone: [nil]!
- ^ TextStyle actualTextStyles detect:
- [:aStyle | aStyle fontArray includes: self] ifNone: [nil]!

Item was changed:
+ ----- Method: TTCFontDescription class>>addFromTTFile: (in category 'instance creations') -----
- ----- 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 |
- | tt old |
  (fileName asLowercase endsWith: 'ttf') ifTrue: [
  tt := TTCFontReader readTTFFrom: (FileStream readOnlyFileNamed: fileName).
  ] ifFalse: [
  tt := TTCFontReader readFrom: (FileStream readOnlyFileNamed: fileName).
  ].
+
+ self addToDescription: tt.
-
- 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 changed:
+ ----- Method: TTCFontDescription class>>descriptionNamed:at: (in category 'accessing') -----
- ----- 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>>name (in category 'accessing') -----
- name
-
- ^ self familyName copyWithout: Character space.
- !

Item was removed:
- ----- Method: TTCFontDescription>>veryDeepCopyWith: (in category 'copying') -----
- veryDeepCopyWith: deepCopier
- "Return self.  I am shared.  Do not record me."
- !

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 changed:
  ----- 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: [ "???"
+ | g |
+ g := glyphs at: value+1.
+ (g isKindOf: TTCompositeGlyph) ifFalse: [
+ encode1 at: i+1 put: g.
+ ] ifTrue: [
+ g basicGlyphs: (((glyphs at: value+1) basicGlyphs) collect: [:t | t key->(glyphs at: (t value glyphIndex+1))]).
+ encode1 at: i+1 put: g
+ ].
- encode1 at: i+1 put: (glyphs at: value+1).
  ]
  ].
 
  ^ {encode0. encode1}.
  !

Item was changed:
  ----- 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"
+ (#(0 1 3) includes: pID) ifTrue: [
+ (assoc notNil and: [assoc key = pID]) ifFalse: [
+ "Go to the beginning of the table"
+ copy := entry copy.
+ copy offset: initialOffset + offset.
+ cmap := self decodeCmapFmtTable: copy.
+ (pID = 0 and: [cmap notNil]) "Prefer Unicode encoding over everything else"
+ ifTrue: [^ pID -> cmap].
+ "(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 better 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 changed:
  ----- 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.
+ ^ fonts gather: [:offset |
- ^ ((Array with: fonts first) collect: [:offset |
  fontDescription := TTCFontDescription new.
+ self readFrom: fontData fromOffset: offset at: EncodingTag]!
- self readFrom: fontData fromOffset: offset at: EncodingTag.
- ]) at: 1.
- !

Item was changed:
  ----- 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: (array at: 1)..
+ fontDescription1 setGlyphs: (array at: 2) mapping: (array at: 2)..
+ fontDescription0 setKernPairs: kernPairs.
+ fontDescription1 setKernPairs: kernPairs.
- 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 changed:
  AbstractFont subclass: #TTCFontSet
+ instanceVariableNames: 'name fontArray foregroundColor derivatives'
+ classVariableNames: ''
- instanceVariableNames: 'name fontArray foregroundColor'
- classVariableNames: 'Registry'
  poolDictionaries: ''
  category: 'TrueType-Fonts'!

Item was changed:
+ ----- Method: TTCFontSet class>>discardDefault (in category 'private') -----
- ----- 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 changed:
+ ----- Method: TTCFontSet class>>familyName:pointSize: (in category 'instance creation') -----
- ----- Method: TTCFontSet class>>familyName:pointSize: (in category 'as yet unclassified') -----
  familyName: n pointSize: s
 
+ "(self familyName: 'MSGothic' pointSize: 14) pointSize"
- "(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 added:
+ ----- Method: TTCFontSet class>>familyName:pointSize:emphasized: (in category 'instance creation') -----
+ familyName: n pointSize: s emphasized: code
+
+
+ | 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 emphasis: code
+ ].
+ ^ ((TextStyle named: n) addNewFontSize: s) emphasis: code.!

Item was added:
+ ----- Method: TTCFontSet class>>getExistings: (in category 'private') -----
+ 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 changed:
+ ----- Method: TTCFontSet class>>initialize (in category 'class initialization') -----
- ----- Method: TTCFontSet class>>initialize (in category 'as yet unclassified') -----
  initialize
  "
  self initialize
  "
 
  | tt |
  tt := TTCFontDescription default.
  tt ifNotNil: [self newTextStyleFromTT: tt].
  !

Item was changed:
+ ----- Method: TTCFontSet class>>newFontArray: (in category 'private') -----
- ----- Method: TTCFontSet class>>newFontArray: (in category 'as yet unclassified') -----
  newFontArray: anArray
   
  ^super new initializeWithFontArray: anArray
  !

Item was changed:
+ ----- Method: TTCFontSet class>>newTextStyleFromTT: (in category 'file out/in') -----
- ----- Method: TTCFontSet class>>newTextStyleFromTT: (in category 'as yet unclassified') -----
  newTextStyleFromTT: descriptionArray
 
+ | array f arrayOfArray |
- | array textStyle styleName arrayOfArray |
 
  arrayOfArray := self pointSizes collect: [:pt |
+ descriptionArray collect: [:ttc |
- descriptionArray collect: [:ttc | | f |
  ttc ifNil: [nil] ifNotNil: [
  f := (ttc size > 256)
+ ifTrue: [MultiTTCFont new]
+ ifFalse: [TTCFont new].
- ifTrue: [MultiTTCFont new initialize]
- ifFalse: [TTCFont new initialize].
  f ttcDescription: ttc.
  f pointSize: pt.
  ].
  ].
  ].
 
  array := arrayOfArray collect: [:fonts |
  self newFontArray: fonts.
  ].
 
+ ^TTCFont reorganizeForNewFontArray: array name: array first familyName asSymbol.
+ "
  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 changed:
+ ----- Method: TTCFontSet class>>newTextStyleFromTTFile: (in category 'file out/in') -----
- ----- 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 added:
+ ----- Method: TTCFontSet class>>newTextStyleFromTTFile:encodingTag:ranges: (in category 'file out/in') -----
+ newTextStyleFromTTFile: fileName encodingTag: encodingTag ranges: ranges
+
+ | description |
+ description := TTFontDescription addSetFromTTFile: fileName encodingTag: encodingTag ranges: ranges.
+ self newTextStyleFromTT: description.
+ ^ description.
+ !

Item was changed:
+ ----- Method: TTCFontSet class>>pointSizes (in category 'accessing') -----
- ----- Method: TTCFontSet class>>pointSizes (in category 'as yet unclassified') -----
  pointSizes
 
  ^ TTCFont pointSizes.
  !

Item was changed:
+ ----- Method: TTCFontSet class>>register:at: (in category 'registry') -----
- ----- Method: TTCFontSet class>>register:at: (in category 'as yet unclassified') -----
  register: anObject at: symbolName
 
  self registry at: symbolName put: anObject.
  !

Item was changed:
+ ----- Method: TTCFontSet class>>registry (in category 'registry') -----
- ----- Method: TTCFontSet class>>registry (in category 'as yet unclassified') -----
  registry
+
+ ^ TTCFont registry.
+ !
- ^ Registry
- ifNil: [Registry := IdentityDictionary new]!

Item was changed:
+ ----- Method: TTCFontSet class>>removeStyleName: (in category 'registry') -----
- ----- 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 changed:
+ ----- Method: TTCFontSet class>>setDefault (in category 'private') -----
- ----- 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 changed:
+ ----- Method: TTCFontSet class>>unregister: (in category 'registry') -----
- ----- Method: TTCFontSet class>>unregister: (in category 'as yet unclassified') -----
  unregister: symbolName
 
  self registry removeKey: symbolName ifAbsent: [].
  !

Item was added:
+ ----- Method: TTCFontSet>>addLined: (in category 'derivatives') -----
+ 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 added:
+ ----- Method: TTCFontSet>>derivativeFont: (in category 'derivatives') -----
+ derivativeFont: aTTCFont
+
+ | index |
+ index := TTCFont 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 added:
+ ----- Method: TTCFontSet>>derivativeFont:at: (in category 'derivatives') -----
+ derivativeFont: aTTCFontSet at: index
+
+ | newDeriv |
+ aTTCFontSet 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: aTTCFontSet
+ !

Item was added:
+ ----- Method: TTCFontSet>>derivativeFonts (in category 'derivatives') -----
+ derivativeFonts
+
+ derivatives ifNil: [^ #()].
+ ^derivatives copyWithout: nil!

Item was added:
+ ----- Method: TTCFontSet>>emphasis: (in category 'derivatives') -----
+ emphasis: code
+
+ code > 3 ifTrue: [^ self].
+ code = 0 ifTrue: [^ self].
+ derivatives isNil ifTrue: [^ self].
+ ^ (derivatives at: code) ifNil: [self].
+ !

Item was changed:
  ----- Method: TTCFontSet>>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 changed:
  ----- Method: TTCFontSet>>familyName (in category 'accessing') -----
  familyName
 
+ ^ (fontArray at: 1) familyName.
- ^ 'Multi', (fontArray at: 1) familyName.
  !

Item was added:
+ ----- Method: TTCFontSet>>hasGlyphWithFallbackOf: (in category 'accessing') -----
+ hasGlyphWithFallbackOf: aCharacter
+
+ | index f |
+ index := aCharacter leadingChar +1.
+ fontArray size < index ifTrue: [^ false].
+ (f := fontArray at: index) ifNil: [^ false].
+
+ ^ f hasGlyphWithFallbackOf: aCharacter.
+ !

Item was changed:
+ ----- Method: TTCFontSet>>initializeWithFontArray: (in category 'initialization') -----
- ----- Method: TTCFontSet>>initializeWithFontArray: (in category 'as yet unclassified') -----
  initializeWithFontArray: anArray
 
  fontArray := anArray.
  "name := anArray first name."
  !

Item was changed:
+ ----- Method: TTCFontSet>>installOn: (in category 'displaying private') -----
- ----- Method: TTCFontSet>>installOn: (in category 'as yet unclassified') -----
  installOn: aDisplayContext
 
  ^aDisplayContext installTTCFont: self.
  !

Item was changed:
+ ----- Method: TTCFontSet>>installOn:foregroundColor:backgroundColor: (in category 'displaying private') -----
- ----- 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 added:
+ ----- Method: TTCFontSet>>isRegular (in category 'testing') -----
+ isRegular
+ "Answer true if I am a Regular/Roman font (i.e. not bold, etc.)"
+ ^ (TTCFont indexOfSubfamilyName: (self subfamilyName)) = 0.
+ !

Item was added:
+ ----- Method: TTCFontSet>>pointSize: (in category 'derivatives') -----
+ pointSize: aNumber
+
+ self privatePointSize: aNumber.
+ derivatives ifNotNil: [ derivatives do: [ :f | f ifNotNil: [ f privatePointSize: aNumber ]]].
+ !

Item was added:
+ ----- Method: TTCFontSet>>privatePointSize: (in category 'derivatives') -----
+ privatePointSize: aNumber
+ fontArray do: [:f |
+ f privatePointSize: aNumber
+ ].
+ !

Item was changed:
  ----- Method: TTCFontSet>>questionGlyphInfoInto: (in category 'private') -----
  questionGlyphInfoInto: glyphInfoArray
  "return glyph info for the question mark character in the first font of the fontArray -sort of a default set of info"
  | 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 ascentOf: $?);
+ at: 5 put: self.
- at: 4 put: self.
  ^ glyphInfoArray.
  !

Item was added:
+ ----- Method: TTCFontSet>>subfamilyName (in category 'accessing') -----
+ subfamilyName
+
+ ^ fontArray first ttcDescription subfamilyName.
+ !

Item was changed:
+ ----- Method: TTCFontSet>>ttcDescription (in category 'accessing') -----
- ----- Method: TTCFontSet>>ttcDescription (in category 'as yet unclassified') -----
  ttcDescription
  ^ fontArray first ttcDescription!

Item was changed:
  ----- Method: TTCFontSet>>widthOf: (in category 'measuring') -----
  widthOf: aCharacter
 
+ | encoding font |
- | encoding |
  encoding := aCharacter leadingChar.
+ encoding >= fontArray size ifFalse: [
+ font := (fontArray at: encoding + 1).
+ font ifNotNil: [^ font widthOf: aCharacter].
+ ].
+ ^ (fontArray at: 1) widthOf: aCharacter.
- ^ (fontArray at: encoding + 1) widthOf: aCharacter.
  !

Item was added:
+ ----- Method: TTCompositeGlyph>>basicGlyphs (in category 'accessing') -----
+ basicGlyphs
+
+ ^ glyphs
+ !

Item was added:
+ ----- Method: TTCompositeGlyph>>basicGlyphs: (in category 'accessing') -----
+ basicGlyphs: colOfAssocs
+
+ glyphs := colOfAssocs
+ !

Item was changed:
  Object subclass: #TTFileDescription
+ instanceVariableNames: 'fileName fileOffset familyName subfamilyName copyright ascender descender lineGap unitsPerEm numGlyphs indexToLocOffset indexToLocFormat glyphTableOffset cmapType cmapOffset numHMetrics hmtxTableOffset sTypoAscender sTypoDescender sTypoLineGap'
- instanceVariableNames: 'fileName fileOffset familyName subfamilyName ascender descender lineGap unitsPerEm numGlyphs indexToLocOffset indexToLocFormat glyphTableOffset cmapType cmapOffset numHMetrics hmtxTableOffset sTypoAscender sTypoDescender sTypoLineGap'
  classVariableNames: 'AllFontsAndFiles FontPaths OfferNonPortableFonts'
  poolDictionaries: ''
  category: 'TrueType-Fonts'!
 
  !TTFileDescription commentStamp: 'ar 7/29/2009 22:18' prior: 0!
  Contrary to TTFontDescritption, this class leaves true type files on disk and only reads the required portions when constructing glyphs. This avoids the need of reading the entire font into memory at the cost of having to hit disk whenever a glyph is requested.!

Item was added:
+ ----- Method: TTFileDescription>>copyright (in category 'accessing') -----
+ copyright
+
+ ^ copyright!

Item was added:
+ ----- Method: TTFileDescription>>fallbackGlyph (in category 'glyphs') -----
+ fallbackGlyph
+ "Answer the fallback glyph, the first in the loca table "
+ | glyph |
+ self withFileDo:[:fontFile|
+ glyph := self readGlyphAt: 0 fromFile: fontFile.
+ self updateGlyphMetrics: glyph fromFile: fontFile.
+ ].
+ ^glyph!

Item was added:
+ ----- Method: TTFileDescription>>isRegular (in category 'testing') -----
+ isRegular
+ "Answer true if I am a Regular/Roman font (i.e. not bold, etc.)"
+ ^ (TTCFont indexOfSubfamilyName: (self subfamilyName)) = 0.
+ !

Item was changed:
  ----- Method: TTFileDescription>>processNamingTable: (in category 'ttf tables') -----
  processNamingTable: fontFile
  "copyright         CHARPTR     The font's copyright notice.
  familyName        CHARPTR     The font's family name.
  subfamilyName     CHARPTR     The font's subfamily name.
  uniqueName        CHARPTR     A unique identifier for this font.
  fullName          CHARPTR     The font's full name (a combination of
                                            familyName and subfamilyName).
  versionName       CHARPTR     The font's version string.
  "
  | nRecords initialOffset storageOffset format |
  initialOffset := fontFile position.
  format := fontFile nextNumber: 2.
  format = 0 ifFalse: [self error: 'Cannot handle format 1 naming tables'].
  "Get the number of name records"
  nRecords := fontFile nextNumber: 2.
  "Offset from the beginning of this table"
  storageOffset := (fontFile nextNumber: 2) + initialOffset.
  1 to: nRecords do:[:i| |  pID sID lID nID length offset string |
  fontFile position: initialOffset + 6 + ((i-1) * 12).
  pID := fontFile nextNumber: 2.
  sID := fontFile nextNumber: 2.
  lID := fontFile nextNumber: 2.
  nID := fontFile nextNumber: 2.
  length := fontFile nextNumber: 2.
  offset := fontFile nextNumber: 2.
  "Read only Macintosh or Microsoft strings"
  (pID = 1 or:[pID = 3 and:[sID = 1]]) ifTrue:[
  "MS uses Unicode all others single byte"
  "multiBytes := pID = 3."
  fontFile position: storageOffset+offset.
  string := (fontFile next: length) asString.
  pID = 3 ifTrue:[ | keep |
  keep := true.
  string := string select:[:ch| keep := keep not].
  ].
  "Select only English names, prefer Macintosh"
  ((pID = 1 and: [lID = 0]) or: [pID = 3 and: [lID = 16r0409]]) ifTrue: [
  nID caseOf: {
+ [0] -> [(pID = 1 or:[copyright == nil]) ifTrue:[copyright := string]].
- "[0] -> [copyright := string]."
  [1] -> [(pID = 1 or:[familyName == nil]) ifTrue:[familyName := string]].
  [2] -> [(pID = 1 or:[subfamilyName == nil]) ifTrue:[subfamilyName := string]].
  "[3] -> [(pID = 1 or:[uniqueName == nil]) ifTrue:[uniqueName := string]]."
  "[4] -> [(pID = 1 or:[fullName == nil]) ifTrue:[fullName := string]]."
  "[5] -> [(pID = 1 or:[versionName == nil]) ifTrue:[versionName := string]]."
  "[6] -> [(pID = 1 or:[postscriptName == ni]) ifTrue:[postscriptName := string]]."
  "[7] -> [(pID = 1 or:[trademark == nil]) ifTrue:[trademark := string]]."
  } otherwise:["ignore"].
  ]
  ].
  ].
  !

Item was added:
+ ----- Method: TTFileDescription>>renderFallbackGlyphOfHeight:fgColor:bgColor:depth: (in category 'rendering') -----
+ renderFallbackGlyphOfHeight: height fgColor: fgColor bgColor: bgColor depth: depth
+ "Render the glyph with the given code point at the specified pixel height."
+ ^ self fallbackGlyph
+ asFormWithScale: height asFloat / (ascender - descender)
+ ascender: ascender
+ descender: descender
+ fgColor: fgColor bgColor: bgColor depth: depth!

Item was added:
+ ----- Method: TTFontDescription class>>addFromSmartRefStream: (in category 'instance creation') -----
+ addFromSmartRefStream: ref
+
+ | tts |
+ tts := ref nextAndClose.
+
+ ^ tts collect: [:tt |
+ self addToDescription: tt.
+ ].
+ !

Item was changed:
+ ----- Method: TTFontDescription class>>addFromTTFile: (in category 'instance creation') -----
- ----- Method: TTFontDescription class>>addFromTTFile: (in category 'instance creations') -----
  addFromTTFile: fileName
  "
  self addFromTTFile: 'C:\WINDOWS\Fonts\ARIALN.TTF'
  "
  ^self addFromTTStream: (FileStream readOnlyFileNamed: fileName).
  !

Item was changed:
+ ----- Method: TTFontDescription class>>addFromTTStream: (in category 'instance creation') -----
- ----- Method: TTFontDescription class>>addFromTTStream: (in category 'instance creations') -----
  addFromTTStream: readStream
  "
  self addFromTTFile: 'C:\WINDOWS\Fonts\ARIALN.TTF'
  "
 
+ | tt |
- | tt old |
  tt := TTFontReader readFrom: readStream.
+ tt := self addToDescription: tt.
+ tt blankGlyphForSeparators.
- old := Descriptions detect: [:f | f name = tt name and: [f subfamilyName = tt subfamilyName]] ifNone: [nil].
- old ifNotNil: [Descriptions remove: old].
- Descriptions add: tt.
  ^ tt.
  !

Item was added:
+ ----- Method: TTFontDescription class>>addSetFromTTFile:encodingTag:ranges: (in category 'instance creation') -----
+ addSetFromTTFile: fileName encodingTag: encodingTag ranges: ranges
+
+ | tt |
+ (fileName asLowercase endsWith: 'ttf') ifTrue: [
+ tt := TTCFontReader readTTFFrom: (FileStream readOnlyFileNamed: fileName).
+ ] ifFalse: [
+ tt := TTCFontReader readFrom: (FileStream readOnlyFileNamed: fileName).
+ ].
+
+ (tt at: encodingTag + 1) compactForRanges: ranges.
+ ^ self addToDescription: tt.
+ !

Item was added:
+ ----- Method: TTFontDescription class>>addToDescription: (in category 'instance creation') -----
+ addToDescription: tt
+
+ | old new |
+ old := Descriptions detect: [:f | f first fullName = tt first fullName] ifNone: [nil].
+ ^ old ifNotNil: [
+ new := old, (Array new: ((tt size - old size) max: 0)).
+ 1 to: tt size do: [:ind |
+ (tt at: ind) ifNotNil: [
+ new at: ind put: (tt at: ind)
+ ].
+ ].
+ Descriptions remove: old.
+ Descriptions add: new.
+ new.
+ ] ifNil: [
+ Descriptions add: tt.
+ tt.
+ ]
+ !

Item was changed:
+ ----- Method: TTFontDescription class>>clearDefault (in category 'instance creation') -----
- ----- Method: TTFontDescription class>>clearDefault (in category 'instance creations') -----
  clearDefault
  "
  self clearDefault
  "
 
  Default := nil.
  !

Item was changed:
+ ----- Method: TTFontDescription class>>clearDescriptions (in category 'instance creation') -----
- ----- Method: TTFontDescription class>>clearDescriptions (in category 'instance creations') -----
  clearDescriptions
  "
  self clearDescriptions
  "
 
  Descriptions := Set new.
  Default ifNotNil: [Descriptions add: Default].
  !

Item was changed:
+ ----- Method: TTFontDescription class>>default (in category 'instance creation') -----
- ----- Method: TTFontDescription class>>default (in category 'instance creations') -----
  default
  ^ Default!

Item was changed:
+ ----- Method: TTFontDescription class>>descriptionFullNamed: (in category 'instance creation') -----
- ----- Method: TTFontDescription class>>descriptionFullNamed: (in category 'instance creations') -----
  descriptionFullNamed: descriptionFullName
  ^ Descriptions
+ detect: [:f | f first fullName = descriptionFullName]
- detect: [:f | f fullName = descriptionFullName]
  ifNone: [Default]!

Item was added:
+ ----- Method: TTFontDescription class>>descriptionFullNamed:at: (in category 'instance creation') -----
+ descriptionFullNamed: descriptionFullName at: index
+ | ans |
+ ans := Descriptions
+ detect: [:f | f first fullName = descriptionFullName]
+ ifNone: [Default].
+ index > 0 ifTrue: [^ ans at: index].
+ ^ ans.
+ !

Item was changed:
+ ----- Method: TTFontDescription class>>descriptionNamed: (in category 'instance creation') -----
- ----- Method: TTFontDescription class>>descriptionNamed: (in category 'instance creations') -----
  descriptionNamed: descriptionName
 
+ ^ Descriptions detect: [:f | f first name = descriptionName] ifNone: [Default].
- ^ Descriptions detect: [:f | f name = descriptionName] ifNone: [Default].
  !

Item was added:
+ ----- Method: TTFontDescription class>>foo (in category 'instance creation') -----
+ foo!

Item was changed:
+ ----- Method: TTFontDescription class>>initialize (in category 'class initialization') -----
- ----- Method: TTFontDescription class>>initialize (in category 'instance creations') -----
  initialize
  "
  self initialize
  "
 
  self clearDescriptions.
  !

Item was changed:
+ ----- Method: TTFontDescription class>>removeDescriptionNamed: (in category 'instance creation') -----
- ----- Method: TTFontDescription class>>removeDescriptionNamed: (in category 'instance creations') -----
  removeDescriptionNamed: descriptionName
 
  | tt |
  Descriptions ifNil: [^ self].
+ [(tt :=  Descriptions detect: [:f | f first name = descriptionName] ifNone: [nil]) notNil] whileTrue:[
- [(tt :=  Descriptions detect: [:f | f name = descriptionName] ifNone: [nil]) notNil] whileTrue:[
  Descriptions remove: tt
  ].
  !

Item was changed:
+ ----- Method: TTFontDescription class>>removeDescriptionNamed:subfamilyName: (in category 'instance creation') -----
- ----- Method: TTFontDescription class>>removeDescriptionNamed:subfamilyName: (in category 'instance creations') -----
  removeDescriptionNamed: descriptionName subfamilyName: subfamilyName
 
  | tts |
  Descriptions ifNil: [^ self].
  tts := Descriptions select: [:f | f name = descriptionName and: [f subfamilyName = subfamilyName]].
  tts do: [:f | Descriptions remove: f].
  !

Item was changed:
+ ----- Method: TTFontDescription class>>setDefault (in category 'instance creation') -----
- ----- Method: TTFontDescription class>>setDefault (in category 'instance creations') -----
  setDefault
  "
  self setDefault
  "
 
  Default := TTFontReader readFrom: (FileStream readOnlyFileNamed: 'C:\WINDOWS\Fonts\comic.ttf').
  !

Item was added:
+ ----- Method: TTFontDescription>>compactForRanges: (in category 'migration') -----
+ compactForRanges: rangesArray
+
+ | newGlyphTable noMapping |
+ noMapping := glyphs == glyphTable.
+ newGlyphTable :=  SparseLargeTable new: rangesArray last last chunkSize: 32 arrayClass: Array base: 0 + 1 defaultValue: (glyphs at: 1).
+ rangesArray do: [:pair |
+ pair first to: pair second do: [:i |
+ newGlyphTable at: i put: (glyphs at: i)
+ ]
+ ].
+ glyphTable := newGlyphTable.
+ noMapping ifTrue: [glyphs := glyphTable].
+ !

Item was added:
+ ----- Method: TTFontDescription>>fallbackGlyph (in category 'accessing') -----
+ fallbackGlyph
+ "Answer the fallback glyph, the first in the loca table "
+ ^ glyphs at: 1!

Item was added:
+ ----- Method: TTFontDescription>>first (in category 'accessing') -----
+ first
+
+ ^ self.
+ !

Item was added:
+ ----- Method: TTFontDescription>>isRegular (in category 'testing') -----
+ isRegular
+ "Answer true if I am a Regular/Roman font (i.e. not bold, etc.)"
+ ^ (TTCFont indexOfSubfamilyName: (self subfamilyName)) = 0.
+ !

Item was changed:
  ----- Method: TTFontDescription>>objectForDataStream: (in category 'copying') -----
  objectForDataStream: refStrm
+ | dp isCollection |
- | 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:"
 
+ isCollection := (Descriptions detect: [:e | e == self]) isCollection.
+
+ dp := DiskProxy global: #TTFontDescription selector: #descriptionFullNamed:at:
+ args: {self fullName. (isCollection ifTrue: [(TTFontDescription descriptionFullNamed: self fullName) indexOf: self] ifFalse: [0])}.
- dp := DiskProxy global: #TTFontDescription selector: #descriptionFullNamed:
- args: {self fullName}.
  refStrm replace: self with: dp.
  ^ dp.
  !

Item was added:
+ ----- Method: TTFontDescription>>renderFallbackGlyphOfHeight:fgColor:bgColor:depth: (in category 'rendering') -----
+ renderFallbackGlyphOfHeight: height fgColor: fgColor bgColor: bgColor depth: depth
+ "Render the glyph with the given code point at the specified pixel height."
+ ^ self fallbackGlyph
+ asFormWithScale: height asFloat / (ascender - descender)
+ ascender: ascender
+ descender: descender
+ fgColor: fgColor bgColor: bgColor depth: depth!

Item was changed:
  ----- Method: TTFontDescription>>size (in category 'accessing') -----
  size
+
+ ^ glyphTable size.
- "Answer the logical number of characters in this font"
- ^glyphTable size - 1
  !

Item was changed:
  ----- Method: TTFontReader class>>installTTF:asTextStyle:sizes: (in category 'instance creation') -----
  installTTF: ttfFileName asTextStyle: textStyleName sizes: sizeArray
  "Sizes are in pixels."
  "TTFontReader
+ installTTF: 'F:\fonts\amazon__.TTF'
- installTTF: 'F:\fonts\amazon:=:=.TTF'
  asTextStyle: #Amazon
  sizes: #(24 60)"
 
  | ttf fontArray |
  ttf := self parseFileNamed: ttfFileName.
  fontArray := sizeArray collect:
  [:each |
  (ttf asStrikeFontScale: each / ttf unitsPerEm)
  name: textStyleName;
+ pixelSize: each].
- pointSize: each].
  TextConstants at: textStyleName asSymbol put: (TextStyle fontArray: fontArray)!

Item was changed:
  ----- Method: TTFontReader>>decodeCmapFmtTable: (in category 'private') -----
  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"
  entryCount := segments inject: 0 into: [:max :seg | max max: seg second].
  cmap := Array new: entryCount+1 withAll: 0..
  segments withIndexDo:
  [:seg :si | | code |
  seg first to: seg second do:
  [:i |
+ i < 256 ifTrue:
+ [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]]].
- 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]].
  ^ 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 changed:
  ----- Method: TTFontReader>>processCharacterMappingTable: (in category 'processing') -----
  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:[
- "Check if this is either a Unicode (0), Macintosh (1),
- or a Windows (3) encoded table"
- (#(0 1 3) includes: pID) ifTrue:[
  "Go to the beginning of the table"
  copy := entry copy.
  copy offset: initialOffset + offset.
  cmap := self decodeCmapFmtTable: copy.
+ (pID = 3 and: [cmap notNil]) "Prefer Windows encoding over everything else"
- (pID = 0 and: [cmap notNil]) "Prefer Unicode encoding over everything else"
  ifTrue: [^ pID -> cmap].
+ assoc := pID -> cmap. "Keep it in case we don't find a Mac encoded table"
- assoc := pID -> cmap. "Keep it in case we don't find a better table"
  ].
  ].
  ^assoc!

Item was changed:
  ----- Method: TTFontReader>>processCompositeGlyph:contours:from: (in category 'processing') -----
  processCompositeGlyph: glyph contours: nContours from: entry
  "Read a composite glyph from the font data. The glyph passed into this method contains some state variables that must be copied into the resulting composite glyph."
  | flags glyphIndex hasInstr cGlyph ofsX ofsY iLen a11 a12 a21 a22 m |
  cGlyph := TTCompositeGlyph new.
  a11 := a22 := 16r4000. "1.0 in F2Dot14"
  a21 := a12 := 0. "0.0 in F2Dot14"
  "Copy state"
  cGlyph bounds: glyph bounds; glyphIndex: glyph glyphIndex.
  hasInstr := false.
  [ flags := entry nextUShort.
  glyphIndex := entry nextUShort + 1.
  (flags bitAnd: 1) = 1 ifTrue:[
  ofsX := entry nextShort.
  ofsY := entry nextShort.
  ] ifFalse:[
  (ofsX := entry nextByte) > 127 ifTrue:[ofsX := ofsX - 256].
  (ofsY := entry nextByte) > 127 ifTrue:[ofsY := ofsY - 256]].
  ((flags bitAnd: 2) = 2) ifFalse:[self halt].
  (flags bitAnd: 8) = 8 ifTrue:[
  a11 := a22 := entry nextShort].
  (flags bitAnd: 64) = 64 ifTrue:[
  a11 := entry nextShort.
  a22 := entry nextShort].
  (flags bitAnd: 128) = 128 ifTrue:[
  "2x2 transformation"
  a11 := entry nextShort.
  a21 := entry nextShort.
  a12 := entry nextShort.
  a22 := entry nextShort].
  m := MatrixTransform2x3 new.
  "Convert entries from F2Dot14 to float"
  m a11: (a11 asFloat / 16r4000).
  m a12: (a12 asFloat / 16r4000).
  m a21: (a21 asFloat / 16r4000).
  m a22: (a22 asFloat / 16r4000).
  m a13: ofsX.
  m a23: ofsY.
  cGlyph addGlyph: (glyphs at: glyphIndex) transformation: m.
  hasInstr := hasInstr or:[ (flags bitAnd: 256) = 256].
+ "Continue as long as the MORE_COMPONENTS bit is set"
- "Continue as long as the MORE:=COMPONENTS bit is set"
  (flags bitAnd: 32) = 32] whileTrue.
  hasInstr ifTrue:[
  iLen := entry nextUShort.
  entry skip: iLen].
  ^cGlyph!

Item was added:
+ ----- Method: TTFontReader>>processKerningSubTableType0: (in category 'processing') -----
+ processKerningSubTableType0: entry
+
+ | kp nKernPairs |
+ nKernPairs := entry nextUShort.
+ entry skip: 2. "Skip search range"
+ entry skip: 2. "Skip entry selector"
+ entry skip: 2. "Skip range shift"
+ kernPairs := Array new: nKernPairs.
+ 1 to: nKernPairs do:[:i|
+ kp := TTKernPair new.
+ kp left: entry nextUShort.
+ kp right: entry nextUShort.
+ kp value: entry nextShort.
+ kernPairs at: i put: kp].
+ ^true
+ !

Item was changed:
  ----- Method: TTFontReader>>processKerningTable: (in category 'processing') -----
  processKerningTable: entry
  "Extract the kerning information for pairs of glyphs."
+ | version  nTables covLow covHigh |
+ version := entry nextUShort. "Skip table version"
+ nTables := entry nextUShort. "Skip number of sub tables -- we're using the first one only"
+ nTables = 0 ifTrue: [" This detection is hacky "
+ entry skip: -4. "rewind"
+ ^ self processOSXKerningTable: entry].
- | covLow covHigh nKernPairs kp |
- entry skip: 2. "Skip table version"
- entry skip: 2. "Skip number of sub tables -- we're using the first one only"
  entry skip: 2. "Skip current subtable number"
  entry skip: 2. "Skip length of subtable"
  covHigh := entry nextByte.
  covLow := entry nextByte.
 
  "Make sure the format is right (kerning table and format type 0)"
  ((covLow bitAnd: 2) = 2 or:[ covHigh ~= 0]) ifTrue:[^false].
+ "Subtable"
+ ^ self processKerningSubTableType0: entry.
+ !
- nKernPairs := entry nextUShort.
- entry skip: 2. "Skip search range"
- entry skip: 2. "Skip entry selector"
- entry skip: 2. "Skip range shift"
- kernPairs := Array new: nKernPairs.
- 1 to: nKernPairs do:[:i|
- kp := TTKernPair new.
- kp left: entry nextUShort.
- kp right: entry nextUShort.
- kp value: entry nextShort.
- kernPairs at: i put: kp].
- ^true!

Item was added:
+ ----- Method: TTFontReader>>processOSXKerningTable: (in category 'processing') -----
+ processOSXKerningTable: entry
+ "From Apple's TrueType reference:
+
+ Previous versions of the 'kern' table defined both the version and nTables fields in the header as UInt16 values and not UInt32 values. Use of the older format on OS X is discouraged (although AAT can sense an old kerning table and still make correct use of it). Microsoft Windows still uses the older format for the 'kern' table and will not recognize the newer one. Fonts targeted for OS X only should use the new format; fonts targeted for both OS X and Windows should use the old format.
+ "
+ "Extract the kerning information for pairs of glyphs."
+ | version  nTables length coverage tupleIndex |
+ version := entry nextULong. "Skip table version"
+ nTables := entry nextULong. "Skip number of sub tables -- we're using the first one only"
+
+ length := entry nextULong. "Skip length of subtable"
+ coverage := entry nextUShort.
+ tupleIndex := entry nextUShort. "Skip tuple index".
+ "Make sure the format is right (kerning table and format type 0)"
+ coverage = 0 ifFalse: [^false].
+
+ "Subtable"
+ ^ self processKerningSubTableType0: entry.
+ !

Item was changed:
  ----- Method: TTFontReader>>processSimpleGlyph:contours:from: (in category 'processing') -----
  processSimpleGlyph: glyph contours: nContours from: entry
 
  | endPts  nPts iLength flags |
  endPts := Array new: nContours.
  1 to: nContours do:[:i| endPts at: i put: entry nextUShort].
  glyph initializeContours: nContours with: endPts.
+ nContours = 0 ifTrue: [^ self].
  nPts := endPts last + 1.
  iLength := entry nextUShort. "instruction length"
  entry skip: iLength.
  flags := self getGlyphFlagsFrom: entry size: nPts.
  self readGlyphXCoords: entry glyph: glyph nContours: nContours flags: flags endPoints: endPts.
  self readGlyphYCoords: entry glyph: glyph nContours: nContours flags: flags endPoints: endPts.
  glyph buildContours.!

!!! TTFontDescription DNU #collect:

Can you execute "TTCFontSet initialize" safely?

Best,
Marcel

Sorry.
Should be fixed.

On 19.03.2015, at 11:32, Marcel Taeumel <[hidden email]> wrote:

> !!! TTFontDescription DNU #collect:
>
> Can you execute "TTCFontSet initialize" safely?
>
> Best,
> Marcel