'From Cuis 1.0 of 16 July 2009 [latest update: #228] on 27 July 2009 at 8:00:36 pm'!
!classDefinition: #AbstractFont category: #'Graphics-Text'!
Object subclass: #AbstractFont
	instanceVariableNames: ''
	classVariableNames: 'AvailableFonts DefaultFont '
	poolDictionaries: ''
	category: 'Graphics-Text'!
!classDefinition: #TextFontReference category: #'System-TextAttributes'!
TextAttribute subclass: #TextFontReference
	instanceVariableNames: 'font '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-TextAttributes'!
!classDefinition: #TextStyle category: #'Graphics-Text'!
Object subclass: #TextStyle
	instanceVariableNames: 'font fontArray lineGrid baseline alignment firstIndent restIndent rightIndent tabsArray marginTabsArray leading defaultFontIndex '
	classVariableNames: 'AvailableTextStyles DefaultTextStyle '
	poolDictionaries: ''
	category: 'Graphics-Text'!

!AbstractFont methodsFor: 'accessing' stamp: 'jmv 7/27/2009 17:31'!
textStyle
	^ TextStyle withFont: self! !


!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 7/27/2009 17:06'!
default
	^DefaultFont! !

!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 7/27/2009 17:06'!
default: aFont
	DefaultFont _ aFont! !

!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 7/27/2009 17:37'!
familyName: aString pointSize: aNumber
	"
	AbstractFont familyName: 'DejaVu' pointSize: 12
	"
	| familyDictionary |
	familyDictionary _ AvailableFonts at: aString ifAbsent: [^nil].
	^familyDictionary at: aNumber ifAbsent: [nil]! !

!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 7/27/2009 18:47'!
familyNames
	"
	AbstractFont familyNames
	"
	^AvailableFonts keys asArray sort! !

!AbstractFont class methodsFor: 'instance accessing' stamp: 'jmv 7/27/2009 18:55'!
pointSizesFor: aString
	"
	AbstractFont pointSizesFor: 'DejaVu'
	"
	| familyDictionary |
	familyDictionary _ AvailableFonts at: aString ifAbsent: [^#()].
	^familyDictionary keys asArray sort! !

!AbstractFont class methodsFor: 'class initialization' stamp: 'jmv 7/27/2009 17:16'!
initialize
	"AvailableFonts is a dictionary whose keys are family names, such as 'DejaVu' and values are family dictionaries
	family dictionaries have keys that are integers (point sizes such as 10 or 12) and values instances of the Font hierarcy
	
	Fonts with emphasis (such as bold or italic) are derivative fonts of the one found in the family dictionary"
	
	AvailableFonts _ Dictionary new! !

!AbstractFont class methodsFor: 'user interface' stamp: 'jmv 7/27/2009 19:26'!
fontMenuForFamily: familyName target: target selector: selector highlight: currentSize 
	"Offer a font menu for the given font family. If one is selected, pass that font to target with a call to selector. The fonts will be displayed in that font."

	| menu  font |
	menu := MenuMorph entitled: familyName.
	(self pointSizesFor: familyName) do: [ :p |
			font := self familyName: familyName pointSize: p.
			menu 
				add: p asString , ' Point'
				target: target
				selector: selector
				argument: font.
			menu lastItem font: font.
			p = currentSize ifTrue: [menu lastItem color: Color blue darker]].
	^menu! !

!AbstractFont class methodsFor: 'user interface' stamp: 'jmv 7/27/2009 19:28'!
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."

	"
	AbstractFont promptForFont: 'Choose system font:' andSendTo: Preferences withSelector: #setSystemFontTo: highlight: nil
	"

	| menu subMenu currentSize currentFamilyName |
	currentFamilyName _ currentFont ifNotNil: [ currentFont familyName ].
	menu _ MenuMorph entitled: aPrompt.
	AbstractFont familyNames do: [ :familyName |
		currentSize _  (familyName = currentFamilyName ifTrue: [ currentFont pointSize ]).
		subMenu _ self fontMenuForFamily: familyName target: aTarget selector: aSelector highlight: currentSize.
		menu add: familyName subMenu: subMenu.
		familyName = currentFamilyName ifTrue: [menu lastItem color: Color blue darker]].

	menu popUpInWorld: self currentWorld! !


!CharacterScanner methodsFor: 'private' stamp: 'jmv 7/27/2009 14:16'!
setFont
	| priorFont |
	"Set the font and other emphasis."
	priorFont _ font.
	text ifNotNil: [
		emphasisCode _ 0.
		kern _ 0.
		indentationLevel _ 0.
		alignment _ textStyle alignment.
		font _ nil.
		(text attributesAt: lastIndex forStyle: textStyle)
			do: [:att | att emphasizeScanner: self]].
	font ifNil: [
		self setActualFont: textStyle font].
	font _ font emphasized: emphasisCode.
	priorFont ifNotNil: [destX _ destX + priorFont descentKern].
	destX _ destX - font descentKern.
	"NOTE: next statement should be removed when clipping works"
	leftMargin ifNotNil: [destX _ destX max: leftMargin].
	kern _ kern - font baseKern.

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


!CodeHolder methodsFor: 'annotation' stamp: 'jmv 7/27/2009 17:50'!
defaultAnnotationPaneHeight
	"Answer the receiver's preferred default height for new annotation panes."

	^ StrikeFont default height + 4! !

!CodeHolder methodsFor: 'annotation' stamp: 'jmv 7/27/2009 17:50'!
defaultButtonPaneHeight
	"Answer the user's preferred default height for new button panes."

	^ StrikeFont default height + 14! !


!Browser methodsFor: 'initialize-release' stamp: 'jmv 7/27/2009 17:50'!
morphicClassColumn
	| column switchHeight divider |
	column _ AlignmentMorph proportional.
	switchHeight _ StrikeFont default height + 4.
	column 
		addMorph: self buildMorphicSwitches
		fullFrame: (LayoutFrame fractions: (0 @ 1 corner: 1 @ 1)
				offsets: (0 @ (1 - switchHeight) corner: 0 @ 0)).
	divider _ BorderedSubpaneDividerMorph forTopEdge.
	Preferences alternativeWindowLook 
		ifTrue: [
			divider
				extent: 4 @ 4;
				color: Color transparent;
				borderColor: #raised;
				borderWidth: 2].
	column addMorph: divider
		fullFrame: (LayoutFrame fractions: (0 @ 1 corner: 1 @ 1)
				offsets: (0 @ switchHeight negated corner: 0 @ (1 - switchHeight))).
	column addMorph: self buildMorphicClassList 
		fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 1)
				offsets: (0 @ 0 corner: 0 @ switchHeight negated)).
	^column! !

