ControllerWithMenu subclass: #CHGController
	instanceVariableNames: 'lastYellowButtonPoint selectedNode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ClassHierarchyGraphBrowser'!
CHGController comment:
'[From CHG 0.2 by Neil W. Van Dyke, neil@cse.ogi.edu, Dec 1992,
Oregon Graduate Institute of Science & Technology, CSE509]

Description:

	CHGController is the controller for the CHGView.

Instance Variables:

	lastYellowButtonPoint    <Point>
		The point at which the yellow mouse button was last pressed.

	selectedNode    <CHGNode>
		The node on which the yellow mouse button was last pressed;
		nil if none.'!


!CHGController methodsFor: 'private'!

redButtonActivity
	"Called on press of red mouse button.  If on a node, focus on the node.
	Pass to superclass."
	
	| node |

	node := ((self model) nodeContainingPoint: (sensor cursorPoint)).

	(node notNil) ifTrue: [
		(self model) focusOn: (node classRef).
		(self view) invalidate.
	].

	^(super redButtonActivity).!

yellowButtonActivity
	"Remember where the menu was invoked from, get a reference to any node
	under the cursor, then let the superclass do the menu processing."

	lastYellowButtonPoint := (sensor cursorPoint).

	selectedNode := ((self model) nodeContainingPoint: lastYellowButtonPoint).

	^(super yellowButtonActivity).! !

!CHGController methodsFor: 'public'!

changeFocusNode
	"Change focus node to the selected node."

	(self model) focusOn: (selectedNode classRef).

	(self view) invalidate.!

inspectModel
	"Inspect the model."

	(self model) inspect.!

inspectNode
	"Inspect the selected node."

	selectedNode inspect.!

menu
	"Return a PopUpMenu, the content of which depends on whether or not a node
	is selected."

	(selectedNode isNil) ifTrue: [
		^PopUpMenu
			labels: ((
				'Update CHG\',
				'Spawn CHG...\',
				'Toggle Superclasses\',
				'About\',
				'Inspect Model'
			) withCRs)
			lines: #(4)
			values: #(
				updateModel
				spawnCHGOnPicked
				toggleSuperclasses
				showAboutInfo
				inspectModel
			).
	]; ifFalse: [
		^PopUpMenu
			labels: ((
				'Spawn Class\',
				'Spawn CHG\',
				'Focus On Class\',
				'Inspect Node'
			) withCRs)
			lines: #(3)
			values: #(
				spawnClassBrowser
				spawnCHGOnSelected
				changeFocusNode
				inspectNode
			).
	].!

showAboutInfo
	"Show DialogView with `About' information."

	DialogView warn: ((
		'CHG  -  Smalltalk Class Hierarchy Graph Browser\',
		'Version 0.3    Fri 18 Dec 1992\',
		'\',
		'by Neil W. Van Dyke    neil@cse.ogi.edu    +1 503 690 1300\',
		'\',
		'Final project for CSE509 Object-Oriented Programming class\',
		'at the Oregon Graduate Institute of Science & Technology.\',
		'\',
		'Available as "cse.ogi.edu:/pub/smalltalk/chg_0_3.tar.Z".'
	) withCRs).!

spawnCHGOnPicked
	"Spawn a CHG browser on a class picked by the user."

	CHGView openPickFocusClass.!

spawnCHGOnSelected
	"Spawn a CHG browser on the class represented by the selected node."

	CHGView openFocusedOn: (selectedNode classRef).!

spawnClassBrowser
	"Spawn a class browser on the class represented by the selected node."

	Browser newOnClass: (selectedNode classRef).!

toggleSuperclasses
	"Toggle the show-superclasses attribute of the model, layout, and
	invalidate the view to redraw."

	(self model) showSuperclasses: (((self model) showSuperclasses) not).

	(self model) layout.

	(self view) invalidate.!

updateModel
	"Update the model to reflect the current state of the class hierarchy."

	(self model) updateFromSmalltalk.

	(self view) invalidate.! !

View subclass: #CHGView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ClassHierarchyGraphBrowser'!
CHGView comment:
'[From CHG 0.2 by Neil W. Van Dyke, neil@cse.ogi.edu, Dec 1992,
Oregon Graduate Institute of Science & Technology, CSE509]

