'From Cuis 1.0 of 16 July 2009 [latest update: #228] on 24 July 2009 at 10:39:37 pm'!
!classDefinition: #CanvasCharacterScanner category: #'Morphic-OldSupport'!
CharacterScanner subclass: #CanvasCharacterScanner
	instanceVariableNames: 'canvas fillBlt foregroundColor runX lineY defaultTextColor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-OldSupport'!
!classDefinition: #PopUpMenu category: #'Tools-Menus'!
Object subclass: #PopUpMenu
	instanceVariableNames: 'labelString font lineArray frame form marker selection '
	classVariableNames: 'CacheMenuForms MenuStyle '
	poolDictionaries: ''
	category: 'Tools-Menus'!
!classDefinition: #TextStyle category: #'Graphics-Text'!
Object subclass: #TextStyle
	instanceVariableNames: 'fontArray fontFamilySize lineGrid baseline alignment firstIndent restIndent rightIndent tabsArray marginTabsArray leading defaultFontIndex '
	classVariableNames: ''
	poolDictionaries: 'TextConstants'
	category: 'Graphics-Text'!

!TextStyle commentStamp: 'jmv 7/24/2009 19:08' prior: 0!
A TextStyle comprises the formatting information for composing and displaying a unit (usually a paragraph) of text.  Typically one makes a copy of a master TextStyle (such as TextStyle default), and then that copy may get altered in the process of editing.  Bad things can happen if you do not copy first.

Each of my instances consists of...
	fontArray			An array of StrikeFonts or other fonts
	lineGrid				An integer; default line spacing for paragraphs
	baseline			An integer; default baseline (dist from line top to bottom of an 'a')
	alignment			An integer; text alignment, see TextStyle alignment:
	firstIndent			An integer; indent of first line in pixels
	restIndent			An integer; indent of remaining lines in pixels
	rightIndent			An integer; indent of right margin rel to section
	tabsArray			An array of integers giving tab offsets in pixels
	marginTabsArray	An array of margin tabs
	leading				An integer giving default vertical line separation

For a concrete example, look at TextStyle default copy inspect!
]style[(368 10 205 20 386 30)f1,f1LStrikeFont Comment;,f1,f1LTextStyle alignment:;,f1,f1dTextStyle default copy inspect;;!


!CanvasCharacterScanner methodsFor: 'private' stamp: 'jmv 7/24/2009 22:30'!
setFont
	foregroundColor _ Color black.
	super setFont.
	destY _ lineY + line baseline - font ascent! !


!MethodFinder methodsFor: 'initialize' stamp: 'jmv 7/24/2009 20:13'!
initialize2
	"The methods we are allowed to use.  (MethodFinder new initialize) "

"Set"
	#("in class" sizeFor:
"testing" "adding" "removing" "enumerating"
"private" array findElementOrNil: 
"accessing" someElement) do: [:sel | Approved add: sel].

"Dictionary, IdentityDictionary, IdentitySet"
	#("accessing" associationAt: associationAt:ifAbsent: at:ifPresent: keyAtIdentityValue: keyAtIdentityValue:ifAbsent: keyAtValue: keyAtValue:ifAbsent: keys
"testing" includesKey: ) do: [:sel | Approved add: sel].
	#(removeKey: removeKey:ifAbsent:
) do: [:sel | AddAndRemove add: sel].

"LinkedList, Interval, MappedCollection"
	#("in class"  from:to: from:to:by:
"accessing" contents) do: [:sel | Approved add: sel].
	#(
"adding" addFirst: addLast:) do: [:sel | AddAndRemove add: sel].

"OrderedCollection, SortedCollection"
	#("accessing" after: before:
"copying" copyEmpty
"adding"  growSize
"removing" "enumerating" "private" 
"accessing" sortBlock) do: [:sel | Approved add: sel].
	#("adding" add:after: add:afterIndex: add:before: addAllFirst: addAllLast: addFirst: addLast:
"removing" removeAt: removeFirst removeLast
"accessing" sortBlock:) do: [:sel | AddAndRemove add: sel].

"Character"
	#("in class, instance creation" allCharacters digitValue: new separators
	"accessing untypeable characters" backspace cr enter lf linefeed nbsp newPage space tab
	"constants" alphabet characterTable
"accessing" asciiValue digitValue
"comparing"
"testing" isAlphaNumeric isDigit isLetter isLowercase isSafeForHTTP isSeparator isSpecial isUppercase isVowel tokenish
"copying"
"converting" asLowercase asUppercase
	) do: [:sel | Approved add: sel].

"String"
	#("in class, instance creation" crlf fromPacked:
	"primitives" findFirstInString:inSet:startingAt: indexOfAscii:inString:startingAt: 	"internet" valueOfHtmlEntity:
"accessing" byteAt: endsWithDigit findAnySubStr:startingAt: findBetweenSubStrs: findDelimiters:startingAt: findString:startingAt: findString:startingAt:caseSensitive: findTokens: findTokens:includes: findTokens:keep: includesSubString: includesSubstring:caseSensitive: indexOf:startingAt: indexOfAnyOf: indexOfAnyOf:ifAbsent: indexOfAnyOf:startingAt: indexOfAnyOf:startingAt:ifAbsent: lineCorrespondingToIndex: lineCount lineNumber: skipAnySubStr:startingAt: skipDelimiters:startingAt: startsWithDigit
"comparing" alike: beginsWith: caseSensitiveLessOrEqual: charactersExactlyMatching: compare: crc16 endsWith: endsWithAnyOf: sameAs: startingAt:match:startingAt:
"copying" copyReplaceTokens:with: padded:to:with:
"converting" asByteArray asDate asFileName asLegalSelector asPacked asText asTime capitalized compressWithTable: contractTo: correctAgainst: initialIntegerOrNil keywords quoted sansPeriodSuffix splitInteger stemAndNumericSuffix substrings surroundedBySingleQuotes truncateWithElipsisTo: withBlanksTrimmed withFirstCharacterDownshifted withNoLineLongerThan: withSeparatorsCompacted withoutLeadingDigits withoutTrailingBlanks
"displaying" "printing"
"system primitives" compare:with:collated: 
"Celeste" withCRs
"internet" decodeMimeHeader decodeQuotedPrintable unescapePercents withInternetLineEndings withSqueakLineEndings withoutQuoting
"testing" isAllSeparators lastSpacePosition
"paragraph support" indentationIfBlank:
"arithmetic" ) do: [:sel | Approved add: sel].
	#(byteAt:put: translateToLowercase match:) do: [:sel | AddAndRemove add: sel].

"Symbol"
	#("in class, private" hasInterned:ifTrue:
	"access" morePossibleSelectorsFor: possibleSelectorsFor: selectorsContaining: thatStarts:skipping:
"accessing" "comparing" "copying" "converting" "printing" 
"testing" isInfix isKeyword isPvtSelector isUnary) do: [:sel | Approved add: sel].

"Array"
	#("comparing" "converting" evalStrings 
"printing" "private" hasLiteralSuchThat:) do: [:sel | Approved add: sel].

"ByteArray"
	#("accessing" doubleWordAt: wordAt: 
"platform independent access" longAt:bigEndian: shortAt:bigEndian: unsignedLongAt:bigEndian: unsignedShortAt:bigEndian: 
"converting") do: [:sel | Approved add: sel].
	#(doubleWordAt:put: wordAt:put: longAt:put:bigEndian: shortAt:put:bigEndian: unsignedLongAt:put:bigEndian: unsignedShortAt:put:bigEndian:
	) do: [:sel | AddAndRemove add: sel].

