'From Cuis 1.0 of 27 August 2009 [latest update: #282] on 2 September 2009 at 10:32:33 am'!
"Change Set:		0284-TextAttributesEnh-jmv
Date:			2 September 2009
Author:			Juan Vuletich

<your descriptive text goes here>"
StrikeFont allInstancesDo: [ :a | a fixDerivatives ].
Text allInstancesDo: [ :a | a initialStyle ]!

!classDefinition: #CharacterScanner category: #'Graphics-Text'!
Object subclass: #CharacterScanner
	instanceVariableNames: 'destX lastIndex xTable map destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern actualTextStyle '
	classVariableNames: 'DefaultStopConditions '
	poolDictionaries: ''
	category: 'Graphics-Text'!
!classDefinition: #IfNotNilTests category: #'Kernel Tests'!
TestCase subclass: #IfNotNilTests
	instanceVariableNames: 'z '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel Tests'!
!classDefinition: #ProcessorTest category: #'Kernel Tests'!
TestCase subclass: #ProcessorTest
	instanceVariableNames: 'z '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel Tests'!
!classDefinition: #SemaphoreTest category: #'Kernel Tests'!
TestCase subclass: #SemaphoreTest
	instanceVariableNames: 'z '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel Tests'!
!classDefinition: #StrikeFontTest category: #'Kernel Tests'!
TestCase subclass: #StrikeFontTest
	instanceVariableNames: 'z '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel Tests'!
!classDefinition: #StringTest category: #'Kernel Tests'!
TestCase subclass: #StringTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel Tests'!
!classDefinition: #TimeTest category: #'Kernel Tests'!
TestCase subclass: #TimeTest
	instanceVariableNames: 'z '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel Tests'!

!Canvas methodsFor: 'drawing' stamp: 'jmv 9/1/2009 17:58'!
paragraph: paragraph bounds: bounds color: c editor: anEditorOrNil
	"Draw the given paragraph"
	^self subclassResponsibility! !


!CharacterScanner methodsFor: 'private' stamp: 'jmv 9/1/2009 17:52'!
setFont
	| priorFont |
	"Set the font and other emphasis.
	In fact set actual TextStyle, alignment, font and emphasis"
	
	priorFont _ font.
	text
		withAttributeValuesAt: lastIndex 
		do: [ :fontInText :colorInText :alignmentInText :textStyleInText :characterStyleInText :kernInText |
			self setActualFont: fontInText.
			colorInText ifNotNil: [ self textColor: colorInText ].
			alignment _ alignmentInText.
			kern _ kernInText.
			actualTextStyle _ textStyleInText ].
	priorFont ifNotNil: [ destX _ destX + priorFont descentKern ].
	destX _ destX - font descentKern.
	kern _ kern - font baseKern.

	"Install various parameters from the font."
	spaceWidth _ font widthOf: Character space.
	xTable _ font xTable.
	map _ font characterToGlyphMap.
	stopConditions _ DefaultStopConditions! !


!ColorMappingCanvas methodsFor: 'drawing' stamp: 'jmv 9/1/2009 17:59'!
paragraph: paragraph bounds: bounds color: c editor: anEditorOrNil
	"Draw the given paragraph"
	myCanvas
		paragraph: paragraph
		bounds: bounds
		color: (self mapColor: c)
		editor: anEditorOrNil! !


!Editor methodsFor: 'accessing' stamp: 'jmv 9/1/2009 18:09'!
currentAttributes
	"Redefined by subclasses that handle TextAttributes"
	^nil! !


!FormCanvas methodsFor: 'drawing' stamp: 'jmv 9/1/2009 17:58'!
paragraph: para bounds: bounds color: c editor: anEditorOrNil

	| scanner |
	self setPaintColor: c.
	scanner _ (port clippedBy: (bounds translateBy: origin))
		displayScannerFor: para
		foreground: (self shadowColor ifNil: [c])
		ignoreColorChanges: self shadowColor notNil.
	para
		displayOn: (self copyClipRect: bounds)
		using: scanner
		at: origin+ bounds topLeft
		editor: anEditorOrNil! !


!Message methodsFor: 'testing' stamp: 'jmv 9/1/2009 10:45'!
hasArguments
	^args size > 0! !


!NewParagraph methodsFor: 'display' stamp: 'jmv 9/1/2009 18:18'!
displaySelectionInLine: line on: aCanvas editor: anEditorOrNil
	| leftX rightX idx caretFont t b caretAttributes |
	selectionStart ifNil: [^self].	"No selection"
	selectionStart = selectionStop 
		ifTrue: [
			"Only show caret on line where clicked"
			selectionStart textLine ~= line ifTrue: [^self]
			]
		ifFalse: [
			"Test entire selection before or after here"
			(selectionStop stringIndex < line first 
				or: [selectionStart stringIndex > (line last + 1)])
					ifTrue: [^self].	"No selection on this line"
			(selectionStop stringIndex = line first 
				and: [selectionStop textLine ~= line])
					ifTrue: [^self].	"Selection ends on line above"
			(selectionStart stringIndex = (line last + 1) 
				and: [selectionStop textLine ~= line])
					ifTrue: [^self]].	"Selection begins on line below"
	leftX _ (selectionStart stringIndex < line first 
				ifTrue: [ line ]
				ifFalse: [ selectionStart ]) left.
	rightX _ (selectionStop stringIndex > (line last + 1) or: [
					selectionStop stringIndex = (line last + 1) 
						and: [selectionStop textLine ~= line]]) 
				ifTrue: [line right]
				ifFalse: [selectionStop left].
	selectionStart = selectionStop 
		ifTrue: [
			idx _ selectionStart stringIndex.
			caretAttributes _ anEditorOrNil ifNotNil: [ anEditorOrNil currentAttributes ].
			caretFont _ caretAttributes
				ifNil: [ text fontAt: idx ]
				ifNotNil: [ text fontIfApplying: caretAttributes ].
			b _ line top + line baseline + caretFont descent.
			t _ line top + line baseline - caretFont ascent.
			self
				displayInsertionMarkAtX: leftX
				top: t
				bottom: b
				width: self caretWidth
				emphasis: caretFont emphasis
				on: aCanvas
			]
		ifFalse: [
			aCanvas fillRectangle: (leftX @ line top corner: rightX @ line bottom)
				color: self selectionColor]! !

