Squeak-dev July 2013

squeak-dev@lists.squeakfoundation.org

50 participants
342 discussions

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

02 Jul '13

Frank Shearar uploaded a new version of Multilingual to project The Trunk: http://source.squeak.org/trunk/Multilingual-fbs.164.mcz ==================== Summary ==================== Name: Multilingual-fbs.164 Author: fbs Time: 2 July 2013, 10:18:42.84 pm UUID: 83457f26-4043-914a-b92d-8b34b4a2b37e Ancestors: Multilingual-fbs.163 This nearly severs the Multilingual -> Morphic dependency. =============== Diff against Multilingual-fbs.163 =============== Item was removed: - ----- Method: MultiCompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide: (in category 'scanning') ----- - composeFrom: startIndex inRectangle: lineRectangle - firstLine: firstLine leftSide: leftSide rightSide: rightSide - "Answer an instance of TextLineInterval that represents the next line in the paragraph." - | runLength stopCondition | - "Set up margins" - leftMargin := lineRectangle left. - leftSide ifTrue: [leftMargin := leftMargin + - (firstLine ifTrue: [textStyle firstIndent] - ifFalse: [textStyle restIndent])]. - destX := spaceX := leftMargin. - firstDestX := destX. - rightMargin := lineRectangle right. - rightSide ifTrue: [rightMargin := rightMargin - textStyle rightIndent]. - lastIndex := startIndex. "scanning sets last index" - destY := lineRectangle top. - lineHeight := baseline := 0. "Will be increased by setFont" - self setStopConditions. "also sets font" - runLength := text runLengthFor: startIndex. - runStopIndex := (lastIndex := startIndex) + (runLength - 1). - line := (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) - rectangle: lineRectangle. - presentationLine := (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) - rectangle: lineRectangle. - numOfComposition := 0. - spaceCount := 0. - self handleIndentation. - leftMargin := destX. - line leftMargin: leftMargin. - presentationLine leftMargin: leftMargin. - - presentation := TextStream on: (Text fromString: (WideString new: text size)). - - [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex - in: text string rightX: rightMargin stopConditions: stopConditions - kern: kern. - "See setStopConditions for stopping conditions for composing." - (self perform: stopCondition) - ifTrue: [presentationLine lineHeight: lineHeight + textStyle leading - baseline: baseline + textStyle leading. - ^ line lineHeight: lineHeight + textStyle leading - baseline: baseline + textStyle leading]] repeat! Item was removed: - ----- Method: MultiCompositionScanner>>setFont (in category 'stop conditions') ----- - setFont - super setFont. - breakAtSpace := false. - wantsColumnBreaks == true ifTrue: [ - stopConditions := stopConditions copy. - stopConditions at: TextComposer characterForColumnBreak asciiValue + 1 put: #columnBreak. - ]. - ! Item was removed: - NewParagraph subclass: #MultiNewParagraph - instanceVariableNames: 'presentationText presentationLines' - classVariableNames: '' - poolDictionaries: 'TextConstants' - category: 'Multilingual-Scanning'! Item was removed: - ----- Method: MultiNewParagraph>>displayOn:using:at: (in category 'fonts-display') ----- - displayOn: aCanvas using: displayScanner at: somePosition - "Send all visible lines to the displayScanner for display" - - | visibleRectangle offset leftInRun line | - visibleRectangle := aCanvas clipRect. - offset := somePosition - positionWhenComposed. - leftInRun := 0. - (self lineIndexForPoint: visibleRectangle topLeft) - to: (self lineIndexForPoint: visibleRectangle bottomRight) - do: [:i | line := lines at: i. - self displaySelectionInLine: line on: aCanvas. - line first <= line last ifTrue: - [leftInRun := displayScanner displayLine: line - offset: offset leftInRun: leftInRun]]. - ! Item was removed: - ----- Method: MultiNewParagraph>>displayOnTest:using:at: (in category 'fonts-display') ----- - displayOnTest: aCanvas using: displayScanner at: somePosition - "Send all visible lines to the displayScanner for display" - - | visibleRectangle offset leftInRun line | - (presentationText isNil or: [presentationLines isNil]) ifTrue: [ - ^ self displayOn: aCanvas using: displayScanner at: somePosition. - ]. - visibleRectangle := aCanvas clipRect. - offset := somePosition - positionWhenComposed. - leftInRun := 0. - (self lineIndexForPoint: visibleRectangle topLeft) - to: (self lineIndexForPoint: visibleRectangle bottomRight) - do: [:i | line := presentationLines at: i. - self displaySelectionInLine: line on: aCanvas. - line first <= line last ifTrue: - [leftInRun := displayScanner displayLine: line - offset: offset leftInRun: leftInRun]]. - ! Item was removed: - ----- Method: MultiNewParagraph>>multiComposeLinesFrom:to:delta:into:priorLines:atY: (in category 'composition') ----- - multiComposeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines - atY: startingY - "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values" - - | newResult composer presentationInfo | - - composer := MultiTextComposer new. - presentationLines := nil. - presentationText := nil. - newResult := composer - multiComposeLinesFrom: start - to: stop - delta: delta - into: lineColl - priorLines: priorLines - atY: startingY - textStyle: textStyle - text: text - container: container - wantsColumnBreaks: wantsColumnBreaks == true. - lines := newResult first asArray. - maxRightX := newResult second. - presentationInfo := composer getPresentationInfo. - presentationLines := presentationInfo first asArray. - presentationText := presentationInfo second. - "maxRightX printString displayAt: 0@0." - ^maxRightX - ! Item was removed: - ----- Method: MultiNewParagraph>>presentationLines (in category 'accessing') ----- - presentationLines - - ^ presentationLines. - ! Item was removed: - ----- Method: MultiNewParagraph>>presentationText (in category 'accessing') ----- - presentationText - - ^ presentationText. - ! Item was removed: - TextComposer subclass: #MultiTextComposer - instanceVariableNames: 'presentation presentationLines' - classVariableNames: '' - poolDictionaries: 'TextConstants' - category: 'Multilingual-Scanning'! Item was removed: - ----- Method: MultiTextComposer>>composeEachRectangleIn: (in category 'as yet unclassified') ----- - composeEachRectangleIn: rectangles - - | myLine lastChar | - - 1 to: rectangles size do: [:i | - currCharIndex <= theText size ifFalse: [^false]. - myLine := scanner - composeFrom: currCharIndex - inRectangle: (rectangles at: i) - firstLine: isFirstLine - leftSide: i=1 - rightSide: i=rectangles size. - lines addLast: myLine. - presentationLines addLast: scanner getPresentationLine. - presentation ifNil: [presentation := scanner getPresentation] - ifNotNil: [presentation := presentation, scanner getPresentation]. - actualHeight := actualHeight max: myLine lineHeight. "includes font changes" - currCharIndex := myLine last + 1. - lastChar := theText at: myLine last. - (CharacterSet crlf includes: lastChar) ifTrue: [^#cr]. - wantsColumnBreaks ifTrue: [ - lastChar = TextComposer characterForColumnBreak ifTrue: [^#columnBreak]. - ]. - ]. - ^false! Item was removed: - ----- Method: MultiTextComposer>>getPresentationInfo (in category 'as yet unclassified') ----- - getPresentationInfo - - ^ Array with: presentationLines with: presentation. - ! Item was removed: - ----- Method: MultiTextComposer>>multiComposeLinesFrom:to:delta:into:priorLines:atY:textStyle:text:container:wantsColumnBreaks: (in category 'as yet unclassified') ----- - multiComposeLinesFrom: argStart to: argStop delta: argDelta into: argLinesCollection priorLines: argPriorLines atY: argStartY textStyle: argTextStyle text: argText container: argContainer wantsColumnBreaks: argWantsColumnBreaks - - wantsColumnBreaks := argWantsColumnBreaks. - lines := argLinesCollection. - presentationLines := argLinesCollection copy. - theTextStyle := argTextStyle. - theText := argText. - theContainer := argContainer. - deltaCharIndex := argDelta. - currCharIndex := startCharIndex := argStart. - stopCharIndex := argStop. - prevLines := argPriorLines. - currentY := argStartY. - defaultLineHeight := theTextStyle lineGrid. - maxRightX := theContainer left. - possibleSlide := stopCharIndex < theText size and: [theContainer isMemberOf: Rectangle]. - nowSliding := false. - prevIndex := 1. - scanner := MultiCompositionScanner new text: theText textStyle: theTextStyle. - scanner wantsColumnBreaks: wantsColumnBreaks. - isFirstLine := true. - self composeAllLines. - isFirstLine ifTrue: ["No space in container or empty text" - self - addNullLineWithIndex: startCharIndex - andRectangle: (theContainer topLeft extent: 0@defaultLineHeight) - ] ifFalse: [ - self fixupLastLineIfCR - ]. - ^{lines asArray. maxRightX} - - ! Item was removed: - ----- Method: TTGlyph>>asFormWithScale:ascender:descender:fgColor:bgColor:depth:replaceColor:lineGlyph:lingGlyphWidth:emphasis: (in category '*Multilingual-Display-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)(a)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!