"FloatArray"		"Dont know what happens when prims not here"
	false ifTrue: [#("accessing" "arithmetic" *= += -= /=
"comparing"
"primitives-plugin" primAddArray: primAddScalar: primDivArray: primDivScalar: primMulArray: primMulScalar: primSubArray: primSubScalar:
"primitives-translated" primAddArray:withArray:from:to: primMulArray:withArray:from:to: primSubArray:withArray:from:to:
"converting" "private" "user interface") do: [:sel | Approved add: sel].
	].

"IntegerArray, WordArray"
"RunArray"
	#("in class, instance creation" runs:values: scanFrom:
"accessing" runLengthAt: 
"adding" "copying"
"private" runs values) do: [:sel | Approved add: sel].
	#(coalesce addLast:times: repeatLast:ifEmpty: repeatLastIfEmpty:
		) do: [:sel | AddAndRemove add: sel].

"Stream  -- many operations change its state"
	#("testing" atEnd) do: [:sel | Approved add: sel].
	#("accessing" next: nextMatchAll: nextMatchFor: upToEnd
next:put: nextPut: nextPutAll: "printing" print:	) do: [:sel | AddAndRemove add: sel].

"PositionableStream"
	#("accessing" contentsOfEntireFile originalContents peek peekFor: "testing"
"positioning" position ) do: [:sel | Approved add: sel].
	#(nextDelimited: nextLine upTo: position: reset resetContents setToEnd skip: skipTo: upToAll: ) do: [:sel | AddAndRemove add: sel].
	"Because it is so difficult to test the result of an operation on a Stream (you have to supply another Stream in the same state), we don't support Streams beyond the basics.  We want to find the messages that convert Streams to other things."

"ReadWriteStream"
	#("file status" closed) do: [:sel | Approved add: sel].
	#("accessing" next: on: ) do: [:sel | AddAndRemove add: sel].

"WriteStream"
	#("in class, instance creation" on:from:to: with: with:from:to:
		) do: [:sel | Approved add: sel].
	#("positioning" resetToStart
"character writing" crtab crtab:) do: [:sel | AddAndRemove add: sel].

"LookupKey, Association, Link"
	#("accessing" key nextLink) do: [:sel | Approved add: sel].
	#(key: key:value: nextLink:) do: [:sel | AddAndRemove add: sel].

"Point"
	#("in class, instance creation" r:degrees: x:y:
"accessing" x y "comparing" "arithmetic" "truncation and round off"
"polar coordinates" degrees r theta
"point functions" bearingToPoint: crossProduct: dist: dotProduct: eightNeighbors flipBy:centerAt: fourNeighbors grid: nearestPointAlongLineFrom:to: nearestPointOnLineFrom:to: normal normalized octantOf: onLineFrom:to: onLineFrom:to:within: quadrantOf: rotateBy:centerAt: transposed unitVector
"converting" asFloatPoint asIntegerPoint corner: extent: rect:
"transforming" adhereTo: rotateBy:about: scaleBy: scaleFrom:to: translateBy: "copying"
"interpolating" interpolateTo:at:) do: [:sel | Approved add: sel].

"Rectangle"
	#("in class, instance creation" center:extent: encompassing: left:right:top:bottom: 
	merging: origin:corner: origin:extent: 
"accessing" area bottom bottomCenter bottomLeft bottomRight boundingBox center corner corners innerCorners left leftCenter origin right rightCenter top topCenter topLeft topRight
"comparing"
"rectangle functions" adjustTo:along: amountToTranslateWithin: areasOutside: bordersOn:along: encompass: expandBy: extendBy: forPoint:closestSideDistLen: insetBy: insetOriginBy:cornerBy: intersect: merge: pointNearestTo: quickMerge: rectanglesAt:height: sideNearestTo: translatedToBeWithin: withBottom: withHeight: withLeft: withRight: withSide:setTo: withTop: withWidth:
"testing" containsPoint: containsRect: hasPositiveExtent intersects: isTall isWide
"truncation and round off"
"transforming" align:with: centeredBeneath: newRectFrom: squishedWithin: "copying"
	) do: [:sel | Approved add: sel].