!Browser methodsFor: 'initialize-release' stamp: 'jmv 7/27/2009 17:50'!
openAsMorphClassEditing: editString 
	"Create a pluggable version a Browser on just a single class."

	| window dragNDropFlag hSepFrac switchHeight mySingletonClassList switches c |
	window := SystemWindow new model: self.
	dragNDropFlag := false.
	hSepFrac := 0.3.
	switchHeight _ StrikeFont default height + 10.
	mySingletonClassList := PluggableListMorph 
				on: self
				list: #classListSingleton
				selected: #indexIsOne
				changeSelected: #indexIsOne:
				menu: #classListMenu:shifted:
				keystroke: #classListKey:from:.
	mySingletonClassList enableDragNDrop: dragNDropFlag.
	self 
		addLowerPanesTo: window
		at: (0 @ hSepFrac corner: 1 @ 1)
		with: editString.
	window addMorph: mySingletonClassList
		fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 0.5 @ 0)
				offsets: (0 @ 0 corner: 0 @ switchHeight)).
	switches _ self buildMorphicSwitches.
	c _ switches color.
	window addMorph: switches
		fullFrame: (LayoutFrame fractions: (0.5 @ 0 corner: 1.0 @ 0)
				offsets: (0 @ 0 corner: 0 @ switchHeight)).
	switches color: c.
	window addMorph: self buildMorphicMessageCatList
		fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 0.5 @ hSepFrac)
				offsets: (0 @ switchHeight corner: 0 @ 0)).
	window addMorph: self buildMorphicMessageList
		fullFrame: (LayoutFrame fractions: (0.5 @ 0 corner: 1.0 @ hSepFrac)
				offsets: (0 @ switchHeight corner: 0 @ 0)).
	window setUpdatablePanesFrom: #(#messageCategoryList #messageList).
	^window! !


!FileList class methodsFor: 'instance creation' stamp: 'jmv 7/27/2009 17:50'!
defaultButtonPaneHeight
	"Answer the user's preferred default height for new button panes."

	^ StrikeFont default height + 10! !


!FileList2 class methodsFor: '*smloader-extension' stamp: 'jmv 7/27/2009 17:47'!
morphicViewOnDirectory: aFileDirectory
	| aFileList window fileListBottom midLine fileListTopOffset |

	aFileList _ self new directory: aFileDirectory.
	window _ (SystemWindow labelled: aFileDirectory pathName) model: aFileList.

	fileListTopOffset _ (StrikeFont default pointSize * 2) + 14.
	fileListBottom _ 0.4.
	midLine _ 0.4.
	
	self addFullPanesTo: window from: {
		{aFileList morphicPatternPane. 			0@0 corner: 0.3@0. 						0@0 corner: 0@fileListTopOffset}.
		{aFileList optionalButtonRow. 			0.3 @ 0 corner: 1@0. 						0@0 corner: 0@fileListTopOffset}.
		{aFileList morphicDirectoryTreePane. 	0@0 corner: midLine@fileListBottom. 	0@fileListTopOffset corner: 0@0}.
		{aFileList morphicFileListPane. 			midLine @ 0 corner: 1@fileListBottom. 	0@fileListTopOffset corner: 0@0}.
		{aFileList morphicFileContentsPane. 		0@fileListBottom corner: 1@1. 			nil}.
	}.
	"
	self addFullPanesTo: window from: {
		{aFileList morphicPatternPane. 0@0 corner: 0.3@0. 0@0 corner: 0@fixedSize}.
		{aFileList optionalButtonRow. 0.3 @ 0 corner: 1@0. 0@0 corner: 0@fixedSize}.
		{aFileList morphicDirectoryTreePane. 0@0 corner: midLine@1. 0@fixedSize corner: 0@0}.
		{aFileList morphicFileListPane. midLine @ 0 corner: 1@1. 0@fixedSize corner: 0@0}.
	}.
	"
	aFileList postOpen.
	^ window ! !


!FormCanvas methodsFor: 'drawing-text' stamp: 'jmv 7/27/2009 17:47'!
drawString: aString from: firstIndex to: lastIndex at: aPoint font: fontOrNil color: c
	| font |
	port colorMap: nil.
	font _ fontOrNil ifNil: [StrikeFont default].
	font installOn: port foregroundColor: (self shadowColor ifNil:[c]).
	font displayString: aString on: port 
		from: firstIndex to: lastIndex at: (origin + aPoint) kern: font baseKern negated.! !

!FormCanvas methodsFor: 'drawing-text' stamp: 'jmv 7/27/2009 17:47'!
drawString: aString from: firstIndex to: lastIndex in: bounds font: fontOrNil color: c
	| font portRect |
	port colorMap: nil.
	portRect _ port clipRect.
	port clipByX1: bounds left + origin x 
		y1: bounds top + origin y 
		x2: bounds right + origin x 
		y2: bounds bottom + origin y.
	font _ fontOrNil ifNil: [StrikeFont default].
	font installOn: port foregroundColor: (self shadowColor ifNil:[c]).
	font displayString: aString asString on: port 
		from: firstIndex to: lastIndex at: (bounds topLeft + origin) kern: font baseKern negated.
	port clipRect: portRect.! !


!HandMorph methodsFor: 'geometry' stamp: 'jmv 7/27/2009 17:48'!
userInitials: aString andPicture: aForm

	| cb pictRect initRect f |

	userInitials _ aString.
	pictRect _ initRect _ cb _ self cursorBounds.
	userInitials isEmpty ifFalse: [
		f _ StrikeFont default.
		initRect _ cb topRight + (0@4) extent: (f widthOfString: userInitials)@(f height).
	].
	self userPicture: aForm.
	aForm ifNotNil: [
		pictRect _ (self cursorBounds topRight + (0@24)) extent: aForm extent.
	].
	self bounds: ((cb merge: initRect) merge: pictRect).


! !


!LazyListMorph methodsFor: 'drawing' stamp: 'jmv 7/27/2009 17:48'!
font: newFont
	font := (newFont ifNil: [ StrikeFont default ]).
	self adjustHeight.
	self changed.! !


!LightWidget methodsFor: 'defaults' stamp: 'jmv 7/27/2009 19:20'!
defaultFont
	^AbstractFont familyName: 'DejaVu' pointSize: 18! !


!ButtonLW methodsFor: 'initialization' stamp: 'jmv 7/27/2009 19:51'!
initialize
	super initialize.
	target _ 'I am the target'.
	action _ #show.
	bounds _ 10@10 extent: 60@30.
	label _ 'button label'.
	font _ AbstractFont familyName: 'DejaVu' pointSize: 16.
	foreColor _ Color white.
	selectedForeColor _ Color white.
	backColor _ Color r: 0.32 g: 0.39 b: 0.63.
	selectedBackColor _ Color r: 0.42 g: 0.5 b: 0.81.
	pressed _ false! !