1 0

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

02 Jul '13

Frank Shearar uploaded a new version of TrueType to project The Trunk: http://source.squeak.org/trunk/TrueType-fbs.23.mcz ==================== Summary ==================== Name: TrueType-fbs.23 Author: fbs Time: 2 July 2013, 10:17:49.29 pm UUID: fcdc0152-0d7a-284f-9e68-59c4ac55bb1d Ancestors: TrueType-fbs.22 Move graphical stuff up into Morphic-Multilingual. =============== Diff against TrueType-fbs.22 =============== Item was removed: - ----- Method: LinedTTCFont>>computeForm: (in category 'as yet unclassified') ----- - computeForm: char - - | ttGlyph scale | - - char = Character tab ifTrue: [^ super computeForm: char]. - - "char = $U ifTrue: [self doOnlyOnce: [self halt]]." - scale := self pixelSize asFloat / (ttcDescription ascender - ttcDescription descender). - ttGlyph := ttcDescription at: char. - ^ ttGlyph asFormWithScale: scale ascender: ttcDescription ascender descender: ttcDescription descender fgColor: foregroundColor bgColor: Color transparent depth: self depth replaceColor: false lineGlyph: lineGlyph lingGlyphWidth: contourWidth emphasis: emphasis! Item was removed: - ----- Method: TTCFont>>computeForm: (in category 'private') ----- - computeForm: char - "Compute the glyph form for the given character" - ^ttcDescription renderGlyph: char height: self height fgColor: foregroundColor bgColor: Color transparent depth: self depth!