"Color"
	#("in class, instance creation" colorFrom: colorFromPixelValue:depth: fromRgbTriplet: gray: h:s:v: r:g:b: r:g:b:alpha: r:g:b:range:
	"named colors" black blue brown cyan darkGray gray green lightBlue lightBrown lightCyan lightGray lightGreen lightMagenta lightOrange lightRed lightYellow magenta orange red transparent veryDarkGray veryLightGray veryVeryDarkGray veryVeryLightGray white yellow
	"other" colorNames indexedColors pixelScreenForDepth: quickHighLight:
"access" alpha blue brightness green hue luminance red saturation
"equality"
"queries" isBitmapFill isBlack isGray isSolidFill isTranslucent isTranslucentColor
"transformations" alpha: dansDarker darker lighter mixed:with: muchLighter slightlyDarker slightlyLighter veryMuchLighter alphaMixed:with:
"groups of shades" darkShades: lightShades: mix:shades: wheel:
"printing" shortPrintString
"other" colorForInsets rgbTriplet
"conversions" asB3DColor asColor balancedPatternForDepth: bitPatternForDepth: closestPixelValue1 closestPixelValue2 closestPixelValue4 closestPixelValue8 dominantColor halfTonePattern1 halfTonePattern2 indexInMap: pixelValueForDepth: pixelWordFor:filledWith: pixelWordForDepth: scaledPixelValue32
"private" privateAlpha privateBlue privateGreen privateRGB privateRed "copying"
	) do: [:sel | Approved add: sel].

"	For each selector that requires a block argument, add (selector argNum) 
		to the set Blocks."
"ourClasses _ #(Object Boolean True False UndefinedObject Behavior ClassDescription Class Metaclass MethodContext BlockContext Message Magnitude Date Time Number Integer SmallInteger LargeNegativeInteger LargePositiveInteger Float Fraction Random Collection SequenceableCollection ArrayedCollection Bag Set Dictionary IdentityDictionary IdentitySet LinkedList Interval MappedCollection OrderedCollection SortedCollection Character String Symbol Array Array2D ByteArray FloatArray IntegerArray WordArray RunArray Stream PositionableStream ReadWriteStream WriteStream LookupKey Association Link Point Rectangle Color).
ourClasses do: [:clsName | cls _ Smalltalk at: clsName.
	(cls selectors) do: [:aSel |
		((Approved includes: aSel) or: [AddAndRemove includes: aSel]) ifTrue: [
			(cls formalParametersAt: aSel) withIndexDo: [:tName :ind |
				(tName endsWith: 'Block') ifTrue: [
					Blocks add: (Array with: aSel with: ind)]]]]].
