Smalltalk › Squeak › Squeak - Dev

[squeak-dev] The Inbox: TrueType-enno.9.mcz

_‹ Previous Topic Next Topic _›

Classic

List

Threaded

1 message

commits-2

[squeak-dev] The Inbox: TrueType-enno.9.mcz

A new version of TrueType was added to project The Inbox:
http://source.squeak.org/inbox/TrueType-enno.9.mcz

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

Name: TrueType-enno.9
Author: enno
Time: 13 September 2009, 5:33:25 am
UUID: c5f974ba-96fc-014c-82cf-1703c7165a52
Ancestors: TrueType-ar.8

incorporates typo fix from
http://code.google.com/p/pharo/issues/detail?id=1045
into trunk

==================== Snapshot ====================

SystemOrganization addCategory: #'TrueType-Fonts'!
SystemOrganization addCategory: #'TrueType-Support'!

Object subclass: #TTContourConstruction
instanceVariableNames: 'points'
classVariableNames: ''
poolDictionaries: ''
category: 'TrueType-Support'!

!TTContourConstruction commentStamp: '<historical>' prior: 0!
This class represents a temporary contour structure during the construction of a TTGlyph from a TrueType file.

Instance variables:
points <Array of: TTPoint> The points defining this contour!

----- Method: TTContourConstruction class>>on: (in category 'instance creation') -----
on: points

^self new points: points!

----- Method: TTContourConstruction>>asCompressedPoints (in category 'converting') -----
asCompressedPoints
"Return the receiver compressed into a PointArray.
All lines will be converted into bezier segments with
the control point set to the start point"
| out minPt maxPt fullRange |
minPt := -16r7FFF asPoint.
maxPt := 16r8000 asPoint.
"Check if we need full 32bit range"
fullRange := points anySatisfy: [:any| any asPoint < minPt or:[any asPoint > maxPt]].
fullRange ifTrue:[
out := WriteStream on: (PointArray new: points size).
] ifFalse:[
out := WriteStream on: (ShortPointArray new: points size).
].
self segmentsDo:[:segment|
out nextPut: segment start.
segment isBezier2Segment
ifTrue:[out nextPut: segment via]
ifFalse:[out nextPut: segment start].
out nextPut: segment end.
].
^out contents!

----- Method: TTContourConstruction>>points (in category 'accessing') -----
points
^points!

----- Method: TTContourConstruction>>points: (in category 'accessing') -----
points: anArray
points := anArray asArray.!

----- Method: TTContourConstruction>>printOn: (in category 'printing') -----
printOn: aStream

aStream
nextPutAll: self class name;
nextPut:$(;
print: points size;
"space;
print: self type;"
nextPut:$)!

----- Method: TTContourConstruction>>segments (in category 'accessing') -----
segments

| segments |
segments := OrderedCollection new.
self segmentsDo:[:seg| segments add: seg].
^segments!

----- Method: TTContourConstruction>>segmentsDo: (in category 'enumerating') -----
segmentsDo: aBlock
"Evaluate aBlock with the segments of the receiver. This may either be straight line
segments or quadratic bezier curves. The decision is made upon the type flags
in TTPoint as follows:
a) Two subsequent #OnCurve points define a straight segment
b) An #OnCurve point followed by an #OffCurve point followed
by an #OnCurve point defines a quadratic bezier segment
c) Two subsequent #OffCurve points have an implicitely defined
#OnCurve point at half the distance between them"
| last next mid index i |
last := points first.
"Handle case where first point is off-curve"
(last type == #OnCurve) ifFalse: [
i := points findFirst: [:pt | pt type == #OnCurve].
i = 0
ifTrue: [mid := TTPoint new
type: #OnCurve;
x: points first x + points last x // 2;
y: points first y + points last y // 2.
points := (Array with: mid), points]
ifFalse: [points := (points copyFrom: i to: points size), (points copyFrom: 1 to: i)].
last := points first].
index := 2.
[index <= points size] whileTrue:[
mid := points at: index.
mid type == #OnCurve ifTrue:[
"Straight segment"
aBlock value: (LineSegment from: last asPoint to: mid asPoint).
last := mid.
] ifFalse:["Quadratic bezier"
"Read ahead if the next point is on curve"
next := (index < points size) ifTrue:[points at: (index+1)] ifFalse:[points first].
next type == #OnCurve ifTrue:[
"We'll continue after the end point"
index := index + 1.
] ifFalse:[ "Calculate center"
next := (next asPoint + mid asPoint) // 2].
aBlock value:(Bezier2Segment from: last asPoint via: mid asPoint to: next asPoint).
last := next].
index := index + 1].
(index = (points size + 1)) ifTrue:[
aBlock value:(LineSegment from: points last asPoint to: points first asPoint)]!

Object subclass: #TTFileDescription
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.!

----- Method: TTFileDescription class>>allFamilyNamesAndFiles (in category 'font paths') -----
allFamilyNamesAndFiles
"Answer a dictionary of all known family names and their corresponding file names."
| names |
AllFontsAndFiles ifNil:[
AllFontsAndFiles := Dictionary new.
Cursor wait showWhile:[self allFontsDo:[:font|
names := AllFontsAndFiles at: font familyName
ifAbsentPut:[OrderedCollection new].
names add: font fileName]]].
^AllFontsAndFiles !

----- Method: TTFileDescription class>>allFontsAndFiles (in category 'font paths') -----
allFontsAndFiles
"Answer a dictionary of all known family names and their corresponding file names."
| names |
AllFontsAndFiles ifNil:[
AllFontsAndFiles := Dictionary new.
Cursor wait showWhile:[self allFontsDo:[:font|
names := AllFontsAndFiles at: font familyName
ifAbsentPut:[OrderedCollection new].
names add: font fileName]]].
^AllFontsAndFiles !

----- Method: TTFileDescription class>>allFontsDo: (in category 'font paths') -----
allFontsDo: aBlock
"Evaluate aBlock with all the fonts we can find. Use sparingly."
self fontPathsDo:[:path|
self fontFilesIn: path do:[:font|
font familyName
ifNotNil:[aBlock value: font]]]!

----- Method: TTFileDescription class>>findFontFile: (in category 'font paths') -----
findFontFile: fontFileName
"Find the path containing the font with the given name.
If it can't be found, return nil."
| fd |
self fontPathsDo:[:path|
fd := FileDirectory on: path.
([fd fileExists: fontFileName] on: Error do:[false])
ifTrue:[^fd fullNameFor: fontFileName].
].
^nil!

----- Method: TTFileDescription class>>fontFilesIn:do: (in category 'font paths') -----
fontFilesIn: path do: aBlock
"TTFileDescription loadAllFilesIn: 'C:\Windows\Fonts'"
"Load all the TTF files we can find in the given path"
| fd |
fd := FileDirectory on: path.
(fd fileNamesMatching: '*.ttf;*.ttc') do:[:fn|
(self readFontsFrom: fn) do:[:font| aBlock value: font]].!

----- Method: TTFileDescription class>>fontFromUser (in category 'user interaction') -----
fontFromUser
"TTFileDescription fontFromUser"
^self fontFromUser: TextStyle defaultFont!

----- Method: TTFileDescription class>>fontFromUser: (in category 'user interaction') -----
fontFromUser: priorFont
^self fontFromUser: priorFont allowKeyboard: true!

----- Method: TTFileDescription class>>fontFromUser:allowKeyboard: (in category 'user interaction') -----
fontFromUser: priorFont allowKeyboard: aBoolean
"TTFileDescription fontFromUser"
| fontMenu active ptMenu label fontNames builder resultBlock result item style font widget |
builder := ToolBuilder default.
fontNames := self allFontsAndFiles keys asArray sort.
fontMenu := builder pluggableMenuSpec new.
fontMenu label: 'Non-portable fonts'.
resultBlock := [:value| result := value].
fontNames do: [:fontName |
active := priorFont familyName sameAs: fontName.
ptMenu := builder pluggableMenuSpec new.
TTCFont pointSizes do: [:pt |
label := pt printString, ' pt'.
item := ptMenu add: label
target: resultBlock
selector: #value:
argumentList: {{fontName. pt}}.
item checked: (active and:[pt = priorFont pointSize]).
].
item := fontMenu add: fontName action: nil.
item subMenu: ptMenu.
item checked: active.
].
widget := builder open: fontMenu.
builder runModal: widget.
result ifNil:[^nil].
style := (TextStyle named: result first) ifNil:[self installFamilyNamed: result first].
style ifNil: [^ self].
font := style fonts detect: [:any | any pointSize = result last] ifNone: [nil].
^ font
!

----- Method: TTFileDescription class>>fontOffsetsInFile: (in category 'instance creation') -----
fontOffsetsInFile: file
"Answer a collection of font offsets in the given file"
| tag version nFonts |
file position: 0.
tag := file next: 4.
tag caseOf:{
['true' asByteArray] -> ["Version 1.0 TTF file"
"http://developer.apple.com/textfonts/TTRefMan/RM06/Chap6.html
The values 'true' (0x74727565) and 0x00010000 are recognized by the Mac OS
as referring to TrueType fonts."
^Array with: 0 "only one font"
].
[#(0 1 0 0) asByteArray] -> ["Version 1.0 TTF file"
^Array with: 0 "only one font"
].
['ttcf' asByteArray] -> ["TTC file"
version := file next: 4.
version = #(0 1 0 0) asByteArray ifFalse:[^self error: 'Unsupported TTC version'].
nFonts := file nextNumber: 4.
^(1 to: nFonts) collect:[:i| file nextNumber: 4].
].
} otherwise:[
self error: 'This is not a valid Truetype file'.
].!

----- Method: TTFileDescription class>>fontPathsDo: (in category 'font paths') -----
fontPathsDo: aBlock
"Evaluate aBlock with all of the font paths that should be searched on the current platform"

"Start with the current directory"
aBlock value: FileDirectory default pathName.

"Then subdirectory 'fonts'"
aBlock value: (FileDirectory default directoryNamed: 'fonts') pathName.

"Platform specific directories"
SmalltalkImage current platformName caseOf:{
['Win32'] -> [
"Standard Windows fonts directory"
aBlock value: 'C:\Windows\Fonts'.
].
['Mac OS'] -> [
"Standard system fonts directory"
aBlock value: '/Library/Fonts'.
].
['unix'] -> [ | base |
"Standard fonts are in /usr/share/fonts/*"
base := '/usr/share/fonts'.
(FileDirectory on: base) directoryNames
do:[:dn| aBlock value: base, '/', dn].
].
} otherwise:[].
!

----- Method: TTFileDescription class>>initialize (in category 'class initialization') -----
initialize
"TTFileDescription initialize"
Smalltalk addToShutDownList: self.
FontPaths := Dictionary new.
AllFontsAndFiles := nil.!