!CheckBoxLW methodsFor: 'initialization' stamp: 'jmv 7/27/2009 19:51'!
initialize
	super initialize.
	target _ self.
	aspect _ #visible.
	action _ #visible:.
	bounds _ 10@10 extent: 200@30.
	label _ 'CheckBox label'.
	font _ AbstractFont familyName: 'DejaVu' pointSize: 12.
	foreColor _ Color white.
	selectedForeColor _ Color white.
	backColor _ Color r: 0.32 g: 0.39 b: 0.63.
	selectedBackColor _ Color r: 0.42 g: 0.5 b: 0.81.
	selected _ false! !


!EntryField2LW methodsFor: 'drawing' stamp: 'jmv 7/27/2009 18:58'!
characterIndexAtPoint: aPoint

	| line block |
	
	line _ TextLine 
		start: 1
		stop: contents size
		internalSpaces: 0
		paddingWidth: 0.
	line
		rectangle: bounds;
		lineHeight: font height baseline: font ascent.
		
	block _ (CharacterBlockScanner new text: contents asText textStyle: font textStyle)
		characterBlockAtPoint: aPoint index: nil
		in: line.

	^ block stringIndex! !

!EntryField2LW methodsFor: 'initialization' stamp: 'jmv 7/27/2009 19:51'!
initialize
	super initialize.
"	target _ self.
	aspect _ #visible.
	action _ #visible:."
	bounds _ 10@10 extent: 200@30.
	contents _ 'Entry Field'.
	actionPending _ false.
	font _ AbstractFont familyName: 'DejaVu' pointSize: 12.
	foreColor _ Color white.
	selectedForeColor _ Color white.
	backColor _ Color r: 0.32 g: 0.39 b: 0.63.
	selectedBackColor _ Color r: 0.42 g: 0.5 b: 0.81.! !


!MinimalStringMorph methodsFor: 'accessing' stamp: 'jmv 7/27/2009 17:48'!
fontToUse
	| fontToUse |
	fontToUse := font isNil ifTrue: [StrikeFont default] ifFalse: [font].
	(emphasis isNil or: [emphasis = 0]) 
		ifTrue: [^fontToUse]
		ifFalse: [^fontToUse emphasized: emphasis]! !


!OneLineEditorMorph methodsFor: 'accessing' stamp: 'jmv 7/27/2009 17:48'!
baseFont

	font isNil ifTrue: [ font _ StrikeFont default ].
	^font! !

!OneLineEditorMorph methodsFor: 'drawing' stamp: 'jmv 7/27/2009 18:59'!
characterIndexAtPoint: aPoint

	| line block f |
	f _ self fontToUse.
	
	line _ TextLine 
		start: 1
		stop: contents size
		internalSpaces: 0
		paddingWidth: 0.
	line
		rectangle: bounds;
		lineHeight: f height baseline: f ascent.
		
	block _ (CharacterBlockScanner new text: contents asText textStyle: font textStyle)
		characterBlockAtPoint: aPoint index: nil
		in: line.

	^ block stringIndex! !


!ParseNode methodsFor: 'private' stamp: 'jmv 7/27/2009 17:48'!
printSingleComment: aString on: aStream indent: indent 
	"Print the comment string, assuming it has been indented indent tabs.
	Break the string at word breaks, given the widths in the default
	font, at 450 points."

	| readStream word position lineBreak font wordWidth tabWidth spaceWidth lastChar |
	readStream _ ReadStream on: aString.
	font _ StrikeFont default.
	tabWidth _ TextStyle defaultTab.
	spaceWidth _ font widthOf: Character space.
	position _ indent * tabWidth.
	lineBreak _ 450.
	[readStream atEnd]
		whileFalse: 
			[word _ self nextWordFrom: readStream setCharacter: [:lc | lastChar _ lc].
			wordWidth _ word inject: 0 into: [:width :char | width + (font widthOf: char)].
			position _ position + wordWidth.
			position > lineBreak
				ifTrue: 
					[aStream crtab: indent.
					position _ indent * tabWidth + wordWidth + spaceWidth.
					lastChar = Character cr
						ifTrue: [[readStream peekFor: Character tab] whileTrue].
					word isEmpty ifFalse: [aStream nextPutAll: word; space]]
				ifFalse: 
					[aStream nextPutAll: word.
					readStream atEnd
						ifFalse: 
							[position _ position + spaceWidth.
							aStream space].
					lastChar = Character cr
						ifTrue: 
							[aStream crtab: indent.
							position _ indent * tabWidth.
							[readStream peekFor: Character tab] whileTrue]]]! !


!PopUpMenu class methodsFor: 'class initialization' stamp: 'jmv 7/27/2009 15:47'!
initialize  "PopUpMenu initialize"
	(MenuStyle _ TextStyle default copy)
		centered.
	PopUpMenu allSubInstancesDo: [:m | m rescan]! !

!PopUpMenu class methodsFor: 'class initialization' stamp: 'jmv 7/27/2009 16:43'!
setMenuFontTo: aFont
	"Set the menu font as indicated"

	MenuStyle _ aFont textStyle.
	MenuStyle
		centered.
	self allSubInstancesDo: [:m | m rescan]! !


!Preferences class methodsFor: 'fonts' stamp: 'jmv 7/27/2009 18:55'!
chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector highlight: currentFont
	AbstractFont promptForFont: aPrompt andSendTo: aReceiver withSelector: aSelector highlight: currentFont! !

!Preferences class methodsFor: 'fonts' stamp: 'jmv 7/27/2009 17:48'!
chooseSystemFont
	self chooseFontWithPrompt: 'Default text font' andSendTo: self withSelector: #setSystemFontTo: highlight: StrikeFont default! !

!Preferences class methodsFor: 'fonts' stamp: 'jmv 7/27/2009 17:51'!
fontConfigurationMenu
	| aMenu |
	aMenu := MenuMorph new defaultTarget: Preferences.
	aMenu addTitle: 'Standard System Fonts' translated.
	aMenu addStayUpIcons.
	aMenu add: 'default text font...' translated action: #chooseSystemFont.
	aMenu 
		balloonTextForLastItem: 'Choose the default font to be used for code and  in workspaces, transcripts, etc.' 
				translated.
	aMenu lastItem font: StrikeFont default.
	aMenu add: 'list font...' translated action: #chooseListFont.
	aMenu lastItem font: Preferences standardListFont.
	aMenu balloonTextForLastItem: 'Choose the font to be used in list panes' 
				translated.
	aMenu add: 'menu font...' translated action: #chooseMenuFont.
	aMenu lastItem font: Preferences standardMenuFont.
	aMenu 
		balloonTextForLastItem: 'Choose the font to be used in menus' translated.
	aMenu add: 'window-title font...' translated action: #chooseWindowTitleFont.
	aMenu lastItem font: Preferences windowTitleFont.
	aMenu 
		balloonTextForLastItem: 'Choose the font to be used in window titles.' 
				translated.
	aMenu add: 'balloon-help font...' translated action: #chooseBalloonHelpFont.
	aMenu lastItem font: Preferences standardBalloonHelpFont.
	aMenu 
		balloonTextForLastItem: 'choose the font to be used when presenting balloon help.' 
				translated.
	aMenu add: 'code font...' translated action: #chooseCodeFont.
	aMenu lastItem font: Preferences standardCodeFont.
	aMenu balloonTextForLastItem: 'Choose the font to be used in code panes.' 
				translated.
	aMenu addLine.
	aMenu add: 'restore default font choices' translated
		action: #restoreDefaultFonts.
	aMenu 
		balloonTextForLastItem: 'Use the standard system font defaults' translated.
	aMenu add: 'print default font choices' translated
		action: #printStandardSystemFonts.
	aMenu 
		balloonTextForLastItem: 'Print the standard system font defaults to the Transcript' 
				translated.
	^aMenu! !