"
#((timesRepeat: 1 ) (indexOf:ifAbsent: 2 ) (pairsCollect: 1 ) (mergeSortFrom:to:by: 3 ) (ifNotNil:ifNil: 1 ) (ifNotNil:ifNil: 2 ) (ifNil: 1 ) (at:ifAbsent: 2 ) (ifNil:ifNotNil: 1 ) (ifNil:ifNotNil: 2 ) (ifNotNil: 1 ) (at:modify: 2 ) (identityIndexOf:ifAbsent: 2 ) (sort: 1 ) (sortBlock: 1 ) (detectMax: 1 ) (repeatLastIfEmpty: 1 ) (allSubclassesWithLevelDo:startingLevel: 1 ) (keyAtValue:ifAbsent: 2 ) (in: 1 ) (ifTrue: 1 ) (or: 1 ) (select: 1 ) (inject:into: 2 ) (ifKindOf:thenDo: 2 ) (forPoint:closestSideDistLen: 2 ) (value:ifError: 2 ) (selectorsDo: 1 ) (removeAllSuchThat: 1 ) (keyAtIdentityValue:ifAbsent: 2 ) (detectMin: 1 ) (detect:ifNone: 1 ) (ifTrue:ifFalse: 1 ) (ifTrue:ifFalse: 2 ) (detect:ifNone: 2 ) (hasLiteralSuchThat: 1 ) (indexOfAnyOf:ifAbsent: 2 ) (reject: 1 ) (newRectFrom: 1 ) (removeKey:ifAbsent: 2 ) (at:ifPresent: 2 ) (associationAt:ifAbsent: 2 ) (withIndexCollect: 1 ) (repeatLast:ifEmpty: 2 ) (findLast: 1 ) (indexOf:startingAt:ifAbsent: 3 ) (remove:ifAbsent: 2 ) (ifFalse:ifTrue: 1 ) (ifFalse:ifTrue: 2 ) (caseOf:otherwise: 2 ) (count: 1 ) (collect: 1 ) (sortBy: 1 ) (and: 1 ) (asSortedCollection: 1 ) (with:collect: 2 ) (sourceCodeAt:ifAbsent: 2 ) (detect: 1 ) (scopeHas:ifTrue: 2 ) (collectWithIndex: 1 ) (compiledMethodAt:ifAbsent: 2 ) (bindWithTemp: 1 ) (detectSum: 1 ) (indexOfSubCollection:startingAt:ifAbsent: 3 ) (findFirst: 1 ) (sourceMethodAt:ifAbsent: 2 ) (collect:thenSelect: 1 ) (collect:thenSelect: 2 ) (select:thenCollect: 1 ) (select:thenCollect: 2 ) (ifFalse: 1 ) (indexOfAnyOf:startingAt:ifAbsent: 3 ) (indentationIfBlank: 1 ) ) do: [:anArray |
	Blocks add: anArray].

self initialize3.

"
MethodFinder new initialize.
MethodFinder new organizationFiltered: TranslucentColor class 
"
"Do not forget class messages for each of these classes"
! !


!PopUpMenu methodsFor: 'accessing' stamp: 'jmv 7/24/2009 20:39'!
frameHeight
	"Designed to avoid the entire frame computation (includes MVC form),
	since the menu may well end up being displayed in Morphic anyway."
	| nItems |
	nItems _ 1 + (labelString occurrencesOf: Character cr).
	^ (nItems * MenuStyle lineGrid) + 4 "border width"! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'jmv 7/24/2009 20:45'!
startUpSegmented: segmentHeight withCaption: captionOrNil at: location allowKeyboard: aBoolean
	"This menu is too big to fit comfortably on the screen.
	Break it up into smaller chunks, and manage the relative indices.
	Inspired by a special-case solution by Reinier van Loon.  The boolean parameter indicates whether the menu should be given keyboard focus (if in morphic)"

"
(PopUpMenu labels: (String streamContents: [:s | 1 to: 100 do: [:i | s print: i; cr]. s skip: -1])
		lines: (5 to: 100 by: 5)) startUpWithCaption: 'Give it a whirl...'.
"
	| nLines nLinesPer allLabels from to subset subLines index |
	allLabels := labelString findTokens: Character cr asString.
	nLines _ allLabels size.
	lineArray ifNil: [lineArray _ Array new].
	nLinesPer _ segmentHeight // MenuStyle lineGrid - 3.
	from := 1.
	[ true ] whileTrue:
		[to := (from + nLinesPer) min: nLines.
		subset := allLabels copyFrom: from to: to.
		subset add: (to = nLines ifTrue: ['start over...'] ifFalse: ['more...'])
			before: subset first.
		subLines _ lineArray select: [:n | n >= from] thenCollect: [:n | n - (from-1) + 1].
		subLines _ (Array with: 1) , subLines.
		index := (PopUpMenu labels: subset asStringWithCr lines: subLines)
					startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean.
		index = 1
			ifTrue: [from := to + 1.
					from > nLines ifTrue: [ from := 1 ]]
			ifFalse: [index = 0 ifTrue: [^ 0].
					^ from + index - 2]]! !

