[squeak-dev] The Trunk: Graphics-fbs.220.mczcommits at source.squeak.org commits at source.squeak.orgTue Jul 23 19:41:44 UTC 2013
Frank Shearar uploaded a new version of Graphics to project The Trunk: http://source.squeak.org/trunk/Graphics-fbs.220.mcz ==================== Summary ==================== Name: Graphics-fbs.220 Author: fbs Time: 23 July 2013, 8:18:46.726 pm UUID: 4066227b-0cc5-0f4f-a6b8-dd4f0c5e27f1 Ancestors: Graphics-fbs.219 Break Graphics -> Morphic dependency. Push some UI-independent code down from Morphic into Graphics, and move extension-y things up into Morphic. =============== Diff against Graphics-fbs.219 =============== 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-Text Support'! Item was removed: - ----- Method: CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide: (in category 'scanning') ----- - composeFrom: startIndex inRectangle: lineRectangle - firstLine: firstLine leftSide: leftSide rightSide: rightSide - "Answer an instance of TextLineInterval that represents the next line in the paragraph." - | runLength stopCondition | - "Set up margins" - leftMargin := lineRectangle left. - leftSide ifTrue: [leftMargin := leftMargin + - (firstLine ifTrue: [textStyle firstIndent] - ifFalse: [textStyle restIndent])]. - destX := spaceX := leftMargin. - rightMargin := lineRectangle right. - rightSide ifTrue: [rightMargin := rightMargin - textStyle rightIndent]. - lastIndex := startIndex. "scanning sets last index" - destY := lineRectangle top. - lineHeight := baseline := 0. "Will be increased by setFont" - line := (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) - rectangle: lineRectangle. - self setStopConditions. "also sets font" - runLength := text runLengthFor: startIndex. - runStopIndex := (lastIndex := startIndex) + (runLength - 1). - spaceCount := 0. - self handleIndentation. - leftMargin := destX. - line leftMargin: leftMargin. - - [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: [^ line lineHeight: lineHeight + textStyle leading - baseline: baseline + textStyle leading]] repeat! Item was removed: - ----- Method: DisplayScreen>>defaultCanvasClass (in category 'blitter defaults') ----- - defaultCanvasClass - "Return the WarpBlt version to use when I am active" - ^FormCanvas! Item was removed: - ----- Method: DisplayText>>composeForm (in category 'private') ----- - composeForm - "For the TT strings in MVC widgets in a Morphic world such as a progress bar, the form is created by Morphic machinery." - | canvas tmpText | - Smalltalk isMorphic - ifTrue: - [tmpText := TextMorph new contentsAsIs: text deepCopy. - foreColor ifNotNil: [tmpText text addAttribute: (TextColor color: foreColor)]. - backColor ifNotNil: [tmpText backgroundColor: backColor]. - tmpText setTextStyle: textStyle. - canvas := FormCanvas on: (Form extent: tmpText extent depth: 32). - tmpText drawOn: canvas. - form := canvas form. - ] - ifFalse: [form := self asParagraph asForm]! Item was added: + Object subclass: #TextComposer + instanceVariableNames: 'lines maxRightX currentY scanner possibleSlide nowSliding prevIndex prevLines currCharIndex startCharIndex stopCharIndex deltaCharIndex theText theContainer isFirstLine theTextStyle defaultLineHeight actualHeight wantsColumnBreaks' + classVariableNames: '' + poolDictionaries: '' + category: 'Graphics-Text Support'! Item was added: + ----- Method: TextComposer class>>characterForColumnBreak (in category 'as yet unclassified') ----- + characterForColumnBreak + + ^Character value: 12! Item was added: + ----- Method: TextComposer>>addNullLineForIndex: (in category 'as yet unclassified') ----- + addNullLineForIndex: index + "This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I couldn't figure out where to put it in the main logic." + + | oldLastLine r | + + oldLastLine := lines last. + oldLastLine last - oldLastLine first >= 0 ifFalse: [^self]. + oldLastLine last = (index - 1) ifFalse: [^self]. + + r := oldLastLine left @ oldLastLine bottom + extent: 0@(oldLastLine bottom - oldLastLine top). + "Even though we may be below the bottom of the container, + it is still necessary to compose the last line for consistency..." + + self addNullLineWithIndex: index andRectangle: r. + ! Item was added: + ----- Method: TextComposer>>addNullLineWithIndex:andRectangle: (in category 'as yet unclassified') ----- + addNullLineWithIndex: index andRectangle: r + + lines addLast: ( + ( + TextLine + start: index + stop: index - 1 + internalSpaces: 0 + paddingWidth: 0 + ) + rectangle: r; + lineHeight: defaultLineHeight baseline: theTextStyle baseline + ) + ! Item was added: + ----- Method: TextComposer>>checkIfReadyToSlide (in category 'as yet unclassified') ----- + checkIfReadyToSlide + + "Check whether we are now in sync with previously composed lines" + + (possibleSlide and: [currCharIndex > stopCharIndex]) ifFalse: [^self]. + + [prevIndex < prevLines size + and: [(prevLines at: prevIndex) first < (currCharIndex - deltaCharIndex)]] + whileTrue: [prevIndex := prevIndex + 1]. + + (prevLines at: prevIndex) first = (currCharIndex - deltaCharIndex) ifTrue: [ + "Yes -- next line will have same start as prior line." + prevIndex := prevIndex - 1. + possibleSlide := false. + nowSliding := true + ] ifFalse: [ + prevIndex = prevLines size ifTrue: [ + "Weve reached the end of prevLines, so no use to keep looking for lines to slide." + possibleSlide := false + ] + ]! Item was added: + ----- Method: TextComposer>>composeAllLines (in category 'as yet unclassified') ----- + composeAllLines + + [currCharIndex <= theText size and: + [(currentY + defaultLineHeight) <= theContainer bottom]] whileTrue: [ + + nowSliding ifTrue: [ + self slideOneLineDown ifNil: [^nil]. + ] ifFalse: [ + self composeOneLine ifNil: [^nil]. + ] + ]. + ! Item was added: + ----- Method: TextComposer>>composeAllRectangles: (in category 'as yet unclassified') ----- + composeAllRectangles: rectangles + + | charIndexBeforeLine numberOfLinesBefore reasonForStopping | + + actualHeight := defaultLineHeight. + charIndexBeforeLine := currCharIndex. + numberOfLinesBefore := lines size. + reasonForStopping := self composeEachRectangleIn: rectangles. + + currentY := currentY + actualHeight. + currentY > theContainer bottom ifTrue: [ + "Oops -- the line is really too high to fit -- back out" + currCharIndex := charIndexBeforeLine. + lines size - numberOfLinesBefore timesRepeat: [lines removeLast]. + ^self + ]. + + "It's OK -- the line still fits." + maxRightX := maxRightX max: scanner rightX. + 1 to: rectangles size - 1 do: [ :i | |lineIndex| + "Adjust heights across rectangles if necessary" + lineIndex:=lines size - rectangles size + i. + (lines size between: 1 and: lineIndex) ifTrue: + [(lines at: lineIndex) + lineHeight: lines last lineHeight + baseline: lines last baseline] + ]. + isFirstLine := false. + reasonForStopping == #columnBreak ifTrue: [^nil]. + currCharIndex > theText size ifTrue: [ + ^nil "we are finished composing" + ]. + ! Item was added: + ----- Method: TextComposer>>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. + 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 added: + ----- Method: TextComposer>>composeLinesFrom:to:delta:into:priorLines:atY:textStyle:text:container:wantsColumnBreaks: (in category 'as yet unclassified') ----- + composeLinesFrom: argStart to: argStop delta: argDelta into: argLinesCollection priorLines: argPriorLines atY: argStartY textStyle: argTextStyle text: argText container: argContainer wantsColumnBreaks: argWantsColumnBreaks + + wantsColumnBreaks := argWantsColumnBreaks. + lines := argLinesCollection. + theTextStyle := argTextStyle. + theText := argText. + theContainer := argContainer. + deltaCharIndex := argDelta. + currCharIndex := startCharIndex := argStart. + stopCharIndex := argStop. + prevLines := argPriorLines. + currentY := argStartY. + maxRightX := theContainer left. + possibleSlide := stopCharIndex < theText size and: [theContainer isMemberOf: Rectangle]. + nowSliding := false. + prevIndex := 1. + scanner := CompositionScanner new text: theText textStyle: theTextStyle. + scanner wantsColumnBreaks: wantsColumnBreaks. + defaultLineHeight := scanner canComputeDefaultLineHeight + ifTrue: [ scanner computeDefaultLineHeight ] + ifFalse: [ theTextStyle lineGrid. ]. + isFirstLine := true. + self composeAllLines. + isFirstLine ifTrue: ["No space in container or empty text" + self + addNullLineWithIndex: startCharIndex + andRectangle: (theContainer topLeft extent: 0 at defaultLineHeight) + ] ifFalse: [ + self fixupLastLineIfCR + ]. + ^{lines asArray. maxRightX} + + ! Item was added: + ----- Method: TextComposer>>composeOneLine (in category 'as yet unclassified') ----- + composeOneLine + | rectangles | + rectangles := theContainer rectanglesAt: currentY height: defaultLineHeight. + rectangles notEmpty + ifTrue: [(self composeAllRectangles: rectangles) ifNil: [^nil]] + ifFalse: [currentY := currentY + defaultLineHeight]. + self checkIfReadyToSlide! Item was added: + ----- Method: TextComposer>>fixupLastLineIfCR (in category 'as yet unclassified') ----- + fixupLastLineIfCR + "This awful bit is to ensure that if we have scanned all the text and the last character is a CR that there is a null line at the end of lines. Sometimes this was not happening which caused anomalous selections when selecting all the text. This is implemented as a post-composition fixup because I couldn't figure out where to put it in the main logic." + + (theText size > 0 and: [CharacterSet crlf includes: theText last]) ifFalse: [^self]. + self addNullLineForIndex: theText size + 1. + ! Item was added: + ----- Method: TextComposer>>slideOneLineDown (in category 'as yet unclassified') ----- + slideOneLineDown + + | priorLine | + + "Having detected the end of rippling recoposition, we are only sliding old lines" + prevIndex < prevLines size ifFalse: [ + "There are no more prevLines to slide." + ^nowSliding := possibleSlide := false + ]. + + "Adjust and re-use previously composed line" + prevIndex := prevIndex + 1. + priorLine := (prevLines at: prevIndex) + slideIndexBy: deltaCharIndex andMoveTopTo: currentY. + lines addLast: priorLine. + currentY := priorLine bottom. + currCharIndex := priorLine last + 1. + wantsColumnBreaks ifTrue: [ + priorLine first to: priorLine last do: [ :i | + (theText at: i) = TextComposer characterForColumnBreak ifTrue: [ + nowSliding := possibleSlide := false. + ^nil + ]. + ]. + ]. + ! Item was added: + Object subclass: #TextLine + instanceVariableNames: 'left right top bottom firstIndex lastIndex internalSpaces paddingWidth baseline leftMargin' + classVariableNames: '' + poolDictionaries: 'TextConstants' + category: 'Graphics-Text Support'! + + !TextLine commentStamp: '<historical>' prior: 0! + A TextLine embodies the layout of a line of composed text. + left right top bottom The full line rectangle + firstIndex lastIndex Starting and stopping indices in the full text + internalSpaces Number of spaces to share paddingWidth + paddingWidth Number of pixels of extra space in full line + baseline Distance of baseline below the top of the line + leftMargin Left margin due to paragraph indentation + TextLine's rather verbose message protocol is required for compatibility with the old CharacterScanners.! Item was added: + ----- Method: TextLine class>>start:stop:internalSpaces:paddingWidth: (in category 'instance creation') ----- + start: startInteger stop: stopInteger internalSpaces: spacesInteger paddingWidth: padWidthInteger + "Answer an instance of me with the arguments as the start, stop points, + number of spaces in the line, and width of the padding." + | line | + line := self new firstIndex: startInteger lastIndex: stopInteger. + ^ line internalSpaces: spacesInteger paddingWidth: padWidthInteger! Item was added: + ----- Method: TextLine>>= (in category 'comparing') ----- + = line + + self species = line species + ifTrue: [^((firstIndex = line first and: [lastIndex = line last]) + and: [internalSpaces = line internalSpaces]) + and: [paddingWidth = line paddingWidth]] + ifFalse: [^false]! Item was added: + ----- Method: TextLine>>baseline (in category 'accessing') ----- + baseline + ^ baseline! Item was added: + ----- Method: TextLine>>bottom (in category 'accessing') ----- + bottom + ^ bottom! Item was added: + ----- Method: TextLine>>bottomRight (in category 'accessing') ----- + bottomRight + ^ right at bottom! Item was added: + ----- Method: TextLine>>first (in category 'accessing') ----- + first + ^ firstIndex! Item was added: + ----- Method: TextLine>>firstIndex:lastIndex: (in category 'private') ----- + firstIndex: firstInteger lastIndex: lastInteger + firstIndex := firstInteger. + lastIndex := lastInteger! Item was added: + ----- Method: TextLine>>hash (in category 'comparing') ----- + hash + "#hash is re-implemented because #= is re-implemented" + ^firstIndex hash bitXor: lastIndex hash! Item was added: + ----- Method: TextLine>>internalSpaces (in category 'accessing') ----- + internalSpaces + "Answer the number of spaces in the line." + + ^internalSpaces! Item was added: + ----- Method: TextLine>>internalSpaces: (in category 'accessing') ----- + internalSpaces: spacesInteger + "Set the number of spaces in the line to be spacesInteger." + + internalSpaces := spacesInteger! Item was added: + ----- Method: TextLine>>internalSpaces:paddingWidth: (in category 'private') ----- + internalSpaces: spacesInteger paddingWidth: padWidthInteger + + internalSpaces := spacesInteger. + paddingWidth := padWidthInteger! Item was added: + ----- Method: TextLine>>justifiedPadFor: (in category 'scanning') ----- + justifiedPadFor: spaceIndex + "Compute the width of pad for a given space in a line of justified text." + + | pad | + internalSpaces = 0 ifTrue: [^0]. + pad := paddingWidth // internalSpaces. + spaceIndex <= (paddingWidth \\ internalSpaces) + ifTrue: [^pad + 1] + ifFalse: [^pad]! Item was added: + ----- Method: TextLine>>justifiedPadFor:font: (in category 'scanning') ----- + justifiedPadFor: spaceIndex font: aFont + "Compute the width of pad for a given space in a line of justified text." + + | pad | + internalSpaces = 0 ifTrue: [^0]. + ^(aFont notNil and:[aFont isSubPixelPositioned]) + ifTrue:[paddingWidth * 1.0 / internalSpaces] + ifFalse:[ + pad := paddingWidth // internalSpaces. + spaceIndex <= (paddingWidth \\ internalSpaces) + ifTrue: [pad + 1] + ifFalse: [pad]] + ! Item was added: + ----- Method: TextLine>>justifiedTabDeltaFor: (in category 'scanning') ----- + justifiedTabDeltaFor: spaceIndex + "Compute the delta for a tab in a line of justified text, so tab falls + somewhere plausible when line is justified." + + | pad extraPad | + internalSpaces = 0 ifTrue: [^0]. + pad := paddingWidth // internalSpaces. + extraPad := paddingWidth \\ internalSpaces. + spaceIndex <= extraPad + ifTrue: [^spaceIndex * (pad + 1)] + ifFalse: [^extraPad * (pad + 1) + (spaceIndex - extraPad * pad)]! Item was added: + ----- Method: TextLine>>last (in category 'accessing') ----- + last + ^ lastIndex! Item was added: + ----- Method: TextLine>>left (in category 'accessing') ----- + left + ^ left! Item was added: + ----- Method: TextLine>>leftMargin (in category 'accessing') ----- + leftMargin + "This has to get fixed -- store during composition" + ^ self left! Item was added: + ----- Method: TextLine>>leftMargin: (in category 'accessing') ----- + leftMargin: lm + left := lm! Item was added: + ----- Method: TextLine>>leftMarginForAlignment: (in category 'accessing') ----- + leftMarginForAlignment: alignmentCode + alignmentCode = RightFlush ifTrue: [^ self left + paddingWidth]. + alignmentCode = Centered ifTrue: [^ self left + (paddingWidth//2)]. + ^ self left "leftFlush and justified"! Item was added: + ----- Method: TextLine>>lineHeight (in category 'accessing') ----- + lineHeight + ^ bottom - top! Item was added: + ----- Method: TextLine>>lineHeight:baseline: (in category 'private') ----- + lineHeight: height baseline: ascent + bottom := top + height. + baseline := ascent! Item was added: + ----- Method: TextLine>>moveBy: (in category 'updating') ----- + moveBy: delta + "Move my rectangle by the given delta" + left := left + delta x. + right := right + delta x. + top := top + delta y. + bottom := bottom + delta y. + ! Item was added: + ----- Method: TextLine>>paddingWidth (in category 'accessing') ----- + paddingWidth + "Answer the amount of space to be added to the font." + + ^paddingWidth! Item was added: + ----- Method: TextLine>>paddingWidth: (in category 'accessing') ----- + paddingWidth: padWidthInteger + "Set the amount of space to be added to the font to be padWidthInteger." + + paddingWidth := padWidthInteger! Item was added: + ----- Method: TextLine>>printOn: (in category 'printing') ----- + printOn: aStream + super printOn: aStream. + aStream space; print: firstIndex; nextPutAll: ' to: '; print: lastIndex! Item was added: + ----- Method: TextLine>>rectangle (in category 'accessing') ----- + rectangle + ^ self topLeft corner: self bottomRight! Item was added: + ----- Method: TextLine>>rectangle: (in category 'accessing') ----- + rectangle: lineRectangle + left := lineRectangle left. + right := lineRectangle right. + top := lineRectangle top. + bottom := lineRectangle bottom! Item was added: + ----- Method: TextLine>>right (in category 'accessing') ----- + right + ^ right! Item was added: + ----- Method: TextLine>>rightMargin (in category 'accessing') ----- + rightMargin + "This has to get fixed -- store during composition" + ^ self right! Item was added: + ----- Method: TextLine>>setRight: (in category 'accessing') ----- + setRight: x + right := x! Item was added: + ----- Method: TextLine>>slide: (in category 'updating') ----- + slide: delta + "Change the starting and stopping points of the line by delta." + + firstIndex := firstIndex + delta. + lastIndex := lastIndex + delta! Item was added: + ----- Method: TextLine>>slideIndexBy:andMoveTopTo: (in category 'updating') ----- + slideIndexBy: delta andMoveTopTo: newTop + "Relocate my character indices and y-values. + Used to slide constant text up or down in the wake of a text replacement." + + firstIndex := firstIndex + delta. + lastIndex := lastIndex + delta. + bottom := bottom + (newTop - top). + top := newTop. + ! Item was added: + ----- Method: TextLine>>stop: (in category 'accessing') ----- + stop: stopInteger + "Set the stopping point in the string of the line to be stopInteger." + + lastIndex := stopInteger! Item was added: + ----- Method: TextLine>>top (in category 'accessing') ----- + top + ^ top! Item was added: + ----- Method: TextLine>>topLeft (in category 'accessing') ----- + topLeft + ^ left @ top! Item was added: + ----- Method: TextLine>>width (in category 'accessing') ----- + width + ^ right - left! Item was removed: - ----- Method: TextStyle class>>emphasisMenuForFont:target:selector:highlight: (in category 'user interface') ----- - emphasisMenuForFont: font target: target selector: selector highlight: currentEmphasis - "Offer a font emphasis menu for the given style. If one is selected, pass that font to target with a call to selector. The fonts will be displayed in that font. - Answer nil if no derivatives exist. - " - - | aMenu derivs | - derivs := font derivativeFonts. - derivs isEmpty ifTrue: [ ^nil ]. - aMenu := MenuMorph entitled: 'emphasis' translated. - derivs := derivs asOrderedCollection. - derivs addFirst: font. - derivs do: [ :df | - aMenu - add: df emphasisString - target: target - selector: selector - argument: df. - aMenu lastItem font: df. - df emphasis == currentEmphasis ifTrue: [aMenu lastItem color: Color blue darker]]. - ^ aMenu! Item was removed: - ----- Method: TextStyle class>>fontMenuForStyle:target:selector: (in category 'user interface') ----- - fontMenuForStyle: styleName target: target selector: selector - ^self fontMenuForStyle: styleName target: target selector: selector highlight: nil! Item was removed: - ----- Method: TextStyle class>>fontMenuForStyle:target:selector:highlight: (in category 'user interface') ----- - fontMenuForStyle: styleName target: target selector: selector highlight: currentFont - "Offer a font menu for the given style. If one is selected, pass - that font to target with a - call to selector. The fonts will be displayed in that font." - | aMenu | - aMenu := MenuMorph entitled: styleName. - (TextStyle named: styleName) - ifNotNil: [:s | s isTTCStyle - ifTrue: [aMenu - add: 'New Size' - target: self - selector: #chooseTTCFontSize: - argument: {styleName. target. selector}]]. - (self pointSizesFor: styleName) - do: [:pointSize | - | font subMenu displayFont | - font := (self named: styleName) - fontOfPointSize: pointSize. - subMenu := self - emphasisMenuForFont: font - target: target - selector: selector - highlight: (currentFont - ifNotNil: [:cf | (cf familyName = styleName - and: [cf pointSize = font pointSize]) - ifTrue: [currentFont emphasis]]). - subMenu - ifNil: [aMenu - add: pointSize asString , ' Point' - target: target - selector: selector - argument: font] - ifNotNil: [aMenu add: pointSize asString , ' Point' subMenu: subMenu]. - displayFont := font. - (font isSymbolFont or:[(font hasDistinctGlyphsForAll: pointSize asString , ' Point') not]) - ifTrue:[ - "don't use a symbol font to display its own name!!!!" - displayFont := self default fontOfPointSize: pointSize]. - aMenu lastItem font: displayFont. - currentFont - ifNotNil: [:cf | (cf familyName = styleName - and: [cf pointSize = font pointSize]) - ifTrue: [aMenu lastItem color: Color blue darker]]]. - ^ aMenu! Item was removed: - ----- Method: TextStyle class>>fontSizeSummary (in category 'user interface') ----- - fontSizeSummary - "Open a text window with a simple summary of the available sizes in each of the fonts in the system." - - "TextStyle fontSizeSummary" - | aString aList | - aList := self knownTextStyles. - aString := String streamContents: - [:aStream | - aList do: [:aStyleName | - aStream nextPutAll: - aStyleName, ' ', - (self fontPointSizesFor: aStyleName) asArray storeString. - aStream cr]]. - (StringHolder new contents: aString) - openLabel: 'Font styles and sizes' translated! Item was removed: - ----- Method: TextStyle class>>promptForFont:andSendTo:withSelector: (in category 'user interface') ----- - promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector - self promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector highlight: nil! Item was removed: - ----- Method: TextStyle class>>promptForFont:andSendTo:withSelector:highlight: (in category 'user interface') ----- - promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector highlight: currentFont - "Morphic Only!! prompt for a font and if one is provided, send it to aTarget using a - message with selector aSelector." - "TextStyle promptForFont: 'Choose system font:' andSendTo: Preferences withSelector: - #setSystemFontTo: " - "Derived from a method written by Robin Gibson" - | menu currentTextStyle | - currentTextStyle := currentFont - ifNotNil: [currentFont textStyleName]. - menu := MenuMorph entitled: aPrompt. - self actualTextStyles keysSortedSafely - do: [:styleName | | subMenu | - subMenu := self - fontMenuForStyle: styleName - target: aTarget - selector: aSelector - highlight: currentFont. - menu add: styleName subMenu: subMenu. - menu lastItem - font: ((self named: styleName) - fontOfSize: 18). - styleName = currentTextStyle - ifTrue: [menu lastItem color: Color blue darker]]. - menu popUpInWorld: self currentWorld!
More information about the Squeak-dev mailing list |