!Preferences class methodsFor: 'fonts' stamp: 'jmv 7/27/2009 17:51'!
printStandardSystemFonts
	"self printStandardSystemFonts"

	#(standardListFont 
	standardMenuFont windowTitleFont 
	standardBalloonHelpFont standardCodeFont standardButtonFont) do: [:selector |
		| font |
		font _ Preferences perform: selector.
		Transcript
			cr; show: selector;
			space; show: font printString]! !

!Preferences class methodsFor: 'fonts' stamp: 'jmv 7/27/2009 17:38'!
setDefaultFonts: defaultFontsSpec
		
	| font |
	defaultFontsSpec do: [ :triplet |
		font _ AbstractFont familyName: triplet second pointSize: triplet third.
		triplet size > 3 ifTrue: [
			font _ font emphasized: triplet fourth ].
		self
			perform: triplet first
			with: font]! !

!Preferences class methodsFor: 'fonts' stamp: 'jmv 7/27/2009 17:45'!
setSystemFontTo: aFont
	"Establish the default text font and style"

	aFont ifNil: [^ self].
	StrikeFont default: aFont.
	TextStyle default: aFont textStyle! !

!Preferences class methodsFor: 'fonts' stamp: 'jmv 7/27/2009 19:21'!
standardButtonFont
	"Answer an attractive font to use for buttons"
	"Answer the font to be used for textual flap tab labels"
	^ Parameters at: #standardButtonFont! !