!PopUpMenu methodsFor: 'basic control sequence' stamp: 'jmv 7/24/2009 20:43'!
startUpWithCaption: captionOrNil at: location allowKeyboard: aBoolean 
	"Display the menu, with caption if supplied. Wait for the mouse button to go down, then track the selection as long as the button is pressed. When the button is released,
	Answer the index of the current selection, or zero if the mouse is not released over  any menu item. Location specifies the desired topLeft of the menu body rectangle. The final argument indicates whether the menu should seize the keyboard focus in order to allow the user to navigate it via the keyboard."

	| maxHeight |
	maxHeight := Display height * 3 // 4.
	self frameHeight > maxHeight 
		ifTrue: 
			[^self 
				startUpSegmented: maxHeight
				withCaption: captionOrNil
				at: location
				allowKeyboard: aBoolean].
	^Cursor normal showWhile: 
							[(MVCMenuMorph from: self title: captionOrNil) 
								invokeAt: location
								in: ActiveWorld
								allowKeyboard: aBoolean]! !

!PopUpMenu methodsFor: 'private' stamp: 'jmv 7/24/2009 20:49'!
labels: aString lines: anArray

	labelString _ aString.
	lineArray _ anArray.
! !

!PopUpMenu methodsFor: 'private' stamp: 'jmv 7/24/2009 20:49'!
rescan
	"Cause my form to be recomputed after a font change."

	labelString == nil ifTrue: [labelString _ 'NoText!!'].
	self labels: labelString lines: lineArray.

	"PopUpMenu allSubInstancesDo: [:m | m rescan]"! !