!NewParagraph methodsFor: 'editing' stamp: 'jmv 9/1/2009 23:10'!
replaceFrom: start to: stop with: aText
	"Edit the text, and then recompose the lines." 
	
	| intervalToFix |
	text replaceFrom: start to: stop with: aText.
	
	"The interval actually modified in text can begin before start, because of paragraph attributes"
	intervalToFix _ text encompassParagraph: (start to: start + aText size - 1).
	self
		recomposeFrom: intervalToFix first
		to: intervalToFix last
		delta: aText size - (stop-start+1)! !

!NewParagraph methodsFor: 'fonts-display' stamp: 'jmv 9/1/2009 17:57'!
displayOn: aCanvas using: displayScanner at: somePosition editor: anEditorOrNil
	"Send all visible lines to the displayScanner for display"
	| visibleRectangle offset leftInRun line |
	visibleRectangle _ aCanvas clipRect.
	offset _ (somePosition - positionWhenComposed) truncated.
	leftInRun _ 0.
	(self lineIndexForPoint: visibleRectangle topLeft)
		to: (self lineIndexForPoint: visibleRectangle bottomRight)
		do: [:i | line _ lines at: i.
			self displaySelectionInLine: line on: aCanvas editor: anEditorOrNil.
			line first <= line last ifTrue: [
				leftInRun _ displayScanner displayLine: line offset: offset leftInRun: leftInRun]].
! !


!PluggableTextMorph methodsFor: 'shout' stamp: 'jmv 9/1/2009 23:04'!
stylerStyled: styledCopyOfText

	textMorph contents privateSetRuns: styledCopyOfText runs.

	"textMorph paragraph recomposeFrom: 1 to: textMorph contents size delta: 0."
	"caused chars to appear in wrong order esp. in demo mode. remove this line when sure it is fixed"
	
	textMorph updateFromParagraph.
	selectionInterval 
		ifNotNil: [
			textMorph editor
				selectInvisiblyFrom: selectionInterval first to: selectionInterval last;
				storeSelectionInParagraph;
				setEmphasisHereFromText].
	textMorph editor blinkParen.
	self scrollSelectionIntoView! !


!SHTextStylerST80 methodsFor: 'private' stamp: 'jmv 9/1/2009 23:04'!
setAttributesIn: aText fromRanges: ranges
	| charAttr defaultAttr attr newRuns newValues lastAttr lastCount | 		

	defaultAttr := self attributesFor: #default.
	charAttr := Array new: aText size.
	1 to: charAttr size do: [ :i | charAttr at: i put: defaultAttr].
	ranges do: [ :range |
		(attr := self attributesFor: range type)
			ifNotNil: [ range start to: range end do: [:i | charAttr at: i put: attr]]].
	newRuns := OrderedCollection new: charAttr size // 10.
	newValues := OrderedCollection new: charAttr size // 10.
	1 to: charAttr size do: [:i |
		attr := charAttr at: i.
		i = 1 
			ifTrue: [
				newRuns add: 1.
				lastCount := 1.
				lastAttr := newValues add: attr]
			ifFalse:[
				attr == lastAttr
					ifTrue: [
						lastCount := lastCount + 1.
						newRuns at: newRuns size put: lastCount]
					ifFalse: [
						newRuns add: 1.
						lastCount := 1.
						lastAttr := newValues add: attr]]].
	aText privateSetRuns: (RunArray runs: newRuns values: newValues)
	! !


!String methodsFor: 'paragraph support' stamp: 'jmv 9/1/2009 14:05'!
encompassParagraph: anInterval
	"Return an interval that includes anInterval, and that comprises one or several whole paragraphs in the receiver.
	Answer starts at the position following a cr (or eventually 1) and ends at a cr (or eventually at self size)"
	| left right |
	left _ (self lastIndexOf: Character cr startingAt: anInterval first - 1 ifAbsent:[0]) + 1.
	right _ (self indexOf: Character cr startingAt: (anInterval last max: anInterval first) ifAbsent: [self size]).
	^left to: right! !


!StringTest methodsFor: 'testing' stamp: 'jmv 9/1/2009 14:12'!
testEncompassParagraph1

	self assert: ('a' encompassParagraph: (1 to: 0)) = (1 to: 1).
	self assert: ('a' encompassParagraph: (1 to: 1)) = (1 to: 1).
	self assert: ('a' encompassParagraph: (2 to: 1)) = (1 to: 1).! !