!Preferences class methodsFor: 'fonts' stamp: 'jmv 7/27/2009 17:48'!
standardCodeFont
	"Answer the font to be used in code"

	 ^ Parameters at: #standardCodeFont ifAbsent:
		[Parameters at: #standardCodeFont put: StrikeFont default]! !

!Preferences class methodsFor: 'fonts' stamp: 'jmv 7/27/2009 17:48'!
standardListFont
	"Answer the font to be used in lists"

	 ^ Parameters at: #standardListFont ifAbsent:
		[Parameters at: #standardListFont put: StrikeFont default]! !

!Preferences class methodsFor: 'fonts' stamp: 'jmv 7/27/2009 17:49'!
standardMenuFont
	"Answer the font to be used in menus"

	 ^ Parameters at: #standardMenuFont ifAbsent:
		[Parameters at: #standardMenuFont put: StrikeFont default]! !

!Preferences class methodsFor: 'fonts' stamp: 'jmv 7/27/2009 19:21'!
windowTitleFont
	"Answer the standard font to use for window titles"
	^  Parameters at: #windowTitleFont! !


!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 7/27/2009 17:49'!
defaultAction

	| delta savedArea textFrame barFrame outerFrame result range lastW w f h textWidth |
	f _ StrikeFont default.
	h _ f height * 3//2.
	textWidth _ (f widthOfString: progressTitle) + h.
	w _ 150 max: textWidth.
	barFrame _ Rectangle center: aPoint extent: w@h.
	textFrame _ 0@0 extent: w@h.
	textFrame _ textFrame align: textFrame bottomCenter
					with: barFrame topCenter + (0@2).
	outerFrame _ barFrame merge: textFrame.
	delta _ outerFrame amountToTranslateWithin: Display boundingBox.
	barFrame _ barFrame translateBy: delta.
	textFrame _ textFrame translateBy: delta.
	outerFrame _ outerFrame translateBy: delta.
	savedArea _ Form fromDisplay: outerFrame.
	Display fillBlack: barFrame; fillWhite: (barFrame insetBy: 2).
	Display fillBlack: textFrame; fillWhite: (textFrame insetBy: 2).
	progressTitle displayOn: Display at: textFrame topLeft + (w-textWidth+h//2@4).
	range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal].  "Avoid div by 0"
	lastW _ 0.
	result _ workBlock value:  "Supply the bar-update block for evaluation in the work block"
		[ :barVal |
		barVal notNil
			ifTrue: [ currentVal _ barVal ]
			ifFalse: [		
				currentVal _ currentVal + 1.
				currentVal >= maxVal
					ifTrue: [ currentVal _ minVal ]].
		w _ ((barFrame width-4) asFloat * ((currentVal-minVal) asFloat / range min: 1.0)) asInteger.
		w < lastW ifTrue: [
			Display fillWhite: (barFrame insetBy: 2)].
		w ~= lastW ifTrue: [
			Display fillGray: (barFrame topLeft + (2@2) extent: w@16).
			lastW _ w]].
	savedArea displayOn: Display at: outerFrame topLeft.
	self resume: result! !


!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 7/27/2009 19:18'!
initLabelMorph
	^ labelMorph _ StringMorph contents: '' font: AbstractFont default! !

!ProgressMorph methodsFor: 'initialization' stamp: 'jmv 7/27/2009 19:18'!
initSubLabelMorph
	^ subLabelMorph _ StringMorph contents: '' font: AbstractFont default! !


!RemoteString methodsFor: 'private' stamp: 'jmv 7/27/2009 14:20'!
makeNewTextAttVersion
	"Create a new TextAttributes version because some inst var has changed.  If no change, don't make a new one."
	"Don't delete this method even though it has no callers!!!!!!!!!!"

| obj cls struct tag |
"Note that TextFontReference and TextAnchor are forbidden."
obj _ #(RunArray TextDoIt TextLink TextURL TextColor TextEmphasis TextKern TextLinkToImplementors 3 'a string') collect: [:each | 
		cls _ Smalltalk at: each ifAbsent: [nil].
		cls ifNil: [each] ifNotNil: [cls new]].
struct _ (SmartRefStream on: (RWBinaryOrTextStream on: String new)) instVarInfo: obj.
tag _ self checkSum: struct printString.
TextAttributeStructureVersions ifNil: [TextAttributeStructureVersions _ Dictionary new].
(struct = CurrentTextAttStructure) & (tag = CurrentTextAttVersion) 
	ifTrue: [^ false].
CurrentTextAttStructure _ struct.
CurrentTextAttVersion _ tag.
TextAttributeStructureVersions at: tag put: struct.
^ true! !


!RunArray class methodsFor: 'instance creation' stamp: 'jmv 7/27/2009 19:24'!
scanFrom: strm
	"Read the style section of a fileOut or sources file.  nextChunk has already been done.  We need to return a RunArray of TextAttributes of various kinds.  These are written by the implementors of writeScanOn:"
	| rr vv aa this |
	(strm peekFor: $( ) ifFalse: [^ nil].
	rr _ OrderedCollection new.
	[strm skipSeparators.
	 strm peekFor: $)] whileFalse: 
		[rr add: (Number readFrom: strm)].
	vv _ OrderedCollection new.	"Value array"
	aa _ OrderedCollection new.	"Attributes list"
	[(this _ strm next) == nil] whileFalse: [
		this == $, ifTrue: [vv add: aa asArray.  aa _ OrderedCollection new].
		this == $a ifTrue: [aa add: 
			(TextAlignment new alignment: (Integer readFrom: strm))].
		this == $F ifTrue: [aa add: (TextFontReference new toFont: 
			(AbstractFont familyName: (strm upTo: $#) pointSize: (Integer readFrom: strm)))].
		this == $b ifTrue: [aa add: (TextEmphasis bold)].
		this == $i ifTrue: [aa add: (TextEmphasis italic)].
		this == $u ifTrue: [aa add: (TextEmphasis underlined)].
		this == $= ifTrue: [aa add: (TextEmphasis struckOut)].
		this == $n ifTrue: [aa add: (TextEmphasis normal)].
		this == $- ifTrue: [aa add: (TextKern kern: -1)].
		this == $+ ifTrue: [aa add: (TextKern kern: 1)].
		this == $c ifTrue: [aa add: (TextColor scanFrom: strm)]. "color"
		this == $L ifTrue: [aa add: (TextLink scanFrom: strm)].	"L not look like 1"
		this == $R ifTrue: [aa add: (TextURL scanFrom: strm)].
				"R capitalized so it can follow a number"
		this == $q ifTrue: [aa add: (TextSqkPageLink scanFrom: strm)].
		this == $P ifTrue: [aa add: (TextPrintIt scanFrom: strm)].
		this == $d ifTrue: [aa add: (TextDoIt scanFrom: strm)].
		"space, cr do nothing"
		].
	aa size > 0 ifTrue: [vv add: aa asArray].
	^ self runs: rr asArray values: vv asArray
"
RunArray scanFrom: (ReadStream on: '(14 50 312)f1,f1b,f1LInteger +;i')
"! !


!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 7/27/2009 17:49'!
fromUser
	"StrikeFont fromUser"
	^self fromUser: StrikeFont default! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 7/27/2009 19:16'!
fromUser: priorFont 

	"StrikeFont fromUser"

	"Present a menu of available fonts, and if one is chosen, return it.
	Otherwise return nil."

	| fontList fontMenu active ptMenu label spec |
	fontList := AbstractFont familyNames.
	fontMenu := MenuMorph new defaultTarget: self.
	fontList do: [:fontName | 
			active := priorFont familyName sameAs: fontName.
			ptMenu := MenuMorph new defaultTarget: self.
			(AbstractFont pointSizesFor:fontName ) do: [ :pt | 
					(active and: [pt = priorFont pointSize]) 
						ifTrue: [label := '<on>']
						ifFalse: [label := '<off>'].
					label := label , pt printString , ' pt'.
					ptMenu 
						add: label
						target: fontMenu
						selector: #modalSelection:
						argument: { 
								fontName.
								pt}].
			active ifTrue: [label := '<on>'] ifFalse: [label := '<off>'].
			label := label , fontName.
			fontMenu add: label subMenu: ptMenu].
	spec := fontMenu invokeModal.
	spec ifNil: [^nil].
	^AbstractFont familyName: spec first pointSize: spec last! !

!StrikeFont class methodsFor: 'instance creation' stamp: 'jmv 7/27/2009 17:46'!
installDejaVu
"
StrikeFont installDejaVu
"
	| baseF base boldF italicF bold italic sizes boldItalicF boldItalic data form dejaVuDict |
	sizes _ 5 to: 24.
	baseF _ sizes collect: [ :s |
		'AAFonts/DejaVu Sans Book ', s printString -> ('DejaVu ', s printString) ].
	boldF _ sizes collect: [ :s |
		'AAFonts/DejaVu Sans Bold ', s printString -> ('DejaVu ', s printString, 'B') ].
	italicF _ sizes collect: [ :s |
		'AAFonts/DejaVu Sans Oblique ', s printString -> ('DejaVu ', s printString, 'I') ].
	boldItalicF _ sizes collect: [ :s |
		'AAFonts/DejaVu Sans Bold Oblique ', s printString -> ('DejaVu ', s printString, 'BI') ].
		
	base := OrderedCollection new.
	bold := OrderedCollection new.
	italic := OrderedCollection new.
	boldItalic := OrderedCollection new.
	
	baseF withIndexDo: [:keyValue :index |
		form _ Form fromFileNamed:keyValue key, '.bmp'.
		data _ (FileStream oldFileNamed: keyValue key, '.txt') contentsOfEntireFile substrings.
		base add: ((StrikeFont new buildFromForm: form data: data name: keyValue value)
			pointSize: keyValue value substrings last asNumber)].
	boldF withIndexDo: [:keyValue :index |
		form _ Form fromFileNamed:keyValue key, '.bmp'.
		data _ (FileStream oldFileNamed: keyValue key, '.txt') contentsOfEntireFile substrings.
		bold add: ((StrikeFont new buildFromForm: form data: data name: keyValue value) 
			emphasis: 1;
			pointSize: keyValue value substrings last asNumber)].
	italicF withIndexDo: [:keyValue :index |
		form _ Form fromFileNamed:keyValue key, '.bmp'.
		data _ (FileStream oldFileNamed: keyValue key, '.txt') contentsOfEntireFile substrings.
		italic add: ((StrikeFont new buildFromForm: form data: data name: keyValue value)
			emphasis:2;
			pointSize: keyValue value substrings last asNumber)].
	boldItalicF withIndexDo: [:keyValue :index |
		form _ Form fromFileNamed:keyValue key, '.bmp'.
		data _ (FileStream oldFileNamed: keyValue key, '.txt') contentsOfEntireFile substrings.
		boldItalic add: ((StrikeFont new buildFromForm: form data: data name: keyValue value)
			emphasis:3;
			pointSize: keyValue value substrings last asNumber)].
			
	1 to: base size do: [ :i |
		(base at: i) derivativeFont: (bold at: i) at: 1.
		(base at: i) derivativeFont: (italic at: i) at: 2.
		(base at: i) derivativeFont: (boldItalic at: i) at: 3 ].

	dejaVuDict _ Dictionary new.
	sizes withIndexDo: [ :s :i |
		dejaVuDict at: s put: (base at: i) ].
	AvailableFonts at: 'DejaVu' put: dejaVuDict.
	Preferences restoreDefaultFonts! !

!StrikeFont class methodsFor: 'removing' stamp: 'jmv 7/27/2009 19:04'!
removeForPDA
"
StrikeFont removeForPDA
"
	| familyDict |
	familyDict _ AvailableFonts at: 'DejaVu'.
	familyDict keys copy do: [ :k |
		(#(5 6 7 8 9) includes: k) 
			ifTrue: [
				(familyDict at: k) derivativeFont: nil at: 0 ]
			ifFalse: [
				familyDict removeKey: k ]].
	
	Preferences setDefaultFonts: #(
		(setSystemFontTo: 'DejaVu' 8)
		(setListFontTo: 'DejaVu' 6)
		(setMenuFontTo: 'DejaVu' 7)
		(setWindowTitleFontTo: 'DejaVu' 9)
		(setBalloonHelpFontTo: 'DejaVu' 7)
		(setCodeFontTo: 'DejaVu' 7)
		(setButtonFontTo: 'DejaVu' 7))! !

!StrikeFont class methodsFor: 'removing' stamp: 'jmv 7/27/2009 19:05'!
removeMostFonts
"
StrikeFont removeMostFonts
"
	| familyDict |
	familyDict _ AvailableFonts at: 'DejaVu'.
	familyDict keys copy do: [ :k |
		(#(8 10 12 14 16 18 20) includes: k) 
			ifTrue: [
				(familyDict at: k) derivativeFont: nil at: 0 ]
			ifFalse: [
				familyDict removeKey: k ]].
	
	Preferences setDefaultFonts: #(
		(setSystemFontTo: 'DejaVu' 10)
		(setListFontTo: 'DejaVu' 10)
		(setMenuFontTo: 'DejaVu' 10)
		(setWindowTitleFontTo: 'DejaVu' 12)
		(setBalloonHelpFontTo: 'DejaVu' 8)
		(setCodeFontTo: 'DejaVu' 10)
		(setButtonFontTo: 'DejaVu' 10))! !

!StrikeFont class methodsFor: 'removing' stamp: 'jmv 7/27/2009 19:07'!
removeSomeFonts
"
StrikeFont removeSomeFonts
"
	| familyDict |
	familyDict _ AvailableFonts at: 'DejaVu'.
	familyDict keys copy do: [ :k |
		(#(5 6 7 8 9 10 11 12 14 16 18 20 24) includes: k)
			ifTrue: [ (familyDict at: k) derivativeFont: nil at: 3 ].
		(#(5 6 7 8 11 12 14 16 20 24) includes: k)
			ifTrue: [ (familyDict at: k) derivativeFont: nil at: 0 ].
		(#(5 6 7 8 9 10 11 12 14 16 18 20 24) includes: k) 
			ifFalse: [ familyDict removeKey: k ]].
	
	Preferences setDefaultFonts: #(
		(setSystemFontTo: 'DejaVu' 9)
		(setListFontTo: 'DejaVu' 9)
		(setMenuFontTo: 'DejaVu' 10)
		(setWindowTitleFontTo: 'DejaVu' 12)
		(setBalloonHelpFontTo: 'DejaVu' 8)
		(setCodeFontTo: 'DejaVu' 9)
		(setButtonFontTo: 'DejaVu' 9))! !


!StringMorph methodsFor: 'accessing' stamp: 'jmv 7/27/2009 17:49'!
fontToUse
	| fontToUse |
	fontToUse := font isNil ifTrue: [StrikeFont default] ifFalse: [font].
	(emphasis isNil or: [emphasis = 0]) 
		ifTrue: [^fontToUse]
		ifFalse: [^fontToUse emphasized: emphasis]! !

!StringMorph methodsFor: 'accessing' stamp: 'jmv 7/27/2009 17:49'!
setWidth: width

	self extent: width @ (font ifNil: [StrikeFont default]) height! !


!SystemDictionary methodsFor: 'shrinking' stamp: 'jmv 7/27/2009 19:22'!
discardOddsAndEnds
	"This method throws out lots of classes that are not frequently used."
	"Smalltalk discardOddsAndEnds"

	SystemOrganization removeSystemCategory: 'System-Serial Port'.
	SystemOrganization removeSystemCategory: 'ST80-Symbols'.
	SystemOrganization removeSystemCategory: 'Tools-File Contents Browser'.
	SystemOrganization removeSystemCategory: 'System-Compression'.
	SystemOrganization removeSystemCategory: 'Tools-Explorer'.
	SystemOrganization removeSystemCategory: 'System-Digital Signatures'.

	Form removeSelector: #edit.
	Smalltalk removeClassNamed: #FormEditorView.
	Smalltalk removeClassNamed: #FormEditor.
	SystemOrganization removeSystemCategory: 'ST80-Paths'.

	"bit editor (remove Form editor first):"
	Form removeSelector: #bitEdit.
	Form removeSelector: #bitEditAt:scale:.
	StrikeFont removeSelector: #edit:.
	Smalltalk removeClassNamed: #FormButtonCache.
	Smalltalk removeClassNamed: #FormMenuController.
	Smalltalk removeClassNamed: #FormMenuView.
	Smalltalk removeClassNamed: #BitEditor.

	"inspector for Dictionaries of Forms"
	Dictionary removeSelector: #inspectFormsWithLabel:.
	Smalltalk removeClassNamed: #FormHolderView.
	Smalltalk removeClassNamed: #FormInspectView.

	"experimental updating object viewer:"
	Object removeSelector: #evaluate:wheneverChangeIn:.
	Smalltalk removeClassNamed: #ObjectViewer.
	Smalltalk removeClassNamed: #ObjectTracer.

	"miscellaneous classes:"
	Smalltalk removeClassNamed: #Array2D.
	Smalltalk removeClassNamed: #DriveACar.
	Smalltalk removeClassNamed: #EventRecorder.
	Smalltalk removeClassNamed: #FindTheLight.
	Smalltalk removeClassNamed: #PluggableTest.
	Smalltalk removeClassNamed: #SystemMonitor.
	Smalltalk removeClassNamed: #DocLibrary.

	Smalltalk removeClassNamed: #ProtocolBrowser.
	Smalltalk removeClassNamed: #ObjectExplorerWrapper.
	Smalltalk removeClassNamed: #HierarchyBrowser.
	Smalltalk removeClassNamed: #LinkedMessageSet.
	Smalltalk removeClassNamed: #ObjectExplorer.
	Smalltalk removeClassNamed: #PackageBrowser.
	Smalltalk removeClassNamed: #AbstractHierarchicalList.
	Smalltalk removeClassNamed: #ChangeList.
	Smalltalk removeClassNamed: #VersionsBrowser.
	Smalltalk removeClassNamed: #ChangeRecord.
	Smalltalk removeClassNamed: #SelectorBrowser.
	Smalltalk removeClassNamed: #CrLfFileStream.
	Smalltalk removeClassNamed: #FXGrafPort.
	Smalltalk removeClassNamed: #FXBlt.

	Smalltalk at: #SampledSound ifPresent: [:c |c initialize].

#(GZipConstants ZipConstants KlattResonatorIndices ) do:
	[:k | Smalltalk removeKey: k ifAbsent: []].
! !


!Text methodsFor: 'emphasis' stamp: 'jmv 7/27/2009 14:22'!
attributesAt: characterIndex forStyle: aTextStyle
	"Answer the code for characters in the run beginning at characterIndex."
	| attributes |
	self size = 0
		ifTrue: [^ #()].  "null text tolerates access"
	attributes _ runs at: characterIndex.
	^ attributes! !

!Text methodsFor: 'emphasis' stamp: 'jmv 7/27/2009 16:27'!
fontAt: characterIndex withStyle: aTextStyle
	"Answer the fontfor characters in the run beginning at characterIndex."
	| attributes font |
	self size = 0 ifTrue: [^ aTextStyle font].	"null text tolerates access"
	attributes _ runs at: characterIndex.
	font _ aTextStyle font.  "default"
	attributes do: 
		[:att | att forFontInStyle: aTextStyle do: [:f | font _ f]].
	^ font! !

!Text methodsFor: 'attributes' stamp: 'jmv 7/27/2009 14:41'!
unembellished 
	"Return true if the only emphases are the default font and bold"
	| bold |
	bold _ TextEmphasis bold.
	Preferences ignoreStyleIfOnlyBold ifFalse: [
		^ runs values isEmpty].

	"If preference is set, then ignore any combo of font1 and bold"
	runs withStartStopAndValueDo: [ :start :stop :emphArray |
		emphArray do: [:emph | 
			(bold = emph) ifFalse: [^ false]]].
	^ true! !


!Text class methodsFor: 'instance creation' stamp: 'jmv 7/27/2009 14:43'!
fromString: aString 
	"Answer an instance of me whose characters are those of the argument, aString."

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

!Text class methodsFor: 'instance creation' stamp: 'jmv 7/27/2009 14:54'!
string: aString emphasis: emphasis
	"This is an old method that is mainly used by old applications"

	^ self string: aString attributes: emphasis! !


!TextEditor methodsFor: 'attributes' stamp: 'jmv 7/27/2009 19:13'!
changeStyle
	"Let user change styles for the current text pane."
	| aList reply style theStyle menuList |

	"cambia estilo o font ???????? que ensalada!!"
	
	aList _ AbstractFont familyNames.
	theStyle _ paragraph textStyle.
	menuList _ aList collect: [ :styleName|
		"REVISAR seguro que esta mal ahora!!"
		"Hack!! use defaultFont for comparison - we have no name that we could use for compare and the style changes with alignment so they're no longer equal."
		(TextStyle named: styleName) font == theStyle font
			ifTrue:['<on>', styleName]
			ifFalse:['<off>',styleName]].
	theStyle = TextStyle default
		ifTrue:[menuList addFirst: '<on>Default Text Style']
		ifFalse:[menuList addFirst: '<off>Default Text Style'].
	aList addFirst: 'Default Text Style'.
	reply _ (SelectionMenu labelList: menuList lines: #(1) selections: aList) startUp.
	reply ifNotNil:
		[(style _ TextStyle named: reply) ifNil: [Beeper beep. ^ true].
		paragraph textStyle: style copy.
		paragraph composeAll.
		self recomputeSelection].
	^ true! !

!TextEditor methodsFor: 'attributes' stamp: 'jmv 7/27/2009 14:20'!
offerFontMenu
	"Present a menu of available fonts, and if one is chosen, apply it to the current selection.  
	Use only names of Fonts of this paragraph  "
	
	^self changeTextFont! !

!TextEditor methodsFor: 'editing keys' stamp: 'jmv 7/27/2009 14:55'!
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
				forStyle: paragraph textStyle.
	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].
	beginTypeInBlock ~~ nil 
		ifTrue: 
			["only change emphasisHere while typing"

			self insertTypeAhead: characterStream.
			emphasisHere := Text addAttribute: attribute toArray: oldAttributes.
			^true].
	self replaceSelectionWith: (thisSel asText addAttribute: attribute).
	^true! !


!SmalltalkEditor methodsFor: 'editing keys' stamp: 'jmv 7/27/2009 14:55'!
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 extras |
	keyCode := ('0123456789-=' indexOf: sensor keyboard ifAbsent: [1]) - 1.
	oldAttributes := paragraph text attributesAt: self pointIndex
				forStyle: paragraph textStyle.
	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).
			extras := #('Link to comment of class' 'Link to definition of class' 'Link to hierarchy of class' 'Link to method').
			index := (PopUpMenu 
						labelArray: colors , #('choose color...' 'Do it' 'Print it') , extras 
								, #('be a web URL link' 'Edit hidden info' 'Copy hidden info')
						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].
					index = 1 
						ifTrue: 
							[attribute := TextDoIt new.
							thisSel := attribute analyze: self selection asString].
					index = 2 
						ifTrue: 
							[attribute := TextPrintIt new.
							thisSel := attribute analyze: self selection asString].
					extras size = 0 & (index > 2) ifTrue: [index := index + 5].	"skip those"
					index = 3 
						ifTrue: 
							[attribute := TextLink new.
							thisSel := attribute analyze: self selection asString with: 'Comment'].
					index = 4 
						ifTrue: 
							[attribute := TextLink new.
							thisSel := attribute analyze: self selection asString with: 'Definition'].
					index = 5 
						ifTrue: 
							[attribute := TextLink new.
							thisSel := attribute analyze: self selection asString with: 'Hierarchy'].
					index = 6 
						ifTrue: 
							[attribute := TextLink new.
							thisSel := attribute analyze: self selection asString].
					index = 7 
						ifTrue: 
							[attribute := TextURL new.
							thisSel := attribute analyze: self selection asString].
					index = 8 
						ifTrue: 
							["Edit hidden info"

							thisSel := self hiddenInfo.	"includes selection"
							attribute := TextEmphasis normal].
					index = 9 
						ifTrue: 
							["Copy hidden info"

							self copyHiddenInfo.
							^true].	"no other action"
					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].
	beginTypeInBlock ~~ nil 
		ifTrue: 
			["only change emphasisHere while typing"

			self insertTypeAhead: characterStream.
			emphasisHere := Text addAttribute: attribute toArray: oldAttributes.
			^true].
	self replaceSelectionWith: (thisSel asText addAttribute: attribute).
	^true! !


!TextFontReference methodsFor: 'as yet unclassified' stamp: 'jmv 7/27/2009 19:24'!
writeScanOn: strm

	strm nextPut: $F.
	strm nextPutAll: font familyName; nextPut: $#.
	font pointSize printOn: strm.! !

!TextFontReference methodsFor: 'comparing' stamp: 'jmv 7/27/2009 15:04'!
dominates: other
	^ other class == self class! !


!TextMorph methodsFor: 'initialization' stamp: 'jmv 7/27/2009 18:59'!
beAllFont: aFont

	textStyle _ aFont textStyle.
	self releaseCachedState; changed! !


!TextStyle methodsFor: 'accessing' stamp: 'jmv 7/27/2009 19:52'!
font
	^font! !

!TextStyle methodsFor: 'accessing' stamp: 'jmv 7/27/2009 19:52'!
font: aFont

	font _ aFont.
	lineGrid _ aFont height + leading.
	baseline _ aFont ascent + leading.
	alignment _ 0.
	firstIndent _ 0.
	restIndent _ 0.
	rightIndent _ 0.
	tabsArray _ TextStyle defaultTabsArray.
	marginTabsArray _ TextStyle defaultMarginTabsArray! !

!TextStyle methodsFor: 'accessing' stamp: 'jmv 7/27/2009 16:32'!
printOn: aStream
	super printOn: aStream.
	aStream space; nextPutAll: self font name! !


!TextStyle class methodsFor: 'instance creation' stamp: 'jmv 7/27/2009 17:30'!
withFont: aFont
	^self new font: aFont! !

!TextStyle class methodsFor: 'user interface' stamp: 'jmv 7/27/2009 19:29'!
modalStyleSelectorWithTitle: title 
	"Presents a modal font-style choice menu, answers a TextStyle or nil."

	"TextStyle modalStyleSelectorWithTitle: 'testing'"

	| menu |
	menu := MenuMorph entitled: title.
	self availableTextStyles keysAndValuesDo: 
			[:styleName :style | 
			menu 
				add: styleName
				target: menu
				selector: #modalSelection:
				argument: style.
			menu lastItem font: style font].
	^menu invokeModal! !

Utilities class removeSelector: #showFormsDictAcrossTopOfScreen:!
TextStyle class removeSelector: #defaultFont!
TextStyle class removeSelector: #fontArray:!
TextStyle class removeSelector: #fontArrayForStyle:!
TextStyle class removeSelector: #fontMenuForStyle:target:selector:highlight:!
TextStyle class removeSelector: #pointSizesFor:!
TextStyle class removeSelector: #promptForFont:andSendTo:withSelector:highlight:!

!TextStyle class reorganize!
('class initialization' initialize)
('constants' defaultMarginTabsArray defaultTab defaultTabsArray)
('instance creation' new withFont:)
('user interface' modalStyleSelectorWithTitle:)
('instance accessing' availableTextStyles default default: named: named:put: removeNamed:)
!

TextStyle removeSelector: #=!
TextStyle removeSelector: #consistOnlyOf:!
TextStyle removeSelector: #defaultFont!
TextStyle removeSelector: #defaultFontIndex!
TextStyle removeSelector: #defaultFontIndex:!
TextStyle removeSelector: #fontArray!
TextStyle removeSelector: #fontAt:!
TextStyle removeSelector: #fontIndexOf:!
TextStyle removeSelector: #fontIndexOfPointSize:!
TextStyle removeSelector: #fontIndexOfSize:!
TextStyle removeSelector: #fontNamed:!
TextStyle removeSelector: #fontNamesWithPointSizes!
TextStyle removeSelector: #fontOfPointSize:!
TextStyle removeSelector: #fontOfSize:!
TextStyle removeSelector: #fonts!
TextStyle removeSelector: #gridForFont:withLead:!
TextStyle removeSelector: #hash!
TextStyle removeSelector: #lineGrid:!
TextStyle removeSelector: #newFontArray:!
TextStyle removeSelector: #pointSizes!
TextStyle removeSelector: #species!
TextStyle removeSelector: #temporaryFix!
!classDefinition: #TextStyle category: #'Graphics-Text'!
Object subclass: #TextStyle
	instanceVariableNames: 'font lineGrid baseline alignment firstIndent restIndent rightIndent tabsArray marginTabsArray leading'
	classVariableNames: 'AvailableTextStyles DefaultTextStyle'
	poolDictionaries: ''
	category: 'Graphics-Text'!

!TextStyle reorganize!
('accessing' alignment alignment: baseline baseline: centered firstIndent firstIndent: font font: justified leading leading: leftFlush lineGrid printOn: restIndent restIndent: rightFlush rightIndent rightIndent:)
('tabs and margins' clearIndents leftMarginTabAt: nextTabXFrom:leftMargin:rightMargin: rightMarginTabAt: tabWidth)
('fonts and font indexes')
('private' marginTabAt:side:)
('Disk I/O' veryDeepCopyWith:)
('as yet unclassified')
!

TextMorph removeSelector: #fontName:size:!
TextMorph removeSelector: #string:fontName:size:!
TextMorph removeSelector: #string:fontName:size:wrap:!
!classDefinition: #TextFontReference category: #'System-TextAttributes'!
TextAttribute subclass: #TextFontReference
	instanceVariableNames: 'font'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-TextAttributes'!
Text removeSelector: #attributesAt:!
Text removeSelector: #fontNumberAt:!
StringMorph removeSelector: #fontName:size:!
StrikeFont class removeSelector: #actualFamilyNames!
StrikeFont class removeSelector: #default!
StrikeFont class removeSelector: #familyName:size:!
StrikeFont class removeSelector: #familyName:size:emphasized:!

!StrikeFont class reorganize!
('instance creation' fromUser fromUser: installDejaVu)
('derivative font caching' shutDown)
('removing' limitTo16Bits removeForPDA removeMostFonts removeSomeFonts saveSpace)
('character shapes' makeControlCharsVisible makeLfInvisible makeLfVisible makeTabInvisible makeTabVisible useLeftArrow useUnderscore)
!

StrikeFont removeSelector: #objectForDataStream:!
StrikeFont removeSelector: #textStyle!
ProgressMorph removeSelector: #fontOfPointSize:!
Preferences class removeSelector: #standardDefaultTextFont!
PopUpMenu initialize!
DisplayScanner class removeSelector: #defaultFont!
CharacterScanner removeSelector: #setFont:!
AbstractFont class removeSelector: #availableFonts!
AbstractFont class removeSelector: #familiName:pointSize:!
AbstractFont initialize!

!AbstractFont class reorganize!
('instance accessing' default default: familyName:pointSize: familyNames pointSizesFor:)
('class initialization' initialize)
('user interface' fontMenuForFamily:target:selector:highlight: promptForFont:andSendTo:withSelector:highlight:)
!

!classDefinition: #AbstractFont category: #'Graphics-Text'!
Object subclass: #AbstractFont
	instanceVariableNames: ''
	classVariableNames: 'AvailableFonts DefaultFont'
	poolDictionaries: ''
	category: 'Graphics-Text'!
Smalltalk removeClassNamed: #TextFontChange!
"Postscript:
Leave the line above, and replace the rest of this comment by a useful one.
Executable statements should follow this comment, and should
be separated by periods, with no exclamation points (!!).
Be sure to put any further comments in double-quotes, like this one."
Clipboard default: nil.
Clipboard default!