!CustomMenu methodsFor: 'construction' stamp: 'jmv 7/24/2009 20:49'!
labels: aString lines: anArrayOrNil
	"This method allows the receiver to accept old-style SelectionMenu creation messages. It should be used only for backward compatibility during the MVC-to-Morphic transition. New code should be written using the other menu construction protocol such as addList:."

	| labelList linesArray |
	labelList _ (aString findTokens: String cr) asArray.
	anArrayOrNil
		ifNil: [linesArray _ #()]
		ifNotNil: [linesArray _ anArrayOrNil].
	1 to: labelList size do: [:i |
		self add: (labelList at: i) action: (labelList at: i).
		(linesArray includes: i) ifTrue: [self addLine]]
! !

!CustomMenu methodsFor: 'invocation' stamp: 'jmv 7/24/2009 20:32'!
startUp
	"Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen."

	^ self startUpWithCaption: title! !

!CustomMenu methodsFor: 'invocation' stamp: 'jmv 7/24/2009 20:33'!
startUpWithCaption: caption
	"Build and invoke this menu with no initial selection. Answer the selection associated with the menu item chosen by the user or nil if none is chosen; use the provided caption"

	self build.
	^ super startUpWithCaption: caption! !

!CustomMenu methodsFor: 'private' stamp: 'jmv 7/24/2009 20:49'!
build
	"Turn myself into an invokable ActionMenu."

	| stream |
	stream _ WriteStream on: (String new).
	labels do: [:label | stream nextPutAll: label; cr].
	(labels isEmpty) ifFalse: [stream skip: -1].  "remove final cr"
	super labels: stream contents
		lines: dividers! !


!PopUpMenu class methodsFor: 'instance creation' stamp: 'jmv 7/24/2009 20:49'!
labels: aString lines: anArray
	"Answer an instance of me whose items are in aString, with lines drawn 
	after each item indexed by anArray."

	^ self new
		labels: aString
		lines: anArray! !


!Preferences class methodsFor: 'fonts' stamp: 'jmv 7/24/2009 19:22'!
setListFontTo: aFont
	"Set the list font as indicated"

	Parameters at: #standardListFont put: aFont! !


!ProgressInitiationException methodsFor: 'as yet unclassified' stamp: 'jmv 7/24/2009 22:19'!
defaultAction

	| delta savedArea textFrame barFrame outerFrame result range lastW w f h textWidth |
	f _ TextStyle defaultFont.
	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! !


!StandardFileMenu methodsFor: 'menu building' stamp: 'jmv 7/24/2009 20:49'!
makeFileMenuFor: aDirectory
"Initialize an instance of me to operate on aDirectory"

	| theMenu |
	pattern ifNil: [ self pattern: '*'].
	Cursor wait showWhile: 
		[self 
			labels: 	(self menuLabelsString: aDirectory)
			lines: 	(self menuLinesArray: aDirectory).
		theMenu _ self selections: (self menuSelectionsArray: aDirectory)].
	^theMenu! !

!StandardFileMenu methodsFor: 'basic control sequences' stamp: 'jmv 7/24/2009 20:46'!
startUpWithCaption: aString at: location

	|result|
	result _ super startUpWithCaption: aString at: location.
	result ifNil: [^nil].
	result isDirectory ifTrue:
		[self makeFileMenuFor: result directory.
		 ^self startUpWithCaption: aString at: location].
	result isCommand ifTrue: 
		[result _ self getTypedFileName: result.
		result ifNil: [^nil]].
	canTypeFileName ifTrue: [^self confirmExistingFiles: result].
	^result
	! !


!String methodsFor: 'displaying' stamp: 'jmv 7/24/2009 20:16'!
displayOn: aDisplayMedium at: aPoint textColor: aColor
	"Show a representation of the receiver as a DisplayText at location aPoint on aDisplayMedium, rendering the text in the designated color"

	aDisplayMedium getCanvas drawString: self from: 1 to: self size at: aPoint font: nil color: aColor! !


!Text class methodsFor: 'class initialization' stamp: 'jmv 7/24/2009 22:22'!
initialize	"Text initialize"
	"Initialize constants shared by classes associated with text display."

	self initTextConstants! !


!Transcripter methodsFor: 'initialization' stamp: 'jmv 7/24/2009 19:35'!
initInFrame: rect
	frame _ rect insetBy: 2.  "Leave room for border"
	para _ NewParagraph new.
	para
		compose: self contents asText
		style: TextStyle default
		in: ((frame insetBy: 4) withHeight: 9999)! !

!Transcripter methodsFor: 'accessing' stamp: 'jmv 7/24/2009 20:10'!
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
		style: TextStyle default
		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 lineGrid)).
		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! !

TextStyle class removeSelector: #changeDefaultFontSizeBy:!
TextStyle class removeSelector: #decodeStyleName:!
TextStyle class removeSelector: #fontMenuForStyle:target:selector:!
TextStyle class removeSelector: #initDefaultFontsAndStyle!
TextStyle class removeSelector: #knownTextStylesWithoutDefault!
TextStyle class removeSelector: #mvcPromptForFont:andSendTo:withSelector:!
TextStyle class removeSelector: #pixelsPerInch!
TextStyle class removeSelector: #pixelsPerInch:!
TextStyle class removeSelector: #pixelsToPoints:!
TextStyle class removeSelector: #pointsToPixels:!
TextStyle class removeSelector: #promptForFont:andSendTo:withSelector:!
TextStyle class removeSelector: #writeSF2FamilyNamed:inDirectory:toChangeSet:!
TextStyle class removeSelector: #writeStyle:named:toChangeSet:!
TextStyle removeSelector: #consolidate!
TextStyle removeSelector: #flushFonts!
TextStyle removeSelector: #storeDataOn:!
!classDefinition: #TextStyle category: #'Graphics-Text'!
Object subclass: #TextStyle
	instanceVariableNames: 'fontArray lineGrid baseline alignment firstIndent restIndent rightIndent tabsArray marginTabsArray leading defaultFontIndex'
	classVariableNames: ''
	poolDictionaries: 'TextConstants'
	category: 'Graphics-Text'!