!StringTest methodsFor: 'testing' stamp: 'jmv 9/1/2009 14:13'!
testEncompassParagraph2

	self assert: ('ab' encompassParagraph: (1 to: 0)) = (1 to: 2).
	self assert: ('ab' encompassParagraph: (1 to: 1)) = (1 to: 2).
	self assert: ('ab' encompassParagraph: (1 to: 2)) = (1 to: 2).
	self assert: ('ab' encompassParagraph: (2 to: 1)) = (1 to: 2).
	self assert: ('ab' encompassParagraph: (2 to: 2)) = (1 to: 2).
	self assert: ('ab' encompassParagraph: (3 to: 2)) = (1 to: 2).! !

!StringTest methodsFor: 'testing' stamp: 'jmv 9/1/2009 14:14'!
testEncompassParagraph3

self assert: ('a
' encompassParagraph: (1 to: 0)) = (1 to: 2).
self assert: ('a
' encompassParagraph: (1 to: 1)) = (1 to: 2).
self assert: ('a
' encompassParagraph: (1 to: 2)) = (1 to: 2).
self assert: ('a
' encompassParagraph: (2 to: 1)) = (1 to: 2).
self assert: ('a
' encompassParagraph: (2 to: 2)) = (1 to: 2).
self assert: ('a
' encompassParagraph: (3 to: 2)) = (3 to: 2).

self assert: ('a
zcxv' encompassParagraph: (1 to: 0)) = (1 to: 2).
self assert: ('a
zcxv' encompassParagraph: (1 to: 1)) = (1 to: 2).
self assert: ('a
zxcv' encompassParagraph: (1 to: 2)) = (1 to: 2).
self assert: ('a
zxcv' encompassParagraph: (2 to: 1)) = (1 to: 2).
self assert: ('a
zxcv' encompassParagraph: (2 to: 2)) = (1 to: 2).
self assert: ('a
zxcv' encompassParagraph: (3 to: 2)) = (3 to: 6).! !

!StringTest methodsFor: 'testing' stamp: 'jmv 9/1/2009 14:17'!
testEncompassParagraph4

self assert: ('
b' encompassParagraph: (1 to: 0)) = (1 to: 1).
self assert: ('
b' encompassParagraph: (1 to: 1)) = (1 to: 1).
self assert: ('
b' encompassParagraph: (1 to: 2)) = (1 to: 2).
self assert: ('
b' encompassParagraph: (2 to: 1)) = (2 to: 2).
self assert: ('
b' encompassParagraph: (2 to: 2)) = (2 to: 2).
self assert: ('
b' encompassParagraph: (3 to: 2)) = (2 to: 2).! !

!StringTest methodsFor: 'testing' stamp: 'jmv 9/1/2009 14:22'!
testEncompassParagraph5

self assert: ('a
b' encompassParagraph: (1 to: 0)) = (1 to: 2).
self assert: ('a
b' encompassParagraph: (1 to: 1)) = (1 to: 2).
self assert: ('a
b' encompassParagraph: (1 to: 2)) = (1 to: 2).
self assert: ('a
b' encompassParagraph: (1 to: 3)) = (1 to: 3).
self assert: ('a
b' encompassParagraph: (2 to: 1)) = (1 to: 2).
self assert: ('a
b' encompassParagraph: (2 to: 2)) = (1 to: 2).
self assert: ('a
b' encompassParagraph: (2 to: 3)) = (1 to: 3).
self assert: ('a
b' encompassParagraph: (3 to: 2)) = (3 to: 3).
self assert: ('a
b' encompassParagraph: (3 to: 3)) = (3 to: 3).
self assert: ('a
b' encompassParagraph: (4 to: 3)) = (3 to: 3).! !


!Text methodsFor: 'accessing' stamp: 'jmv 9/1/2009 23:09'!
at: index put: character

	| answer prevChar |
	prevChar _ string at: index.
	answer _ string at: index put: character.

	"Only fix ParagraphAttributes if there is real danger of breaking the invariant"
	(prevChar = Character cr and: [
			(self attributesAt: index) anySatisfy: [ :attr | attr isParagraphAttribute]]) ifTrue: [
		self fixParagraphAttributesFrom: index to: index ].
	
	^answer! !

!Text methodsFor: 'accessing' stamp: 'jmv 9/1/2009 17:06'!
initialStyle

	^initialStyle! !

!Text methodsFor: 'accessing' stamp: 'jmv 9/1/2009 23:11'!
replaceFrom: start to: stop with: aText
	"newSize = oldSize - (stop-start-1) + aText size"
	
	| txt |
	txt _ aText asText.	"might be a string"
	string _ string copyReplaceFrom: start to: stop with: txt string.
	runs _ runs copyReplaceFrom: start to: stop with: txt runs.
	"Ensure the ParagraphAttributes invariant for the interval that could have been affected"
	self fixParagraphAttributesFrom: start to: start + aText size - 1! !

!Text methodsFor: 'converting' stamp: 'jmv 9/1/2009 23:12'!
replaceFrom: start to: stop with: replacement startingAt: repStart 
	"This destructively replaces elements from start to stop in the receiver starting at index, repStart, in replacementCollection. 
	Do it to both the string and the runs.
	The size does not change"

	| rep newRepRuns |
	rep _ replacement asText.	"might be a string"
	string replaceFrom: start to: stop with: rep string startingAt: repStart.
	newRepRuns _ rep runs copyFrom: repStart to: repStart + stop - start.
	runs _ runs copyReplaceFrom: start to: stop with: newRepRuns.
	"Ensure the ParagraphAttributes invariant for the interval that could have been affected"
	self fixParagraphAttributesFrom: start to: stop! !

!Text methodsFor: 'converting' stamp: 'jmv 9/1/2009 23:13'!
reversed
	"Answer a copy of the receiver with element order reversed."
	
	| answer |
	answer _ self class initialStyle: initialStyle string: string reversed runs: runs reversed.
	"Ensure the ParagraphAttributes invariant for the interval that could have been affected.
	The way it is done could be considered to be wrong. In this case, instead of making the text to take
	the ParagraphAttributes from the cr characters, it could be done the other way, making the cr's take 
	the ParagraphAttributes of the preceeding char. This way, the attributes would be mostrly preserved.
	I don't know if this is of much use anyway"
	answer fixParagraphAttributesFrom: 1 to: answer size.
	^answer

  "  It is assumed that  self size = runs size  holds. "! !

!Text methodsFor: 'emphasis' stamp: 'jmv 9/1/2009 23:10'!
addAttribute: att from: requestedStart to: requestedStop

	"Set the attribute for characters in the interval start to stop."
	| intervalToFix start stop |
	start _ requestedStart.
	stop _ requestedStop.
	
	"If att must be applied to whole paragraphs, do so."
	att isParagraphAttribute ifTrue: [
		intervalToFix _ self encompassParagraph: (start to: stop).
		start _ intervalToFix first.
		stop _ intervalToFix last ].

	runs _  runs
		copyReplaceFrom: start
		to: stop
		with: ((runs copyFrom: start to: stop) mapValues: [ :attributes | 
			Text addAttribute: att toArray: attributes])! !

!Text methodsFor: 'emphasis' stamp: 'jmv 9/1/2009 17:15'!
alignmentAt: characterIndex

	self withAttributeValuesAt: characterIndex do: [ :font :color :alignment :textStyle :characterStyle :kern |
		^alignment ]! !

!Text methodsFor: 'emphasis' stamp: 'jmv 9/1/2009 15:40'!
characterStyleOrNilAt: characterIndex
	| style |
	self size = 0 ifTrue: [ ^ nil ].
	(runs at: characterIndex) do: [:attribute | 
		attribute forCharacterStyleReferenceDo: [ :characterStyle | style _ characterStyle ]].
	^ style! !

!Text methodsFor: 'emphasis' stamp: 'jmv 9/1/2009 17:11'!
fontAt: characterIndex
	"Answer the font for characters in the run beginning at characterIndex."
	
	self withAttributeValuesAt: characterIndex do: [ :font :color :alignment :textStyle :characterStyle :kern |
		^font ]! !

!Text methodsFor: 'emphasis' stamp: 'jmv 9/1/2009 18:06'!
fontIfApplying: textAttributes
	"Answer the font for characters in the run beginning at characterIndex."
	
	self withAttributeValues: textAttributes do: [ :font :color :alignment :textStyle :characterStyle :kern |
		^font ]! !

!Text methodsFor: 'emphasis' stamp: 'jmv 9/1/2009 23:08'!
removeAttribute: att from: requestedStart to: requestedStop
	"Remove the attribute over the interval start to stop."

	| intervalToFix start stop |
	start _ requestedStart.
	stop _ requestedStop.
	
	"If att must be applied to whole paragraphs, do so."
	att isParagraphAttribute ifTrue: [
		intervalToFix _ self encompassParagraph: (start to: stop).
		start _ intervalToFix first.
		stop _ intervalToFix last ].

	runs _  runs
		copyReplaceFrom: start
		to: stop
		with: ((runs copyFrom: start to: stop) mapValues: [ :attributes | 
			attributes copyWithout: att])! !

!Text methodsFor: 'emphasis' stamp: 'jmv 9/1/2009 16:37'!
textStyleAt: characterIndex
	| textStyle |
	textStyle _ initialStyle.
	self size = 0 ifTrue: [ ^ textStyle ].
	(runs at: characterIndex) do: [ :attribute | 
		attribute forTextStyleReferenceDo: [ :s | textStyle _ s ] ].
	^textStyle! !

!Text methodsFor: 'emphasis' stamp: 'jmv 9/1/2009 18:06'!
withAttributeValues: attributes do: aBlock
	"Evaluate aBlock with the values of various attributes applied in the correct order
	The order is (each overwriting the previous one)
	1) initialStyle
	2) TextStyleReferene
	3) CharacterStyleReference
	4) TextFontReference
	5) TextEmphasis"

	| textStyle characterStyle font emphasis alignment color kern |
	textStyle _ initialStyle.	"First candidate as the textStyle"
	emphasis _ 0.
	kern _ 0.
	
	"TextStyle is the first to set several values"
	attributes do: [ :attribute |
		attribute forTextStyleReferenceDo: [ :s | 
			textStyle _ s.
			textStyle color ifNotNil: [ :c | color _ c ]]].
	font _ textStyle font.
	alignment _ textStyle alignment.
	
	"CharacterStyle, if present, can override font and color"
	attributes do: [ :attribute |
		attribute forCharacterStyleReferenceDo: [ :s | 
			characterStyle _ s.
			font _ characterStyle font.
			characterStyle color ifNotNil: [ :c | color _ c ]]].
	
	"Hardcoded color for TextAction comes before TextColor"
	attributes do: [ :attribute |
		attribute forTextActionInfoDo: [ :info | color _ TextAction purple ]].

	"These will not interfere with each other, and all of them take precedence over previous values"
	attributes do: [ :attribute |
		attribute forFontReferenceDo: [ :f | font _ f ].
		attribute forTextEmphasisDo: [ :e | emphasis _ emphasis bitOr: e ].
		attribute forTextColorDo: [ :c | color _ c ].
		attribute forTextAlignmentDo: [ :a | alignment _ a ].
		attribute forTextKernDo: [ :k | kern _ kern + k ].
	].

	"Finally, the font must include any specified emphasis"
	font _ font emphasized: emphasis.
	
	"Done. Now evaluate the block."
	aBlock valueWithArguments: {font. color. alignment. textStyle. characterStyle. kern }! !

!Text methodsFor: 'emphasis' stamp: 'jmv 9/1/2009 18:06'!
withAttributeValuesAt: idx do: aBlock
	"Evaluate aBlock with the values of various attributes at position idx
	The order is (each overwriting the previous one)
	1) initialStyle
	2) TextStyleReferene
	3) CharacterStyleReference
	4) TextFontReference
	5) TextEmphasis"

	| attributes |
	attributes _ self size = 0
		ifTrue: [ #() ]
		ifFalse: [ runs at: idx ].
	^self withAttributeValues: attributes do: aBlock! !

!Text methodsFor: 'private' stamp: 'jmv 9/1/2009 23:07'!
fixParagraphAttributesFrom: start to: end
	"Helper method to ensure the invariant that TextAttributes that answer true to
	 #isParagraphAttribute are only applied to whole paragraphs.
	See senders"
	
	| paragraphEnd paragraphInterval paragraphStart paragraphAttributes |
	
	paragraphEnd _ end max: start.	"end could be start-1 when new text is empty, for example, when backspacing"
	[
		paragraphInterval _ self encompassParagraph: (paragraphEnd to: paragraphEnd).
		paragraphStart _ paragraphInterval first.
		paragraphEnd _ paragraphInterval last.
		"We must honor the paragraph attributes as defined in the Character enter that ends the paragraph"
		paragraphAttributes _ (self attributesAt: paragraphEnd) select: [ :attr | attr isParagraphAttribute ].
		self privateSetParagraphAttributes: paragraphAttributes from: paragraphStart to: paragraphEnd.
	
		paragraphEnd _ paragraphStart - 1.
		paragraphStart > start ] whileTrue! !

!Text methodsFor: 'private' stamp: 'jmv 9/1/2009 23:05'!
privateSetRuns: anArray
	"Warning. No attempt is done to ensure the invariant that TextAttributes that answer true to
	 #isParagraphAttribute are only applied to whole paragraphs.
	Use with care. Currently only used for Shout, that seems to know what it does."

	runs _ anArray! !

!Text methodsFor: 'private' stamp: 'jmv 9/1/2009 23:05'!
setInitialStyle: aTextStyle setString: aString setRuns: anArray
	"Warning. No attempt is done to ensure the invariant that TextAttributes that answer true to
	 #isParagraphAttribute are only applied to whole paragraphs.
	Use with care. "

	initialStyle _ aTextStyle.
	string _ aString.
	runs _ anArray! !


!Text class methodsFor: 'instance creation' stamp: 'jmv 9/1/2009 09:55'!
initialStyle: aTextStyle string: aString
	"Answer an instance of me whose characters are those of aString."

	^self initialStyle: aTextStyle string: aString attributes: #()! !


!TextAttribute methodsFor: 'iterating' stamp: 'jmv 9/1/2009 15:44'!
forCharacterStyleReferenceDo: aBlock
	"No action is the default"! !

!TextAttribute methodsFor: 'iterating' stamp: 'jmv 9/1/2009 15:44'!
forFontReferenceDo: aBlock
	"No action is the default"! !

!TextAttribute methodsFor: 'iterating' stamp: 'jmv 9/1/2009 15:44'!
forTextActionInfoDo: aBlock
	"No action is the default"! !

!TextAttribute methodsFor: 'iterating' stamp: 'jmv 9/1/2009 15:48'!
forTextAlignmentDo: aBlock
	"No action is the default"! !

!TextAttribute methodsFor: 'iterating' stamp: 'jmv 9/1/2009 15:46'!
forTextColorDo: aBlock
	"No action is the default"! !

!TextAttribute methodsFor: 'iterating' stamp: 'jmv 9/1/2009 16:12'!
forTextEmphasisDo: aBlock
	"No action is the default"! !

!TextAttribute methodsFor: 'iterating' stamp: 'jmv 9/1/2009 16:31'!
forTextKernDo: aBlock
	"No action is the default"! !

!TextAttribute methodsFor: 'iterating' stamp: 'jmv 9/1/2009 16:07'!
forTextStyleReferenceDo: aBlock
	"No action is the default"! !


!TextAction methodsFor: 'iterating' stamp: 'jmv 9/1/2009 15:44'!
forTextActionInfoDo: aBlock
	aBlock value: self info! !


!TextAction class methodsFor: 'as yet unclassified' stamp: 'jmv 9/2/2009 10:30'!
purple
	^Purple! !


!TextAlignment methodsFor: 'iterating' stamp: 'jmv 9/1/2009 15:48'!
forTextAlignmentDo: aBlock
	aBlock value: alignment! !


!TextColor methodsFor: 'iterating' stamp: 'jmv 9/1/2009 15:47'!
forTextColorDo: aBlock
	aBlock value: color! !


!TextEditor methodsFor: 'accessing' stamp: 'jmv 9/1/2009 18:09'!
currentAttributes
	^emphasisHere! !

!TextEditor methodsFor: 'attributes' stamp: 'jmv 9/1/2009 22:53'!
changeEmphasisOrAlignment
	| aList reply  code align menuList startIndex attribute |
	startIndex _ self startIndex.
	aList _ #(normal bold italic narrow underlined struckOut leftFlush centered rightFlush justified).	
	align _ paragraph text alignmentAt: startIndex.
	code _ paragraph text emphasisAt: startIndex.
	menuList _ WriteStream on: Array new.
	menuList nextPut: (code isZero ifTrue:['<on>'] ifFalse:['<off>']), 'normal' translated.
	menuList nextPutAll: (#(bold italic underlined struckOut) collect:[:emph|
		(code anyMask: (TextEmphasis perform: emph) emphasisCode)
			ifTrue: [ '<on>', emph asString translated ]
			ifFalse: [ '<off>',emph asString translated ]]).
	((paragraph text attributesAt: startIndex)
		anySatisfy: [ :attr | attr isKern and: [attr kern < 0 ]]) 
			ifTrue: [ menuList nextPut:'<on>', 'narrow' translated ]
			ifFalse: [ menuList nextPut:'<off>', 'narrow' translated ].
	menuList nextPutAll: (#(leftFlush centered rightFlush justified) collectWithIndex: [ :type :i |
		align = (i-1)
			ifTrue: [ '<on>',type asString translated ]
			ifFalse: [ '<off>',type asString translated ]]).
	aList _ #(normal bold italic underlined struckOut narrow leftFlush centered rightFlush justified).
	reply _ (SelectionMenu labelList: menuList contents lines: #(1 6) selections: aList) startUpWithoutKeyboard.
	reply notNil ifTrue: [
		(#(leftFlush centered rightFlush justified) includes: reply)
			ifTrue: [
				attribute _TextAlignment perform: reply]
			ifFalse: [
				attribute _ TextEmphasis perform: reply].
		self applyAttribute:  attribute].
	^ true! !

!TextEditor methodsFor: 'attributes' stamp: 'jmv 9/1/2009 22:56'!
changeTextFont
	"Present a menu of available fonts, and if one is chosen, apply it to the current selection."
	| curFont newFont attr startIndex |
	startIndex _ self startIndex.
	curFont _ paragraph text fontAt: startIndex.
	newFont _ StrikeFont fromUser: curFont.
	newFont ifNil: [ ^self ].
	attr _ TextFontReference toFont: newFont.
	self applyAttribute: attr! !

!TextEditor methodsFor: 'editing keys' stamp: 'jmv 9/1/2009 22:37'!
changeEmphasis: characterStream
	"Change the emphasis of the current selection or prepare to accept characters with the change in emphasis. Emphasis change amounts to a font change.  Keeps typeahead."

	"control 0..9 -> 0..9"

	| keyCode attribute oldAttributes index thisSel colors |
	keyCode := ('0123456789-=' indexOf: sensor keyboard ifAbsent: [1]) - 1.
	oldAttributes := paragraph text attributesAt: self pointIndex.
	thisSel := self selection.

	"Decipher keyCodes for Command 0-9..."
	"
	(keyCode between: 1 and: 5) 
		ifTrue: [attribute := TextFontChange fontNumber: keyCode].
	"
	keyCode = 6 
		ifTrue: [
			colors := #(#black #magenta #red #yellow #green #blue #cyan #white).
			index := (PopUpMenu 
						labelArray: colors , #('choose color...' )
						lines: (Array with: colors size + 1)) startUp.
			index = 0 ifTrue: [^true].
			index <= colors size 
				ifTrue: [attribute := TextColor color: (Color perform: (colors at: index))]
				ifFalse: [
					index := index - colors size - 1.	"Re-number!!!!!!"
					index = 0 ifTrue: [attribute := self chooseColor].
					thisSel ifNil: [^true]	"Could not figure out what to link to"]].
	(keyCode between: 7 and: 11) 
		ifTrue: [
			sensor leftShiftDown 
				ifTrue: [
					keyCode = 10 ifTrue: [attribute := TextKern kern: -1].
					keyCode = 11 ifTrue: [attribute := TextKern kern: 1]]
				ifFalse: [
					attribute := TextEmphasis 
								perform: (#(#bold #italic #narrow #underlined #struckOut) at: keyCode - 6).
					oldAttributes 
						do: [:att | (att dominates: attribute) ifTrue: [attribute turnOff]]]].
	keyCode = 0 ifTrue: [ attribute := TextEmphasis normal ].
	attribute ifNotNil: [
		self applyAttribute: attribute].
	^true! !

!TextEditor methodsFor: 'editing keys' stamp: 'jmv 9/1/2009 15:47'!
hiddenInfo
	"In TextLinks, TextDoits, TextColor, and TextURLs, there is hidden info.  Return the entire string that was used by Cmd-6 to create this text attribute.  Usually enclosed in < >."

	| attrList |
	attrList _ paragraph text attributesAt: (self pointIndex + self markIndex)//2.
	attrList do: [:attr |
		attr forTextActionInfoDo: [ :info |
			^ self selection asString, '<', info, '>']].
	"If none of the above"
	attrList do: [:attr |
		attr forTextColorDo: [ :color |
			^ self selection asString, '<', color printString, '>']].
	^ self selection asString, '[No hidden info]'! !

!TextEditor methodsFor: 'events' stamp: 'jmv 9/1/2009 10:23'!
mouseUp: evt
	"An attempt to break up the old processRedButton code into threee phases"
	oldInterval ifNil: [^ self].  "Patched during clickAt: repair"
	(self hasCaret 
		and: [oldInterval = self selectionInterval])
		ifTrue: [self selectWord].
	self setEmphasisHereFromText.
	(self isDisjointFrom: oldInterval) ifTrue:
		[otherInterval _ oldInterval].
	self storeSelectionInParagraph! !

!TextEditor methodsFor: 'initialize-release' stamp: 'jmv 9/1/2009 10:23'!
resetState 
	"Establish the initial conditions for editing the paragraph: place caret 
	before first character, set the emphasis to that of the first character,
	and save the paragraph for purposes of canceling."

	markBlock _ paragraph defaultCharacterBlock.
	self pointBlock: markBlock copy.
	beginTypeInBlock _ nil.
	UndoInterval _ otherInterval _ 1 to: 0.
	self setEmphasisHereFromText.
	selectionShowing _ false! !

!TextEditor methodsFor: 'menu messages' stamp: 'jmv 9/1/2009 22:44'!
changeAlignment
	| aList reply  |
	aList _ #(leftFlush centered justified rightFlush).
	reply _ (SelectionMenu labelList: aList selections: aList) startUp.
	reply ifNil:[^self].
	self applyAttribute: (TextAlignment perform: reply).
	^ true! !

!TextEditor methodsFor: 'new selection' stamp: 'jmv 9/1/2009 10:23'!
selectFrom: start to: stop
	"Select the specified characters inclusive."
	self selectInvisiblyFrom: start to: stop.
	self closeTypeIn.
	self storeSelectionInParagraph.
	"Preserve current emphasis if selection is empty"
	stop > start ifTrue: [
		self setEmphasisHereFromText ]! !

!TextEditor methodsFor: 'typing support' stamp: 'jmv 9/1/2009 10:45'!
backTo: startIndex
	"During typing, backspace to startIndex.  Deleted characters fall into three
	 clusters, from left to right in the text: (1) preexisting characters that were
	 backed over; (2) newly typed characters that were backed over (excluding
	 typeahead, which never even appears); (3) preexisting characters that
	 were highlighted before typing began.  If typing has not yet been opened,
	 open it and watch for the first and third cluster.  If typing has been opened,
	 watch for the first and second cluster.  Save characters from the first and third
	 cluster in UndoSelection.  Tally characters from the first cluster in UndoMessage's parameter.
	 Delete all the clusters.  Do not alter Undoer or UndoInterval (except via
	 openTypeIn).  The code is shorter than the comment."

	| saveLimit newBackovers |
	saveLimit _ beginTypeInBlock
		ifNil: [self openTypeIn. UndoSelection _ self nullText. self stopIndex]
		ifNotNil: [self startOfTyping].
	self markIndex: startIndex.
	startIndex < saveLimit ifTrue: [
		newBackovers _ self startOfTyping - startIndex.
		beginTypeInBlock _ self startIndex.
		UndoSelection replaceFrom: 1 to: 0 with:
			(paragraph text copyFrom: startIndex to: saveLimit - 1).
		UndoMessage hasArguments ifTrue: [ 
			UndoMessage argument: (UndoMessage argument ifNil: [1]) + newBackovers]].
	self zapSelectionWith: self nullText.
	self unselect! !

!TextEditor methodsFor: 'typing support' stamp: 'jmv 9/1/2009 18:45'!
setEmphasisHereFromText

	self setEmphasisHereFromTextForward: true! !

!TextEditor methodsFor: 'typing support' stamp: 'jmv 9/1/2009 18:44'!
setEmphasisHereFromTextForward: forward

	| delta |
	delta _ forward ifTrue: [ 1 ] ifFalse: [ 0 ].
	emphasisHere _ (paragraph text attributesAt: (self pointIndex - delta max: 1))
					select: [:att | att mayBeExtended]! !

!TextEditor methodsFor: 'private' stamp: 'jmv 9/1/2009 23:03'!
applyAttribute: aTextAttribute
	"The user selected aTextAttribute via shortcut, menu or other means.
	If there is a selection, apply the attribute to the selection.
	In any case use the attribute for the user input (emphasisHere)
	It really looks like the 2 branches in this method should be closer!! (handling of Undo is different, and likely wrong)"

	| thisSel interval |

	aTextAttribute isParagraphAttribute
		ifTrue: [
			interval _ paragraph text encompassParagraph: self selectionInterval.
			paragraph 
				replaceFrom: interval first 
				to: interval last 
				with: ((paragraph text copyFrom: interval first to: interval last)
						addAttribute: aTextAttribute).
			paragraph composeAll.
			self recomputeSelection ]
		
		ifFalse: [
			thisSel _ self selection.
			thisSel notEmpty
				ifTrue: [
					self replaceSelectionWith: (thisSel addAttribute: aTextAttribute).
					paragraph composeAll.
					self recomputeSelection] ].

	emphasisHere _ Text addAttribute: aTextAttribute toArray: emphasisHere! !

!TextEditor methodsFor: 'private' stamp: 'jmv 9/1/2009 18:43'!
moveCursor: directionBlock forward: forward specialBlock: specialBlock

	super moveCursor: directionBlock forward: forward specialBlock: specialBlock.
	self setEmphasisHereFromTextForward: forward! !


!TextEmphasis methodsFor: 'iterating' stamp: 'jmv 9/1/2009 16:12'!
forTextEmphasisDo: aBlock
	aBlock value: emphasisCode! !


!TextFontReference methodsFor: 'iterating' stamp: 'jmv 9/1/2009 15:35'!
forFontReferenceDo: aBlock
	aBlock value: font! !


!TextKern methodsFor: 'iterating' stamp: 'jmv 9/1/2009 16:31'!
forTextKernDo: aBlock
	aBlock value: kern! !


!TextMorph methodsFor: 'drawing' stamp: 'jmv 9/1/2009 17:59'!
drawOn: aCanvas
	"Draw the receiver on a canvas"

	| fauxBounds |
	self setDefaultContentsIfNil.
	super drawOn: aCanvas.  "Border and background if any"
	false ifTrue: [self debugDrawLineRectsOn: aCanvas].  "show line rects for debugging"
	text size = 0
		ifTrue: [self drawNullTextOn: aCanvas].
	"Hack here:  The canvas expects bounds to carry the location of the text, but we also need to communicate clipping."
	fauxBounds _ self bounds topLeft corner: self innerBounds bottomRight.
	aCanvas paragraph: self paragraph bounds: fauxBounds color: color editor: editor! !


!TextMorphForEditView methodsFor: 'drawing' stamp: 'jmv 9/1/2009 17:59'!
drawNullTextOn: aCanvas
	"Just run the normal code to show selection in a window"
	aCanvas paragraph: self paragraph bounds: bounds color: color editor: editor
! !


!Transcripter methodsFor: 'accessing' stamp: 'jmv 9/1/2009 18:02'!
endEntry
	| c d cb |
	c _ self contents.
	Display extent ~= DisplayScreen actualScreenSize ifTrue: [
		"Handle case of user resizing physical window"
		DisplayScreen startUp.
		frame _ frame intersect: Display boundingBox.
		^ self clear; show: c].
	para compose: c asText
		in: ((frame insetBy: 4) withHeight: 9999).
	para positionWhenComposed: 0@0.
	d _ para extent y - frame height.
	d > 0 ifTrue: [
		"Scroll up to keep all contents visible"
		cb _ para characterBlockAtPoint:
			para compositionRectangle topLeft + (0@(d+TextStyle default initialLineGrid)).
		self on: (c copyFrom: cb stringIndex to: c size).
		readLimit_ position_ collection size.
		^ self endEntry].
	Display fill: (frame insetBy: -2) fillColor: self black;
			fill: frame fillColor: self white.
	Display getCanvas
		paragraph: para 
		bounds: (0@0 extent: Display extent) 
		color: Color black
		editor: nil! !

!classDefinition: #TimeTest category: #'Kernel Tests'!
TestCase subclass: #TimeTest
	instanceVariableNames: 'z'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel Tests'!
TextKern removeSelector: #emphasizeScanner:!
TextFontReference removeSelector: #emphasizeScanner:!
TextFontReference removeSelector: #forFontDo:!
TextEmphasis removeSelector: #emphasizeScanner:!
TextEditor removeSelector: #applyAttributeToWholeParagraph:!
TextEditor removeSelector: #selectAndScroll!
TextEditor removeSelector: #setAlignment:!
TextEditor removeSelector: #setEmphasis:!
TextEditor removeSelector: #setEmphasisHere!
TextEditor removeSelector: #updateMarker!
TextColor removeSelector: #emphasizeScanner:!
TextAlignment removeSelector: #emphasizeScanner:!
TextAction removeSelector: #emphasizeScanner:!
TextAttribute removeSelector: #emphasizeScanner:!
TextAttribute removeSelector: #forFontDo:!
TextAttribute removeSelector: #oldEmphasisCode:!
Text removeSelector: #alignmentAt:ifAbsent:!
Text removeSelector: #setRuns:!
!classDefinition: #StrikeFontTest category: #'Kernel Tests'!
TestCase subclass: #StrikeFontTest
	instanceVariableNames: 'z'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel Tests'!
!classDefinition: #SemaphoreTest category: #'Kernel Tests'!
TestCase subclass: #SemaphoreTest
	instanceVariableNames: 'z'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel Tests'!
!classDefinition: #ProcessorTest category: #'Kernel Tests'!
TestCase subclass: #ProcessorTest
	instanceVariableNames: 'z'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel Tests'!
NewParagraph removeSelector: #displayOn:using:at:!
NewParagraph removeSelector: #displaySelectionInLine:on:!
!classDefinition: #IfNotNilTests category: #'Kernel Tests'!
TestCase subclass: #IfNotNilTests
	instanceVariableNames: 'z'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel Tests'!
FormCanvas removeSelector: #paragraph:bounds:color:!
ColorMappingCanvas removeSelector: #paragraph:bounds:color:!
CharacterScanner removeSelector: #addEmphasis:!
CharacterScanner removeSelector: #addKern:!
CharacterScanner removeSelector: #setActualTextStyle:!
CharacterScanner removeSelector: #setAlignment:!
!classDefinition: #CharacterScanner category: #'Graphics-Text'!
Object subclass: #CharacterScanner
	instanceVariableNames: 'destX lastIndex xTable map destY stopConditions text alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth kern actualTextStyle'
	classVariableNames: 'DefaultStopConditions'
	poolDictionaries: ''
	category: 'Graphics-Text'!
Canvas removeSelector: #paragraph:bounds:color:!
Smalltalk removeClassNamed: #TextSqkPageLink!