1 0

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

02 Jul '13

Frank Shearar uploaded a new version of Tools to project The Trunk: http://source.squeak.org/trunk/Tools-fbs.478.mcz ==================== Summary ==================== Name: Tools-fbs.478 Author: fbs Time: 2 July 2013, 8:55:00.661 pm UUID: e23933e2-9027-7b4f-97a8-c1c5dc0620de Ancestors: Tools-fbs.477 Revert accidental commit of alpha quality exploratory hack. =============== Diff against Tools-fbs.477 =============== Item was changed: ----- Method: Browser>>dragFromClassList: (in category 'drag and drop') ----- dragFromClassList: index "Drag a class from the browser" | name envt | (name := self classList at: index) ifNil: [ ^ nil ]. (envt := self selectedEnvironment) ifNil: [ ^ nil ]. - "To maintain our current place in the list, try select the next class." - (self classList size = 1) ifTrue: [self selectClassNamed: self classList first]. - (self classList size > 2) ifTrue: [ | currClassName classNames | - currClassName := self selectedClassName. - classNames := self classList. - self selectClassNamed: (currClassName = classNames last - ifTrue: [self classList before: currClassName] - ifFalse: [self classList after: currClassName])]. ^ envt at: name withBlanksTrimmed asSymbol ifAbsent: [ ]!

1 0

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

02 Jul '13