TextIndent class removeSelector: #example!
Text initialize!
Text removeSelector: #asDisplayText!
Text removeSelector: #asParagraph!
String removeSelector: #asDisplayText!
String removeSelector: #asParagraph!
StrikeFont removeSelector: #fontDisplay!
StandardFileMenu class removeSelector: #newFileMenu:withPattern:!
StandardFileMenu class removeSelector: #oldFileMenu:withPattern:!
StandardFileMenu class removeSelector: #oldFileStream!
StandardFileMenu removeSelector: #computeLabelParagraph!
CustomMenu class removeSelector: #example!
SelectionMenu class removeSelector: #labelList:!
SelectionMenu class removeSelector: #labelList:lines:!
CustomMenu removeSelector: #invokeOn:defaultSelection:!
CustomMenu removeSelector: #labels:font:lines:!
CustomMenu removeSelector: #preSelect:!
CustomMenu removeSelector: #startUp:!
CustomMenu removeSelector: #startUp:withCaption:!
PopUpMenu removeSelector: #center!
PopUpMenu removeSelector: #computeForm!
PopUpMenu removeSelector: #computeLabelParagraph!
PopUpMenu removeSelector: #controlActivity!
PopUpMenu removeSelector: #displayAt:withCaption:during:!
PopUpMenu removeSelector: #labels:font:lines:!
PopUpMenu removeSelector: #manageMarker!
PopUpMenu removeSelector: #markerOff!
PopUpMenu removeSelector: #markerOn:!
PopUpMenu removeSelector: #markerTop:!
PopUpMenu removeSelector: #menuForm!
PopUpMenu removeSelector: #readKeyboard!
PopUpMenu removeSelector: #scrollIntoView:!
PopUpMenu removeSelector: #selection!
PopUpMenu removeSelector: #setSelection:!
PopUpMenu removeSelector: #startUpCenteredWithCaption:!
PopUpMenu removeSelector: #startUpLeftFlush!
!classDefinition: #PopUpMenu category: #'Tools-Menus'!
Object subclass: #PopUpMenu
	instanceVariableNames: 'labelString lineArray'
	classVariableNames: 'MenuStyle'
	poolDictionaries: ''
	category: 'Tools-Menus'!
NewParagraph removeSelector: #OLDcomposeLinesFrom:to:delta:into:priorLines:atY:!
NewParagraph removeSelector: #testNewComposeAll!
DisplayScanner removeSelector: #characterNotInFont!
DisplayScanner removeSelector: #displayLines:in:clippedBy:!
DisplayScanner removeSelector: #initializeFromParagraph:clippedBy:!
CompositionScanner removeSelector: #composeLine:fromCharacterIndex:inParagraph:!
CompositionScanner removeSelector: #forParagraph:!
CharacterBlockScanner removeSelector: #characterNotInFont!
CanvasCharacterScanner removeSelector: #defaultTextColor!
CanvasCharacterScanner removeSelector: #defaultTextColor:!
CanvasCharacterScanner removeSelector: #doesDisplaying!
!classDefinition: #CanvasCharacterScanner category: #'Morphic-OldSupport'!
CharacterScanner subclass: #CanvasCharacterScanner
	instanceVariableNames: 'canvas foregroundColor runX lineY'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Morphic-OldSupport'!
CharacterScanner removeSelector: #characterNotInFont!
CharacterScanner removeSelector: #primScanCharactersFrom:to:in:rightX:stopConditions:kern:!
Array removeSelector: #objectForDataStream:!
AbstractFont removeSelector: #pixelSize!
AbstractFont removeSelector: #pixelsPerInchChanged!
Smalltalk removeClassNamed: #DisplayText!
Smalltalk removeClassNamed: #FontSet!
Smalltalk removeClassNamed: #ListParagraph!
Smalltalk removeClassNamed: #Paragraph!
Smalltalk removeClassNamed: #SegmentScanner!
Smalltalk removeClassNamed: #TextLineInterval!