Description:

	View for CHGModel.
'!


!CHGView methodsFor: 'private'!

displayFocusNodeOn: aGC
	"Display the focus node."

	((self model) focusNode) displayOn: aGC focused: true.!

displayStatusOn: aGC
	"Display the status line."

	| labelString |

	labelString := 'Focus: ', (((self model) focusNode) className).

	labelString := labelString, '   Superclasses: '.

	((self model) showSuperclasses) ifTrue: [ 
		labelString := labelString, 'ON'.
	]; ifFalse: [ 
		labelString := labelString, 'OFF'.
	].

	((labelString asText) emphasizeAllWith: #italic)
		displayOn: aGC at: (10 @ 15).!

displaySubtree: aNode on: aGC
	""

	aNode displayOn: aGC.

	(aNode children) do: [ :node | self displaySubtree: node on: aGC ].!

pickAClass: prompt	
	"Choose a class with a prompter.  Bring up menu for wildcards.  Answer the
	an empty string if that's what the user returned or if the user selects
	outside the menu, answer nil if the user pa name that does not match any
	class name.  NOTE: Stolen from `Browser>>pickAClass:'."

	| chosenSelector classes destClass destClassName |

	destClassName := (DialogView request: prompt
		initialAnswer: (ParagraphEditor currentSelection)).

	(destClassName = '') ifTrue: [ ^'' ].

	((destClassName findString: '*' startingAt: 1) ~= 0) ifTrue: [
		classes := OrderedCollection new.
		(Cursor execute) showWhile: [ 
			classes := Smalltalk classNames
				select: [ :cn | destClassName match: cn]
		].
		(classes == nil or: [classes size = 0]) ifTrue: [^nil].
		(chosenSelector :=
			(PopUpMenu labelList: (Array with: classes)) startUp) = 0
			ifTrue: [ ^'' ]
			ifFalse: [ destClassName := (classes at: chosenSelector) ]
	] ifFalse: [
		destClassName := ((Smalltalk keys) 
			detect: [ :cn | destClassName match: cn] ifNone: [^nil]).
	].

	destClass := (Smalltalk at: (destClassName asSymbol) ifAbsent: [ ^nil ]).

	"(destClass meta) ifTrue: [ destClass := (destClass class) ]."

	^destClass! !

!CHGView methodsFor: 'public'!

defaultControllerClass
	"Return the default controller class for the view"

	^CHGController.!

displayOn: aGC
	"Display on the specified graphics context, by invoking the methods to
	display the node tree, display the status line, and lighlight the focus
	node."

	| visibleRoot |

	((visibleRoot := ((self model) visibleRootNode)) isNil) ifFalse: [
		self displaySubtree: visibleRoot on: aGC.
	].

	self displayStatusOn: aGC.

	self displayFocusNodeOn: aGC.! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CHGView class
	instanceVariableNames: ''!


!CHGView class methodsFor: 'private'!

open
	"Open a view."

	| view |

	view := (self new).

	self open: view.

	^view.!

open: aCHGView
	"Open on the supplied view."

	ScheduledWindow new
		label: 'Class Hierarchy Graph Browser';
		component: aCHGView;
		minimumSize: (250 @ 50);
		openWithExtent: (400 @ 200).!

openOnModel: aCHGModel
	"Open a view on the specified CHGModel model."

	^(self open) model: aCHGModel.! !

!CHGView class methodsFor: 'public'!

openFocusedOn: aClass
	"Create a CHGModel and a view, focused on the specified class."

	^(self openOnModel: (CHGModel newFocusedOn: aClass)).!

openPickFocusClass
	"Prompt for a class from the user with a dialog, and open on a model
	focused on that class."

	| class |

	class := ((self new) pickAClass: 'Browse what class?').

	(class = '') ifTrue: [ ^self ].

	(class isNil) ifTrue: [
		DialogView warn: 'No matching class'.
		^self.
	].

	(class isBehavior) ifFalse: [ class := (class class) ].
	(class isMeta) ifTrue: [ class := (class soleInstance) ].

	^(self openFocusedOn: class).! !

Model subclass: #CHGModel
	instanceVariableNames: 'focusNode layoutHorizontalSpacing layoutVerticalSpacing rootNode showSuperclasses '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ClassHierarchyGraphBrowser'!
CHGModel comment:
'[From CHG 0.2 by Neil W. Van Dyke, neil@cse.ogi.edu, Dec 1992,
Oregon Graduate Institute of Science & Technology, CSE509]

Description:

	Model of the class hierarchy graph browser.

Instance Variables:

	focusNode    <CHGNode>
		Node for the class which is currently in focus.

	layoutHorizontalSpacing    <Integer>
		Horizontal spacing between the origins of horizontally-adjacent
		nodes.  Computed in the layout algorithms.

	layoutVerticalSpacing    <Integer>
		Vertical spacing between the origins of vertically-adjacent
		nodes.  Constant in current implementation.

	rootNode    <CHGNode>
		The root node of the tree.  Should always be the node for the `Object'' class.

	showSuperclasses    <Boolean>
		Flag for whether or not to show the superclasses of the focus node.'!


!CHGModel methodsFor: 'private'!

adjustSubtreeLayout: aNode
	"Adjust the layout of the subtree recursively, by doing a depth-first
	traversal and centering each node above its children.  This method should
	be invoked after `CHGModel>>layoutSubtreeSimply:at:'."

	(aNode isLeaf) ifFalse: [

		(aNode children) do: [ :node | self adjustSubtreeLayout: node ].

		self centerNodeRelativeToChildren: aNode.
	].!

build
	"Build the class hierarchy by building the subclass tree and the superclass
	path of the focus node."

	self buildChildNodes: focusNode.

	((focusNode classRef) == Object) ifTrue: [
		self rootNode: focusNode.
	]; ifFalse: [
		self buildParentNodes: focusNode.
	].!

buildChildNodes: aNode
	"Recursively build the child node trees of aNode."

	((aNode classRef) subclasses) do: [ :subclass |
		| childNode |

		childNode := ((CHGNode new) classRef: subclass).

		aNode addChild: childNode.

		self buildChildNodes: childNode.
	].!

buildParentNodes: aNode
	"Recursively build the parent node chain of aNode."

	| superclass |

	((superclass := ((aNode classRef) superclass)) notNil) ifTrue: [
		| parentNode |
		parentNode := ((CHGNode new) classRef: superclass).
		parentNode addChild: aNode.
		self rootNode: parentNode.
		self buildParentNodes: parentNode
	].!

centerNodeRelativeToChildren: aNode
	"Center the node vertically, relative to its immediate children.  NOTE:
	This method is not intended to be invoked in leaf nodes."

	| childrenBounds |

	childrenBounds := ((aNode children)  bounds).

	aNode origin: (
		(
			(aNode origin) x
		) @ (
			"((((aNode children) bounds) height) / 2)"
			((childrenBounds top) + ((childrenBounds height) / 2))
			-
			(((aNode bounds) height) / 2)
		)
	).!

focusOn: aClass
	"Focus on the specified class, by creating a new node and building and
	laying out from that node.  Any existing nodes are gobbled by garbage
	collection."

	focusNode := ((CHGNode new) classRef: aClass).

	self
		build;
		layout.!

initialize
	"Initialize the defaults for the layout spacing.  These may be overwritten
	as the layout algorithm determines optimal values."

	layoutHorizontalSpacing := 175.
	layoutVerticalSpacing := 30.!

largestNodeWidthInSubtree: aNode
	"Recursively determine the largest node width in the specified subtree.
	This is generally used to determine layout horizontal spacing."

	| largestWidth |

	largestWidth := ((aNode extent) x).

	(aNode children) do: [ :childNode |
		| childWidth |
		childWidth := (self largestNodeWidthInSubtree: childNode).
		(childWidth > largestWidth) ifTrue: [
			largestWidth := childWidth.
		].
	].

	^largestWidth.!

layout
	"Perform layout from the visible root."

	| visibleRoot |

	((visibleRoot := (self visibleRootNode)) == nil) ifTrue: [ ^self ].

	layoutHorizontalSpacing :=
		((self largestNodeWidthInSubtree: rootNode) + 20).

	self layoutSubtreeSimply: visibleRoot at: (10 @ 20).

	self adjustSubtreeLayout: visibleRoot.!

layoutSubtreeSimply: aNode at: startPoint
	"Do a simple layout on the subtree beginning with the specified node.  The
	node is positioned at startPoint, and this method is invoked recursively
	for each child.  Returns the last Y value a node was placed at."

	| childStartX childStartY lastY |
	aNode origin: startPoint.

	childStartX := ((startPoint x) + layoutHorizontalSpacing).

	childStartY := (startPoint y).

	lastY := childStartY.

	(aNode children) do: [ :node | 

		lastY := (self layoutSubtreeSimply: node
			at: (childStartX @ childStartY)).

		childStartY := (lastY + layoutVerticalSpacing).

].

^lastY.!

rootNode: aNode
	"Sets the root node of the tree."

	rootNode := aNode.!

visibleRootNode
	"Returns the visible root node.  If showing superclasses, is the actual
	root; otherwise, is the focus node."

	(self showSuperclasses) ifTrue: [ ^rootNode ]; ifFalse: [ ^focusNode ].! !

!CHGModel methodsFor: 'public'!

focusNode
	"Returns the focus node."

	^focusNode.!

nodeContainingPoint: aPoint
	"Returns the node in the model whose shape contains aPoint, or nil if
	none."

	^(self nodeContainingPoint: aPoint inSubtree: rootNode).!

nodeContainingPoint: aPoint inSubtree: aNode
	"Recursively searches for a node in the subtree which contains aPoint.
	Returns the node found, or nil if none."

	(aNode containsPoint: aPoint) ifTrue: [ ^aNode ].

	(aNode children) do: [ :childNode |
		| returnedPoint |
		returnedPoint :=
			(self nodeContainingPoint: aPoint inSubtree: childNode).
		(returnedPoint notNil) ifTrue: [
			^returnedPoint.
		].
	].

	^nil.!

rootNode
	"Returns the root node of the graph."

	^rootNode.!

showSuperclasses
	"Returns the status of the show-superclasses attribute."

	^showSuperclasses.!

showSuperclasses: aBoolean
	"Sets the show-superclasses attribute."

	showSuperclasses := aBoolean.!

updateFromSmalltalk
	"Updates the model to the current class hierarchy."

	self focusOn: (focusNode classRef).! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CHGModel class
	instanceVariableNames: ''!


!CHGModel class methodsFor: 'public'!

new
	"Creates and initializes an instance."

	^((super new) initialize).!

newFocusedOn: aClass
	"Creates a new model, focused on the specified class, not showing
	superclasses."

	^(self newFocusedOn: aClass showSuperclasses: false).!

newFocusedOn: aClass showSuperclasses: aBoolean
	"Creates a new model, focused on the specified class, showing the
	superclasses as specified."

	| newModel |

	(newModel := (self new))
		showSuperclasses: aBoolean;
		focusOn: aClass.

	^newModel.! !

SortedCollection variableSubclass: #CHGNodeCollection
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ClassHierarchyGraphBrowser'!
CHGNodeCollection comment:
'[From CHG 0.2 by Neil W. Van Dyke, neil@cse.ogi.edu, Dec 1992,
Oregon Graduate Institute of Science & Technology, CSE509]

Description:

	Collection of CHGNodes, sorted by increasing order of class name.
	Overrides the default sortBlock of SortedCollection, and provides a method
	for determining the bounds of all nodes in the collection.'!


!CHGNodeCollection methodsFor: 'private'!

initialize
	"Initialize a new CHGNodeCollection."

	"Set the sortBlock to sort in increasing order by class name."
	self sortBlock: [ :a :b | ((a className) <= (b className)) ].! !

!CHGNodeCollection methodsFor: 'public'!

bounds
	"Returns a rectangle which encloses all nodes in the set."

	| mergedBounds |

	mergedBounds := nil.

	(self) do: [ :node |
		(mergedBounds isNil) ifTrue: [
			mergedBounds := (node bounds).
		]; ifFalse: [
			mergedBounds := (mergedBounds merge: (node bounds)).
		].
	].

	^mergedBounds.! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CHGNodeCollection class
	instanceVariableNames: ''!


!CHGNodeCollection class methodsFor: 'public'!

new
	"Creates a new node collection."

	^((super new) initialize).! !

Object subclass: #CHGNode
	instanceVariableNames: 'children className classRef extent labelText origin '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'ClassHierarchyGraphBrowser'!
CHGNode comment:
'[From CHG 0.2 by Neil W. Van Dyke, neil@cse.ogi.edu, Dec 1992,
Oregon Graduate Institute of Science & Technology, CSE509]

Description:

	Node in CHGModel, representing a class in the hierarchy.

Instance Variables:

	children    <CHGNodeCollection>
		Collection of children nodes of this node.

	className    <String>
		Name of the class as a string.

	classRef    <Class>
		Class represented.

	extent    <Point>
		Extent of shape of node display.

	labelText    <Text>
		Graphical text for the class name.

	origin    <Point>
		Origin of shape of node display.'!


!CHGNode methodsFor: 'public'!

addChild: aCHGNode
	"Add a child node to the node."

	children add: aCHGNode.!

bounds
	"Return a rectangle for this node."

	^(origin extent: extent).!

childConnectionPoint
	"Return a point to which a line connecting to a child should begin."

	| bounds |

	bounds := (self bounds).

	^((bounds topRight) + (0 @ ((bounds height) / 2))).!

children
	"Return the collection of this node's child nodes."

	^children.!

children: aCHGNodeCollection
	"Set the child nodes collection of this node."

	children := aCHGNodeCollection.!

className
	"Return the string of the class name."

	^className.!

classRef
	"Return the class."

	^classRef.!

classRef: aClass
	"Set the class the node represents."

	"Set the class reference."
	classRef := aClass.

	"Get the class name."
	className := (classRef name).

	"Build the label text."
	labelText := ((className asText) asComposedText).

	"Set the extent, based on the width of the label text."
	extent := ((((labelText preferredBounds) width) + 10) @ 20)!

containsPoint: aPoint
	"Return a Boolean for whether or not the specified Point is contained
	within the bounds of the receiver node.  (This is useful for determining if
	the node is under the cursor, for example.)"

	| bounds |

	bounds := self bounds.

	^ (aPoint >= bounds origin) & (aPoint <= bounds corner)!

displayConnectionOn: aGC to: aNode
	"Displays a connection line from the receiver to the specified node."

	aGC displayLineFrom: (self childConnectionPoint)
		to: (aNode parentConnectionPoint).!

displayOn: aGC
	"Displays the receiver as a node other than the focus node."

	self displayOn: aGC focused: false.!

displayOn: aGC focused: isFocusNode
	"Displays the receiver, highlighting it as the focus node if isFocusNode
	is true."

	| bounds |

	"Get the bounds of the node."
	bounds := (self bounds).

	"Display shape."
	aGC displayRectangularBorder: bounds.

	"Display label."
	labelText displayOn: aGC at: ((self origin) + (5 @ 0)).

	"Display a thicker border if focus node."
	(isFocusNode) ifTrue: [
		aGC displayRectangularBorder:
			(Rectangle origin: ((bounds origin) + (1 @ 1))
				extent: ((bounds extent) - (2 @ 2))).

	].

	"Display connections to children."
	(children) do: [ :childNode |
		self displayConnectionOn: aGC to: childNode.
	].!

extent
	"Return the extent of the node."

	^extent.!

initialize
	"Initialize this CHGNode."

	children := (CHGNodeCollection new).
	origin := (0 @ 0).!

isLeaf
	"Returns a Boolean for whether or not this node is a leaf node (i.e., has
	no children)."

	^((children size) = 0).!

origin
	"Return the origin (i.e., upper-left corner)."

	^origin.!

origin: aPoint
	"Set the origin."

	origin := aPoint.!

parentConnectionPoint
	"Return the point to which a connection line from the parent should
	connect."

	| bounds |

	bounds := (self bounds).

	^((bounds origin) + (0 @ ((bounds height) / 2))).! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CHGNode class
	instanceVariableNames: ''!


!CHGNode class methodsFor: 'public'!

new
	"Create a new node."

	^((super new) initialize).! !