Frank Shearar uploaded a new version of Tools to project The Trunk: http://source.squeak.org/trunk/Tools-fbs.477.mcz ==================== Summary ==================== Name: Tools-fbs.477 Author: fbs Time: 2 July 2013, 8:43:03.913 pm UUID: e1e06342-faa6-ad4e-9562-be1a71871fe9 Ancestors: Tools-fbs.476 Move Tools' MVC extensions to a separate package, ST80Tools. This makes Tools independent of MVC, at the cost of requiring an extra package to reload/unload MVC. =============== Diff against Tools-fbs.476 =============== Item was changed: ----- Method: Browser>>dragFromClassList: (in category 'drag and drop') ----- dragFromClassList: index "Drag a class from the browser" | name envt | (name := self classList at: index) ifNil: [ ^ nil ]. (envt := self selectedEnvironment) ifNil: [ ^ nil ]. + "To maintain our current place in the list, try select the next class." + (self classList size = 1) ifTrue: [self selectClassNamed: self classList first]. + (self classList size > 2) ifTrue: [ | currClassName classNames | + currClassName := self selectedClassName. + classNames := self classList. + self selectClassNamed: (currClassName = classNames last + ifTrue: [self classList before: currClassName] + ifFalse: [self classList after: currClassName])]. ^ envt at: name withBlanksTrimmed asSymbol ifAbsent: [ ]! Item was removed: - ----- Method: ParagraphEditor>>browseChangeSetsWithSelector (in category '*Tools') ----- - browseChangeSetsWithSelector - "Determine which, if any, change sets have at least one change for the selected selector, independent of class" - - | aSelector | - self lineSelectAndEmptyCheck: [^ self]. - (aSelector := self selectedSelector) == nil ifTrue: [^ view flash]. - self terminateAndInitializeAround: [ChangeSorter browseChangeSetsWithSelector: aSelector]! Item was removed: - ----- Method: ParagraphEditor>>browseItHere (in category '*Tools') ----- - browseItHere - "Retarget the receiver's window to look at the selected class, if appropriate. 3/1/96 sw" - | aSymbol b | - (((b := model) isKindOf: Browser) and: [b couldBrowseAnyClass]) - ifFalse: [^ view flash]. - model okToChange ifFalse: [^ view flash]. - self selectionInterval isEmpty ifTrue: [self selectWord]. - (aSymbol := self selectedSymbol) ifNil: [^ view flash]. - - self terminateAndInitializeAround: - [| foundClass | - foundClass := (Smalltalk at: aSymbol ifAbsent: [nil]). - foundClass ifNil: [^ view flash]. - (foundClass isKindOf: Class) - ifTrue: - [model selectSystemCategory: foundClass category. - model classListIndex: (model classList indexOf: foundClass name)]]! Item was removed: - ----- Method: ParagraphEditor>>debug:receiver:in: (in category '*Tools') ----- - debug: aCompiledMethod receiver: anObject in: evalContext - - | guineaPig debugger context | - guineaPig := [ - aCompiledMethod - valueWithReceiver: anObject - arguments: (evalContext ifNil: [ #() ] ifNotNil: [ { evalContext } ]) ] newProcess. - context := guineaPig suspendedContext. - debugger := Debugger new - process: guineaPig - controller: ((Smalltalk isMorphic not and: [ScheduledControllers inActiveControllerProcess]) - ifTrue: [ScheduledControllers activeController] - ifFalse: [nil]) - context: context. - debugger openFullNoSuspendLabel: 'Debug it'. - [debugger interruptedContext method == aCompiledMethod] - whileFalse: [debugger send]! Item was removed: - ----- Method: ParagraphEditor>>debugIt (in category '*Tools') ----- - debugIt - - | method receiver context | - (model respondsTo: #doItReceiver) - ifTrue: - [receiver := model doItReceiver. - context := model doItContext] - ifFalse: - [receiver := context := nil]. - self lineSelectAndEmptyCheck: [^self]. - method := self compileSelectionFor: receiver in: context. - method notNil ifTrue: - [self debug: method receiver: receiver in: context].! Item was removed: - ----- Method: ScreenController>>browseRecentLog (in category '*Tools') ----- - browseRecentLog - "Open a changelist browser on changes submitted since the last snapshot. 1/17/96 sw" - - ChangeList browseRecentLog! Item was removed: - ----- Method: ScreenController>>chooseDirtyBrowser (in category '*Tools') ----- - chooseDirtyBrowser - "Put up a list of browsers with unsubmitted edits and activate the one selected by the user, if any." - "ScheduledControllers screenController chooseDirtyBrowser" - - ScheduledControllers findWindowSatisfying: - [:c | (c model isKindOf: Browser) and: [c model canDiscardEdits not]]. - ! Item was removed: - ----- Method: ScreenController>>openChangeManager (in category '*Tools') ----- - openChangeManager - "Open a dual change sorter. For looking at two change sets at once." - DualChangeSorter new open! Item was removed: - ----- Method: ScreenController>>openFile (in category '*Tools') ----- - openFile - FileList openFileDirectly! Item was removed: - ----- Method: ScreenController>>openFileList (in category '*Tools') ----- - openFileList - "Create and schedule a FileList view for specifying files to access." - - FileList open! Item was removed: - ----- Method: ScreenController>>openPackageBrowser (in category '*Tools') ----- - openPackageBrowser - "Create and schedule a Browser view for browsing code." - - PackagePaneBrowser openBrowser! Item was removed: - ----- Method: ScreenController>>openSelectorBrowser (in category '*Tools') ----- - openSelectorBrowser - "Create and schedule a selector fragment window." - - SelectorBrowser new open! Item was removed: - ----- Method: ScreenController>>openSimpleChangeSorter (in category '*Tools') ----- - openSimpleChangeSorter - ChangeSorter new open! Item was removed: - ----- Method: StringHolderView>>canHaveUnacceptedEdits (in category '*Tools-multi-window support') ----- - canHaveUnacceptedEdits - "Answer if the receiver is an object that can hold unaccepted edits (such as a text editor widget)" - - ^true! Item was removed: - ----- Method: StringHolderView>>unacceptedEditState (in category '*Tools-multi-window support') ----- - unacceptedEditState - ^hasUnacceptedEdits ifTrue: [displayContents text]! Item was removed: - ----- Method: StringHolderView>>unacceptedEditState: (in category '*Tools-multi-window support') ----- - unacceptedEditState: stateOrNil - (hasUnacceptedEdits := stateOrNil notNil) ifTrue: - [self editString: stateOrNil]!

