[Pkg] The Trunk: Morphic-fbs.674.mcz

commits at source.squeak.org commits at source.squeak.org
Tue Jul 23 19:43:08 UTC 2013


Frank Shearar uploaded a new version of Morphic to project The Trunk:
http://source.squeak.org/trunk/Morphic-fbs.674.mcz

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

Name: Morphic-fbs.674
Author: fbs
Time: 23 July 2013, 8:19:08.276 pm
UUID: 64910e8e-45f5-1248-b74d-5c66938bf1c5
Ancestors: Morphic-dtl.673

Break Graphics -> Morphic dependency. Push some UI-independent code down from Morphic into Graphics, and move extension-y things up into Morphic.

=============== Diff against Morphic-dtl.673 ===============

Item was added:
+ ----- Method: CompositionScanner>>composeFrom:inRectangle:firstLine:leftSide:rightSide: (in category '*Morphic-Text') -----
+ 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 added:
+ ----- Method: DisplayScreen>>defaultCanvasClass (in category '*Morphic-blitter defaults') -----
+ defaultCanvasClass
+ 	"Return the WarpBlt version to use when I am active"
+ 	^FormCanvas!

Item was added:
+ ----- Method: DisplayText>>composeForm (in category '*Morphic-Text') -----
+ 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 removed:
- 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: 'Morphic-Text Support'!

Item was removed:
- ----- Method: TextComposer class>>characterForColumnBreak (in category 'as yet unclassified') -----
- characterForColumnBreak
- 
- 	^Character value: 12!

Item was removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- Object subclass: #TextLine
- 	instanceVariableNames: 'left right top bottom firstIndex lastIndex internalSpaces paddingWidth baseline leftMargin'
- 	classVariableNames: ''
- 	poolDictionaries: 'TextConstants'
- 	category: 'Morphic-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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- Method: TextLine>>baseline (in category 'accessing') -----
- baseline
- 	^ baseline!

Item was removed:
- ----- Method: TextLine>>bottom (in category 'accessing') -----
- bottom
- 	^ bottom!

Item was removed:
- ----- Method: TextLine>>bottomRight (in category 'accessing') -----
- bottomRight
- 	^ right at bottom!

Item was removed:
- ----- Method: TextLine>>first (in category 'accessing') -----
- first
- 	^ firstIndex!

Item was removed:
- ----- Method: TextLine>>firstIndex:lastIndex: (in category 'private') -----
- firstIndex: firstInteger lastIndex: lastInteger
- 	firstIndex := firstInteger.
- 	lastIndex := lastInteger!

Item was removed:
- ----- Method: TextLine>>hash (in category 'comparing') -----
- hash
- 	"#hash is re-implemented because #= is re-implemented"
- 	^firstIndex hash bitXor: lastIndex hash!

Item was removed:
- ----- Method: TextLine>>internalSpaces (in category 'accessing') -----
- internalSpaces
- 	"Answer the number of spaces in the line."
- 
- 	^internalSpaces!

Item was removed:
- ----- Method: TextLine>>internalSpaces: (in category 'accessing') -----
- internalSpaces: spacesInteger 
- 	"Set the number of spaces in the line to be spacesInteger."
- 
- 	internalSpaces := spacesInteger!

Item was removed:
- ----- Method: TextLine>>internalSpaces:paddingWidth: (in category 'private') -----
- internalSpaces: spacesInteger paddingWidth: padWidthInteger
- 
- 	internalSpaces := spacesInteger.
- 	paddingWidth := padWidthInteger!

Item was removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- Method: TextLine>>last (in category 'accessing') -----
- last
- 	^ lastIndex!

Item was removed:
- ----- Method: TextLine>>left (in category 'accessing') -----
- left
- 	^ left!

Item was removed:
- ----- Method: TextLine>>leftMargin (in category 'accessing') -----
- leftMargin
- 	"This has to get fixed -- store during composition"
- 	^ self left!

Item was removed:
- ----- Method: TextLine>>leftMargin: (in category 'accessing') -----
- leftMargin: lm
- 	left := lm!

Item was removed:
- ----- 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 removed:
- ----- Method: TextLine>>lineHeight (in category 'accessing') -----
- lineHeight
- 	^ bottom - top!

Item was removed:
- ----- Method: TextLine>>lineHeight:baseline: (in category 'private') -----
- lineHeight: height baseline: ascent
- 	bottom := top + height.
- 	baseline := ascent!

Item was removed:
- ----- 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 removed:
- ----- Method: TextLine>>paddingWidth (in category 'accessing') -----
- paddingWidth
- 	"Answer the amount of space to be added to the font."
- 
- 	^paddingWidth!

Item was removed:
- ----- 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 removed:
- ----- Method: TextLine>>printOn: (in category 'printing') -----
- printOn: aStream
- 	super printOn: aStream.
- 	aStream space; print: firstIndex; nextPutAll: ' to: '; print: lastIndex!

Item was removed:
- ----- Method: TextLine>>rectangle (in category 'accessing') -----
- rectangle
- 	^ self topLeft corner: self bottomRight!

Item was removed:
- ----- Method: TextLine>>rectangle: (in category 'accessing') -----
- rectangle: lineRectangle
- 	left := lineRectangle left.
- 	right := lineRectangle right.
- 	top := lineRectangle top.
- 	bottom := lineRectangle bottom!

Item was removed:
- ----- Method: TextLine>>right (in category 'accessing') -----
- right
- 	^ right!

Item was removed:
- ----- Method: TextLine>>rightMargin (in category 'accessing') -----
- rightMargin
- 	"This has to get fixed -- store during composition"
- 	^ self right!

Item was removed:
- ----- Method: TextLine>>setRight: (in category 'accessing') -----
- setRight: x
- 	right := x!

Item was removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- 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 removed:
- ----- Method: TextLine>>top (in category 'accessing') -----
- top
- 	^ top!

Item was removed:
- ----- Method: TextLine>>topLeft (in category 'accessing') -----
- topLeft
- 	^ left @ top!

Item was removed:
- ----- Method: TextLine>>width (in category 'accessing') -----
- width
- 	^ right - left!

Item was added:
+ ----- Method: TextStyle class>>emphasisMenuForFont:target:selector:highlight: (in category '*Morphic-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 added:
+ ----- Method: TextStyle class>>fontMenuForStyle:target:selector: (in category '*Morphic-user interface') -----
+ fontMenuForStyle: styleName target: target selector: selector
+ 	^self fontMenuForStyle: styleName target: target selector: selector highlight: nil!

Item was added:
+ ----- Method: TextStyle class>>fontMenuForStyle:target:selector:highlight: (in category '*Morphic-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 added:
+ ----- Method: TextStyle class>>fontSizeSummary (in category '*Morphic-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 added:
+ ----- Method: TextStyle class>>promptForFont:andSendTo:withSelector: (in category '*Morphic-user interface') -----
+ promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector
+ 	self promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector highlight: nil!

Item was added:
+ ----- Method: TextStyle class>>promptForFont:andSendTo:withSelector:highlight: (in category '*Morphic-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 Packages mailing list