----- Method: TTFileDescription class>>installFamilyNamed: (in category 'instance creation') -----
installFamilyNamed: familyName
"Install all the corresponding fonts for this family"
"
TTFileDescription installFamilyNamed: 'Arial'.
TTFileDescription installFamilyNamed: 'Batang'.
"
| fontFiles ttDesc |
fontFiles := self allFontsAndFiles at: familyName ifAbsent:[#()].
fontFiles do:[:fileName|
ttDesc := (self readFontsFrom: fileName) detect:[:fnt| fnt familyName = familyName].
TTCFont newTextStyleFromTT: ttDesc.
].
^TextStyle named: familyName!

----- Method: TTFileDescription class>>loadAllFontFiles (in category 'examples') -----
loadAllFontFiles
"Load all the TTF files we can find in all font paths"
"
TTFileDescription loadAllFontFiles.
"
self fontPathsDo:[:path| | fd |
fd := FileDirectory on: path.
(fd fileNamesMatching: '*.ttf;*.ttc') do:[:fn|
(self readFontsFrom: fn) do:[:font|
(1 to: font numGlyphs)
do:[:i| font readGlyphAt: i-1]
displayingProgress: 'Reading ', font name].
] displayingProgress: 'Scanning ', path.
].!

----- Method: TTFileDescription class>>offerNonPortableFonts (in category 'user interaction') -----
offerNonPortableFonts
"Should native fonts be offered when displaying font menus?"
<preference: 'Offer Native Fonts'
category: 'Morphic'
description: 'When true, an additional menu is offered for choosing non-portable fonts'
type: #Boolean>
^OfferNonPortableFonts ifNil:[true]!

----- Method: TTFileDescription class>>offerNonPortableFonts: (in category 'user interaction') -----
offerNonPortableFonts: aBool
"Should native fonts be offered when displaying font menus?"
OfferNonPortableFonts := aBool.!

----- Method: TTFileDescription class>>openFontFile:do: (in category 'instance creation') -----
openFontFile: fontFileName do: aBlock
"Open the font with the given font file name"
| fontFilePath file |
fontFilePath := FontPaths at: fontFileName
ifAbsentPut:[self findFontFile: fontFileName].
fontFilePath ifNil:[^nil].
[file := FileStream readOnlyFileNamed: fontFilePath] on: Error do:[:ex|
"We lost the font; someone might have moved it away"
fontFilePath removeKey: fontFileName ifAbsent:[].
^nil
].
^[aBlock value: file binary] ensure:[file close].!

----- Method: TTFileDescription class>>readFontsFrom: (in category 'instance creation') -----
readFontsFrom: aFilename
"Reads and returns all the fonts in the given file"
"
TTFileDescription readFontsFrom: 'batang.ttc'.
"
^self openFontFile: aFilename do:[:file|
(self fontOffsetsInFile: file)
collect:[:offset| self new on: aFilename offset: offset]
thenSelect:[:font| font notNil]].
!

----- Method: TTFileDescription class>>shutDown (in category 'class initialization') -----
shutDown
"Flush my caches"
FontPaths := Dictionary new.
AllFontsAndFiles := nil.!

----- Method: TTFileDescription>>ascender (in category 'accessing') -----
ascender
"Ascender of the font. Relative to unitsPerEm.
Easily confused with the typographic ascender."
^ascender!

----- Method: TTFileDescription>>at: (in category 'accessing') -----
at: charOrCode
"Compatibility with TTFontDescription"
^self glyphAt: charOrCode!

----- Method: TTFileDescription>>childGlyphAt:in:fromFile: (in category 'glyphs') -----
childGlyphAt: glyphIndex in: glyphCache fromFile: fontFile
"Get the glyph with the given glyph index. Look in cache first, then read from file.
Ensure file is positioned at point where it was when it came here."
^glyphCache at: glyphIndex ifAbsentPut:[ | glyph filePos |
filePos := fontFile position.
glyph := self readGlyphAt: glyphIndex fromFile: fontFile.
fontFile position: filePos.
glyph].!

----- Method: TTFileDescription>>descender (in category 'accessing') -----
descender
"Descender of the font. Relative to unitsPerEm.
Easily confused with the typographic descender."
^descender!

----- Method: TTFileDescription>>displayAll (in category 'private') -----
displayAll
"Read all the glyphs and display them"
| glyph form scale points x y |
points := 24.
scale := points asFloat / unitsPerEm.
x := y := 0.
Display deferUpdates: true.
1 to: numGlyphs do:[:i|
glyph := self readGlyphAt: i-1.
form := glyph asFormWithScale: scale
ascender: ascender
descender: descender.
Display fillWhite: (x@y extent: form extent).
form displayOn: Display at: x@y rule: 34.
Display forceToScreen: (x@y extent: form extent).
x := x + form width.
x > Display width ifTrue:[y := y + form height. x := 0].
y > Display height ifTrue:[y := 0].
Sensor anyButtonPressed ifTrue:[^Display restore].
].!

----- Method: TTFileDescription>>familyName (in category 'accessing') -----
familyName
"The family name for the font"
^familyName!

----- Method: TTFileDescription>>fileName (in category 'accessing') -----
fileName
"The name of the Truetype file"
^fileName!

----- Method: TTFileDescription>>findTable:in: (in category 'ttf tables') -----
findTable: tag in: fontFile
"Position the fontFile at the beginning of the table with the given tag.
Answer true if we found the table, false otherwise."
| maxTables chksum offset length table |
fontFile position: fileOffset.
fontFile skip: 4. "version"
maxTables := fontFile nextNumber: 2.
fontFile skip: 6.
1 to: maxTables do:[:i|
table := (fontFile next: 4) asString.
chksum := fontFile nextNumber: 4.
offset := fontFile nextNumber: 4.
length := fontFile nextNumber: 4.
table = tag ifTrue:[
fontFile position: offset.
^true].
].
chksum. length. "fake usage"
^false!

----- Method: TTFileDescription>>fontHeight (in category 'accessing') -----
fontHeight
^ascender - descender!

----- Method: TTFileDescription>>getGlyphFlagsFrom:size: (in category 'glyphs') -----
getGlyphFlagsFrom: fontFile size: nPts
"Read in the flags for this glyph. The outer loop gathers the flags that
are actually contained in the table. If the repeat bit is set in a flag
then the next byte is read from the table; this is the number of times
to repeat the last flag. The inner loop does this, incrementing the
outer loops index each time."
| flags index repCount flagBits |
flags := ByteArray new: nPts.
index := 1.
[index <= nPts] whileTrue:[
flagBits := fontFile next.
flags at: index put: flagBits.
(flagBits bitAnd: 8) = 8 ifTrue:[
repCount := fontFile next.
repCount timesRepeat:[
index := index + 1.
flags at: index put: flagBits]].
index := index + 1].
^flags!

----- Method: TTFileDescription>>glyphAt: (in category 'glyphs') -----
glyphAt: charOrCode
"Answer the glyph with the given code point"
| codePoint glyphIndex glyph |
codePoint := charOrCode asCharacter charCode.
self withFileDo:[:fontFile|
glyphIndex := self readCmapTableAt: codePoint fromFile: fontFile.
glyph := self readGlyphAt: glyphIndex fromFile: fontFile.
self updateGlyphMetrics: glyph fromFile: fontFile.
].
^glyph!

----- Method: TTFileDescription>>lineGap (in category 'accessing') -----
lineGap
"Leading of the font. Relative to unitsPerEm.
Easily confused with the typographic linegap."
^lineGap!

----- Method: TTFileDescription>>name (in category 'accessing') -----
name
"For compatibility with TTFontDescription"
^familyName!

----- Method: TTFileDescription>>numGlyphs (in category 'accessing') -----
numGlyphs
"The number of glyphs represented in this font"
^numGlyphs!

----- Method: TTFileDescription>>on: (in category 'initialize') -----
on: aFileName
"Initialize the receiver from a file name"
fileName := aFileName.
self withFileDo:[:fontFile|
(self findTable: 'head' in: fontFile)
ifFalse:[^self error: 'File does not have a header table'].
self processFontHeaderTable: fontFile.
(self findTable: 'maxp' in: fontFile)
ifFalse:[^self error: 'File does not have a profile table'].
self processMaximumProfileTable: fontFile.
(self findTable: 'name' in: fontFile)
ifFalse:[^self error: 'File does not have a naming table'].
self processNamingTable: fontFile.
(self findTable: 'hhea' in: fontFile)
ifFalse:[^self error: 'File does not have a horizontal header table'].
self processHorizontalHeaderTable: fontFile.
(self findTable: 'hmtx' in: fontFile)
ifFalse:[^self error: 'File does not have a horizontal header table'].
hmtxTableOffset := fontFile position.
(self findTable: 'loca' in: fontFile)
ifFalse:[^self error: 'File does not have a naming table'].
indexToLocOffset := fontFile position.
(self findTable: 'glyf' in: fontFile)
ifFalse:[^self error: 'File does not have a naming table'].
glyphTableOffset := fontFile position.
(self findTable: 'cmap' in: fontFile)
ifFalse:[^self error: 'File does not have a header table'].
self processCharacterMappingTable: fontFile.
].!

----- Method: TTFileDescription>>on:offset: (in category 'initialize') -----
on: aFileName offset: fontOffset
"Initialize the receiver from a file name"
fileName := aFileName.
fileOffset := fontOffset.
self withFileDo:[:fontFile|
"Some bitmap fonts are called .ttf; skip anything that doesn't have a header"
(self findTable: 'head' in: fontFile) ifFalse:[^nil].
self processFontHeaderTable: fontFile.
(self findTable: 'maxp' in: fontFile)
ifFalse:[^self error: 'File does not have a profile table'].
self processMaximumProfileTable: fontFile.
(self findTable: 'name' in: fontFile)
ifFalse:[^self error: 'File does not have a naming table'].
self processNamingTable: fontFile.
(self findTable: 'hhea' in: fontFile)
ifFalse:[^self error: 'File does not have a horizontal header table'].
self processHorizontalHeaderTable: fontFile.
(self findTable: 'OS/2' in: fontFile)
ifTrue:[self processOS2Table: fontFile].
(self findTable: 'hmtx' in: fontFile)
ifFalse:[^self error: 'File does not have a horizontal header table'].
hmtxTableOffset := fontFile position.
(self findTable: 'loca' in: fontFile)
ifFalse:[^self error: 'File does not have a naming table'].
indexToLocOffset := fontFile position.
(self findTable: 'glyf' in: fontFile)
ifFalse:[^self error: 'File does not have a naming table'].
glyphTableOffset := fontFile position.
(self findTable: 'cmap' in: fontFile)
ifFalse:[^self error: 'File does not have a header table'].
self processCharacterMappingTable: fontFile.
].!

----- Method: TTFileDescription>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
aStream nextPutAll: '('; print: fileName; nextPutAll: ')'.!

----- Method: TTFileDescription>>processCharacterMappingTable: (in category 'ttf tables') -----
processCharacterMappingTable: fontFile
"Read the font's character to glyph index mapping table."
| initialOffset nSubTables pID sID offset |
initialOffset := fontFile position.
fontFile skip: 2. "Skip table version"
nSubTables := fontFile nextNumber: 2.
1 to: nSubTables do:[:i|
pID := fontFile nextNumber: 2.
sID := fontFile nextNumber: 2.
offset := fontFile nextNumber: 4.
"Check if this is either a Unicode (0), Macintosh (1),
or a Windows (3) encoded table"
(#(0 1 3) includes: pID) ifTrue:[
cmapType := pID.
cmapOffset := initialOffset + offset.
cmapType = 0 ifTrue:[^self]. "found Unicode table; use it"
].
].!

----- Method: TTFileDescription>>processCompositeGlyph:contours:from: (in category 'glyphs') -----
processCompositeGlyph: glyph contours: nContours from: fontFile
"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 ofsX ofsY iLen a11 a12 a21 a22 m glyphCache |
glyphCache := Dictionary new.
a11 := a22 := 16r4000. "1.0 in F2Dot14"
a21 := a12 := 0. "0.0 in F2Dot14"
"Copy state"
hasInstr := false.
[ flags := fontFile nextNumber: 2.
glyphIndex := fontFile nextNumber: 2.
(flags bitAnd: 1) = 1 ifTrue:[
ofsX := self short: (fontFile nextNumber: 2).
ofsY := self short: (fontFile nextNumber: 2).
] ifFalse:[
(ofsX := fontFile next) > 127 ifTrue:[ofsX := ofsX - 256].
(ofsY := fontFile next) > 127 ifTrue:[ofsY := ofsY - 256].
].
((flags bitAnd: 2) = 2) ifFalse:[
| i1 i2 p1 p2 |
(flags bitAnd: 1) = 1 ifTrue: [
i1 := ofsX + 65536 \\ 65536.
i2 := ofsY + 65536 \\ 65536]
ifFalse: [
i1 := ofsX + 256 \\ 256.
i2 := ofsY + 256 \\ 256].
p1 := glyph referenceVertexAt: i1+1.
p2 := (self childGlyphAt: glyphIndex in: glyphCache fromFile: fontFile) referenceVertexAt: i2+1.
ofsX := p1 x - p2 x.
ofsY := p1 y - p2 y.
].
(flags bitAnd: 8) = 8 ifTrue:[
a11 := a22 := self short: (fontFile nextNumber: 2)].
(flags bitAnd: 64) = 64 ifTrue:[
a11 := self short: (fontFile nextNumber: 2).
a22 := self short: (fontFile nextNumber: 2).
].
(flags bitAnd: 128) = 128 ifTrue:[
"2x2 transformation"
a11 := self short: (fontFile nextNumber: 2).
a21 := self short: (fontFile nextNumber: 2).
a12 := self short: (fontFile nextNumber: 2).
a22 := self short: (fontFile nextNumber: 2).
].
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.
glyph addGlyph: (self childGlyphAt: glyphIndex in: glyphCache fromFile: fontFile) transformation: m.
hasInstr := hasInstr or:[ (flags bitAnd: 256) = 256].
"Continue as long as the MORE:=COMPONENTS bit is set"
(flags bitAnd: 32) = 32] whileTrue.
hasInstr ifTrue:[
iLen := fontFile nextNumber: 2.
fontFile skip: iLen].!

----- Method: TTFileDescription>>processFontHeaderTable: (in category 'ttf tables') -----
processFontHeaderTable: fontFile
"Value Data Type Description
unitsPerEm USHORT Granularity of the font's em square.
xMax USHORT Maximum X-coordinate for the entire font.
xMin USHORT Minimum X-coordinate for the entire font.
yMax USHORT Maximum Y-coordinate for the entire font.
yMin USHORT Minimum Y-coordinate for the entire font.
indexToLocFormat SHORT Used when processing the Index To Loc Table."

fontFile skip: 4. "Skip table version number"
fontFile skip: 4. "Skip font revision number"
fontFile skip: 4. "Skip check sum adjustment"
fontFile skip: 4. "Skip magic number"
fontFile skip: 2. "Skip flags"

unitsPerEm := fontFile nextNumber: 2.

fontFile skip: 8. "Skip creation date"
fontFile skip: 8. "Skip modification date"

"Skip min/max values of all glyphs"
fontFile skip: 2.
fontFile skip: 2.
fontFile skip: 2.
fontFile skip: 2.

fontFile skip: 2. "Skip mac style"
fontFile skip: 2. "Skip lowest rec PPEM"
fontFile skip: 2. "Skip font direction hint"

indexToLocFormat := fontFile nextNumber: 2.
!

----- Method: TTFileDescription>>processHorizontalHeaderTable: (in category 'ttf tables') -----
processHorizontalHeaderTable: fontFile
"
ascender SHORT Typographic ascent.
descender SHORT Typographic descent.
lineGap SHORT Typographic lineGap.
numberOfHMetrics USHORT Number hMetric entries in the HTMX
Table; may be smaller than the total
number of glyphs.
"
fontFile skip: 4. "Skip table version"
ascender := self short: (fontFile nextNumber: 2).
descender := self short: (fontFile nextNumber: 2).
lineGap := self short: (fontFile nextNumber: 2).
fontFile skip: 2. "Skip advanceWidthMax"
fontFile skip: 2. "Skip minLeftSideBearing"
fontFile skip: 2. "Skip minRightSideBearing"
fontFile skip: 2. "Skip xMaxExtent"
fontFile skip: 2. "Skip caretSlopeRise"
fontFile skip: 2. "Skip caretSlopeRun"
fontFile skip: 10. "Skip 5 reserved shorts"
fontFile skip: 2. "Skip metricDataFormat"

numHMetrics := fontFile nextNumber: 2.

^numHMetrics!

----- Method: TTFileDescription>>processMaximumProfileTable: (in category 'ttf tables') -----
processMaximumProfileTable: fontFile
"
numGlyphs USHORT The number of glyphs in the font.
"
fontFile skip: 4. "Skip Table version number"
numGlyphs := fontFile nextNumber: 2.!

----- 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 pID sID nID length offset string |
initialOffset := fontFile position.
fontFile skip: 2. "Skip format selector"
"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|
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].
].
nID caseOf: {
"[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 == nil]) ifTrue:[postscriptName := string]]."
"[7] -> [(pID = 1 or:[trademark == nil]) ifTrue:[trademark := string]]."
} otherwise:["ignore"].
].
].
!