1 0

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

02 Jul '13

Frank Shearar uploaded a new version of ST80Tools to project The Trunk: http://source.squeak.org/trunk/ST80Tools-fbs.1.mcz ==================== Summary ==================== Name: ST80Tools-fbs.1 Author: fbs Time: 2 July 2013, 8:41:50.912 pm UUID: 108ec7bc-d1f5-dd4b-9511-e7a653a71e9f Ancestors: Move Tools' MVC extensions to a separate package, ST80Tools. This makes Tools independent of MVC, at the cost of requiring an extra package to reload/unload MVC. ==================== Snapshot ==================== ----- Method: ParagraphEditor>>browseChangeSetsWithSelector (in category '*ST80Tools') ----- browseChangeSetsWithSelector "Determine which, if any, change sets have at least one change for the selected selector, independent of class" | aSelector | self lineSelectAndEmptyCheck: [^ self]. (aSelector := self selectedSelector) == nil ifTrue: [^ view flash]. self terminateAndInitializeAround: [ChangeSorter browseChangeSetsWithSelector: aSelector]! ----- Method: ParagraphEditor>>browseItHere (in category '*ST80Tools') ----- browseItHere "Retarget the receiver's window to look at the selected class, if appropriate. 3/1/96 sw" | aSymbol b | (((b := model) isKindOf: Browser) and: [b couldBrowseAnyClass]) ifFalse: [^ view flash]. model okToChange ifFalse: [^ view flash]. self selectionInterval isEmpty ifTrue: [self selectWord]. (aSymbol := self selectedSymbol) ifNil: [^ view flash]. self terminateAndInitializeAround: [| foundClass | foundClass := (Smalltalk at: aSymbol ifAbsent: [nil]). foundClass ifNil: [^ view flash]. (foundClass isKindOf: Class) ifTrue: [model selectSystemCategory: foundClass category. model classListIndex: (model classList indexOf: foundClass name)]]! ----- Method: ParagraphEditor>>debug:receiver:in: (in category '*ST80Tools') ----- debug: aCompiledMethod receiver: anObject in: evalContext | guineaPig debugger context | guineaPig := [ aCompiledMethod valueWithReceiver: anObject arguments: (evalContext ifNil: [ #() ] ifNotNil: [ { evalContext } ]) ] newProcess. context := guineaPig suspendedContext. debugger := Debugger new process: guineaPig controller: ((Smalltalk isMorphic not and: [ScheduledControllers inActiveControllerProcess]) ifTrue: [ScheduledControllers activeController] ifFalse: [nil]) context: context. debugger openFullNoSuspendLabel: 'Debug it'. [debugger interruptedContext method == aCompiledMethod] whileFalse: [debugger send]! ----- Method: ParagraphEditor>>debugIt (in category '*ST80Tools') ----- debugIt | method receiver context | (model respondsTo: #doItReceiver) ifTrue: [receiver := model doItReceiver. context := model doItContext] ifFalse: [receiver := context := nil]. self lineSelectAndEmptyCheck: [^self]. method := self compileSelectionFor: receiver in: context. method notNil ifTrue: [self debug: method receiver: receiver in: context].! ----- Method: StringHolderView>>canHaveUnacceptedEdits (in category '*ST80Tools-multi-window support') ----- canHaveUnacceptedEdits "Answer if the receiver is an object that can hold unaccepted edits (such as a text editor widget)" ^true! ----- Method: StringHolderView>>unacceptedEditState (in category '*ST80Tools-multi-window support') ----- unacceptedEditState ^hasUnacceptedEdits ifTrue: [displayContents text]! ----- Method: StringHolderView>>unacceptedEditState: (in category '*ST80Tools-multi-window support') ----- unacceptedEditState: stateOrNil (hasUnacceptedEdits := stateOrNil notNil) ifTrue: [self editString: stateOrNil]! ----- Method: ScreenController>>browseRecentLog (in category '*ST80Tools') ----- browseRecentLog "Open a changelist browser on changes submitted since the last snapshot. 1/17/96 sw" ChangeList browseRecentLog! ----- Method: ScreenController>>chooseDirtyBrowser (in category '*ST80Tools') ----- chooseDirtyBrowser "Put up a list of browsers with unsubmitted edits and activate the one selected by the user, if any." "ScheduledControllers screenController chooseDirtyBrowser" ScheduledControllers findWindowSatisfying: [:c | (c model isKindOf: Browser) and: [c model canDiscardEdits not]]. ! ----- Method: ScreenController>>openChangeManager (in category '*ST80Tools') ----- openChangeManager "Open a dual change sorter. For looking at two change sets at once." DualChangeSorter new open! ----- Method: ScreenController>>openFile (in category '*ST80Tools') ----- openFile FileList openFileDirectly! ----- Method: ScreenController>>openFileList (in category '*ST80Tools') ----- openFileList "Create and schedule a FileList view for specifying files to access." FileList open! ----- Method: ScreenController>>openPackageBrowser (in category '*ST80Tools') ----- openPackageBrowser "Create and schedule a Browser view for browsing code." PackagePaneBrowser openBrowser! ----- Method: ScreenController>>openSelectorBrowser (in category '*ST80Tools') ----- openSelectorBrowser "Create and schedule a selector fragment window." SelectorBrowser new open! ----- Method: ScreenController>>openSimpleChangeSorter (in category '*ST80Tools') ----- openSimpleChangeSorter ChangeSorter new open!

1 0

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

02 Jul '13

Frank Shearar uploaded a new version of Tests to project The Trunk: http://source.squeak.org/trunk/Tests-fbs.229.mcz ==================== Summary ==================== Name: Tests-fbs.229 Author: fbs Time: 2 July 2013, 8:30:52.72 pm UUID: d4802b6d-0eb5-0d41-8310-066e1f765af6 Ancestors: Tests-fbs.228 TrueType -/-> Multilingual. =============== Diff against Tests-fbs.228 =============== Item was changed: ----- Method: PackageDependencyTest>>testTrueType (in category 'tests') ----- testTrueType self testPackage: 'TrueType' dependsExactlyOn: #( Collections Balloon Files Graphics Kernel - Multilingual System 'ToolBuilder-Kernel' ).!

1 0

The System package and layered dependencies
by Frank Shearar 02 Jul '13

02 Jul '13

I've been working on introducing layered dependencies in the base image. That is, packages depend _only_ on packages below them. An immediate consequence of such a system is that you cannot have cyclic dependencies. You also have a _constructible_ system. The System package, however, stands as "vertical" package in the system. On one hand, it provides abstract hooks to services - AppRegistry subclasses like ToolSet, for instance. It also provides all manner of low level stuff, like System-Change Notification, SARInstaller and System-Object Events. And then it provides loads of extra stuff as well: crypto, an HTTP client, finalization, and so on. It's not that System is particularly large - it's only a little bigger than Kernel - but that System is a bit scattered in purpose, and provides too much inter-layer complications. Suggestions on how to break up System into smaller, more focused packages, greatly welcome! (Especially in the form of commits!)

1 0

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

02 Jul '13

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

1 0

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

02 Jul '13