----- Method: TTFileDescription>>processOS2Table: (in category 'ttf tables') -----
processOS2Table: fontFile
"
USHORT version 0x0004
SHORT xAvgCharWidth
USHORT usWeightClass
USHORT usWidthClass
USHORT fsType
SHORT ySubscriptXSize
SHORT ySubscriptYSize
SHORT ySubscriptXOffset
SHORT ySubscriptYOffset
SHORT ySuperscriptXSize
SHORT ySuperscriptYSize
SHORT ySuperscriptXOffset
SHORT ySuperscriptYOffset
SHORT yStrikeoutSize
SHORT yStrikeoutPosition
SHORT sFamilyClass
BYTE panose[10]
ULONG ulUnicodeRange1 Bits 0-31
ULONG ulUnicodeRange2 Bits 32-63
ULONG ulUnicodeRange3 Bits 64-95
ULONG ulUnicodeRange4 Bits 96-127
CHAR achVendID[4]
USHORT fsSelection
USHORT usFirstCharIndex
USHORT usLastCharIndex
SHORT sTypoAscender
SHORT sTypoDescender
SHORT sTypoLineGap
USHORT usWinAscent
USHORT usWinDescent
ULONG ulCodePageRange1 Bits 0-31
ULONG ulCodePageRange2 Bits 32-63
SHORT sxHeight
SHORT sCapHeight
USHORT usDefaultChar
USHORT usBreakChar
USHORT usMaxContext "
| version fsSelection minAscii maxAscii |
version := self short: (fontFile nextNumber: 2). "table version"
version = 0 ifTrue:[^self].
fontFile skip: 60.
fsSelection := fontFile nextNumber: 2.
minAscii := fontFile nextNumber: 2.
maxAscii := fontFile nextNumber: 2.
sTypoAscender := self short: (fontFile nextNumber: 2).
sTypoDescender := self short: (fontFile nextNumber: 2).
sTypoLineGap := self short: (fontFile nextNumber: 2).
!

----- Method: TTFileDescription>>processSimpleGlyph:contours:from: (in category 'glyphs') -----
processSimpleGlyph: glyph contours: nContours from: fontFile
"Construct a simple glyph frm the font file"
| endPts nPts iLength flags |
endPts := Array new: nContours.
1 to: nContours do:[:i| endPts at: i put: (fontFile nextNumber: 2)].
glyph initializeContours: nContours with: endPts.
nContours = 0 ifTrue:[^self].
nPts := endPts last + 1.
iLength := fontFile nextNumber: 2. "instruction length"
fontFile skip: iLength.
flags := self getGlyphFlagsFrom: fontFile size: nPts.
self readGlyphXCoords: fontFile glyph: glyph nContours: nContours flags: flags endPoints: endPts.
self readGlyphYCoords: fontFile glyph: glyph nContours: nContours flags: flags endPoints: endPts.!

----- Method: TTFileDescription>>profileAll (in category 'private') -----
profileAll
"Profile reading all the glyphs"
MessageTally spyOn:[
1 to: numGlyphs do:[:glyphIndex| self readGlyphAt: glyphIndex-1].
].!

----- Method: TTFileDescription>>readCmapTableAt:fromFile: (in category 'glyphs') -----
readCmapTableAt: codePoint fromFile: fontFile
| cmapFmt length firstCode entryCount segCount segIndex startCode endCode idDelta idRangeOffset offset |
fontFile position: cmapOffset.
cmapFmt := fontFile nextNumber: 2.
length := fontFile nextNumber: 2.
fontFile skip: 2. "skip version"

cmapFmt = 0 ifTrue:["byte encoded table"
codePoint > 255 ifTrue:[^0].
length := length - 6. "should be always 256"
length <= 0 ifTrue: [^0]. "but sometimes, this table is empty"
fontFile skip: codePoint. "move to correct byte offset in table"
^fontFile next].

cmapFmt = 4 ifTrue:[ "segment mapping to deltavalues"
codePoint > 16rFFFF ifTrue:[^0].
segCount := (fontFile nextNumber: 2) // 2.
fontFile skip: 6. "skip searchRange, entrySelector, rangeShift"
segIndex := (0 to: segCount-1)
detect:[:i| (endCode := (fontFile nextNumber: 2)) >= codePoint].
fontFile position: cmapOffset + 16 + (segCount*2) + (segIndex*2).
startCode := fontFile nextNumber: 2.
startCode <= codePoint ifFalse:[^0]. "not in segment range"
fontFile position: cmapOffset + 16 + (segCount*4) + (segIndex*2).
idDelta := fontFile nextNumber: 2.
fontFile position: cmapOffset + 16 + (segCount*6) + (segIndex*2).
idRangeOffset := fontFile nextNumber: 2.
idRangeOffset = 0 ifTrue:[^(idDelta + codePoint) bitAnd: 16rFFFF].
offset := (fontFile position - 2) + idRangeOffset + ((codePoint - startCode) * 2).
fontFile position: offset.
^fontFile nextNumber: 2.
].

cmapFmt = 6 ifTrue:[ "trimmed table"
firstCode := fontFile nextNumber: 2.
entryCount := fontFile nextNumber: 2.
(codePoint between: firstCode and: firstCode+entryCount) ifFalse:[^0].
fontFile skip: (codePoint-firstCode) * 2.
^fontFile nextNumber: 2].

^0!

----- Method: TTFileDescription>>readGlyphAt: (in category 'glyphs') -----
readGlyphAt: glyphIndex
| glyph |
self withFileDo:[:fontFile|
glyph := self readGlyphAt: glyphIndex fromFile: fontFile.
self updateGlyphMetrics: glyph fromFile: fontFile.
].
^glyph!

----- Method: TTFileDescription>>readGlyphAt:fromFile: (in category 'glyphs') -----
readGlyphAt: glyphIndex fromFile: fontFile
"Answer the glyph with the given glyph index"
| glyphOffset nextOffset glyphLength glyph nContours left top right bottom |
indexToLocFormat = 0 ifTrue:["Format0: offset/2 is stored"
fontFile position: indexToLocOffset+(glyphIndex * 2).
glyphOffset := (fontFile nextNumber: 2) * 2.
nextOffset := (fontFile nextNumber: 2) * 2.
] ifFalse:["Format1: store actual offset"
fontFile position: indexToLocOffset+(glyphIndex * 4).
glyphOffset := fontFile nextNumber: 4.
nextOffset := fontFile nextNumber: 4.
].
glyphLength := nextOffset - glyphOffset.
glyphLength = 0 ifTrue:[^TTGlyph new glyphIndex: glyphIndex].

fontFile position: glyphTableOffset+glyphOffset.
nContours := self short: (fontFile nextNumber: 2).
left := self short: (fontFile nextNumber: 2).
top := self short: (fontFile nextNumber: 2).
right := self short: (fontFile nextNumber: 2).
bottom := self short: (fontFile nextNumber: 2).
nContours >= 0 ifTrue:[
glyph := TTGlyph new glyphIndex: glyphIndex.
self processSimpleGlyph: glyph contours: nContours from: fontFile.
] ifFalse:[
glyph := TTCompositeGlyph new glyphIndex: glyphIndex.
self processCompositeGlyph: glyph contours: nContours from: fontFile.
].
glyph buildAllContours.
glyph bounds: (left@top corner: right@bottom).
^glyph
!

----- Method: TTFileDescription>>readGlyphXCoords:glyph:nContours:flags:endPoints: (in category 'glyphs') -----
readGlyphXCoords: fontFile glyph: glyph nContours: nContours flags: flags endPoints: endPts
"Read the x coordinates for the given glyph from the font file."
| startPoint endPoint flagBits xValue contour ttPoint |
startPoint := 1.
1 to: nContours do:[:i|
contour := glyph contours at: i.
"Get the end point"
endPoint := (endPts at: i) + 1.
"Store number of points"
startPoint to: endPoint do:[:j|
ttPoint := contour points at: (j - startPoint + 1).
flagBits := flags at: j.
"If bit zero in the flag is set then this point is an on-curve
point, if not, then it is an off-curve point."
(flagBits bitAnd: 1) = 1
ifTrue:[ ttPoint type: #OnCurve]
ifFalse:[ttPoint type: #OffCurve].
"First we check to see if bit one is set. This would indicate that
the corresponding coordinate data in the table is 1 byte long.
If the bit is not set, then the coordinate data is 2 bytes long."
(flagBits bitAnd: 2) = 2 ifTrue:[ "one byte"
xValue := fontFile next.
xValue := (flagBits bitAnd: 16)=16 ifTrue:[xValue] ifFalse:[xValue negated].
ttPoint x: xValue.
] ifFalse:[ "two byte"
"If bit four is set, then this coordinate is the same as the
last one, so the relative offset (of zero) is stored. If bit
is not set, then read in two bytes and store it as a signed value."
(flagBits bitAnd: 16) = 16 ifTrue:[ ttPoint x: 0 ]
ifFalse:[
xValue := self short: (fontFile nextNumber: 2).
ttPoint x: xValue]]].
startPoint := endPoint + 1]!

----- Method: TTFileDescription>>readGlyphYCoords:glyph:nContours:flags:endPoints: (in category 'glyphs') -----
readGlyphYCoords: fontFile glyph: glyph nContours: nContours flags: flags endPoints: endPts
"Read the y coordinates for the given glyph from the font file."
| startPoint endPoint flagBits yValue contour ttPoint |
startPoint := 1.
1 to: nContours do:[:i|
contour := glyph contours at: i.
"Get the end point"
endPoint := (endPts at: i) + 1.
"Store number of points"
startPoint to: endPoint do:[:j|
ttPoint := contour points at: (j - startPoint + 1).
flagBits := flags at: j.
"Check if this value one or two byte encoded"
(flagBits bitAnd: 4) = 4 ifTrue:[ "one byte"
yValue := fontFile next.
yValue := (flagBits bitAnd: 32)=32 ifTrue:[yValue] ifFalse:[yValue negated].
ttPoint y: yValue.
] ifFalse:[ "two byte"
(flagBits bitAnd: 32) = 32 ifTrue:[ ttPoint y: 0 ]
ifFalse:[
yValue := self short: (fontFile nextNumber: 2).
ttPoint y: yValue]]].
startPoint := endPoint + 1]!

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

----- Method: TTFileDescription>>short: (in category 'private') -----
short: aNumber
(aNumber bitAnd: 16r8000) = 0
ifTrue: [^aNumber]
ifFalse: [^-1 - (aNumber bitXor: 16rFFFF)]!

----- Method: TTFileDescription>>size (in category 'accessing') -----
size
"Compatibility with TTFontDescription"
^16rFFFF!

----- Method: TTFileDescription>>subfamilyName (in category 'accessing') -----
subfamilyName
"The subfamily name for the font"
^subfamilyName!

----- Method: TTFileDescription>>typographicAscender (in category 'accessing') -----
typographicAscender
"Microsoft defines this as the 'true typographic metrics' of the font."
^sTypoAscender ifNil:[ascender]!

----- Method: TTFileDescription>>typographicDescender (in category 'accessing') -----
typographicDescender
"Microsoft defines this as the 'true typographic metrics' of the font."
^sTypoDescender ifNil:[descender]!

----- Method: TTFileDescription>>typographicLineGap (in category 'accessing') -----
typographicLineGap
"Microsoft defines this as the 'true typographic metrics' of the font."
^sTypoLineGap ifNil:[lineGap]!

----- Method: TTFileDescription>>updateGlyphMetrics:fromFile: (in category 'glyphs') -----
updateGlyphMetrics: glyph fromFile: fontFile
"Update the horizontal metrics for the given glyph"
| glyphIndex |
glyphIndex := glyph glyphIndex.
glyphIndex <= numHMetrics ifTrue:[
fontFile position: hmtxTableOffset + (glyphIndex*4).
glyph advanceWidth: (fontFile nextNumber: 2).
glyph leftSideBearing: (self short: (fontFile nextNumber: 2)).
] ifFalse:[
fontFile position: hmtxTableOffset + ((numHMetrics-1) *4).
glyph advanceWidth: (fontFile nextNumber: 2).
fontFile position: hmtxTableOffset + (numHMetrics * 4) + ((glyphIndex-numHMetrics)*2).
glyph leftSideBearing: (self short: (fontFile nextNumber: 2)).
].
glyph updateRightSideBearing.!

----- Method: TTFileDescription>>withFileDo: (in category 'initialize') -----
withFileDo: aBlock
"Open the font file for the duration of aBlock"
^self class openFontFile: fileName do: aBlock.!

Object subclass: #TTFontDescription
instanceVariableNames: 'glyphTable glyphs kernPairs copyright familyName fullName subfamilyName uniqueName versionName postscriptName trademark bounds unitsPerEm ascender descender lineGap sTypoAscender sTypoDescender sTypoLineGap'
classVariableNames: 'Default Descriptions'
poolDictionaries: ''
category: 'TrueType-Fonts'!

!TTFontDescription commentStamp: '<historical>' prior: 0!
Holds a TrueType font in memory. Is used by TTSampleStringMorph as its font.

Class owns a default example. !

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

----- Method: TTFontDescription class>>addFromTTStream: (in category 'instance creations') -----
addFromTTStream: readStream
"
self addFromTTFile: 'C:\WINDOWS\Fonts\ARIALN.TTF'
"

| tt old |
tt := TTFontReader readFrom: readStream.
old := Descriptions detect: [:f | f name = tt name and: [f subfamilyName = tt subfamilyName]] ifNone: [nil].
old ifNotNil: [Descriptions remove: old].
Descriptions add: tt.
^ tt.
!

----- Method: TTFontDescription class>>clearDefault (in category 'instance creations') -----
clearDefault
"
self clearDefault
"

Default := nil.
!

----- Method: TTFontDescription class>>clearDescriptions (in category 'instance creations') -----
clearDescriptions
"
self clearDescriptions
"

Descriptions := Set new.
Default ifNotNil: [Descriptions add: Default].
!

----- Method: TTFontDescription class>>default (in category 'instance creations') -----
default
^ Default!

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

----- Method: TTFontDescription class>>descriptionNamed: (in category 'instance creations') -----
descriptionNamed: descriptionName

^ Descriptions detect: [:f | f name = descriptionName] ifNone: [Default].
!

----- Method: TTFontDescription class>>initialize (in category 'instance creations') -----
initialize
"
self initialize
"

self clearDescriptions.
!

----- Method: TTFontDescription class>>removeDescriptionNamed: (in category 'instance creations') -----
removeDescriptionNamed: descriptionName

| tt |
Descriptions ifNil: [^ self].
[(tt := Descriptions detect: [:f | f name = descriptionName] ifNone: [nil]) notNil] whileTrue:[
Descriptions remove: tt
].
!

----- 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].
!

----- Method: TTFontDescription class>>setDefault (in category 'instance creations') -----
setDefault
"
self setDefault
"

Default := TTFontReader readFrom: (FileStream readOnlyFileNamed: 'C:\WINDOWS\Fonts\comic.ttf').
!

----- Method: TTFontDescription>>asStrikeFontScale: (in category 'converting') -----
asStrikeFontScale: scale
"Generate a StrikeFont (actually a FormSetFont) for this TTF font at a given scale."

| forms |
forms := (0 to: 255) collect:
[:i |
(self at: i)
asFormWithScale: scale
ascender: ascender
descender: descender].
^ FormSetFont new
fromFormArray: forms
asciiStart: 0
ascent: (ascender * scale) rounded!

----- Method: TTFontDescription>>ascender (in category 'properties') -----
ascender
"Ascender of the font. Relative to unitsPerEm.
Easily confused with the typographic ascender."
^ascender!

----- Method: TTFontDescription>>at: (in category 'accessing') -----
at: aCharOrInteger
^glyphTable at: aCharOrInteger asInteger+1!

----- Method: TTFontDescription>>at:put: (in category 'accessing') -----
at: index put: value
^self shouldNotImplement!

----- Method: TTFontDescription>>blankGlyphForSeparators (in category 'migration') -----
blankGlyphForSeparators

| space |
space := (self at: Character space charCode) copy.
space contours: #().
Character separators do: [:s |
glyphTable at: s charCode +1 put: space.
].
!

----- Method: TTFontDescription>>bounds (in category 'properties') -----
bounds
^bounds!

----- Method: TTFontDescription>>copyright (in category 'information') -----
copyright
^copyright!

----- Method: TTFontDescription>>deepCopy (in category 'copying') -----
deepCopy

"Since it shouldn't be copied for transmitting or any reason, it returns self."
^ self.
!

----- Method: TTFontDescription>>descender (in category 'properties') -----
descender
"Descender of the font. Relative to unitsPerEm.
Easily confused with the typographic descender."
^descender!

----- Method: TTFontDescription>>familyName (in category 'information') -----
familyName
^familyName!

----- Method: TTFontDescription>>flipAroundY (in category 'private-initialization') -----
flipAroundY
bounds := (bounds origin x @ bounds corner y negated) corner:
(bounds corner x @ bounds origin y negated).
glyphs do:[:glyph| glyph flipAroundY]!

----- Method: TTFontDescription>>fontHeight (in category 'accessing') -----
fontHeight
^ascender - descender!

----- Method: TTFontDescription>>fullName (in category 'information') -----
fullName
^fullName!

----- Method: TTFontDescription>>lineGap (in category 'properties') -----
lineGap
"Leading of the font. Relative to unitsPerEm.
Easily confused with the typographic linegap."
^lineGap!

----- Method: TTFontDescription>>name (in category 'accessing') -----
name

^ self familyName copyWithout: Character space.
!

----- Method: TTFontDescription>>objectForDataStream: (in category 'copying') -----
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: #TTFontDescription selector: #descriptionFullNamed:
args: {self fullName}.
refStrm replace: self with: dp.
^ dp.
!

----- Method: TTFontDescription>>postscriptName (in category 'information') -----
postscriptName
^postscriptName!

----- Method: TTFontDescription>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
aStream nextPut: $(.
familyName printOn: aStream.
aStream nextPut:$).!

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

----- Method: TTFontDescription>>setAscender:descender:lineGap: (in category 'private-initialization') -----
setAscender: asc descender: desc lineGap: lgap
ascender := asc.
descender := desc.
lineGap := lgap!

----- Method: TTFontDescription>>setBounds:unitsPerEm: (in category 'private-initialization') -----
setBounds: aRect unitsPerEm: aNumber
bounds := aRect.
unitsPerEm := aNumber.!

----- Method: TTFontDescription>>setGlyphs:mapping: (in category 'private-initialization') -----
setGlyphs: glyphArray mapping: mappingTable
glyphs := glyphArray.
glyphTable := mappingTable.!

----- Method: TTFontDescription>>setKernPairs: (in category 'private-initialization') -----
setKernPairs: array
kernPairs := array!

----- Method: TTFontDescription>>setStrings: (in category 'private-initialization') -----
setStrings: anArray
copyright := anArray at: 1.
familyName := anArray at: 2.
subfamilyName := anArray at: 3.
uniqueName := anArray at: 4.
fullName := anArray at: 5.
versionName := anArray at: 6.
postscriptName := anArray at: 7.
trademark := anArray at: 8.
!

----- Method: TTFontDescription>>setTypographicAscender:descender:lineGap: (in category 'private-initialization') -----
setTypographicAscender: asc descender: desc lineGap: lGap
sTypoAscender := asc.
sTypoDescender := desc.
sTypoLineGap := lGap.
!

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

----- Method: TTFontDescription>>subfamilyName (in category 'information') -----
subfamilyName
^subfamilyName!

----- Method: TTFontDescription>>trademark (in category 'information') -----
trademark
^trademark!

----- Method: TTFontDescription>>typographicAscender (in category 'accessing') -----
typographicAscender
"Microsoft defines this as the 'true typographic metrics' of the font."
^sTypoAscender ifNil:[ascender]!

----- Method: TTFontDescription>>typographicDescender (in category 'accessing') -----
typographicDescender
"Microsoft defines this as the 'true typographic metrics' of the font."
^sTypoDescender ifNil:[descender]!

----- Method: TTFontDescription>>typographicLineGap (in category 'accessing') -----
typographicLineGap
"Microsoft defines this as the 'true typographic metrics' of the font."
^sTypoLineGap ifNil:[lineGap]!

----- Method: TTFontDescription>>uniqueName (in category 'information') -----
uniqueName
^uniqueName!

----- Method: TTFontDescription>>unitsPerEm (in category 'properties') -----
unitsPerEm
^unitsPerEm!

----- Method: TTFontDescription>>versionName (in category 'information') -----
versionName
^versionName!

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

Object subclass: #TTFontReader
instanceVariableNames: 'charMap glyphs nGlyphs kernPairs infoBar fontDescription'
classVariableNames: ''
poolDictionaries: ''
category: 'TrueType-Support'!

!TTFontReader commentStamp: '<historical>' prior: 0!
TTFontReader constructs a TTFontDescription from a TrueType font (.ttf).!

----- Method: TTFontReader class>>fileReaderServicesForFile:suffix: (in category 'class initialization') -----
fileReaderServicesForFile: fullName suffix: suffix

^(suffix = 'fnt') | (suffix = '*')
ifTrue: [ self services]
ifFalse: [#()]
!

----- Method: TTFontReader class>>initialize (in category 'class initialization') -----
initialize
"self initialize"

FileList registerFileReader: self!

----- 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'
asTextStyle: #Amazon
sizes: #(24 60)"

| ttf fontArray |
ttf := self parseFileNamed: ttfFileName.
fontArray := sizeArray collect:
[:each |
(ttf asStrikeFontScale: each / ttf unitsPerEm)
name: textStyleName;
pointSize: each].
TextConstants at: textStyleName asSymbol put: (TextStyle fontArray: fontArray)!

----- Method: TTFontReader class>>openTTFFile: (in category 'class initialization') -----
openTTFFile: fullName

(TTFontReader parseFileNamed: fullName) asMorph open!

----- Method: TTFontReader class>>parseFileNamed: (in category 'instance creation') -----
parseFileNamed: aString
"TTFontReader parseFileNamed:'c:\windows\fonts\arial.ttf'"
"TTFontReader parseFileNamed:'c:\windows\times.ttf'"
| contents |
contents := (FileStream readOnlyFileNamed: aString) binary contentsOfEntireFile.
^self readFrom: (ReadStream on: contents)!

----- Method: TTFontReader class>>readFrom: (in category 'instance creation') -----
readFrom: aStream

^self new readFrom: aStream!

----- Method: TTFontReader class>>readTTFFrom: (in category 'instance creation') -----
readTTFFrom: aStream

^self new readTTFFrom: aStream!

----- Method: TTFontReader class>>serviceOpenTrueTypeFont (in category 'class initialization') -----
serviceOpenTrueTypeFont

^ SimpleServiceEntry
provider: self
label: 'open true type font'
selector: #openTTFFile:
description: 'open true type font'!

----- Method: TTFontReader class>>services (in category 'class initialization') -----
services

^ Array with: self serviceOpenTrueTypeFont
!

----- Method: TTFontReader class>>unload (in category 'class initialization') -----
unload

FileList unregisterFileReader: self !

----- Method: TTFontReader>>decodeCmapFmtTable: (in category 'private') -----
decodeCmapFmtTable: entry
| cmapFmt length cmap firstCode entryCount segCount segments offset code |
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 |
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]].
^ 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!

----- Method: TTFontReader>>getGlyphFlagsFrom:size: (in category 'private') -----
getGlyphFlagsFrom: entry size: nPts
"Read in the flags for this glyph. The outer loop gathers the flags that
are actually contained in the table. If the repeat bit is set in a flag
then the next byte is read from the table; this is the number of times
to repeat the last flag. The inner loop does this, incrementing the
outer loops index each time."
| flags index repCount flagBits |
flags := ByteArray new: nPts.
index := 1.
[index <= nPts] whileTrue:[
flagBits := entry nextByte.
flags at: index put: flagBits.
(flagBits bitAnd: 8) = 8 ifTrue:[
repCount := entry nextByte.
repCount timesRepeat:[
index := index + 1.
flags at: index put: flagBits]].
index := index + 1].
^flags!

----- Method: TTFontReader>>getTableDirEntry:from: (in category 'private') -----
getTableDirEntry: tagString from: fontData
"Find the table named tagString in fontData and return a table directory entry for it."
| nTables pos currentTag tag |
nTables := fontData shortAt: 5 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.
1 to: nTables do:[:i|
currentTag := fontData longAt: pos bigEndian: true.
currentTag = tag ifTrue:[^TTFontTableDirEntry on: fontData at: pos].
pos := pos+16].
^nil!

----- Method: TTFontReader>>macToWin: (in category 'private') -----
macToWin: index
^ (index - 1) asCharacter macToSqueak asciiValue + 1!

----- Method: TTFontReader>>processCharMap: (in category 'processing') -----
processCharMap: assoc
"Process the given character map"

| charTable glyph cmap |
cmap := assoc value.

assoc key = 0 ifTrue: "Unicode table"
[charTable := SparseLargeTable new: cmap size
chunkSize: 256 arrayClass: Array base: 1
defaultValue: glyphs first.
1 to: charTable size do:
[:i |
glyph := glyphs at: (cmap at: i) + 1 ifAbsent: [glyphs first].
charTable at: i put: glyph].
charTable zapDefaultOnlyEntries.
^charTable].

charTable := Array new: 256 withAll: glyphs first. "Initialize with default glyph"

assoc key = 1 ifTrue: "Mac encoded table"
[1 to: (cmap size min: charTable size) do:
[:i |
glyph := glyphs at: (cmap at: i) + 1.
charTable at: (self macToWin: i) put: glyph]].

assoc key = 3 ifTrue: "Win encoded table"
[1 to: (cmap size min: charTable size) do:
[:i |
glyph := glyphs at: (cmap at: i) + 1.
charTable at: i put: glyph]].

^ charTable!

----- 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 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 = 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 better table"
].
].
^assoc!

----- 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"
(flags bitAnd: 32) = 32] whileTrue.
hasInstr ifTrue:[
iLen := entry nextUShort.
entry skip: iLen].
^cGlyph!

----- Method: TTFontReader>>processFontHeaderTable: (in category 'processing') -----
processFontHeaderTable: entry
"Value Data Type Description
unitsPerEm USHORT Granularity of the font's em square.
xMax USHORT Maximum X-coordinate for the entire font.
xMin USHORT Minimum X-coordinate for the entire font.
yMax USHORT Maximum Y-coordinate for the entire font.
yMin USHORT Minimum Y-coordinate for the entire font.
indexToLocFormat SHORT Used when processing the Index To Loc Table."
| origin corner units indexToLocFormat |
entry skip: 4. "Skip table version number"
entry skip: 4. "Skip font revision number"
entry skip: 4. "Skip check sum adjustment"
entry skip: 4. "Skip magic number"
entry skip: 2. "Skip flags"

units := entry nextUShort.

entry skip: 8. "Skip creation date"
entry skip: 8. "Skip modification date"

"Get min/max values of all glyphs"
origin := entry nextShort @ entry nextShort.
corner := entry nextShort @ entry nextShort.

entry skip: 2. "Skip mac style"
entry skip: 2. "Skip lowest rec PPEM"
entry skip: 2. "Skip font direction hint"
indexToLocFormat := entry nextShort.

fontDescription setBounds: (origin corner: corner) unitsPerEm: units.
^indexToLocFormat!

----- Method: TTFontReader>>processGlyphDataTable:offsets: (in category 'processing') -----
processGlyphDataTable: entry offsets: offsetArray
"Read the actual glyph data from the font.
offsetArray contains the start offsets in the data for each glyph."
| initialOffset glyph nextOffset glyphLength glyphOffset nContours origin corner |
initialOffset := entry offset.
glyphs := Array new: nGlyphs.
1 to: nGlyphs do:[:i |
glyphs at: i put: (TTGlyph new glyphIndex: i-1)].
'Reading glyph data'
displayProgressAt: Sensor cursorPoint
from: 1 to: nGlyphs during:[:bar|

1 to: nGlyphs do:[:glyphIndex |
bar value: glyphIndex.
glyph := glyphs at: glyphIndex.
glyphOffset := offsetArray at: glyphIndex.
nextOffset := offsetArray at: glyphIndex+1.
glyphLength := nextOffset - glyphOffset.
glyphLength = 0 ifFalse:[
entry offset: initialOffset + glyphOffset.
nContours := entry nextShort.
origin := entry nextShort @ entry nextShort.
corner := entry nextShort @ entry nextShort.
glyph bounds: (origin corner: corner).
nContours >= 0 ifTrue:[
self processSimpleGlyph: glyph contours: nContours from: entry
] ifFalse:[
glyph := self processCompositeGlyph: glyph contours: nContours from: entry.
glyphs at: glyphIndex put: glyph]]]
].!

----- Method: TTFontReader>>processHorizontalHeaderTable: (in category 'processing') -----
processHorizontalHeaderTable: entry
"
ascender SHORT Typographic ascent.
descender SHORT Typographic descent.
lineGap SHORT Typographic lineGap.
numberOfHMetrics USHORT Number hMetric entries in the HTMX
Table; may be smaller than the total
number of glyphs.
"
| asc desc lGap numHMetrics |
entry skip: 4. "Skip table version"
asc := entry nextShort.
desc := entry nextShort.
lGap := entry nextShort.
entry skip: 2. "Skip advanceWidthMax"
entry skip: 2. "Skip minLeftSideBearing"
entry skip: 2. "Skip minRightSideBearing"
entry skip: 2. "Skip xMaxExtent"
entry skip: 2. "Skip caretSlopeRise"
entry skip: 2. "Skip caretSlopeRun"
entry skip: 10. "Skip 5 reserved shorts"
entry skip: 2. "Skip metricDataFormat"

numHMetrics := entry nextUShort.

fontDescription setAscender: asc descender: desc lineGap: lGap.
^numHMetrics!

----- Method: TTFontReader>>processHorizontalMetricsTable:length: (in category 'processing') -----
processHorizontalMetricsTable: entry length: numHMetrics
"Extract the advance width, left side bearing, and right
side bearing for each glyph from the Horizontal Metrics Table."
| index lastAW glyph |
index := 1.
[index <= numHMetrics] whileTrue:[
glyph := glyphs at: index.
glyph advanceWidth: entry nextUShort.
glyph leftSideBearing: entry nextShort.
glyph updateRightSideBearing.
index := index + 1].
index = (nGlyphs +1) ifTrue:[^true].
lastAW := (glyphs at: index-1) advanceWidth.

[index <= nGlyphs] whileTrue:[
glyph := glyphs at: index.
glyph advanceWidth: lastAW.
glyph leftSideBearing: entry nextShort.
glyph updateRightSideBearing.
index := index + 1].!

----- Method: TTFontReader>>processIndexToLocationTable:format: (in category 'processing') -----
processIndexToLocationTable: entry format: indexToLocFormat
"glyphOffset ULONG[numGlyphs] An array that contains each glyph's
offset into the Glyph Data Table.
" | glyphOffset offset|
glyphOffset := Array new: nGlyphs+1.
1 to: nGlyphs+1 do:[:i|
(indexToLocFormat = 0) ifTrue:[ "Format0: offset/2 is stored"
offset := entry nextUShort * 2.
] ifFalse:["Format1: store actual offset"
offset := entry nextULong].
glyphOffset at: i put: offset].
^glyphOffset!

----- Method: TTFontReader>>processKerningTable: (in category 'processing') -----
processKerningTable: entry
"Extract the kerning information for pairs of glyphs."
| 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].
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!

----- Method: TTFontReader>>processMaximumProfileTable: (in category 'processing') -----
processMaximumProfileTable: entry
"
numGlyphs USHORT The number of glyphs in the font.
"
entry skip: 4. "Skip Table version number"
nGlyphs := entry nextUShort.!

----- Method: TTFontReader>>processNamingTable: (in category 'processing') -----
processNamingTable: entry
"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 pID sID lID nID length offset multiBytes string strings |
strings := Array new: 8.
strings atAllPut:''.
initialOffset := entry offset.
entry skip: 2. "Skip format selector"
"Get the number of name records"
nRecords := entry nextUShort.
"Offset from the beginning of this table"
storageOffset := entry nextUShort + initialOffset.
1 to: nRecords do:[:i|
pID := entry nextUShort.
sID := entry nextUShort.
lID := entry nextUShort.
nID := entry nextUShort.
length := entry nextUShort.
offset := entry nextUShort.
"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.
string := entry stringAt: storageOffset + offset length: length multiByte: multiBytes.
"Put the name at the right location.
Note: We prefer Macintosh strings about everything else."
nID < strings size ifTrue:[
(pID = 1 or:[(strings at: nID+1) = ''])
ifTrue:[strings at: nID+1 put: string].
].
].
].
fontDescription setStrings: strings.!

----- Method: TTFontReader>>processOS2Table: (in category 'processing') -----
processOS2Table: entry
"
USHORT version 0x0004
SHORT xAvgCharWidth
USHORT usWeightClass
USHORT usWidthClass
USHORT fsType
SHORT ySubscriptXSize
SHORT ySubscriptYSize
SHORT ySubscriptXOffset
SHORT ySubscriptYOffset
SHORT ySuperscriptXSize
SHORT ySuperscriptYSize
SHORT ySuperscriptXOffset
SHORT ySuperscriptYOffset
SHORT yStrikeoutSize
SHORT yStrikeoutPosition
SHORT sFamilyClass
BYTE panose[10]
ULONG ulUnicodeRange1 Bits 0-31
ULONG ulUnicodeRange2 Bits 32-63
ULONG ulUnicodeRange3 Bits 64-95
ULONG ulUnicodeRange4 Bits 96-127
CHAR achVendID[4]
USHORT fsSelection
USHORT usFirstCharIndex
USHORT usLastCharIndex
SHORT sTypoAscender
SHORT sTypoDescender
SHORT sTypoLineGap
USHORT usWinAscent
USHORT usWinDescent
ULONG ulCodePageRange1 Bits 0-31
ULONG ulCodePageRange2 Bits 32-63
SHORT sxHeight
SHORT sCapHeight
USHORT usDefaultChar
USHORT usBreakChar
USHORT usMaxContext "
| version fsSelection minAscii maxAscii asc desc lGap |
version := entry nextShort. "table version"
version = 0 ifTrue:[^self].
entry skip: 60.
fsSelection := entry nextUShort.
minAscii := entry nextUShort.
maxAscii := entry nextUShort.
asc := entry nextShort.
desc := entry nextShort.
lGap := entry nextShort.
fontDescription setTypographicAscender: asc descender: desc lineGap: lGap.!

----- 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.
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.!

----- Method: TTFontReader>>readFrom: (in category 'public') -----
readFrom: aStream

| fontData headerEntry maxProfileEntry nameEntry indexLocEntry charMapEntry glyphEntry horzHeaderEntry horzMetricsEntry kerningEntry glyphOffset cmap numHMetrics indexToLocFormat |

"Read the raw font byte data"
aStream binary.
fontData := aStream contents asByteArray.
fontDescription := TTFontDescription new.

"Search the tables required to build the font"
(headerEntry := self getTableDirEntry: 'head' from: fontData) == nil ifTrue:[
^self error:'This font does not have a header table'].
(maxProfileEntry := self getTableDirEntry: 'maxp' from: fontData) == nil ifTrue:[
^self error:'This font does not have a maximum profile table'].
(nameEntry := self getTableDirEntry: 'name' from: fontData) == nil ifTrue:[
^self error:'This font does not have a name table'].
(indexLocEntry := self getTableDirEntry: 'loca' from: fontData) == nil ifTrue:[
^self error:'This font does not have a relocation table'].
(charMapEntry := self getTableDirEntry: 'cmap' from: fontData) == nil ifTrue:[
^self error:'This font does not have a character map table'].
(glyphEntry := self getTableDirEntry: 'glyf' from: fontData) == nil ifTrue:[
^self error:'This font does not have a glyph table'].
(horzHeaderEntry := self getTableDirEntry: 'hhea' from: fontData) == nil ifTrue:[
^self error:'This font does not have a horizontal header table'].
(horzMetricsEntry := self getTableDirEntry: 'hmtx' from: fontData) == nil ifTrue:[
^self error:'This font does not have a horizontal metrics table'].
(kerningEntry := self getTableDirEntry: 'kern' from: fontData) == 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].
charMap := self processCharMap: cmap.
fontDescription setGlyphs: glyphs mapping: charMap.
fontDescription setKernPairs: kernPairs.
^fontDescription!

----- Method: TTFontReader>>readGlyphXCoords:glyph:nContours:flags:endPoints: (in category 'private') -----
readGlyphXCoords:entry glyph: glyph nContours: nContours flags: flags endPoints: endPts
"Read the x coordinates for the given glyph from the font file."
| startPoint endPoint flagBits xValue contour ttPoint |
startPoint := 1.
1 to: nContours do:[:i|
contour := glyph contours at: i.
"Get the end point"
endPoint := (endPts at: i) + 1.
"Store number of points"
startPoint to: endPoint do:[:j|
ttPoint := contour points at: (j - startPoint + 1).
flagBits := flags at: j.
"If bit zero in the flag is set then this point is an on-curve
point, if not, then it is an off-curve point."
(flagBits bitAnd: 1) = 1
ifTrue:[ ttPoint type: #OnCurve]
ifFalse:[ttPoint type: #OffCurve].
"First we check to see if bit one is set. This would indicate that
the corresponding coordinate data in the table is 1 byte long.
If the bit is not set, then the coordinate data is 2 bytes long."
(flagBits bitAnd: 2) = 2 ifTrue:[ "one byte"
xValue := entry nextByte.
xValue := (flagBits bitAnd: 16)=16 ifTrue:[xValue] ifFalse:[xValue negated].
ttPoint x: xValue.
] ifFalse:[ "two byte"
"If bit four is set, then this coordinate is the same as the
last one, so the relative offset (of zero) is stored. If bit
is not set, then read in two bytes and store it as a signed value."
(flagBits bitAnd: 16) = 16 ifTrue:[ ttPoint x: 0 ]
ifFalse:[
xValue := entry nextShort.
ttPoint x: xValue]]].
startPoint := endPoint + 1]!

----- Method: TTFontReader>>readGlyphYCoords:glyph:nContours:flags:endPoints: (in category 'private') -----
readGlyphYCoords:entry glyph: glyph nContours: nContours flags: flags endPoints: endPts
"Read the y coordinates for the given glyph from the font file."
| startPoint endPoint flagBits yValue contour ttPoint |
startPoint := 1.
1 to: nContours do:[:i|
contour := glyph contours at: i.
"Get the end point"
endPoint := (endPts at: i) + 1.
"Store number of points"
startPoint to: endPoint do:[:j|
ttPoint := contour points at: (j - startPoint + 1).
flagBits := flags at: j.
"Check if this value one or two byte encoded"
(flagBits bitAnd: 4) = 4 ifTrue:[ "one byte"
yValue := entry nextByte.
yValue := (flagBits bitAnd: 32)=32 ifTrue:[yValue] ifFalse:[yValue negated].
ttPoint y: yValue.
] ifFalse:[ "two byte"
(flagBits bitAnd: 32) = 32 ifTrue:[ ttPoint y: 0 ]
ifFalse:[
yValue := entry nextShort.
ttPoint y: yValue]]].
startPoint := endPoint + 1]!

----- Method: TTFontReader>>warn: (in category 'private') -----
warn: aString
Transcript cr; show: aString; endEntry.!

----- Method: TTFontReader>>winToMac: (in category 'private') -----
winToMac: index
^ (index - 1) asCharacter squeakToMac asciiValue + 1!

Object subclass: #TTFontTableDirEntry
instanceVariableNames: 'tag fontData offset length checkSum'
classVariableNames: ''
poolDictionaries: ''
category: 'TrueType-Support'!

!TTFontTableDirEntry commentStamp: '<historical>' prior: 0!
This class represents an entry in a truetype font table directory. Used by TTFontReader only.!

----- Method: TTFontTableDirEntry class>>on:at: (in category 'instance creation') -----
on: fontData at: index

^self new on: fontData at: index!

----- Method: TTFontTableDirEntry>>nextByte (in category 'accessing') -----
nextByte

| value |
value := fontData byteAt: offset.
offset := offset + 1.
^value!

----- Method: TTFontTableDirEntry>>nextBytes:into:startingAt: (in category 'accessing') -----
nextBytes: numBytes into: array startingAt: byteOffset

1 to: numBytes do:[:i|
array at: i put: (fontData byteAt: byteOffset + i - 1)].!

----- Method: TTFontTableDirEntry>>nextLong (in category 'accessing') -----
nextLong

| value |
value := fontData longAt: offset bigEndian: true.
offset := offset + 4.
^value!

----- Method: TTFontTableDirEntry>>nextShort (in category 'accessing') -----
nextShort

| value |
value := fontData shortAt: offset bigEndian: true.
offset := offset + 2.
^value!

----- Method: TTFontTableDirEntry>>nextULong (in category 'accessing') -----
nextULong

| value |
value := fontData unsignedLongAt: offset bigEndian: true.
offset := offset + 4.
^value!

----- Method: TTFontTableDirEntry>>nextUShort (in category 'accessing') -----
nextUShort

| value |
value := fontData unsignedShortAt: offset bigEndian: true.
offset := offset + 2.
^value!

----- Method: TTFontTableDirEntry>>offset (in category 'accessing') -----
offset
^offset!

----- Method: TTFontTableDirEntry>>offset: (in category 'accessing') -----
offset: newOffset
offset := newOffset!

----- Method: TTFontTableDirEntry>>on:at: (in category 'initialize-release') -----
on: fd at: index

fontData := fd.
tag := fontData longAt: index bigEndian: true.
checkSum := fontData longAt: index+4 bigEndian: true.
offset := (fontData longAt: index+8 bigEndian: true) + 1.
length := fontData longAt: index+12 bigEndian: true.!

----- Method: TTFontTableDirEntry>>skip: (in category 'accessing') -----
skip: n
"Skip n bytes"
offset := offset + n.!

----- Method: TTFontTableDirEntry>>stringAt:length:multiByte: (in category 'accessing') -----
stringAt: stringOffset length: byteLength multiByte: aBoolean

| string index stringLength |
aBoolean ifFalse:[
stringLength := byteLength.
string := String new: stringLength.
index := stringOffset.
1 to: stringLength do:[:i|
string at: i put: (Character value: (fontData byteAt: index + i - 1))].
^string
] ifTrue:[
stringLength := byteLength // 2.
string := String new: stringLength.
index := stringOffset.
1 to: stringLength do:[:i|
string at: i put: (Character value: (fontData byteAt: index + 1)).
index := index + 2].
^string]!

Object subclass: #TTGlyph
instanceVariableNames: 'bounds contours advanceWidth leftSideBearing rightSideBearing glyphIndex'
classVariableNames: ''
poolDictionaries: ''
category: 'TrueType-Fonts'!

!TTGlyph commentStamp: '<historical>' prior: 0!
This class represents a glyph of a TrueType font.

Instance variables:
bounds <Rectangle> The receiver's bounds
contours <Array of: PointArray> The compressed contours in the receiver
advanceWidth <Integer> advance width of the glyph
leftSideBearing <Integer> left side bearing
rightSideBearing <Integer> right side bearing
glyphIndex <Integer> the original index of the glyph (used for kerning)!

TTGlyph subclass: #TTCompositeGlyph
instanceVariableNames: 'glyphs'
classVariableNames: ''
poolDictionaries: ''
category: 'TrueType-Fonts'!

!TTCompositeGlyph commentStamp: '<historical>' prior: 0!
This class represents a composite TrueType glyph, e.g.one which contains many simple TTGlyphs.!

----- Method: TTCompositeGlyph>>addGlyph:transformation: (in category 'accessing') -----
addGlyph: aGlyph transformation: aMatrix
glyphs := glyphs copyWith: (aMatrix -> aGlyph)!

----- Method: TTCompositeGlyph>>buildAllContours (in category 'accessing') -----
buildAllContours
"Build the contours in all non-composite glyphs."
glyphs do:[:assoc| assoc value buildAllContours].!

----- Method: TTCompositeGlyph>>computeContours (in category 'private') -----
computeContours
| out |
out := WriteStream on: (Array new: glyphs size * 4).
self glyphsAndTransformationsDo:[:glyph :transform|
glyph contours do:[:ptArray|
out nextPut: (transform localPointsToGlobal: ptArray).
].
].
^out contents!

----- Method: TTCompositeGlyph>>contours (in category 'accessing') -----
contours
^contours ifNil:[contours := self computeContours]!

----- Method: TTCompositeGlyph>>flipAroundY (in category 'private') -----
flipAroundY
bounds := (bounds origin x @ bounds corner y negated) corner:
(bounds corner x @ bounds origin y negated).
contours := nil.!

----- Method: TTCompositeGlyph>>glyphs (in category 'accessing') -----
glyphs

^glyphs collect:[:assoc| assoc value].!

----- Method: TTCompositeGlyph>>glyphsAndTransformationsDo: (in category 'accessing') -----
glyphsAndTransformationsDo: aBlock
glyphs do:[:assoc|
aBlock value: assoc value value: assoc key.
].!

----- Method: TTCompositeGlyph>>initialize (in category 'initialize') -----
initialize
glyphs := #().!

----- Method: TTCompositeGlyph>>isComposite (in category 'testing') -----
isComposite
^true!

----- Method: TTCompositeGlyph>>referenceVertexAt: (in category 'initialize') -----
referenceVertexAt: index
"Only used while reading before constructing contours"
| i p |
i := index.
self glyphsAndTransformationsDo: [:glyph :transform |
p := glyph referenceVertexAt: i.
p isPoint
ifTrue: [^transform localPointToGlobal: p].
i := i - p].
self error: ['this should not happen']!

----- Method: TTGlyph>>advanceWidth (in category 'accessing') -----
advanceWidth
^advanceWidth!

----- Method: TTGlyph>>advanceWidth: (in category 'accessing') -----
advanceWidth: aNumber
advanceWidth := aNumber.!

----- Method: TTGlyph>>asFormWithScale:ascender:descender: (in category 'converting') -----
asFormWithScale: scale ascender: ascender descender: descender
^ self
asFormWithScale: scale
ascender: ascender
descender: descender
fgColor: Color black
bgColor: Color white
depth: 8
replaceColor: true.
!

----- Method: TTGlyph>>asFormWithScale:ascender:descender:fgColor:bgColor:depth: (in category 'converting') -----
asFormWithScale: scale ascender: ascender descender: descender fgColor: fgColor bgColor: bgColor depth: depth

^ self
asFormWithScale: scale
ascender: ascender
descender: descender
fgColor: fgColor
bgColor: bgColor
depth: depth
replaceColor: false.
!

----- Method: TTGlyph>>asFormWithScale:ascender:descender:fgColor:bgColor:depth:replaceColor: (in category 'converting') -----
asFormWithScale: scale ascender: ascender descender: descender fgColor: fgColor bgColor: bgColor depth: depth replaceColor: replaceColorFlag

^ self
asFormWithScale: scale
ascender: ascender
descender: descender
fgColor: fgColor
bgColor: bgColor
depth: depth
replaceColor: replaceColorFlag
lineGlyph: nil
lingGlyphWidth: 0
emphasis: 0.!

----- Method: TTGlyph>>asFormWithScale:ascender:descender:fgColor:bgColor:depth:replaceColor:lineGlyph:lingGlyphWidth:emphasis: (in category 'converting') -----
asFormWithScale: scale ascender: ascender descender: descender fgColor: fgColor bgColor: bgColor depth: depth replaceColor: replaceColorFlag lineGlyph: lineGlyph lingGlyphWidth: lWidth emphasis: code

| form canvas newScale |
form := Form extent: (advanceWidth @ (ascender - descender) * scale) rounded depth: depth.
form fillColor: bgColor.
canvas := BalloonCanvas on: form.
canvas aaLevel: 4.
canvas transformBy: (MatrixTransform2x3 withScale: scale asPoint * (1 @ -1)).
canvas transformBy: (MatrixTransform2x3 withOffset: 0 @ ascender negated).
canvas
drawGeneralBezierShape: self contours
color: fgColor
borderWidth: 0
borderColor: fgColor.
((code bitAnd: 4) ~= 0 or: [(code bitAnd: 16) ~= 0]) ifTrue: [
newScale := (form width + 1) asFloat / lineGlyph calculateWidth asFloat.
canvas transformBy: (MatrixTransform2x3 withScale: (newScale / scale)@1.0).

(code bitAnd: 4) ~= 0 ifTrue: [
canvas
drawGeneralBezierShape: lineGlyph contours
color: fgColor
borderWidth: 0
borderColor: fgColor.
].

(code bitAnd: 16) ~= 0 ifTrue: [
canvas transformBy: (MatrixTransform2x3 withOffset: 0@(ascender // 2)).
canvas
drawGeneralBezierShape: lineGlyph contours
color: fgColor
borderWidth: 0
borderColor: fgColor.
].
].

replaceColorFlag ifTrue: [
form replaceColor: bgColor withColor: Color transparent.
].
^ form!

----- Method: TTGlyph>>bounds (in category 'accessing') -----
bounds
^bounds!

----- Method: TTGlyph>>bounds: (in category 'accessing') -----
bounds: aRectangle
bounds := aRectangle!

----- Method: TTGlyph>>buildAllContours (in category 'private-initialization') -----
buildAllContours
"Build the contours in all non-composite glyphs."
^self buildContours!

----- Method: TTGlyph>>buildContours (in category 'private-initialization') -----
buildContours
"Build the contours in the receiver glyph.
The contour is constructed by converting the points
form each contour into an absolute value and then
compressing the contours into PointArrays."
| tx ty points |
tx := ty := 0.
contours := contours collect:[:contour|
contour isCollection ifTrue:[^self]. "already built"
points := contour points.
points do:[:pt|
pt x: (tx := tx + pt x).
pt y: (ty := ty + pt y)].
contour asCompressedPoints].!

----- Method: TTGlyph>>calculateWidth (in category 'private') -----
calculateWidth

| min max |
min := SmallInteger maxVal.
max := SmallInteger minVal.
self contours do: [:a | a do: [:p |
p x > max ifTrue: [max := p x].
p x < min ifTrue: [min := p x].
]].
^ max - min.
!

----- Method: TTGlyph>>contours (in category 'accessing') -----
contours
^contours!

----- Method: TTGlyph>>contours: (in category 'accessing') -----
contours: aCollection
contours := aCollection asArray.!

----- Method: TTGlyph>>display (in category 'private') -----
display
| canvas |
canvas := Display getCanvas.
self contours do:[:ptArray|
1 to: ptArray size by: 3 do:[:i|
canvas line: (ptArray at: i) // 10
to: (ptArray at: i+2) // 10
width: 1 color: Color black.
].
].!

----- Method: TTGlyph>>flipAroundY (in category 'private') -----
flipAroundY
bounds := (bounds origin x @ bounds corner y negated) corner:
(bounds corner x @ bounds origin y negated).
contours := self contours collect:[:contour| contour collect:[:pt| pt x @ pt y negated]].!

----- Method: TTGlyph>>glyphIndex (in category 'accessing') -----
glyphIndex
^glyphIndex!

----- Method: TTGlyph>>glyphIndex: (in category 'accessing') -----
glyphIndex: anInteger
glyphIndex := anInteger!

----- Method: TTGlyph>>glyphsAndTransformationsDo: (in category 'accessing') -----
glyphsAndTransformationsDo: aBlock
aBlock value: self value: MatrixTransform2x3 identity!

----- Method: TTGlyph>>initialize (in category 'initialize-release') -----
initialize

bounds := 0@0 corner: 0@0.
contours := #().
advanceWidth := 0.
leftSideBearing := 0.
rightSideBearing := 0.!

----- Method: TTGlyph>>initializeContours:with: (in category 'private-initialization') -----
initializeContours: numContours with: endPoints
"Initialize the contours for creation of the glyph."
| startPt pts endPt |
contours := Array new: numContours.
startPt := -1.
1 to: numContours do:[:i|
endPt := endPoints at: i.
pts := Array new: endPt - startPt.
1 to: pts size do:[:j| pts at: j put: TTPoint new].
contours at: i put: (TTContourConstruction on: pts).
startPt := endPt].!

----- Method: TTGlyph>>isComposite (in category 'testing') -----
isComposite
^false!

----- Method: TTGlyph>>leftSideBearing (in category 'accessing') -----
leftSideBearing
^leftSideBearing!

----- Method: TTGlyph>>leftSideBearing: (in category 'accessing') -----
leftSideBearing: aNumber
leftSideBearing := aNumber.!

----- Method: TTGlyph>>printOn: (in category 'printing') -----
printOn: aStream

aStream
nextPutAll: self class name;
nextPut:$(;
print: (contours ifNil: [0] ifNotNil: [contours size]);
nextPut:$).!

----- Method: TTGlyph>>referenceVertexAt: (in category 'private-initialization') -----
referenceVertexAt: index
"Only used while reading before constructing contours"
| count vertices |
count := 0.
contours do: [:construction |
vertices := construction points.
index - count > vertices size
ifTrue: [count := count + vertices size]
ifFalse: [^(vertices at: index - count) asPoint]].
^count!

----- Method: TTGlyph>>rightSideBearing (in category 'accessing') -----
rightSideBearing
^rightSideBearing!

----- Method: TTGlyph>>rightSideBearing: (in category 'accessing') -----
rightSideBearing: aNumber
rightSideBearing := aNumber.!

----- Method: TTGlyph>>updateRightSideBearing (in category 'private-initialization') -----
updateRightSideBearing
"Update the right side bearing value"
"@@: Is the following really correct?!!?!!"
rightSideBearing := advanceWidth - leftSideBearing - bounds corner x + bounds origin x!

Object subclass: #TTKernPair
instanceVariableNames: 'left right value mask'
classVariableNames: ''
poolDictionaries: ''
category: 'TrueType-Fonts'!

!TTKernPair commentStamp: '<historical>' prior: 0!
A TTKernPair represents a TrueType kerning pair.

Instance variables:
left <Integer> The glyph index for the left character.
right <Integer> The glyph index for the right character.
value <Integer> The amount of kerning.
mask <Integer> An efficient representation for the left and the right value.!

----- Method: TTKernPair class>>maskFor:with: (in category 'accessing') -----
maskFor: left with: right
^(left bitShift: 12) + right!

----- Method: TTKernPair>>left (in category 'accessing') -----
left
^left!

----- Method: TTKernPair>>left: (in category 'accessing') -----
left: aNumber

left := aNumber!

----- Method: TTKernPair>>mask (in category 'accessing') -----
mask
^mask ifNil:[mask := self class maskFor: left with: right]!

----- Method: TTKernPair>>right (in category 'accessing') -----
right
^right!

----- Method: TTKernPair>>right: (in category 'accessing') -----
right: aNumber

right := aNumber!

----- Method: TTKernPair>>value (in category 'accessing') -----
value
^value!

----- Method: TTKernPair>>value: (in category 'accessing') -----
value: aNumber

value := aNumber!

Object subclass: #TTPoint
instanceVariableNames: 'x y type'
classVariableNames: ''
poolDictionaries: ''
category: 'TrueType-Support'!

!TTPoint commentStamp: '<historical>' prior: 0!
A representation of a TrueType point which includes a 'type' flag defining whether this point is an 'on' or an 'off' curve point.!

----- Method: TTPoint>>asPoint (in category 'converting') -----
asPoint
^x@y!

----- Method: TTPoint>>printOn: (in category 'printing') -----
printOn: aStream

aStream
nextPutAll: self class name;
nextPut:$(;
print: x;
nextPut:$@;
print: y;
nextPut:$|;
print: type;
nextPut:$)!

----- Method: TTPoint>>type (in category 'accessing') -----
type
^type!

----- Method: TTPoint>>type: (in category 'accessing') -----
type: aSymbol

type := aSymbol!

----- Method: TTPoint>>x (in category 'accessing') -----
x
^x!

----- Method: TTPoint>>x: (in category 'accessing') -----
x: aNumber

x := aNumber!

----- Method: TTPoint>>y (in category 'accessing') -----
y
^y!

----- Method: TTPoint>>y: (in category 'accessing') -----
y: aNumber
y := aNumber!