Frank Shearar uploaded a new version of Graphics to project The Trunk: http://source.squeak.org/trunk/Graphics-fbs.213.mcz ==================== Summary ==================== Name: Graphics-fbs.213 Author: fbs Time: 2 July 2013, 8:22:08.772 pm UUID: 4596c82c-588c-8d45-8f6f-f91168e57234 Ancestors: Graphics-fbs.212 Break the Multilingual <-> TrueType cyclic dependency by moving TTC (TrueType Collection) classes to TrueType and FixedFaceFont to Graphics-Fonts (because this concerns displaying fonts). =============== Diff against Graphics-fbs.212 =============== Item was changed: SystemOrganization addCategory: #'Graphics-Display Objects'! + SystemOrganization addCategory: #'Graphics-External-Ffenestri'! SystemOrganization addCategory: #'Graphics-Files'! SystemOrganization addCategory: #'Graphics-Fonts'! SystemOrganization addCategory: #'Graphics-Primitives'! SystemOrganization addCategory: #'Graphics-Text'! SystemOrganization addCategory: #'Graphics-Transformations'! - SystemOrganization addCategory: #'Graphics-External-Ffenestri'! Item was added: + AbstractFont subclass: #FixedFaceFont + instanceVariableNames: 'baseFont substitutionCharacter displaySelector' + classVariableNames: '' + poolDictionaries: '' + category: 'Graphics-Fonts'! + + !FixedFaceFont commentStamp: 'tak 12/22/2004 01:45' prior: 0! + I am a font for special purpose like password or fallback. + I can show same form whenever someone requests any character. + + Variable displaySelector is future use to show a form dynamically. + (Although it would be unnecessary...)! Item was added: + ----- Method: FixedFaceFont>>ascent (in category 'accessing') ----- + ascent + ^baseFont ascent! Item was added: + ----- Method: FixedFaceFont>>ascentOf: (in category 'accessing') ----- + ascentOf: aCharacter + ^ self ascent! Item was added: + ----- Method: FixedFaceFont>>baseFont (in category 'accessing') ----- + baseFont + ^baseFont! Item was added: + ----- Method: FixedFaceFont>>baseFont: (in category 'accessing') ----- + baseFont: aFont + baseFont := aFont! Item was added: + ----- Method: FixedFaceFont>>baseKern (in category 'accessing') ----- + baseKern + ^baseFont baseKern! Item was added: + ----- Method: FixedFaceFont>>characterFormAt: (in category 'accessing') ----- + characterFormAt: character + ^ baseFont characterFormAt: substitutionCharacter! Item was added: + ----- Method: FixedFaceFont>>descent (in category 'accessing') ----- + descent + ^baseFont descent! Item was added: + ----- Method: FixedFaceFont>>descentKern (in category 'accessing') ----- + descentKern + ^baseFont descentKern! Item was added: + ----- Method: FixedFaceFont>>descentOf: (in category 'accessing') ----- + descentOf: aCharacter + ^ self descent! Item was added: + ----- Method: FixedFaceFont>>displayErrorOn:length:at:kern: (in category 'displaying') ----- + displayErrorOn: aCanvas length: length at: aPoint kern: kernDelta + | maskedString | + maskedString := String new: length. + maskedString atAllPut: substitutionCharacter. + ^ baseFont + displayString: maskedString + on: aCanvas + from: 1 + to: length + at: aPoint + kern: kernDelta! Item was added: + ----- Method: FixedFaceFont>>displayErrorOn:length:at:kern:baselineY: (in category 'displaying') ----- + displayErrorOn: aCanvas length: length at: aPoint kern: kernDelta baselineY: baselineY + | maskedString | + maskedString := String new: length. + maskedString atAllPut: substitutionCharacter. + ^ baseFont + displayString: maskedString + on: aCanvas + from: 1 + to: length + at: aPoint + kern: kernDelta + baselineY: baselineY! Item was added: + ----- Method: FixedFaceFont>>displayPasswordOn:length:at:kern: (in category 'displaying') ----- + displayPasswordOn: aCanvas length: length at: aPoint kern: kernDelta + | maskedString | + maskedString := String new: length. + maskedString atAllPut: substitutionCharacter. + ^ baseFont + displayString: maskedString + on: aCanvas + from: 1 + to: length + at: aPoint + kern: kernDelta! Item was added: + ----- Method: FixedFaceFont>>displayPasswordOn:length:at:kern:baselineY: (in category 'displaying') ----- + displayPasswordOn: aCanvas length: length at: aPoint kern: kernDelta baselineY: baselineY + | maskedString | + maskedString := String new: length. + maskedString atAllPut: substitutionCharacter. + ^ baseFont + displayString: maskedString + on: aCanvas + from: 1 + to: length + at: aPoint + kern: kernDelta + baselineY: baselineY! Item was added: + ----- Method: FixedFaceFont>>displayString:on:from:to:at:kern: (in category 'displaying') ----- + displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta + | size | + size := stopIndex - startIndex + 1. + ^ self perform: displaySelector withArguments: (Array with: aDisplayContext with: size with: aPoint with: kernDelta with: aPoint y + self ascent).! Item was added: + ----- Method: FixedFaceFont>>displayString:on:from:to:at:kern:baselineY: (in category 'displaying') ----- + displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta baselineY: baselineY + | size | + size := stopIndex - startIndex + 1. + ^ self perform: displaySelector withArguments: (Array with: aDisplayContext with: size with: aPoint with: kernDelta with: baselineY).! Item was added: + ----- Method: FixedFaceFont>>displayString:on:from:to:at:kern:from: (in category 'displaying') ----- + displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont + | destPoint | + destPoint := self + displayString: aString + on: aBitBlt + from: startIndex + to: stopIndex + at: aPoint + kern: kernDelta. + ^ Array with: stopIndex + 1 with: destPoint! Item was added: + ----- Method: FixedFaceFont>>displayString:on:from:to:at:kern:from:baselineY: (in category 'displaying') ----- + displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta from: fromFont baselineY: baselineY + | destPoint | + destPoint := self + displayString: aString + on: aBitBlt + from: startIndex + to: stopIndex + at: aPoint + kern: kernDelta + baselineY: baselineY. + ^destPoint! Item was added: + ----- Method: FixedFaceFont>>emphasized: (in category 'accessing') ----- + emphasized: emph + ^self class new baseFont: (baseFont emphasized: emph)! Item was added: + ----- Method: FixedFaceFont>>errorFont (in category 'initialize-release') ----- + errorFont + displaySelector := #displayErrorOn:length:at:kern:baselineY:. + substitutionCharacter := $?.! Item was added: + ----- Method: FixedFaceFont>>familyName (in category 'accessing') ----- + familyName + ^baseFont familyName, '-pw'! Item was added: + ----- Method: FixedFaceFont>>fontSize: (in category 'accessing') ----- + fontSize: aNumber + self baseFont: (StrikeFont familyName: baseFont familyName size: aNumber) copy! Item was added: + ----- Method: FixedFaceFont>>glyphInfoOf:into: (in category 'private') ----- + glyphInfoOf: aCharacter into: glyphInfoArray + + ^ baseFont glyphInfoOf: substitutionCharacter into: glyphInfoArray. + ! Item was added: + ----- Method: FixedFaceFont>>height (in category 'accessing') ----- + height + ^baseFont height! Item was added: + ----- Method: FixedFaceFont>>initialize (in category 'initialize-release') ----- + initialize + "This used to be the default textstyle, but it needs to be a StrikeFont and not a TTCFont and sometimes the default textstyle is a TTCFont. So, we use a typical StrikeFont as the default fallback font." + baseFont := StrikeFont defaultSized: 12. + self passwordFont! Item was added: + ----- Method: FixedFaceFont>>installOn:foregroundColor:backgroundColor: (in category 'displaying') ----- + installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor + ^baseFont installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor! Item was added: + ----- Method: FixedFaceFont>>lineGrid (in category 'accessing') ----- + lineGrid + ^baseFont lineGrid! Item was added: + ----- Method: FixedFaceFont>>maxAscii (in category 'accessing') ----- + maxAscii + ^ SmallInteger maxVal! Item was added: + ----- Method: FixedFaceFont>>passwordCharacter (in category 'accessing') ----- + passwordCharacter + ^$*! Item was added: + ----- Method: FixedFaceFont>>passwordFont (in category 'initialize-release') ----- + passwordFont + displaySelector := #displayPasswordOn:length:at:kern:baselineY:. + substitutionCharacter := $*! Item was added: + ----- Method: FixedFaceFont>>pointSize (in category 'accessing') ----- + pointSize + ^baseFont pointSize! Item was added: + ----- Method: FixedFaceFont>>releaseCachedState (in category 'caching') ----- + releaseCachedState + baseFont releaseCachedState.! Item was added: + ----- Method: FixedFaceFont>>widthOf: (in category 'measuring') ----- + widthOf: aCharacter + ^ baseFont widthOf: substitutionCharacter!

1 0

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

02 Jul '13

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

1 0

Jump to page: