HopscotchForBrazil.ns

Newspeak3
'Hopscotch'
class HopscotchForBrazil usingPlatform: platform = (
(* Hopscotch is Newspeak's highly composable application framework.

Vassili Bykov. Hopscotch: Toward User Interface Composition
http://bracha.org/hopscotch-wasdett.pdf

Copyright 2008 Cadence Design Systems, Inc.
Copyright 2009 Ryan Macnak and other contributors.
Copyright 2012 Cadence Design Systems, Inc.

Licensed under the Apache License, Version 2.0 (the ''License''); you may not use this file except in compliance with the License.  You may obtain a copy of the License at  http://www.apache.org/licenses/LICENSE-2.0 *)
|
	public HopscotchImages = platform squeak HopscotchImages.
	private Form = platform squeak Form.

	private Clipboard = platform squeak Clipboard.
	private SharedQueue = platform squeak SharedQueue.
	private Processor = platform squeak Processor.
	private World = platform squeak World.
	private Request = platform namespace Request.

	public (* bogus *) Color = platform graphics Color.
	private Point = platform graphics Point.
	private Cursor = platform graphics Cursor.
	private Rectangle = platform graphics Rectangle.

	private List = platform collections List.
	private Map = platform collections Map.

	private brazil = platform brazil.
	private Anchor = brazil areas Anchor.
	private CellWidthEqualizer = brazil areas CellWidthEqualizer.
	private Frame = brazil areas Frame.
	public (* bogus *) Menu = brazil menus Menu.
	public (* bogus *) MenuItem = brazil menus MenuItem.
	public (* bogus *) SeparatorItem = brazil menus SeparatorItem.
	private SubmenuItem = brazil menus SubmenuItem.
	private AdHocMessageReceiver = brazil manipulation AdHocMessageReceiver.
	private DragSource = brazil manipulation DragSource.
	private DropTarget = brazil manipulation DropTarget.
	private DragDropTracker = brazil manipulation DragDropTracker.
	private ArbitraryArityBlockWrapper = brazil manipulation ArbitraryArityBlockWrapper.
	private Font = brazil plumbing Font.
	public Gradient = brazil plumbing Gradient.
	private Viewport = brazil containers Viewport.
	private Column = brazil containers Column.
	private CompositeVisual = brazil containers CompositeVisual.
	private Flow = brazil containers Flow.
	private Row = brazil containers Row.
	private SpyingWrapper = brazil containers SpyingWrapper.
	private Wrapper = brazil containers Wrapper.
	private Desktop = brazil containers Desktop.
	private VerticalViewport = brazil containers VerticalViewport.
	private Window = brazil containers Window.
	private Icon = brazil widgets Icon.
	private Label = brazil widgets Label.
	private Button = brazil widgets Button.
	private SensitiveIcon = brazil widgets SensitiveIcon.
	private TextDisplay = brazil widgets TextDisplay.
	private TextView = brazil widgets TextView.
	private LineShape = brazil widgets LineShape.
	private PolygonShape = brazil widgets PolygonShape.
	private ActiveIcon = brazil widgets ActiveIcon.
	private Blank = brazil widgets Blank.
	private Hyperlink = brazil widgets Hyperlink.
	private RectangleShape = brazil widgets RectangleShape.
	private RoundedRectangleShape = brazil widgets RoundedRectangleShape.
	private MessageBox = brazil tools MessageBox.

	private cachedPlatform = platform.

	public core = CoreClasses new.
	public fragments = FragmentClasses new. (* after core *)
	public composers = ComposerClasses new. (* after core, fragments *)
	public canvas = CanvasClasses new. (* after core, composers *)
	public outline = OutlineClasses new. (* after core *)
|composers postInit. core postInit) (
class CanvasClasses = (|
	Composer = core Composer.
	ColorDecorator = composers ColorDecorator.
	DragSensitiveHolderComposer = composers DragSensitiveHolderComposer.
	HolderComposer = composers HolderComposer.
|) (
public class CanvasComposer = Composer (
(* Displays its elements within a free-form scrollable area. The elements are either CanvasItems or CanvasDependents.

Slots:

items <List[CanvasItem]>
dropTargetCreationBlock <[DropTarget] | nil>
dragTracker <DragDropTracker> *)
| items dropTargetCreationBlock dragTracker |) (
abandonCanvasItemFrom: source <CanvasItemMoveDragSource> = (
	self moveItem: source item to: source originalPosition
)
add: presenter <Presenter> at: location <Point> ^<CanvasItem> = (
	^addItem:: CanvasItem withContent: presenter at: location.
)
addItem: item <CanvasItem | CanvasDecoration> ^<CanvasItem> = (
	items add: item.
	item parent: self.
	hasVisual ifTrue: [item addVisualsTo: visual].
	^item
)
canvasDo: action <[:CanvasComposer]> = (
	^action value: self
)
public childrenDo: aBlock = (
	items do: aBlock
)
color: aColor = (
	addDecorator:: ColorDecorator new color: aColor
)
computeCurrentPositionForItemMove: source <CanvasItemMoveDragSource> ^<Point> = (
	(* Compute the origin the item being moved by the source should have now, based on the current position of the mouse. When we implement client drag trajectory control, this is the place to hook it up. *)
	^visual mousePoint - source grabPoint
)
createClientSuppliedDropTargetFor: session <DragDropSession> ^<DropTarget> = (
	^dropTargetCreationBlock valueWithPossibleArgument: session
)
createDropTargetFor: session <DragDropSession> ^<DropTarget> = (
	^if: session source
		isMovingMyItem: [createDropTargetForItemMove]
		otherwise: [createClientSuppliedDropTargetFor: session]
)
createDropTargetForItemMove = (
	^DropTarget new
		entryAction: [:source | pickUpCanvasItemFrom: source];
		stepAction: [:source | moveCanvasItemFrom: source];
		dropAction: [:source | dropCanvasItemFrom: source];
		exitAction: [:source | abandonCanvasItemFrom: source]
)
createViewport ^<Viewport> = (
	^createVisual
)
createVisual ^<Visual> = (
	| viewport |
	viewport:: Viewport new color: defaultColor.
	items do:
		[:each |
		each addVisualsTo: viewport].
	^viewport
)
defaultColor = (
	^Color gray: 0.7
)
dropCanvasItemFrom: source <CanvasItemMoveDragSource> = (
	(* Nothing to be done for the move - after the last step event the item is already where it should be. *)
)
dropTargetFor: session <DragDropSession> ^<DropTarget | nil> = (
	^session
		targetAt: self
		ifAbsentPut: [createDropTargetFor: session]
)
elements: itemCollection <Collection[CanvasItem]> = (
	items:: itemCollection asOrderedCollection
)
if: source <DragSource> isMovingMyItem: action <[]> otherwise: alternative <[]> = (
	source identifyPayloadTo:
		(AdHocMessageReceiver new
			receive: #draggingCanvasItem:
			using:
				[:item |
				source canvas == self ifTrue: [^action value]]).
	^alternative value
)
ifInterestedInDragAt: windowRelativePoint <Point>
forSession: session <DragDropSession>
doWithTarget: targetBlock = (
	(dropTargetCreationBlock notNil
			and: [visualContainsPoint: windowRelativePoint])
		ifTrue:
			[(dropTargetFor: session) ifNotNil: targetBlock]
)
includes: containedChild <Fragment> = (
	^includesItem: containedChild parent
)
includesItem: item <CanvasItem> = (
	^items includes: item
)
move: containedChild <Fragment> to: newLocation <Point> = (
	self move: containedChild parent to: newLocation.
)
moveCanvasItemFrom: source <CanvasItemMoveDragSource> = (
	self
		moveItem: source item
		to: (computeCurrentPositionForItemMove: source)
)
moveItem: child <CanvasItem> to: newLocation <Point> = (
	child position: newLocation.
)
pickUpCanvasItemFrom: source <CanvasItemMoveDragSource> = (
	(* Nothing special to do; the item is physically moved by the step response. *)
)
public receiveRequestFrom: dispatcher <UpwardRequestDispatcher | DownwardRequestDispatcher> ^<Boolean> = (
	(* Enable the receiver to receive messages sent using the sendUp/sendDown mechanism. *)

	(self respondsTo: dispatcher selector) ifTrue:
		[dispatcher message sendTo: self.
		^true].
	^false
)
remove: containedChild <Fragment> = (
	self removeItem: containedChild parent
)
removeItem: child <CanvasItem> = (
	items remove: child.
	child noticeRemoval.
	hasVisual ifTrue: [child removeVisualsFrom: visual].
	child noticeAbandonment
)
visualContainsPoint: windowRelativePoint <Point> ^<Boolean> = (
	^visual windowRelativeBounds containsPoint: windowRelativePoint
)
) : (
elements: itemCollection <Collection[CanvasItem]> = (
	^self new elements: itemCollection
)
)
class CanvasDependent = Composer (
(* This abstract class captures the concept of a dependent canvas item, i.e. an item whose position and existence depends on that of its 'masters'. The item will receive notifications when the position of one of the masters change, as well as one of the master items has been removed. In response to these, concrete subclasses should make arrangements to update their own layout and to remove themselves if they should not exist without the master. *)
) (
addVisualsTo: container = (
	subclassResponsibility
)
public childrenDo: aBlock = (
	(* This is a leaf. *)
)
mastersDo: action <[:CanvasItem]> = (
	(* A subclass must implement this method to invoke the argument with each of its masters as the argument. *)
	subclassResponsibility
)
noticeLayoutChangeOfMaster: item <CanvasItem> = (
	updateLayout
)
noticeRemovalOfMaster: item <CanvasItem> = (
	(* A subclass should implement this to remove itself from the canvas if it cannot exist without the master. *)
	subclassResponsibility
)
registerWithMasters = (
	mastersDo: [:each | each addDependent: self]
)
remove = (
	unregisterWithMasters.
	parent removeItem: self
)
removeVisualsFrom: container = (
	subclassResponsibility
)
replaceChild: aFragment with: anotherFragment = (
	self error: 'this is a leaf'
)
unregisterWithMasters = (
	mastersDo: [:each | each removeDependent: self]
)
updateLayout = (
	(* Sent by one of the master items when its bounds have changed, as a chance for all dependents to update their layout. *)
	subclassResponsibility
)
) : (
)
public class CanvasItem withContent: definition = HolderComposer withContent: definition (
(* This is a special kind of holder used as a wrapper around presenters placed inside a canvas. A part of its content can be marked as grabArea:, which will automatically equip it for drag-and-drop to pick up and drag the item. Canvas items can also manage dependents, which are subclasses of CanvasDependent providing decorations whose position and existence depends on the available items. For example, lines connecting the items can be implemented as dependents. A canvas item notifies all dependents when it is moved or deleted. *)
| internalPosition xAnchorFraction ::=0. yAnchorFraction ::=0. dependents ::= List new. |) (
addDependent: dependent = (
	dependents add: dependent
)
addVisualsTo: viewport <Viewport> = (
	viewport add: visual in: Anchor.
	visual area
		origin: position;
		xAnchorFraction: xAnchorFraction;
		yAnchorFraction: yAnchorFraction
)
canvasItemDo: action <[:CanvasItem]> = (
	(* This message is sent by a containing grab area through the sendUp mechanism in order to find the item the area is supposed to move. *)
	^action value: self
)
createVisual = (
	| theVisual |
	theVisual:: super createVisual.
	theVisual boundsChangedChannel =>
		[:ignored <Rectangle> | notifyDependentsOfLayoutChange].
	^theVisual
)
public noticeRemoval = (
	(* Sent by the canvas just after the item has been removed from it. *)
	dependents copy do: [:each | each noticeRemovalOfMaster: self].
)
notifyDependentsOfLayoutChange = (
	dependents do: [:each | each noticeLayoutChangeOfMaster: self]
)
position ^<Point> = (
	^internalPosition
)
position: newPosition <Point> = (
	internalPosition:: newPosition.
	hasVisual ifTrue: [visual area anchorPosition: internalPosition]
)
public receiveRequestFrom: dispatcher <UpwardRequestDispatcher | DownwardRequestDispatcher>
^<Boolean> = (
	(* Enable the receiver to receive messages sent using the sendUp/sendDown mechanism. *)

	(self respondsTo: dispatcher selector) ifTrue:
		[dispatcher message sendTo: self.
		^true].
	^false
)
remove = (
	parent removeItem: self
)
removeDependent: dependent = (
	dependents remove: dependent
)
removeVisualsFrom: viewport <Viewport> = (
	viewport remove: visual
)
) : (
withContent: presenter <Presenter> at: location <Point> = (
	^(self withContent: presenter)
		position: location
)
)
public class CanvasItemGrabArea withContent: definition = DragSensitiveHolderComposer withContent: definition (
(* This class implements the move behavior of canvas items. The elements of the items wrapped with a grab area become a ''handle'' that cooperates with the canvas to pick up and move the item when dragged. *)
) (
containingCanvas ^<CanvasComposer | nil> = (
	sendUp optional canvasDo: [:canvas | ^canvas].
	^nil
)
containingCanvasItem ^<CanvasItem | nil> = (
	sendUp optional canvasItemDo: [:item | ^item].
	^nil
)
createDragSource = (
	| canvas item |
	canvas:: containingCanvas.
	item:: containingCanvasItem.
	^(canvas notNil and: [item notNil])
		ifTrue:
			[CanvasItemMoveDragSource new
				canvas: canvas;
				item: item;
				grabPoint: (grabPointRelativeTo: item);
				originalPosition: item position]
		ifFalse:
			[DragSource new]
)
grabPointRelativeTo: item <CanvasItem> = (
	^tracker dragOrigin
		translateFrom: tracker visual
		to: item visual
)
) : (
)
class CanvasItemMoveDragSource = DragSource (
(* Represents the dragging of a canvas item initiated by grabbing the item's drag area. The item and the canvas that contains it are stored in the instance slots.

Slots:

canvas <Canvas> The canvas the dragged item belongs to.
item <CanvasItem> The item itself.
grabPoint <Point> The location of the mouse relative to the item at the time the drag started.
originalPosition <Point> The position of the item within the canvas at the time the drag started. *)
| canvas item grabPoint originalPosition |) (
public identifyPayloadTo: identificationReceiver = (
	^identificationReceiver
		try: [identificationReceiver draggingCanvasItem: item]
		or: [super identifyPayloadTo: identificationReceiver]
)
) : (
)
class CanvasLineBetweenItems from: item1 <CanvasItem> to: item2 <CanvasItem> = CanvasDependent (
(* Creates and manages a line between two canvas items, so that the line goes from the center of one item to the center of the other. *)
|
	lineColorS ::= Color black.
	showArrowS ::= false.
	arrowColorS ::= Color black.
	arrowBorderColorS ::= nil. (* that is, use lineColor *)
	arrowSizeS ::= 10.
	arrowSweepS ::= 40 (* degrees *).
	fromItem ::= item1.
	toItem ::= item2.
	line arrowhead
|registerWithMasters) (
addVisualsTo: viewport <Viewport> = (
	viewport addAtBack: visual.
	showArrow ifTrue:
		[arrowhead:: createArrowheadShape.
		viewport add: arrowhead inFrontOf: line].
	updateLayout.
)
arrowBorderColor = (
	^arrowBorderColorS ifNil: [lineColor]
)
arrowBorderColor: newColor <Color> = (
	arrowBorderColorS:: newColor.
	arrowhead ifNotNil: [:it | it borderColor: newColor]
)
arrowColor = (
	^arrowColorS
)
arrowColor: newColor <Color> = (
	arrowColorS:: newColor.
	arrowhead ifNotNil: [:it | it color: newColor]
)
arrowSize = (
	^arrowSizeS
)
arrowSize: newSize <Number> = (
	arrowSizeS:: newSize.
	arrowhead ifNotNil: [updateLayout]
)
arrowSweep = (
	^arrowSweepS
)
arrowSweep: degrees <Number> = (
	arrowSweepS:: degrees.
	arrowhead ifNotNil: [updateLayout]
)
public childrenDo: action <[:Fragment]> = (
	(* This is a leaf. *)
)
computeArrowVerticesPointingAt: toPoint <Point> from: fromPoint <Point> ^<Collection[Point]> = (
	| halfSweep size direction point1 point2 |
	halfSweep:: arrowSweepS // 2.
	size:: arrowSize.
	direction:: (toPoint - fromPoint) theta radiansToDegrees.
	^{
		toPoint.
		toPoint - (Point r: size degrees: direction + halfSweep) rounded.
		toPoint - (Point r: size degrees: direction - halfSweep) rounded.
	}
)
createArrowheadShape = (
	^PolygonShape new
		borderColor: arrowBorderColor;
		borderWidth: 1;
		color: arrowColor;
		visible: showArrow
)
createVisual = (
	line:: LineShape new.
	^line
)
edgePointOf: rect <Rectangle> goingTo: point <Point> ^<Point> = (
	(* Compute a point at the intersection of the rectangle border and the line going from the rectangle center to the given point. *)
	| center |
	(rect containsPoint: point) ifTrue: [^point].
	center:: rect center.
	center y = point y ifFalse:
		[ | k x |
		k:: (point x - center x) / (point y - center y).
		point y < center y
			ifTrue:
				[x:: (rect top - center y) * k + center x.
				(x between: rect left and: rect right) ifTrue:
					[^x rounded @ rect top]]
			ifFalse:
				[x:: (rect bottom - center y) * k + center x.
				(x between: rect left and: rect right) ifTrue:
					[^x rounded @ rect bottom]]].
	center x = point x ifFalse:
		[ | k y |
		k:: (point y - center y) / (point x - center x).
		point x < center x
			ifTrue:
				[y:: (rect left - center x) * k + center y.
				(y between: rect top  and: rect bottom) ifTrue:
					[^rect left @ y rounded]]
			ifFalse:
				[y:: (rect right - center x) * k + center y.
				(y between: rect top and: rect bottom) ifTrue:
					[^rect right @ y rounded]]].
	(* If the point is outside the rectangle, one of the four exit conditions above should have held. *)
	error: 'eh?'
)
lineColor = (
	^lineColorS
)
lineColor: newColor <Color> = (
	lineColorS:: newColor.
	line ifNotNil: [:it | it color: newColor]
)
mastersDo: action <[:CanvasItem]> = (
	action
		value: fromItem;
		value: toItem
)
noticeRemovalOfMaster: item <CanvasItem> = (
	remove
)
removeVisualsFrom: viewport <Viewport> = (
	line ifNotNil: [:it | viewport remove: it].
	arrowhead ifNotNil: [:it | viewport remove: it].
)
replaceChild: one <Fragment> with: two <Fragment> = (
	self error: 'Canvas line decorations are leaves.'
)
showArrow = (
	^showArrowS
)
showArrow: show <Boolean> = (
	showArrowS:: show.
	arrowhead notNil
		ifTrue: [arrowhead visible: show]
		ifFalse:
			[line notNil ifTrue:
				[arrowhead:: createArrowheadShape.
				line parent add: arrowhead inFrontOf: line]]
)
updateLayout = (
	| fromBounds toBounds fromPoint toPoint |
	fromBounds:: fromItem visual bounds.
	toBounds:: toItem visual bounds.
	(fromBounds intersects: toBounds) ifTrue:
		[line visible: false.
		arrowhead ifNotNil: [:it | it visible: false].
		^self].
	fromPoint:: edgePointOf: fromBounds goingTo: toBounds center.
	toPoint:: edgePointOf: toBounds goingTo: fromBounds center.
	line area startPoint: fromPoint endPoint: toPoint.
	arrowhead ifNotNil:
		[:it |
		it area vertices: (computeArrowVerticesPointingAt: toPoint from: fromPoint).
		it visible: showArrow].
	line visible: true.
)
) : (
)
) : (
)
class ComposerClasses = (|
	Presenter = core Presenter.
	Subject = core Subject.
	Decorator = core Decorator.
	Composer = core Composer.

	BlankFragment = fragments BlankFragment.
	HopscotchSubjectDragSource = fragments HopscotchSubjectDragSource.
	HopscotchWastelandDropTarget = fragments HopscotchWastelandDropTarget.

	OutlineItemPresenter (* = Outline OutlineItemPresenter *)
|) (
public class AdHocRoundedCornersHolderComposer withContent: definition = HolderComposer withContent: definition (
(* Until we clean up the whole decoration story so that there are a number of visual appearance gadgets that can be composed even more freely, here is a simple holder that shows itself as a rounded corners rectangle. *)
| color |) (
createVisual = (
	| composite contentVisual roundedCornersRectangle |
	composite:: CompositeVisual new.
	contentVisual:: content visual.
	roundedCornersRectangle:: RoundedRectangleShape new color: color.
	composite
		add: roundedCornersRectangle in: Frame;
		add: contentVisual in: Frame.
	roundedCornersRectangle area fullyCoverParent.
	contentVisual area fullyCoverParent.
	^composite.
)
) : (
)
class AggregatePresenter onSubject: s = Presenter onSubject: s () (
definition = (
	^list: [subject model collect: [:each | each presenter]]
)
) : (
)
class AggregateSubject onModel: m = Subject onModel: m (
(* The model is a collection of other subjects. The presenter will display default presenters of those subjects. *)
) (
public createPresenter = (
	^AggregatePresenter subject: self
)
public title = (
	| titles |
	titles:: (String new: 30) writeStream.
	model
		do: [:each | titles nextPutAll: each title]
		separatedBy: [titles nextPutAll: ', '].
	^titles contents
)
) : (
)
public class CellLayoutDecorator = Decorator (
(* A decorator that can be attached to a fragment contained by a row to control its layout parameters. Can be used for columns too, but in typical Hopscotch UIs there is no need to control column cell layout. *)
|
	public size
	public minimumSize
	public expansibility
	public compressibility
|) (
public decorate: aVisual = (
	size ifNotNil: [:it | aVisual area principalSize: it].
	minimumSize ifNotNil: [:it | aVisual area minimumSize: it].
	(* general elasticity is obsolete and will go away. Until then, apply
	the general before the specific so the specific can override. *)
	expansibility ifNotNil: [:it | aVisual area expansibility: it].
	compressibility ifNotNil: [:it | aVisual area compressibility: it].
	^aVisual
)
public elasticity: newValue = (
	(* Support the old API. *)
	expansibility: newValue.
	compressibility: newValue.
)
) : (
)
public class CenteringFrameComposer content: aFragment = FrameComposer content: aFragment (
) (
contentAreaClass = (
	^Anchor
)
setupContentArea: anArea = (
	anArea beCentered
)
) : (
)
public class ColorDecorator = Decorator (|
	public color
|) (
public decorate: aVisual = (
	aVisual color: color.
	^aVisual
)
) : (
)
public class ColumnComposer definitions: fragments = SequenceComposer definitions: fragments (
(* Arranges the fragments it holds as a column. *)
) (
visualClass = (
	^Column
)
) : (
)
public class DeferredContentComposer = Composer (|
	public contentSource
	public initialContent ::= BlankFragment new.
	public contentFragment
|) (
public childrenDo: aBlock = (
	contentFragment ifNotNil: aBlock
)
public collectDeferredContentInto: aCollection = (
	aCollection add: self.
	super collectDeferredContentInto: aCollection
)
public createDeferredContent = (
	(* Evaluate the content source block to produce the actual content fragment and remember it to be installed later. This method is executed by a background process parallel to the main UI. *)
	contentFragment:: contentSource value.
	contentFragment parent: self.
	contentFragment visual. (* Force computation of the subtree off of the UI thread. *)
	^contentFragment
)
createVisual = (
	^Wrapper with: initialContent visual
)
public installDeferredContent = (
	(* Replace the placeholder blank with the real content fragment, typically computed before. *)

	visualX content:
		(contentFragment ifNil: [createDeferredContent])
			visual
)
) : (
)
public class DisclosureComposer = TwoStateComposerWithToggleIcon (
(* Displays a ''heading'' fragment with a triangular ''expand'' button which shows or hides an additional ''details'' fragment. *)
|
	public header
	public bodyDefinition
	bodyPresenter
	contentHolder
|) (
bodyPartOrNil = (
	^bodyPresenter
)
public childrenDo: aBlock = (
	aBlock value: header.
	bodyPresenter notNil ifTrue:
		[aBlock value: bodyPresenter]
)
createVisual = (
	(* IMPORTANT: a change in the structure of visuals created here also requires changing the #updateVisual:of: method. *)

	| column |
	column:: Column new.
	column
		addNew: Row setup:
			[:row |
			row
				add: (Wrapper with: toggleIcon) beCentered;
				addBlankSize: 3;
				add: header visual.
			header visual area elasticity: 1];
		addNew: Row setup:
			[:row |
			row addBlankSize: 13.
			contentHolder:: Wrapper new.
			row add: contentHolder.
			contentHolder area elasticity: 1].
	isExpanded
		ifTrue: [privateExpand].
	^column
)
public header: headerPresenter <HopscotchPresenter> bodyDefinition: block <Block> = (
	header:: headerPresenter.
	header parent: self.
	bodyDefinition:: block
)
headerPart = (
	^header
)
installContentVisual: aVisual = (
	contentHolder content: aVisual.
	aVisual areaClass: Frame.
	aVisual area fullyCoverParent
)
privateCollapse = (
	contentHolder content: Blank new.
	(* bodyPresenter:: nil *)
)
privateExpand = (
	bodyPresenter ifNil:
		[bodyPresenter:: bodyDefinition value.
		bodyPresenter parent: self].
	installContentVisual: bodyPresenter visual.
)
) : (
)
public class DragSensitiveHolderComposer withContent: definition = HolderComposer withContent: definition (
(* Turns the content into an area that can be dragged from. The content is passivized in the process--any mouse interaction with it is impossible, so presumably it is made of components that are passive in the first place, such as labels, images and their compositions. This class is abstract, to be specialized to interpret the dragging in a particular way. *)
| grabOverlay tracker |) (
createDragSource = (
	subclassResponsibility
)
createGrabOverlay = (
	grabOverlay:: RectangleShape new
		borderWidth: 0;
		color: Color transparent.
	^grabOverlay
)
createTracker = (
	tracker:: DragDropTracker new
		attachTo: grabOverlay;
		sourceCreationBlock: [createDragSource].
)
createVisual = (
	| composite contentVisual |
	createGrabOverlay.
	createTracker.
	composite:: CompositeVisual new.
	contentVisual:: content visual.
	composite
		add: contentVisual in: Frame;
		add: grabOverlay in: Frame.
	grabOverlay area fullyCoverParent.
	contentVisual area fullyCoverParent.
	^composite.
)
) : (
)
public class DragSubjectHolderComposer withContent: definition = DragSensitiveHolderComposer withContent: definition (
(* A specialization of the abstract DragSensitiveHolderComposer allowing to drag out a Hopscotch Subject. *)
|
	public subject
	public image
|) (
public createDragSource = (
	^HopscotchSubjectDragSource new
		visual: visual;
		subject: subject;
		draggedImage: image;
		wastelandTarget: HopscotchWastelandDropTarget new
)
) : (
)
public class DropTargetHolderComposer withContent: definition = HolderComposer withContent: definition (
| expectedSelector dropAction cachedTarget |) (
createTarget = (
	^DropTarget new
		dropAction: [:source | dropFrom: source]
)
public dropFrom: dragSource <DropSource> = (
	dragSource identifyPayloadTo:
		(AdHocMessageReceiver new
			receive: expectedSelector
			using: dropAction)
)
ifInterestedInDragAt: windowRelativePoint <Point>
forSession: session <DragDropSession>
doWithTarget: targetBlock = (
	(visualContainsPoint: windowRelativePoint) ifTrue:
		[targetBlock value: target]
)
public receiveRequestFrom: dispatcher ^<Boolean> = (
	(* Receive and process a notice coming from one of the children (usually as the result of using #sendUp or #sendDown). *)

	(self respondsTo: dispatcher selector) ifTrue:
		[dispatcher message sendTo: self.
		^true].
	^false
)
target = (
	^cachedTarget ifNil:
		[cachedTarget:: createTarget.
		cachedTarget]
)
visualContainsPoint: windowRelativePoint <Point> ^<Boolean> = (
	^visual windowRelativeBounds containsPoint: windowRelativePoint
)
) : (
)
class EqualizerDecorator = Decorator (
| sequenceDefinition elementIndex |) (
public decorate: aVisual = (
	CellWidthEqualizer
		equalize: aVisual children
		at: elementIndex.
	^aVisual
)
) : (
)
public class FloatingHeaderComposer header: header <Fragment> body: body <Fragment> = Composer (
(* Holds onto two fragments: a header and a body. In a situation when the entire composer area is visible in the top-level presenter's viewport, acts as a column positioning the header fragment above the body fragment. However, if the area is partially scrolled out of view so the top is hidden, the header moves the header component down to keep it visible.

The composer will try to keep some of the body visible as the view is scrolled up, so at some point it will stop repositioning the header and will let it scroll up out of the view. When this will happen is determined by the minimumBodyToHeaderRatio parameter. If the ratio is 2, the default, the header will start scrolling out of view when the visible body height drops to twice the header height.

The top-level presenter that supplies the viewport for the entire page must register an interest in the #changed duct of its viewport's scrollPosition holder and send down the #respondToScrollingInViewport: message when the scroll position changes. That is taken care of in the standard Presenter>>createViewportWithVisual method.
*)
|
	header = header.
	body = body.
	minimumBodyToHeaderRatio ::= 2.

	headerVisual
	bodyVisual
|header parent: self.
	body parent: self) (
public childrenDo: aBlock = (
	header childrenDo: aBlock.
	body childrenDo: aBlock.
)
createVisual = (
	| panel |
	panel:: CompositeVisual new.
	panel
		add: (bodyVisual:: body visual) in: Frame;
		add: (headerVisual:: header visual) in: Frame.
	header visual notifications =>
		[:change |
		change = #naturalExtentChanged ifTrue:
			[refreshHeaderLayout]].
	repositionHeaderAt: 0.
	^panel
)
headerHeight = (
	^headerVisual naturalExtent y
)
public receiveRequestFrom: dispatcher <RequestDispatcher> ^<Boolean> = (
	(* Receive a request sent from somewhere using sendDown or sendUp. We are interested specifically in the scrolling notifications sent by the top-level presenter that manages the main viewport. *)
	^dispatcher selector = #respondToScrollingInViewport:
		and: [dispatcher message sendTo: self. true]
)
public refresh = (
	header refresh.
	body refresh.
)
refreshHeaderLayout = (
	repositionHeaderAt: header visual area topOffset
)
repositionHeaderAt: topPosition <Integer> = (
	| height |
	height:: headerHeight.
	headerVisual area
		leftFraction: 0 offset: 0
		topFraction: 0 offset: topPosition
		rightFraction: 1 offset: 0
		bottomFraction: 0 offset: topPosition + height.
	(* We update the body position too because headerHeight is not constant over time. *)
	bodyVisual area
		leftFraction: 0 offset: 0
		topFraction: 0 offset: height
		rightFraction: 1 offset: 0
		bottomFraction: 1 offset: 0.
)
public respondToScrollingInViewport: viewport <VerticalViewport> = (
	(* Received when the top-level viewport has been scrolled to a new position. If possible, move the header to keep it in sight. *)
	| visibleBounds newTop |
	visibleBounds:: visual localBounds translateFrom: visual to: viewport.
	visibleBounds bottom < 0 ifTrue:
		(* Scrolled up out of sight, don't bother adjusting. *)
		[^self].
	visibleBounds top > viewport localBounds bottom ifTrue:
		(* Scrolled down out of sight, don't bother adjusting. *)
		[^self].
	newTop:: (visibleBounds top negated
		min: visual localBounds bottom - ((minimumBodyToHeaderRatio + 1) * headerHeight))
			max: 0.
	repositionHeaderAt: newTop.
)
) : (
)
public class FloatingPanelComposer panel: panel <Fragment> = Composer (
(* Makes the content panel float within a potentially larger container space, keeping the panel positioned within the visible area of the main viewport as the viewport is scrolled. *)
|
	panel = panel.
|panel parent: self) (
public childrenDo: aBlock = (
	panel childrenDo: aBlock
)
createVisual = (
	| column |
	column:: Column new.
	column
		addBlankSize: 0;
		add: panel visual.
	^column
)
public receiveRequestFrom: dispatcher <RequestDispatcher> ^<Boolean> = (
	(* Receive a request sent from somewhere using sendDown or sendUp. We are interested specifically in the scrolling notifications sent by the top-level presenter that manages the main viewport. *)
	^dispatcher selector = #respondToScrollingInViewport:
		and: [dispatcher message sendTo: self. true]
)
repositionPanelAt: newTop <Integer> = (
	visual children first area height: newTop
)
public respondToScrollingInViewport: viewport <VerticalViewport> = (
	(* Received when the top-level viewport has been scrolled to a new position. If possible, move the header to keep it in sight. *)
	| visibleBounds newTop |
	visibleBounds:: visual localBounds translateFrom: visual to: viewport.
	visibleBounds bottom < 0 ifTrue:
		(* Scrolled up out of sight, don't bother adjusting. *)
		[^self].
	visibleBounds top > viewport localBounds bottom ifTrue:
		(* Scrolled down out of sight, don't bother adjusting. *)
		[^self].
	newTop:: (visibleBounds top negated
		min: visual localBounds bottom - panel visual localBounds height)
			max: 0.
	repositionPanelAt: newTop.
)
) : (
)
public class FlowComposer definitions: fragments = SequenceComposer definitions: fragments () (
createVisual = (
	| visual |

	flag: #BOGUS. (* the right implementation is at the end. The current is a temporary one to hold us over until Flow can wholesale-set childedn. *)

	visual:: visualClass new.
	visual horizontalGap: 8.
	children keysAndValuesDo:
		[:index :each | | elasticity |
		visual add: each visual].
	^visual


(*	^super createVisual
		horizontalGap: 8 *)
)
visualClass = (
	^Flow
)
) : (
)
class FrameComposer content: aFragment = Composer (
| contentX ::= aFragment. |) (
public childrenDo: aBlock = (
	content ifNotNil: aBlock
)
public content = (
	^contentX
)
public content: aFragment = (
	contentX:: aFragment.
	aFragment parent: self
)
contentAreaClass = (
	subclassResponsibility
)
createVisual ^<Visual> = (
	| holder |
	holder:: Wrapper with: content visual.
	holder content areaClass: contentAreaClass.
	setupContentArea: holder content area.
	^holder
)
replaceChild: aFragment with: anotherFragment = (
	aFragment == content ifFalse: [error: 'not the child'].
	hasVisual ifTrue: [content noticeConcealment].
	content parent: nil.
	content: anotherFragment.
	content parent: self.
	hasVisual ifTrue:
		[content noticeImminentExposure.
		visualX content: content visual.
		content noticeExposure]
)
setupContentArea: anArea = (
	subclassResponsibility
)
) : (
)
public class HolderComposer withContent: definition = Composer (
(* Holds onto a fragment that can be replaced at any time by sending the #content: message. The fragment can be set either literally or as a block evaluated to produce the fragment. In the latter case the block is re-evaluated each time the holder is refreshed, replacing the old content with the new.

Slots:
	contentSource <Fragment | Block> The fragment to display or the block to be evaluated to produce the fragment.
	actualContent <Fragment> The actual fragment held onto--the same as contentX if the content is a fragment, or the result of last evaluation of contentX if it's a block. *)
| contentSource ::= definition. actualContent |) (
public childrenDo: aBlock = (
	actualContent ifNotNil: aBlock
)
public content ^<Fragment> = (
	(* Answer the current content fragment, evaluating the source to fetch it if needed. *)

	actualContent ifNil:
		[actualContent:: contentSource value.
		actualContent parent: self].
	^actualContent
)
public content: newSource <Fragment | Block> = (
	(* Accept the new content source. If the actual content has already been retrieved from the old source, retrieve new content from the new source right away. No-op if newSource is identical to the current contentSource. *)

	newSource == contentSource ifTrue: [^self].
	actualContent notNil ifTrue:
		[hasVisual ifTrue: [actualContent noticeConcealment].
		actualContent parent: nil].
	contentSource:: newSource.
	actualContent notNil ifTrue:
		[actualContent:: nil. (* force content fetch in next step *)
		content (* recreates and sets actualContent *)
			noticeImminentExposure.
		hasVisual ifTrue:
			[visualX content: actualContent visual.
			actualContent noticeExposure]]
)
createVisual = (
	^Wrapper with: content visual
)
public refresh = (
	| oldContent |
	(contentSource isClosure and: [hasVisual])
		ifTrue:
			[oldContent:: actualContent.
			actualContent
				noticeConcealment;
				parent: nil.
			actualContent:: nil.
			content (* creates and sets actualContent *)
				noticeImminentExposure.
			actualContent parent: self.
			visual content: actualContent visual.
			actualContent noticeExposure.
			actualContent = oldContent ifTrue: [actualContent refresh]]
		ifFalse:
			[actualContent refresh]
)
replaceChild: aFragment with: anotherFragment = (
	(actualContent == aFragment and: [aFragment ~~ anotherFragment])
		ifTrue:
			[hasVisual ifTrue:
				[actualContent noticeConcealment].
			actualContent parent: nil.
			contentSource:: anotherFragment.
			actualContent:: anotherFragment.
			actualContent parent: self.
			hasVisual ifTrue:
				[actualContent noticeImminentExposure.
				visualX content: actualContent visual.
				actualContent noticeExposure]]
		ifFalse:
			[error: 'not a child']
)
) : (
)
public class MoreOrLessComposer = TwoStateComposer (| lessDefinition moreDefinition lessPresenter morePresenter
	public moreCaption ::= 'more...'.
	public lessCaption ::= 'less...'.
	leftAlignToggleLink ::= false.
 toggleLink |) (
public childrenDo: aBlock = (
	lessPresenter ifNotNil: aBlock.
	morePresenter ifNotNil: aBlock
)
createControlBar = (
	| wrapper |
	toggleLink:: Hyperlink new font: Font tiny.
	toggleLink
		label: (isExpanded ifTrue: [lessCaption] ifFalse: [moreCaption]).
	toggleLink
		action: [toggle].
	wrapper:: Wrapper with: toggleLink.
	leftAlignToggleLink
		ifTrue: [toggleLink area beLeftCenter]
		ifFalse: [toggleLink area beRightCenter].
	^wrapper
)
createVisual = (
	| column |
	column:: Column new.
	column add:
		(isExpanded
			ifTrue: [ensureMorePresenter]
			ifFalse: [ensureLessPresenter]) visual.
	column add: createControlBar.
	^column
)
ensureLessPresenter = (
	lessPresenter ifNil:
		[lessPresenter:: lessDefinition value.
		lessPresenter parent: self].
	^lessPresenter
)
ensureMorePresenter = (
	morePresenter ifNil:
		[morePresenter:: moreDefinition value.
		morePresenter parent: self].
	^morePresenter
)
public lessDefinition: block1 moreDefinition: block2 = (
	lessDefinition:: block1.
	moreDefinition:: block2
)
privateCollapse = (
	| presenter |
	morePresenter noticeConcealment; noticeRemoval.
	morePresenter:: nil.
	presenter:: ensureLessPresenter.
	presenter noticeImminentExposure.
	visual at: 1 put: presenter visual.
	presenter noticeExposure.
)
privateExpand = (
	| presenter |
	lessPresenter noticeConcealment; noticeRemoval.
	lessPresenter:: nil.
	presenter:: ensureMorePresenter.
	presenter noticeImminentExposure.
	visual at: 1 put: presenter visual.
	presenter noticeExposure.
)
updateToggleWidget = (
	toggleLink label:
		(isExpanded
			ifTrue: [lessCaption]
			ifFalse: [moreCaption])
)
) : (
)
public class PaddedFrameComposer = FrameComposer (|
	public paddingLeft ::= 0.
	public paddingTop ::= 0.
	public paddingRight ::= 0.
	public paddingBottom ::= 0.
|) (
contentAreaClass = (
	^Frame
)
setupContentArea: anArea = (
	anArea
		leftFraction: 0 offset: paddingLeft
		topFraction: 0 offset: paddingTop
		rightFraction: 1 offset: paddingRight negated
		bottomFraction: 1 offset: paddingBottom negated.
)
) : (
)
public class RowComposer definitions: fragments = SequenceComposer definitions: fragments () (
visualClass = (
	^Row
)
) : (
)
class SequenceComposer definitions: fragments = Composer (
(* An abstract superclass of composers that hold onto a list of children and somehow arrange them visually--for example, as a row or as a column. *)
| childrenX ::= List new. definitionsX |privateSetChildren: fragments) (
public add: fragment = (
	childrenX add: fragment.
	fragment parent: self.
	hasVisual ifTrue:
		[visual add: fragment visual]
)
public add: fragment <Fragment> beforeIndex: index <Integer> = (
	childrenX add: fragment beforeIndex: index.
	fragment parent: self.
	hasVisual ifTrue:
		[visual add: fragment visual beforeIndex: index]
)
public addFirst: fragment = (
	childrenX addFirst: fragment.
	fragment parent: self.
	hasVisual ifTrue:
		[visual addFirst: fragment visual]
)
public children = (
	^childrenX
)
public children: fragmentsWithNils <List[Fragment | nil]> = (
	(* A wholesale update of the content. The content needs to be updated carefully, though. If there are children already, we don't want to remove those that are in the collection to avoid unmapping and mapping their visuals. The sequence may contain nils, which are filtered out. *)

	| fragments removed added |
	fragments:: fragmentsWithNils reject: [:each | each == nil].
	removed:: childrenX reject: [:each | fragments includes: each].
	added:: fragments reject: [:each | childrenX includes: each].
	childrenX:: fragments asMutableArrayList.
	added do: [:each | each parent: self].
	hasVisual ifTrue:
		[visual blockIncrementalLayoutUpdatesWhile:
			[removed do: [:each | visual remove: each visual].
			added do: [:each | visual add: each visual].
			visual reorder: (fragments collect: [:each | each visual])]]
)
public childrenDo: aBlock = (
	childrenX do: aBlock
)
public color: aColor = (
	addDecorator::
		ColorDecorator new color: aColor
)
createVisual = (
	| visual |
	visual:: visualClass new.
	visual children: (children collect: [:each | each visual]).
(*	children keysAndValuesDo:
		[:index :each | | elasticity |
		visual add: each visual]. *)
	^visual
)
privateSetChildren: fragmentsWithNils <List[Fragment | nil]> = (
	children:: (fragmentsWithNils reject: [:each | each == nil])
		asMutableArrayList
)
public remove: fragment = (
	childrenX remove: fragment.
	hasVisual ifTrue:
		[visual remove: fragment visual]
)
public removeAt: index <Integer> = (
	childrenX removeAt: index.
	hasVisual ifTrue:
		[visual removeAt: index]
)
public reorder: fragments = (
	(* Change the order of elements to match that of the argument. The argument must include all the elements currently in the receiver. *)

	(childrenX difference: fragments) isEmpty ifFalse:
		[error: 'bad arguments'].
	childrenX: fragments asOrderedCollection.
	hasVisual ifTrue:
		[visual reorder: (fragments collect: [:each | each visual])]
)
public replace: fragment with: newFragment = (
	| index |
	index:: childrenX indexOf: fragment.
	index = 0 ifTrue: [error: 'fragment is not a child'].
	childrenX at: index put: newFragment.
	newFragment parent: self.
	hasVisual ifTrue:
		[visual at: index put: newFragment visual]
)
visualClass = (
	subclassResponsibility
)
) : (
)
public class SplitterComposer left: left <Fragment> right: right <Fragment> = Composer (
(* WORK IN PROGRESS. A composer that puts two fragments side by side with a draggable sash in between.

A known issue with this implementation is that when the fragments are resized to an extreme so that one of them becomes very narrow and then the container is made smaller, the smallest fragment may end up being invisible. Setting the fragments' minimum size doesn't help (and should not be attempted) because that affects the natural extent measurement. *)
|
	protected left = left.
	protected right = right.

	protected ratioValue ::= 1.
	protected widthDelta ::= 0.
	protected sash <RectangleShape>

	protected mouseDownLocation
	protected widthDeltaOnMouseDown
	protected leftWidthOnMouseDown
	protected rightWidthOnMouseDown
|) (
public childrenDo: aBlock = (
	aBlock value: left.
	aBlock value: right.
)
createSash = (
	| rectangle |
	rectangle:: RectangleShape new.
	rectangle
		color: Color transparent;
		mouseDownLeftResponse: [noticeMouseDown];
		mouseMoveResponse: [noticeMouseMove];
		mouseUpLeftResponse: [noticeMouseUp].
	^rectangle.
)
createVisual ^<Visual> = (
	| row |
	row:: Row new.
	row
		add: left visual;
		add: (sash:: createSash);
		add: right visual.
	row children first area
		width: 0;
		elasticity: ratioValue.
	sash area width: 5.
	row children last area
		width: 0;
		elasticity: 1.
	^row
)
noticeMouseDown = (
	mouseDownLocation:: visual mousePoint.
	widthDeltaOnMouseDown:: widthDelta.
	leftWidthOnMouseDown:: left visual extent x.
	rightWidthOnMouseDown:: right visual extent x.
)
noticeMouseMove = (
	| move limitedMove |
	move:: (visual mousePoint - mouseDownLocation) x.
	limitedMove:: (move max: leftWidthOnMouseDown negated + 50) min: rightWidthOnMouseDown - 50.
	widthDelta:: widthDeltaOnMouseDown + limitedMove.
	updateLayout
)
noticeMouseUp = (
	noticeMouseMove
)
ratio: newRatioValue <Number> = (
	(* The ratio value should be a positive number expressing the initial width of the left half relative to the right half. For example, the value of 2 makes the left half twice as wide as the left. *)
	ratioValue: newRatioValue.
	hasVisual ifTrue: [updateLayout]
)
updateLayout = (
	(* Bring the layout in sync with the current value of ratioValue and widthDelta. *)
	| leftArea = visual children first area. |
	leftArea elasticity ~= ratioValue ifTrue:
		[leftArea elasticity: ratioValue].
	leftArea width: widthDelta.
	visual children last area width: widthDelta negated.
)
) : (
)
public class SpyingHolderComposer withContent: definition = HolderComposer withContent: definition (
(* This is a layout debugging tool that allows inserting a SpyingWrapper in the rendered tree of visuals in order to track layout negotiation requests. *)
) (
createVisual = (
	^SpyingWrapper with: content visual
)
) : (
)
public class ToggleComposer = TwoStateComposerWithToggleIcon (
(* Appears as a disclosure triangle that toggles between two fragments, one for the expanded and one for the collapsed state. *)
| 	expandedDefinition
	collapsedDefinition
	public expandedPresenter
	public collapsedPresenter
	contentHolder
|) (
public childrenDo: aBlock = (
	collapsedPresenter notNil ifTrue:
		[aBlock value: collapsedPresenter].
	expandedPresenter notNil ifTrue:
		[aBlock value: expandedPresenter].
)
public collapsedDefinition: block2 expandedDefinition: block1 = (
	expandedDefinition:: block1.
	collapsedDefinition:: block2.
)
collapsedPart = (
	^collapsedPresenter
)
createVisual = (
	| wrappedIcon row |
	wrappedIcon:: Wrapper with: toggleIcon.
	wrappedIcon content area yOffset: 2.
	row:: Row new.
	row
		add: wrappedIcon;
		addBlankSize: 3.
	contentHolder:: row addNew: Wrapper setup:
		[:wrapper |
		wrapper area elasticity: 1].
	isExpanded
		ifTrue: [installExpandedPresenter]
		ifFalse: [installCollapsedPresenter].
	^row
)
expandedPart = (
	^expandedPresenter
)
installCollapsedPresenter = (
	collapsedPresenter ifNil:
		[collapsedPresenter:: collapsedDefinition value.
		collapsedPresenter parent: self].
	collapsedPresenter noticeImminentExposure.
	installContentVisual: collapsedPresenter visual.
)
installContentVisual: aVisual = (
	aVisual areaClass: Frame.
	aVisual area fullyCoverParent.
	contentHolder content: aVisual.
)
installExpandedPresenter = (
	expandedPresenter ifNil:
		[expandedPresenter:: expandedDefinition value.
		expandedPresenter parent: self].
	expandedPresenter noticeImminentExposure.
	installContentVisual: expandedPresenter visual.
)
privateCollapse = (
	expandedPresenter ifNotNil: [:it | it noticeConcealment].
	installCollapsedPresenter.
	collapsedPresenter noticeExposure
)
privateExpand = (
	collapsedPresenter ifNotNil: [:it | it noticeConcealment].
	installExpandedPresenter.
	expandedPresenter noticeExposure.
)
public replaceChild: aFragment with: replacement <Fragment> = (
	expandedPresenter == aFragment ifTrue:
		[expandedPresenter:: replacement.
		expandedPresenter parent: self.
		isExpanded ifTrue:
			[installContentVisual:: expandedPresenter visual].
		^self].
	collapsedPresenter == aFragment ifTrue:
		[collapsedPresenter:: replacement.
		collapsedPresenter parent: self.
		isExpanded ifFalse:
			[installContentVisual:: collapsedPresenter visual].
		^self].
	error: 'the argument is not a child of the receiver'
)
visiblePart = (
	^isExpanded
		ifTrue: [expandedPresenter]
		ifFalse: [collapsedPresenter]
)
) : (
public collapsedDefinition: block1 expandedDefinition: block2 = (
	^self new
		collapsedDefinition: block1
		expandedDefinition: block2
)
)
class TwoStateComposer = Composer (
(* TwoStateComposer is an abstract superclass of composers that hold onto two fragments, showing them in a particular way depending on the ''expanded'' or ''collapsed'' state of the composer. This superclass provides the mechanism for managing the current state of the interface and provides hooks to install code to run when the user or a program toggles the state, or to enable or disable the switching of states. *)
| expandedX ::=false. togglePermission ::=[true]. onAboutToToggle onToggled retainInvisiblePart |) (
public collapse = (
	expanded: false
)
public expand = (
	expanded: true
)
public expanded: state <Boolean> = (
	(expandedX ~= state and: [togglePermission value]) ifTrue:
		[onAboutToToggle value.
		expandedX:: state.
		hasVisual ifTrue:
			[state
				ifTrue: [privateExpand]
				ifFalse: [privateCollapse].
			updateToggleWidget].
		onToggled value]
)
public isExpanded = (
	^expandedX
)
privateCollapse = (
	(* Do whatever is necessary to switch the visuals to the collapsed appearance. *)

	subclassResponsibility
)
privateExpand = (
	(* Do whatever is necessary to switch the visuals to the expanded appearance. *)

	subclassResponsibility
)
public toggle = (
	expanded: isExpanded not.
	parent class = OutlineItemPresenter ifFalse:
		[notifyOfPossibleOutlineChange]
)
updateToggleWidget = (
	(* Subclasses must redefine this to bring the state of the UI element used for switching the states in sync with the current state of the receiver. *)

	subclassResponsibility
)
) : (
)
class TwoStateComposerWithToggleIcon = TwoStateComposer (|
	toggleIconX
	public onUserToggled
	useExplorerLikeImages ::=false.
|) (
closedImage = (
	^useExplorerLikeImages
		ifTrue: [HopscotchImages default disclosurePlusImage]
		ifFalse: [HopscotchImages default disclosureClosedImage]
)
createToggleIcon = (
	^ActiveIcon new action: [userToggle]
)
openImage = (
	^useExplorerLikeImages
		ifTrue: [HopscotchImages default disclosureMinusImage]
		ifFalse: [HopscotchImages default disclosureOpenImage]
)
toggleIcon = (
	toggleIconX isNil ifTrue:
		[toggleIconX:: createToggleIcon.
		updateToggleWidget].
	^toggleIconX
)
transitionImage = (
	^useExplorerLikeImages
		ifTrue: [HopscotchImages default disclosurePlusImage]
		ifFalse: [HopscotchImages default disclosureTransitionImage]
)
updateToggleWidget = (
	^isExpanded
		ifTrue:
			[toggleIcon
				image: openImage;
				hoverImage: openImage;
				downImage: transitionImage]
		ifFalse:
			[toggleIcon
				image: closedImage;
				hoverImage: closedImage;
				downImage: transitionImage]
)
public userToggle = (
	toggle.
	onUserToggled value
)
) : (
)
public class ZebraDecorator firstColor: firstColor secondColor: secondColor = Decorator (|
	firstColor ::= firstColor.
	secondColor ::= secondColor.
	sequenceDefinition
|) (
public decorate: aVisual = (
	aVisual children keysAndValuesDo:
		[:index :each |
		(each respondsTo: #color) ifTrue:
			[each color = Color transparent ifTrue:
				[each color:
					(index odd
						ifTrue: [firstColor]
						ifFalse: [secondColor])]]].
	^aVisual
)
) : (
public darkerColorFirst = (
	^self firstColor: (Color gray: 0.97) secondColor: Color white
)
public lighterColorFirst = (
	^self firstColor: Color white secondColor: (Color gray: 0.97)
)
)
public postInit = (
	OutlineItemPresenter:: outline OutlineItemPresenter
)
) : (
)
class CoreClasses = (|
	CanvasComposer
	CanvasItem
	CanvasItemGrabArea

	AdHocRoundedCornersHolderComposer
	CellLayoutDecorator
	CenteringFrameComposer
	ColorDecorator
	ColumnComposer
	DeferredContentComposer
	DisclosureComposer
	DragSubjectHolderComposer
	DropTargetHolderComposer
	FloatingHeaderComposer
	FloatingPanelComposer
	FlowComposer
	HolderComposer
	MoreOrLessComposer
	PaddedFrameComposer
	RowComposer
	SplitterComposer
	SpyingHolderComposer
	ToggleComposer
	ZebraDecorator

	BlankFragment
	ButtonFragment
	CollapsibleLabelFragment
	DropDownMenuFragment
	HyperlinkFragment
	HyperlinkImageFragment
	ImageButtonFragment
	ProgressFragment
	StaticImageFragment
	StaticLabelFragment
	TextDisplayFragment

	Outliner
|) (
public class Composer = Fragment (
(* Composer is the abstract superclass of all fragments that combine a number of children in a particular way, and often give them particular behavior. For example, ColumnComposer arranges the visuals representing its children as a column, while DisclosureComposer shows an expandable panel with a permanently displayed heading and a body that can be hidden or displayed. *)
) (
) : (
)
public class Decorator = (
(* A Decorator is attached to a fragment and is called by the fragment to change the various attributes of the Brazil visual created by the fragment itself. *)
) (
public decorate: aVisual = (
	(* Change properties of aVisual or wrap it into a new visual that applies whatever decorating we represent to aVisual. Answer aVisual or the new visual. *)
	subclassResponsibility
)
) : (
)
class DownwardRequestDispatcher = (
(* Responsible for delivering requests in a fragment hierarchy in the direction from parents to children. Typically created by sending the #sendDown message to a fragment. Unlike the upward dispatcher, the message is delivered to all children who care to receive it rather than to the first one. The children are traversed in some unspecified order (which happens to be depth-first :). *)
| public sender public message |) (
public arguments ^<Array> = (
	^message arguments
)
public deliverToChildrenOf: object = (
	object childrenDo:
		[:each |
		each receiveRequestFrom: self.
		deliverToChildrenOf: each]
)
doesNotUnderstand: aMessage = (
	message:: aMessage.
	deliverToChildrenOf: sender.
)
public selector ^<Symbol> = (
	^message selector
)
) : (
)
class DropEnabledPresenterList = PresenterList (
(* This is the variant of PresenterList that allows dropping things between the items, presumably to insert. Instances are usually created using the #list:dropExpecting:action: combinator provided by presenters.

Slots:

expectedSelector <Symbol> The selector a drop source accepted by this list should identify itself with.

dropAction <[Integer Array]> The block that gets invoked when an acceptable drag source is dropped within the list. The first argument is the index of the element after which the drop occurred (i.e. 0 if dropped before the first element). The second argument is the array of arguments supplied by the source's data identification message (the one specified by expectedSelector).

cachedTarget - used internally by the implementation.
*)
|
	public expectedSelector
	public dropAction
	cachedTarget
|) (
createTarget = (
	^DropTargetForPresenterList new
		owner: self
)
discardTarget = (
	cachedTarget:: nil
)
dropFrom: dragSource <DropSource> afterIndex: index <Integer> = (
	(* This message is sent by a drop target created for this list when something has been dropped onto the list. *)
	dragSource identifyPayloadTo:
		(AdHocMessageReceiver new
			receive: expectedSelector
			using:
				(ArbitraryArityBlockWrapper block:
					[:arguments |
					invokeDropActionFrom: dragSource
					withArguments: arguments
					afterIndex: index]))
)
ifInterestedInDragAt: windowRelativePoint <Point>
forSession: session <DragDropSession>
doWithTarget: targetBlock = (
	(visualContainsPoint: windowRelativePoint) ifTrue:
		[targetBlock value: target]
)
insertionIndexForCurrentMousePointWithMarker: marker <Fragment | nil> ^<Integer> = (
	(* This method determines where the drop local marker should be positioned for the current mouse pointer position. The returned value is the index preceding the desired index of the marker (i.e. it can be used with the add:afterIndex: message). The argument is the marker currently inserted in the presenter list, or nil if the list has no marker now. The result is in the 0..N range, where N is the current number of presenters if marker is nil, or in the 0..N-1 range if marker is not nil. *)
	| mousePoint y index |
	mousePoint:: visual mousePoint.
	y:: mousePoint y.
	index:: 0.
	presenters do:
		[:each | | eachBounds |
		each == marker ifFalse:
			[eachBounds:: each visual bounds translateFrom: each visual parent to: visual.
			y < eachBounds center y ifTrue: [^index].
			index:: index + 1.
			y <= eachBounds bottom ifTrue: [^index]]].
	^index
)
invokeDropActionFrom: dragSource <DragSource>
withArguments: subjectReportedArguments <Array>
afterIndex: index <Integer> = (
	dropAction ifNotNil:
		[:it |
		it
			value: index
			value: subjectReportedArguments]
)
public receiveRequestFrom: dispatcher ^<Boolean> = (
	(* Receive and process a notice coming from one of the children (usually as the result of using #sendUp or #sendDown). *)

	(self respondsTo: dispatcher selector) ifTrue:
		[dispatcher message sendTo: self.
		^true].
	^false
)
target = (
	^cachedTarget ifNil:
		[cachedTarget: createTarget.
		cachedTarget]
)
visualContainsPoint: windowRelativePoint <Point> ^<Boolean> = (
	^visual windowRelativeBounds containsPoint: windowRelativePoint
)
) : (
)
class DropTargetForPresenterList = DropTarget (
(* This drop target specializes in handling the drag-and-drop interaction of DropEnabledPresenterLists. In particular, it manages the display of the drop location marker displayed when a dragged thing is hovering over a drop-enabled list.

Slots:

owner <DropEnabledPresenterList> The presenter handled by target.

dropLocationMarker <Fragment | nil> The fragment or presenter temporarily inserted by this target into the owner in order to show drop location feedback. If the slot is nil, no such fragment is currently inserted.

markerIndex <Integer | nil> If not nil, the current index of the drop location marker in the owner list.
*)
| owner dropLocationMarker markerIndex |) (
createDropLocationMarker = (
	(* This is the guy that appears as the drop marker, but not having the usual presenter combinators we have to build it by hand. *)
	dropLocationMarker::
		ColumnComposer definitions:
			{BlankFragment size: 3.
			RowComposer definitions:
				{BlankFragment size: 10.
				(StaticLabelFragment text: markerText) color: markerTextColor.
				BlankFragment elasticity: 2}.
			BlankFragment size: 3}.
	dropLocationMarker color: markerBackgroundColor.
)
dragDropFrom: source <DragSource> = (
	| dropAfterIndex |
	if: source isDraggingExpectedSelectorDo:
		[dropAfterIndex:: markerIndex - 1.
		removeDropLocationMarker.
		owner discardTarget.
		owner dropFrom: source afterIndex: dropAfterIndex]
)
dragEnterFrom: source <DragSource> = (
	||
	if: source
	isDraggingExpectedSelectorDo:
		[showDropLocationMarker]
)
dragExitFrom: source <DragSource> = (
	||
	if: source
	isDraggingExpectedSelectorDo:
		[removeDropLocationMarker.
		owner discardTarget].
)
public dragStepFrom: source <DragSource> = (
	||
	if: source
	isDraggingExpectedSelectorDo:
		[updateDropLocationMarkerPosition]
)
if: source <DragSource> isDraggingExpectedSelectorDo: aBlock <[:Array]> = (
	source identifyPayloadTo:
		(AdHocMessageReceiver new
			receive: owner expectedSelector
			using:
				(ArbitraryArityBlockWrapper block:
					[:ignoredArguments | aBlock value]))
)
markerBackgroundColor ^<Color> = (
	^Color gray: 0.7
)
markerText ^<String> = (
	^'drop here'
)
markerTextColor ^<Color> = (
	^Color gray: 1
)
removeDropLocationMarker = (
	owner removeAt: markerIndex.
	dropLocationMarker:: nil.
	markerIndex:: nil.
)
showDropLocationMarker = (
	| insertionIndex |
	createDropLocationMarker.
	insertionIndex:: owner insertionIndexForCurrentMousePointWithMarker: dropLocationMarker.
	owner add: dropLocationMarker afterIndex: insertionIndex.
	markerIndex:: insertionIndex + 1.
)
updateDropLocationMarkerPosition = (
	| newIndex insertionIndex |
	newIndex:: owner insertionIndexForCurrentMousePointWithMarker: dropLocationMarker.
	(newIndex = (markerIndex - 1) or:
		[newIndex = owner presenters size and: [markerIndex = newIndex]])
			(* same position, inside or at the bottom of the list *)
			ifTrue: [^self].
	owner removeAt: markerIndex.
	insertionIndex:: newIndex min: owner presenters size.
	owner add: dropLocationMarker afterIndex: insertionIndex.
	(* {newIndex. markerIndex. insertionIndex} trace. *)
	markerIndex:: insertionIndex + 1
)
) : (
)
class Fragment = (
(* A Fragment is the basic unit of a Hopscotch tool (document). This class is the abstract superclass defining the traits common to all fragments:

	* The parent/child hierarchy of fragments and its maintenance.
	* The visual created by the fragment, if any.

Slots:
	parentX <Fragment> The parent of this fragment.
	visualX <Visual | nil> The rendition of this fragment as a Brazil Visual, if exists. The rendition is created lazily by the #createVisual method on receipt of the #visual message by an instance.
	decorators <nil | Collection[Decorator]> Decorators that are to be applied to the rendition of the fragment to complete its presentation.
*)
| parentX visualX decorators |) (
public addDecorator: newDecorator <Decorator> = (
	(* The argument is added last to the collection of our decorators, meaning it will be applied after all the other decorators we might have. *)
	nil = decorators ifTrue: [decorators:: List new].
	decorators addLast: newDecorator.
)
addOutlineItemsTo: parentItem = (
	childrenDo: [:each | each addOutlineItemsTo: parentItem]
)
children ^<Collection[Fragment]> = (
	| result |
	result:: List new.
	childrenDo: [:each | result add: each].
	^result
)
public childrenDo: aBlock = (
	subclassResponsibility
)
public class = (
	#ACCESSBOGUS. (* All known ordinary sends are for implementing equality, which should use isFoo instead. *)
	^super class
)
public collectDeferredContentInto: aCollection = (
	(* A downward request to collect all deferred content composers in the hierarchy into the collection passed as the argument. *)

	childrenDo: [:each | each collectDeferredContentInto: aCollection]
)
public compressibility: compressibility <Number> = (
	addDecorator::
		CellLayoutDecorator new
			compressibility: compressibility
)
createViewportWithVisual ^<Viewport> = (
	| wrapper viewport |
	wrapper:: Wrapper with: (decorate: createVisual).
	wrapper content areaClass: Frame.
	wrapper content area
		fullyCoverParent;
		leftOffset: 3;
		topOffset: 3;
		rightOffset: -3.
	viewport:: VerticalViewport new color: viewportColor.
	viewport add: wrapper.
	viewport scrollPositionH changed
		=> [:p | sendDown respondToScrollingInViewport: viewport].
	^viewport
)
createVisual ^<Visual> = (
	subclassResponsibility
)
public decorate: aVisual = (
	(* The argument is a visual freshly created by the #createVisual or #createViewportWithVisual method. If we have any decorators attached, apply them now to arrive at the final decorated visual. *)
	| decorated |
	decorated:: aVisual.
	decorators ifNotNil:
		[decorators do: [:each | decorated:: each decorate: decorated]].
	^decorated
)
public elasticity: elasticityNumber <Number> = (
	addDecorator::
		CellLayoutDecorator new
			expansibility: elasticityNumber;
			compressibility: elasticityNumber
)
error: msg <String> = (
	^Error signal: msg
)
public expansibility: expansibility <Number> = (
	addDecorator::
		CellLayoutDecorator new
			expansibility: expansibility
)
public findTargetForDragAt: windowRelativePoint <Point> forSession: session <DragDropSession> ^<DropTarget> = (
	^nil
)
flash = (
	visualX ifNotNil: [:it | it flash]
)
public hasChildren ^<Boolean> = (
	(* Return true if the receiver has any children. This is the generic catch-all implementation in terms of childrenDo:. A subclass may redefine this to perform the test more efficiently. *)

	childrenDo: [:any | ^true].
	^false
)
public hasParent = (
	^parentX notNil
)
public hasPendingChanges ^<Boolean> = (
	(* Answer whether the fragment at this time displays any changes made by the user which haven't yet been applied to the displayed objects (for example, method edits). *)
	childrenDo: [:any | any hasPendingChanges ifTrue: [^true]].
	^false
)
public hasVisual ^<Boolean> = (
	(* Answer true if the visual for this fragment has already been created and remembered. *)

	^visualX notNil
)
public isInstalledInShell = (
	^parent notNil and: [parent isInstalledInShell: self]
)
public isInstalledInShell: aChild = (
	^parent notNil and: [parent isInstalledInShell: self]
)
minimumWidth: pixels <Number> = (
	addDecorator::
		CellLayoutDecorator new
			minimumSize: pixels
)
public noticeAbandonment = (
	(* Sent to all fragments of a hierarchy just before it is forgotten by a top-level navigation-enabling parent. *)

	childrenDo: [:each | each noticeAbandonment]
)
public noticeAdoption = (
	(* Sent to all fragments of a hierarchy after it has been adopted by a top-level navigation-enabling parent. *)

	childrenDo: [:each | each noticeAdoption]
)
public noticeConcealment = (
	(* Propagated down the fragment hierarchy after the hierarchy has become invisible because the navigator or the the containing composer such as a toggle has hidden the root. At the time the message is received, the fragment's visual is not visible anymore. A fragment may receive this message multiple times over its life. *)

	childrenDo: [:each | each noticeConcealment]
)
public noticeExposure = (
	(* Propagated down the fragment hierarchy just after the hierarchy has been made visible. A fragment may receive this message multiple times over its life. *)

	childrenDo: [:each | each noticeExposure]
)
public noticeImminentExposure = (
	(* Propagated down the fragment hierarchy just before the hierarchy is made visible. A fragment may receive this message multiple times over its life. *)

	childrenDo: [:each | each noticeImminentExposure]
)
public noticeInstallation = (
	(* Sent to the root fragment of a hierarchy after the hierarchy has been attached to a composer in another hierarchy or a browser. *)

	noticeAdoption.
	scheduleDeferredContentInstallation
)
public noticeRemoval = (
	(* Sent to the root fragment of a hierarchy when the hierarchy is removed from a composer in another hierarchy or from a browser. *)

	noticeAbandonment
)
public noticeVisualCreation = (
	(* Received after the receiver's visual has been created and stored in the corresponding slot. *)
)
public notifyOfPossibleOutlineChange = (
	sendUp deliveryOptional outlineMayHaveChanged
)
public parent ^<Fragment> = (
	^parentX
)
public parent: newParent <Fragment | nil> = (
	(* This message is sent to a child by its parent right after the child is registered as a child of the parent, or (when the argument is nil) just before it is removed from the parent's records. *)

	parentX:: newParent.
	newParent isNil
		ifTrue: [noticeRemoval]
		ifFalse: [newParent isInstalledInShell ifTrue: [noticeInstallation]]
)
public receiveRequestFrom: dispatcher <RequestDispatcher> ^<Boolean> = (
	(* Process the request to execute a 'vertical' message carrried by the dispatcher and answer true, or answer false if the request is not recognized. *)

	^false
)
public refresh = (
	(* Fragments that dynamically retrieve their information should reimplement this to update their visuals accordingly. *)

	childrenDo: [:each | each refresh]
)
replaceChild: aFragment with: anotherFragment = (
	subclassResponsibility
)
public requestVisibility = (
	(* Notify the parent chain of this fragment that it wants to be visible. *)
	requestVisibilityOfRectangle: self visual localBounds
)
requestVisibilityOfRectangle: rect <Rectangle> = (
	(* Notify whoever is responsible for scrolling up the parent chain of this fragment that the specified range of Y coordinates (relative to the fragment's top left corner) should be made visible. *)
	sendUp deliveryOptional
		ensureVisibilityOfRectangle: rect within: self
)
scheduleDeferredContentInstallation = (
	(* Collect all children that are deferred-constructed and fork a background process to construct them. *)

	| deferredFragments |
	deferredFragments:: List new.
	collectDeferredContentInto: deferredFragments.
	deferredFragments isEmpty not ifTrue:
		[sendUp deliveryOptional navigatorDo:
			[:shell |
			shell addDeferredContent: deferredFragments]]
)
public sendDown ^<RequestDispatcher> = (
	(* Create and answer a RequestDispatcher that can deliver a downward request on behalf of the receiver. *)

	^DownwardRequestDispatcher new sender: self
)
public sendUp ^<RequestDispatcher> = (
	(* Create and answer a RequestDispatcher that can deliver a request on behalf of the receiver. *)

	^UpwardRequestDispatcher sender: self
)
public shell ^<Hopscotch> = (
	#ACCESSBOGUS.
	(* Answer the top-level navigator application. Fail if there is no path to it. *)

	^parent isNil
		ifTrue: [error: 'hierarchy not installed in a shell']
		ifFalse: [parent shell]
)
public title = (
	^'anonymous fragment'
)
public value = (
	BOGUS. (* expected when these classes extended the Squeak Object *)
	^self
)
public viewport ^<Visual> = (
	(* Normally presenters render themselves in response to the #visual message, producing a block visual. In some situations, for example when the presenter is the top-level presenter in a Hopscotch shell application, the presenter is instead asked to produce a scrollable viewport.
	Subclasses that never want to render as a viewport will want to redefine this method. It is not *required* to answer a viewport -- the message simply indicates that the sender intends to use the result in a context where a viewport is more appropriate. *)

	visualX == nil ifTrue:
		[visualX:: createViewportWithVisual.
		noticeVisualCreation].
	^visualX
)
viewportColor = (
	^Color white
)
public visual ^<Visual> = (
	(* Render the receiver as a hierarchy of Brazil visuals. *)

	visualX == nil ifTrue:
		[visualX:: decorate: createVisual.
		noticeVisualCreation].
	^visualX
)
public width: anInteger = (
	addDecorator::
		CellLayoutDecorator new size: anInteger
)
public width: anInteger elasticity: elasticityNumber = (
	addDecorator::
		CellLayoutDecorator new
			size: anInteger;
			expansibility: elasticityNumber;
			compressibility: elasticityNumber
)
withAllChildrenDo: aBlock = (
	aBlock value: self.
	childrenDo: [:each | each withAllChildrenDo: aBlock]
)
public ~~ other = (
	BOGUS. (* expected by Set>>includes: *)
	^(self == other) not
)
) : (
)
class HistoryPresenter onSubject: s = Presenter onSubject: s (
) (
definition = (
	^column: {
		majorHeadingBlock:
			(row: {
				label: 'Viewed in this Browser' asText allBold.
				filler.
				button: 'Forget All' action: [forgetAll].
				}).
		blank: 2.
		zebra: (column: presentersForHistoryEntries).
		}
)
forgetAll = (
	sendUp navigatorDo: [:shell | shell eraseHistory]
)
forgetEntry: aPresenter = (
	sendUp navigatorDo: [:sh | sh eraseHistoryEntry: aPresenter].
)
forgetEntryUIFor: aPresenter = (
	^(link: '[forget]'
		action: [forgetEntry: aPresenter. parent refresh])
			tinyFont color: (Color gray: 0.8).
)
indentedBlock: body = (
	^column: {
		mediumBlank.
		row: {
			mediumBlank.
			elastic: body
			}.
		mediumBlank
		}
)
public isTransient = (
	(* Should not be recorded in navigation history. *)
	^true
)
majorHeadingBlock: body = (
	^(padded: body with: {10. 10. 5. 10.})
		color: majorHeadingColor
)
majorHeadingColor = (
	^Gradient
		from: (Color h: 240 s: 0.05 v: 0.92)
		to: (Color h: 240 s: 0.05 v: 0.86)
)
presentersForHistoryEntries ^<Collection[Presenter]> = (
	| presenters |
	presenters:: List new: 20.
	subject historyDo:
		[:each |
		presenters add:
			(row: {
				elastic: each listElementMetapresenter.
				blank: 5.
				forgetEntryUIFor: each.
				blank: 5.
				})].
	^presenters
)
) : (
)
public class HistorySubject onModel: m = Subject onModel: m (
) (
public createPresenter = (
	^HistoryPresenter onSubject: self
)
public historyDo: aBlock = (
(* Evaluate the argument for all presenters in the history I represent, most recently visited one first. *)

^model reverseDo: aBlock
)
public title = (
	^'History'
)
) : (
)
class HomePresenter onSubject: s = Presenter onSubject: s (
) (
public definition = (
	^label: 'Home'
)
) : (
)
public class HomeSubject onModel: m = Subject onModel: m (
) (
public createPresenter = (
	^HomePresenter onSubject: self
)
) : (
public new = (
	^onModel: nil
)
)
class HopscotchShell = (
(* This abstract class captures the top-level browser functionality of history tracking and back/forward navigation. It also supports the basic rendering of presenters as Brazil visuals and installing the rendition of the currentPresenter as the content of the contentHolder. Subclasses will provide fancier facilities such as the actual window with the contentHolder, the toolbar, etc.
*)
|
	navigator ::= NavigationHistory new
		transientTestBlock: [:presenter | presenter isTransient].
	deferredContentQueue ::= SharedQueue new.
	showOutline ::= false.
	homeSubject ::= HomeSubject new.
	currentPresenterX
	contentHolder
	deferredContentInstaller
	outliner
|startDeferredContentInstaller) (
public addDeferredContent: fragments <Collection[DeferredFragment]> = (
	(* In some debugging situations there may not be a deferred content installer because we decided not to start it to isolate concurrency issues. *)

	deferredContentInstaller ifNotNil:
		[fragments do: [:each | deferredContentQueue nextPut: each]]
)
atHome = (
	^homeSubject = currentPresenter subject
)
buildContentHolder = (
	contentHolder:: Wrapper new.
	^contentHolder
)
buildDropDown: actionBlock = (
	| button images |
	button:: ActiveIcon new.
	images:: HopscotchImages default.
	button
		image: images hsDropdownImage;
		disabledImage: images hsDropdownOutImage;
		hoverImage: images hsDropdownOverImage;
		downImage: images hsDropdownDownImage;
		actOnMouseDown: true;
		action: actionBlock.
	^button
)
public childrenDo: aBlock = (
	aBlock value: currentPresenter
)
computeScrollYToShowFrom: desiredStart to: desiredEnd between: visibleStart and: visibleEnd = (
	(* The workhorse of handling scroll requests; computes where to scroll to display what we want with the minimal disturbance of the view. desiredStart and desiredEnd are the Y coordinates of what we want visible, visibleStart and visibleEnd are what's visible with the current scroll. What the method returns becomes the new visibleStart. *)

	| canSeeTop canSeeBottom overshoot |
	canSeeTop:: desiredStart between: visibleStart and: visibleEnd.
	canSeeBottom:: desiredEnd between: visibleStart and: visibleEnd.
	overshoot:: 3. (* How many pixels too many to scroll for better appearance. *)
	canSeeTop & canSeeBottom ifTrue:
		(* Peachy. *)
		[^visibleStart].
	canSeeTop & canSeeBottom not ifTrue:
		(* Scroll down just a little to make the thing completely visible. *)
		[^visibleStart + (desiredEnd - visibleEnd) + overshoot
			min: desiredStart - overshoot].
	canSeeTop not & canSeeBottom ifTrue:
		(* Scroll up just a little to make the thing completely visible. *)
		[^desiredStart - overshoot].
	(* Neither the top nor the bottom are visible, scroll just enough to show. *)
	^desiredStart < visibleStart
		ifTrue: (* Scrolling up *)
			[desiredStart - overshoot]
		ifFalse: (* Scrolling down *)
			[visibleStart + (desiredEnd - visibleEnd) + overshoot]
)
public currentPresenter = (
	^currentPresenterX
)
currentPresenter: aPresenter = (
	navigator visit: aPresenter.
	currentPresenterX:: aPresenter
)
currentSubject = (
	^currentPresenter subject
)
desktop = (
	^brazil theDesktop
)
displayPresenter: aPresenter = (
	(* Make the presenter the currently displayed one. This presenter change does not get recorded as a navigation event in navigation history. Use #enterPresenter: for that. *)

	| oldPresenter fragmentToInstall |
	oldPresenter:: currentPresenter.
	oldPresenter noticeConcealment.
	currentPresenter:: aPresenter.
	fragmentToInstall:: showOutline
		ifTrue: [setupOutliner]
		ifFalse: [currentPresenter].
	resetDeferredContentInstaller.
	Cursor wait showWhile:
		[fragmentToInstall parent == self ifFalse:
			[fragmentToInstall parent: self].
		currentPresenter noticeImminentExposure.
		(* Instrumentation to benchmark the creation of visuals. *)
		flag: #profile.
		(* MessageTally spyOn: [contentHolder content: currentPresenter viewport]. *)
		contentHolder content: fragmentToInstall viewport].
	currentPresenter noticeExposure
)
displaySubject: aSubject = (
	(* Make the default presenter of the subject the currently displayed one. This presenter change is not recorded in the navigation history. *)

	self displayPresenter: aSubject presenter
)
ensureVisibilityOf: aFragment = (
	(* Scroll the viewport to make the requestor visible. *)

	| viewport position requestorVisual requestorBounds finalScrollY |
	flag: #BOGUS. (* this is ugly and fragile *)
	viewport:: showOutline
		ifTrue: [contentHolder content children last]
		ifFalse: [contentHolder content].
	requestorVisual:: aFragment visual.
	(requestorVisual isDescendantOf: viewport) ifFalse: [^self].
	position:: viewport scrollPosition.
	requestorBounds:: requestorVisual bounds
		translateFrom: requestorVisual parent to: (viewport at: 1).
	finalScrollY::
		computeScrollYToShowFrom: requestorBounds top
		to: requestorBounds bottom
		between: position y
		and: position y + viewport innerExtent y.
	viewport scrollPosition: position x @ finalScrollY
)
public ensureVisibilityOfRectangle: spotlight <Rectangle> within: requestor <Fragment> = (
	(* Scroll the viewport to make the specified rectangle within the requestor visible (if it isn't already). *)
	| viewport position requestorVisual spotlightInViewport finalScrollY |
	flag: #BOGUS.
	(* [vassili 9/13/2012 10:38] perhaps we want to take out the showOutline nonsense *)
	viewport:: showOutline
		ifTrue: [contentHolder content children last]
		ifFalse: [contentHolder content].
	requestorVisual:: requestor visual.
	(requestorVisual isDescendantOf: viewport) ifFalse: [^self].
	position:: viewport scrollPosition.
	spotlightInViewport:: spotlight
		translateFrom: requestorVisual to: (viewport at: 1).
	finalScrollY::
		computeScrollYToShowFrom: spotlightInViewport top
		to: spotlightInViewport bottom
		between: position y
		and: position y + viewport innerExtent y.
	viewport scrollPosition: position x @ finalScrollY
)
public enterPresenter: aPresenter <Presenter> ^<Presenter> = (
	(* This is the workhorse of navigation, the primary means of requesting a browser to display a particular presenter. If the browser already has a presenter in its visit history equal (=) to the argument, the presenter from the history is displayed instead of the argument. The method returns the actual displayed presenter, so (result = aPresenter) is always true while (result == aPresenter) may be false. *)

	| presenterToDisplay |
	shiftWasPressed
		ifTrue: (* open in a new window *)
			[openPresenterInNewWindow: aPresenter.
			^aPresenter]
		ifFalse: (* open here and record in history *)
			[presenterToDisplay:: navigator equalVisitOr: aPresenter.
			navigator visit: presenterToDisplay.
			displayPresenter: presenterToDisplay.
			^presenterToDisplay]
)
public enterSubject: aSubject = (
	(* Enter the default presenter for the subject. *)

	self enterPresenter: aSubject presenter
)
public eraseHistory = (
	(* Forget all visits in the history and show the home page. *)
	navigator erase.
	goHome
)
public eraseHistoryEntry: aPresenter = (
	navigator eraseEntry: aPresenter.
)
public goBack = (
	| presenterToGoTo |
	navigator isPastEmpty ifFalse:
		[shiftWasPressed ifTrue:
			[^openSubjectInNewWindow: navigator previous subject refreshmentSubject].
		navigator goBack.
		displayPresenter: navigator current]
)
public goForward = (
	| presenterToGoTo |
	navigator isFutureEmpty ifFalse:
		[shiftWasPressed ifTrue:
			[^openSubjectInNewWindow: navigator next subject refreshmentSubject].
		navigator goForward.
		displayPresenter: navigator current]
)
public goHome = (
	atHome ifFalse:
		[enterSubject: homeSubject]
)
public isInstalledInShell = (
	(* This is the shell. *)

	^true
)
public isInstalledInShell: child = (
	^child == currentPresenter
)
public navigateTo: subject <Subject> = (
	(* Intended to be sent through the sendUp mechanism as the way to have the shell go to a different place. May be intercepted along the way to change the default behavior. *)
	enterSubject: subject
)
public navigatorDo: aBlock = (
	(* Process a request sent from somewhere in the presenter hierarchy to communicate with the navigator. The argument is a block that should be invoked with a navigator instance. *)

	^aBlock value: self
)
openPresenterInNewWindow: aPresenter = (
	(self class new presenter: aPresenter) openOnDesktop: desktop
)
openSubjectInNewWindow: aSubject = (
	(self class new subject: aSubject) openOnDesktop: desktop
)
public parent = (
	^nil
)
prepareToForget: aPresenter = (
	aPresenter noticeRemoval
)
prepareToForgetAllPresenters = (
	currentPresenter noticeConcealment.
	navigator do: [:each | prepareToForget: each]
)
public presenter: aPresenter = (
	currentPresenter:: aPresenter
)
public receiveRequestFrom: dispatcher ^<Boolean> = (
	(self respondsTo: dispatcher selector) ifTrue:
		[dispatcher message sendTo: self.
		^true].
	^false
)
public refresh = (
	(* Since refreshing forces a new copy of the current presenter into the browser, we need to massage it into the history as well. *)

	| newSubject |
	newSubject:: currentPresenter subject refreshmentSubject.
	displaySubject: newSubject.
	navigator replaceCurrentWith: newSubject presenter.
)
public replaceChild: aFragment <Fragment> with: replacement <Fragment> = (
	aFragment == currentPresenter
		ifTrue:
			[navigator replaceCurrentWith: replacement.
			displayPresenter: replacement]
		ifFalse: [navigator replace: aFragment with: replacement]
)
resetDeferredContentInstaller = (
	(* This action is performed when a new presenter replaces the old one in the shell view. There may still be deferred content pending installation. We cannot simply flush the queue and keep the existing installer process because the incorrect implementation of SharedQueue in Squeak makes it possible for the flush to cause a synchronization error if it happens when the installer process is past the semaphore but has not yet grabbed the next element.
	To avoid that we create a brand new queue and installer process. If the old one is still processing input, it will break our of the loop and complete on finding that it is no longer the official installer for this shell. If it is stopped on a semaphore of an empty queue, it is not runnable and will be garbage-collected together with the queue.
	If there is no installer process to begin with, we don't want one for debugging reasons. *)

	deferredContentInstaller ifNotNil:
		[deferredContentQueue:: SharedQueue new.
		startDeferredContentInstaller]
)
selectFutureItem: aPresenter = (
	| index |
	shiftWasPressed ifTrue:
		[^openSubjectInNewWindow: aPresenter subject refreshmentSubject].
	navigator goToFutureItem: aPresenter.
	displayPresenter: navigator current
)
selectPastItem: aPresenter = (
	| index |
	shiftWasPressed ifTrue:
		[^openSubjectInNewWindow: aPresenter subject refreshmentSubject].
	navigator goToPastItem: aPresenter.
	displayPresenter: navigator current
)
sendDown ^<RequestDispatcher> = (
	(* Create and answer a RequestDispatcher that can deliver a downward request on behalf of the receiver. *)

	^DownwardRequestDispatcher new sender: self
)
setupOutliner ^<Outliner> = (
	outliner:: Outliner new presenter: currentPresenter.
	^outliner
)
public shell = (
	^self
)
public shiftWasPressed = (
	^desktop modifierKeyStateForCurrentEvent shiftPressed
)
public showHistory = (
	enterPresenter: (HistoryPresenter onSubject: (HistorySubject onModel: navigator allVisits))
)
spawn = (
	(self class new subject: currentPresenter subject copy) open
)
startDeferredContentInstaller = (
	deferredContentInstaller::
	[
		(* See the comment in #resetDeferredContentInstaller. *)
		[Processor activeProcess == deferredContentInstaller] whileTrue:
			[ | fragment |
			fragment:: deferredContentQueue next.
			fragment createDeferredContent.
			fragment visual desktop ifNotNil:
				[:desktop |
				desktop scheduleUIInstallment:
					[fragment installDeferredContent]]]
	] forkAt: Processor userBackgroundPriority
)
stopDeferredContentInstaller = (
	deferredContentInstaller ifNotNil:
		[:it |
		it terminate.
		deferredContentInstaller: nil].
	deferredContentQueue flush
)
public subject: aSubject = (
	presenter:: aSubject presenter.
)
toggleOutline = (
	outliner ifNotNil: [:it | it toggleOutline]
)
wrapToAlignToBottomCenter: aVisual = (
	| wrapper |
	wrapper:: Wrapper new.
	wrapper content: aVisual.
	aVisual area beBottomCenter.
	^wrapper
)
) : (
withSubjectFromBlock: aBlock = (
	| instance |
	instance:: self new.
	instance subject: (aBlock value: instance).
	^instance
)
)
public class HopscotchWindow = HopscotchShell (
(* Builds on the basic HopscotchShell to add the ''real'' window displaying the current presenter, with a toolbar showing back and forward buttons and other navigational gadgets. *)
| initialOriginX initialExtentX public window toolbar forwardButton backButton pastButton futureButton homeButton |) (
acceptDropOfHopscotchSubject: subject = (
	self enterSubject: subject refreshmentSubject
)
addMenuBarItemsTo: menu <Menu> = (
	menu add: (SubmenuItem
		label: '&Navigator'
		submenu: (Menu new
			add: (MenuItem label: '&New' action: [respondToNew]);
			add: SeparatorItem new;
			add: (MenuItem label: '&Refresh' action: [refresh]);
			add: (MenuItem label: '&Close' action: [respondToClose]);
			yourself
		)).
	menu add: (SubmenuItem
		label: '&Go'
		submenu: (Menu new
			add: (MenuItem label: '&Back' action: [goBack]);
			add: (MenuItem label: '&Forward' action: [goForward]);
			add: SeparatorItem new;
			add: (MenuItem label: '&Home' action: [goHome]);
			add: (MenuItem label: 'Hi&story' action: [showHistory]);
			yourself
		)).
	menu add: (SubmenuItem
		label: '&Help'
		submenu: (Menu new
			add: (MenuItem label: 'User''s Guide' action: []);
			add: SeparatorItem new;
			add: (MenuItem label: 'About' action: []);
			yourself
		)).
)
addToolbarItemsTo: toolbar = (
	pastButton:: buildDropDown: [selectFromPast].
	toolbar add: (wrapToAlignToBottomCenter: pastButton).
	toolbar addBlankSize: 3.
	backButton:: toolbar add: buildBackButton.
	forwardButton:: toolbar add: buildForwardButton.
	toolbar addBlankSize: 3.
	futureButton:: buildDropDown: [selectFromFuture].
	toolbar add: (wrapToAlignToBottomCenter: futureButton).

	toolbar addBlankSize: 10.
	toolbar add: buildHistoryButton.
	toolbar addBlankSize: 2.
	homeButton:: toolbar add: buildHomeButton.

	toolbar addBlankSize: 10.
	toolbar add: buildRefreshButton.
	toolbar addBlankSize: 2.
	toolbar add: buildNewButton.

	showOutline ifTrue:
		[toolbar addBlankSize: 10.
		toolbar add: buildToggleOutlineButton]
)
authorizeUnsavedChanges = (
	^false
)
buildBackButton = (
	| button images |
	button:: ActiveIcon new.
	images:: HopscotchImages default.
	button
		image: images hsBackImage;		
		action: [goBack].
	^button
)
buildForwardButton = (
	| button images |
	button:: ActiveIcon new.
	images:: HopscotchImages default.
	button
		image: images hsForwardImage;
		disabledImage: images hsForwardOutImage;
		hoverImage: images hsForwardOverImage;
		downImage: images hsForwardDownImage;
		action: [goForward].
	^button
)
buildHistoryButton = (
	| button images |
	button:: ActiveIcon new.
	images:: HopscotchImages default.
	button
		image: images hsHistoryImage;
		hoverImage: images hsHistoryOverImage;
		downImage: images hsHistoryDownImage;
		action: [showHistory].
	^button
)
buildHomeButton = (
	| button images |
	button:: ActiveIcon new.
	images:: HopscotchImages default.
	button
		image: images hsHomeImage;
		disabledImage: images hsHomeOutImage;
		hoverImage: images hsHomeOverImage;
		downImage: images hsHomeDownImage;
		action: [goHome].
	^button
)
buildMenuBar ^<Menu | nil> = (
	(* The method should answer the menu to use as the menu bar, or nil if the window should have no menu bar. *)

	| menu |
	menu:: Menu new.
	addMenuBarItemsTo: menu.
	^menu
)
buildNewButton = (
	| button images |
	button:: ActiveIcon new.
	images:: HopscotchImages default.
	button
		image: images hsNewImage;
		hoverImage: images hsNewOverImage;
		downImage: images hsNewDownImage;
		action: [respondToNew].
	^button
)
buildRefreshButton = (
	| button images |
	button:: ActiveIcon new.
	images:: HopscotchImages default.
	button
		image: images hsRefreshImage;
		hoverImage: images hsRefreshOverImage;
		downImage: images hsRefreshDownImage;
		action: [refresh].
	^button
)
buildToggleOutlineButton = (
	| button images |
	button:: ActiveIcon new.
	images:: HopscotchImages default.
	button
		image: images hsNewImage;
		hoverImage: images hsNewOverImage;
		downImage: images hsNewDownImage;
		action: [toggleOutline].
	^button
)
buildToolbar = (
	toolbar:: Row new.
	toolbar addBlankSize: 5.
	addToolbarItemsTo: toolbar.
	toolbar addBlankSize: 5.
	^toolbar
)
buildWindow = (
	window:: Window new title: 'Hopscotch'.
	window
		owner: self;
		dragDropDispatcher: self;
		closePermission: [checkWindowClosePermission];
		on: #closed do: [notifyAllPresentersOfRemoval].
	window content: Column new.
	window content
		addBlankSize: 3;
		add: buildToolbar;
		addBlankSize: 5;
		add: buildContentHolder.
	contentHolder area elasticity: 1.
	buildMenuBar ifNotNil: [:it | window menuBarMenu: it].
	^window
)
checkWindowClosePermission ^<Boolean> = (
	^(navigator allVisits select: [:each | each hasPendingChanges]) isEmpty not
		ifTrue:
			[authorizeUnsavedChanges]
		ifFalse:
			[true]
)
public desktop = (
	#ACCESSBOGUS.
	^window desktop
)
displayPresenter: aPresenter = (
	(* Also update the window elements that depend on the current presenter. *)

	super displayPresenter: aPresenter.
	updateToolbar.
	updateWindowTitle
)
public dropFrom: dragSource <DragSource> = (
	dragSource identifyPayloadTo:
		(AdHocMessageReceiver new
			receive: #draggingHopscotchSubject:
			using: [:subject | acceptDropOfHopscotchSubject: subject])
)
public findTargetForDragAt: windowRelativePoint <Point> forSession: session <DragDropSession> = (
	(* A HopscotchWindow registers itself as the dragDropDispatcher of its Brazil window, so it is here that we direct target search to look among the fragments. *)
	sendDown
		ifInterestedInDragAt: windowRelativePoint
		forSession: session
		doWithTarget: [:target | ^target].
	^viewpointSwitchingDropTarget
)
public forceCloseWindow = (
	window closePermission: nil.
	window close
)
public initialBounds ^<Rectangle> = (
	(* Return the bounds on the screen the receiver should occupy when first opened. *)

	^initialOrigin extent: initialExtent
)
public initialBounds: newValue <Rectangle> = (
	(* Set the position and size of the receiver when first opened. *)
	initialOrigin: newValue origin.
	initialExtent: newValue extent.
)
public initialExtent ^<Point> = (
	(* Return the size the receiver should have when first opened. *)

	^initialExtentX ifNil:
		[showOutline
			ifTrue: [800 @ 800]
			ifFalse: [600 @ 800]]
)
public initialExtent: newValue ^<Point> = (
	(* Set the size of the receiver when first opened. *)

	initialExtentX:: newValue
)
public initialOrigin ^<Point> = (
	(* Return the position the receiver should have when first opened. *)

	^initialOriginX ifNil: [200 @ 100]
)
public initialOrigin: theOrigin ^<Point> = (
	(* Set the position of the receiver when first opened. *)

	initialOriginX:: theOrigin
)
notifyAllPresentersOfRemoval = (
	navigator allVisits do: [:each | each noticeRemoval]
)
public open = (
	openOnDesktop: brazil theDesktop.
)
public openOnDesktop: aDesktop = (
	| screenBounds windowBounds fragmentToInstall |
	screenBounds:: Rectangle origin: 0@0 extent: aDesktop extent.
	windowBounds:: initialBounds translatedToBeWithin: screenBounds.
	windowBounds:: windowBounds intersect: screenBounds.
	buildWindow.
	fragmentToInstall:: showOutline
		ifTrue: [setupOutliner]
		ifFalse: [currentPresenter].
	fragmentToInstall parent: self.
	currentPresenter noticeImminentExposure.
	contentHolder content: fragmentToInstall viewport.
	aDesktop add: window.
	windowBounds:: window agent outerToInner: windowBounds.
	window area bounds: windowBounds.
	window on: #closed do: [respondToClose].
	currentPresenter
		noticeExposure.
	updateToolbar.
	updateWindowTitle.
	window visible: true.
)
respondToClose = (
	stopDeferredContentInstaller.
	prepareToForgetAllPresenters.
)
respondToNew = (
	(* The New button has been clicked. Respond by opening a new browser. If the Shift key is down, show a copy of the current page in the new browser. *)

	openSubjectInNewWindow:
		(shiftWasPressed
			ifTrue:
				[currentPresenter subject refreshmentSubject]
			ifFalse:
				[homeSubject refreshmentSubject])
)
selectFromFuture = (
	| menu |
	menu:: Menu forVisual: window.
	navigator future do:
		[:each | | item |
		item:: MenuItem
			label: each title
			action: [selectFutureItem: each].
		item icon: each icon.
		menu add: item].
	menu
		openIn: window desktop
		at: (0 @ futureButton extent y
				translateFrom: futureButton
				to: window desktop)
)
selectFromPast = (
	| menu |
	menu:: Menu forVisual: window.
	navigator past reverseDo:
		[:each | | item |
		item:: MenuItem
			label: each title
			action: [selectPastItem: each].
		item icon: each icon.
		menu add: item].
	menu
		openIn: window desktop
		at: (0 @ pastButton extent y
				translateFrom: pastButton
				to: window desktop)
)
public updateToolbar = (
	(* Update the state of toolbar controls that depend on the current state of the browser. *)
	backButton enabled: navigator isPastEmpty not.
	forwardButton enabled: navigator isFutureEmpty not.
	pastButton enabled: navigator isPastEmpty not.
	futureButton enabled: navigator isFutureEmpty not.
	homeButton enabled: atHome not.
)
updateWindowTitle = (
	| title |
	title:: currentPresenter title.
	title isEmpty ifTrue:
		[title:: 'Hopscotch'].
	window desktop isWindows ifTrue:
		[title:: title, ' - Newspeak'].
	window title: title
)
viewpointSwitchingDropTarget = (
	| target |
	target:: DropTarget new
		dropAction: [:source | dropFrom: source].
	^target
)
) : (
public openSubject: aSubject <Subject> = (
	^openSubjectFromBlock: [:instance | aSubject]
)
public openSubjectFromBlock: aBlock = (
	^(withSubjectFromBlock: aBlock) open
)
public withSubjectFromBlock: aBlock = (
	| instance |
	instance:: self new.
	instance subject: (aBlock value: instance).
	^instance
)
)
public class LeafFragment = Fragment (
(* This is the abstract superclass of all leaf fragments, that is those without any children of their own.
*)
) (
children = (
	^Array new
)
public childrenDo: aBlock = (
	(* No children. *)
)
hasChildren = (
	(* Never. *)

	^false
)
public hasPendingChanges ^<Boolean> = (
	(* For simplicity, we assume that most leaf fragments can never have pending changes. Those for which it is not true should override this method. *)
	^false
)
replaceChild: aFragment with: anotherFragment = (
	error: 'a leaf fragment should never receive this'
)
) : (
)
class NavigationHistory = (
(* NavigationHistory is a richly structured collection that maintains a web browser-like history of ''visits''. Visits are arbitrary objects. NavigationHistory makes no assumptions about visits other than that they can be compared using #=.

The important attributes of a history are: the ''current'' visit, the ''past'', the ''future'' and ''allVisits''. A history starts off empty. To visit an object, send the #visit: message to the history with the object as the argument. This makes the object the ''current'' object of the history.

The ''past'' is a queue of visits that used to be the current (most recently current object last). Sending the #goBack message makes the most recently current object from the past the current again, while the current object becomes the first member of the ''future'' queue. Sending the #goForward message reverses the process. Visiting an object other than the first element of the ''future'' queue erases the future queue.

All visits visited by a history are remembered in the ''allVisits'' set. This set is never emptied, other than on an explicit request.

A history can optionally be configured with a transientTestBlock. The test block is applied to visits to determine whether they are transient or not. Transient visits are not recorded in the ''past'' and ''future'' queues and in the ''allVisits'' set. By default all visits are considered to be non-transient.
*)
|
	currentVisitX
	public allVisits
	public past
	public future
	public transientTestBlock ::= [:element | false].
|erase) (
public current = (
	^currentVisitX
)
public do: aBlock = (
	(* Do the current visit separately if transient because it's not among allVisits. *)
	(isTransient: currentVisitX) ifTrue:
		[aBlock value: currentVisitX].
	allVisits do: aBlock
)
public equalVisitOr: anObject = (
	(* Return a visit from the history equal to the argument, or the argument itself if there is no equal visit in the history. *)

	^allVisits detect: [:some | some = anObject] ifNone: [anObject]
)
public erase = (
	currentVisitX:: nil.
	allVisits:: List new.
	erasePast.
	eraseFuture.
)
public eraseEntry: anObject = (
	allVisits remove: anObject.
	past remove: anObject ifAbsent: [].
	future remove: anObject ifAbsent: []. (* can it ever be in the future list? *)
)
eraseFuture = (
	future:: List new.
)
erasePast = (
	past:: List new.
)
public goBack = (
	isPastEmpty ifFalse:
		[(isTransient: currentVisitX) ifFalse:
			[future addFirst: currentVisitX].
		currentVisitX:: past removeLast]
)
public goForward = (
	isFutureEmpty ifFalse:
		[(isTransient: currentVisitX) ifFalse:
			[past addLast: currentVisitX].
		currentVisitX:: future removeFirst]
)
public goToFutureItem: anObject = (
	[currentVisitX = anObject or: [isFutureEmpty]]
		whileFalse: [goForward]
)
public goToPastItem: anObject = (
	[currentVisitX = anObject or: [isPastEmpty]]
		whileFalse: [goBack]
)
includesVisit: anObject = (
	^allVisits includes: anObject
)
isEmpty = (
	^allVisits isEmpty
)
public isFutureEmpty = (
	^future isEmpty
)
public isPastEmpty = (
	^past isEmpty
)
isTransient: anObject = (
	^transientTestBlock value: anObject
)
next = (
	(* Answer the closest visit from the future. Fail if the future is empty. *)

	^future first
)
previous = (
	(* Answer the most recent visit from the past. Fail if the past is empty. *)

	^past last
)
replace: anObject with: replacement = (
	(* Replace all references to anObject that we have with references to 'replacement'. *)

	allVisits remove: anObject ifAbsent: [].
	(isTransient: replacement) ifFalse: [allVisits add: replacement].
	currentVisitX = anObject ifTrue: [currentVisitX:: replacement].
	past keysAndValuesDo:
		[:index :each | each = anObject ifTrue: [past at: index put: replacement]].
	future keysAndValuesDo:
		[:index :each | each = anObject ifTrue: [future at: index put: replacement]]
)
public replaceCurrentWith: anObject = (
	self replace: currentVisitX with: anObject
)
public visit: anObject = (
	(* Make the argument the current object of the history. The prior current object becomes the last object of the 'past' queue. The 'future' queue is erased, unless the visit is equal to the first element of the future. *)

	currentVisitX = anObject ifTrue: [^self].
	(currentVisitX notNil and: [(isTransient: currentVisitX) not]) ifTrue:
		[past addLast: currentVisitX].
	currentVisitX:: anObject.
	(isTransient: anObject) ifFalse:
		[allVisits
			remove: anObject ifAbsent: [];
			add: anObject].
	future isEmpty not ifTrue:
		[future first = currentVisitX
			ifTrue: [future removeFirst]
			ifFalse: [eraseFuture]].
)
) : (
)
public class Presenter onSubject: aSubject = Fragment (
(* A Presenter is a semantic Fragment, aware of the thing it presents (held onto by its subject). *)
|
	public subject ::=aSubject. (* The setter should be protected. *)
	substanceX
	noticeHandlerSelectorsX
|#ACCESSBOGUS) (
public = anotherPresenter = (
	^anotherPresenter class = class and: [anotherPresenter subject = subject]
)
public adviseOnViewportScrollPosition: requestor = (
	(* Expected to be sent using sendUp from a contaned presenter; respond by directly invoking the standard viewport scrolling notification. *)
	(visual isKindOf: VerticalViewport) ifTrue:
		[requestor respondToScrollingInViewport: visual]
)
alert: message <String> = (
	MessageBox new ok: message; open
)
at: location <Point> display: presenter <Presenter> ^<CanvasItem> = (
	^CanvasItem withContent: presenter at: location
)
blank: size <Number> = (
	^BlankFragment size: size
)
button: label <String> action: block = (
	^ButtonFragment new
		label: label;
		action: block
)
canvas: elements <Collection[CanvasElementAnchor | CanvasElementFrame]> ^<CanvasComposer> = (
	^CanvasComposer elements: elements
)
canvas: elements <Collection[CanvasElementAnchor | CanvasElementFrame]>
dropTargetCreationBlock: block <Block> ^<CanvasComposer> = (
	^(CanvasComposer elements: elements)
		dropTargetCreationBlock: block
)
centered: content <Fragment> = (
	^CenteringFrameComposer content: content
)
public childrenDo: aBlock = (
	substanceX ifNotNil: [:it | aBlock value: it]
)
collapsed: collapsed <Block> expanded: expanded <Block> ^<Block> = (
	^	collapsed: collapsed
		expanded: expanded
		initiallyExpanded: false
)
collapsed: collapsed <Block> expanded: expanded <Block> initiallyExpanded: flag <Boolean>
^<Block> = (
	^ToggleComposer new
		collapsedDefinition: collapsed expandedDefinition: expanded;
		expanded: flag
)
collapsibleLabel: label <String | nil> = (
	^CollapsibleLabelFragment new text: label
)
column: definitions <Collection[Block]> ^<Composer> = (
	^ColumnComposer definitions: definitions
)
copyToClipboard: object = (
	Clipboard clipboardText: object asString
)
createVisual = (
	ensureSubstance.
	^substanceX visual
)
deferred: contentSource <Block> ^<DeferredContentComposer> = (
	^DeferredContentComposer new contentSource: contentSource
)
definition = (
	subclassResponsibility
)
draggable: content <Fragment> subject: subject <Subject> image: image <Form | nil> = (
	^(DragSubjectHolderComposer withContent: content)
		subject: subject;
		image: image
)
draggableImage: image <Form | Block> forSubject: subjectOrBlock <Subject | [Subject]> = (
	^draggable: (image: image) subject: subjectOrBlock image: image
)
dropDownMenu: menuSupplier <Block> = (
	^DropDownMenuFragment new
		menuSupplier: menuSupplier
)
dropTarget: fragment expecting: selector dropAction: aBlock = (
	^(DropTargetHolderComposer content: fragment)
		expectedSelector: selector;
		dropAction: aBlock;
		yourself
)
elastic: aFragment = (
	aFragment elasticity: 1.
	^aFragment
)
ensureSubstance = (
	substanceX ifNil:
		[substanceX:: self definition.
		substanceX parent: self.
		noticeSubstanceCreation]
)
enterPresenter: aPresenter = (
	(* Look into getting rid of this. *)
	sendUp navigatorDo:
		[:navigator | navigator enterPresenter: aPresenter]
)
enterSubject: aSubject = (
	sendUp
		ifUndelivered: [core HopscotchWindow openSubject: aSubject];
		navigateTo: aSubject
)
expanded: expanded <Block> collapsed: collapsed <Block> ^<Block> = (
	^	collapsed: collapsed
		expanded: expanded
		initiallyExpanded: true
)
extraInformationMetapresenter ^<Presenter> = (
	^nothing
)
filler = (
	^BlankFragment elasticity: 1
)
floatingHeader: header <Fragment> body: body <Fragment> = (
	^FloatingHeaderComposer header: header body: body
)
floatingHeader: header <Fragment> body: body <Fragment> minimumRatio: ratio <Integer> = (
	^(FloatingHeaderComposer header: header body: body)
		minimumBodyToHeaderRatio: ratio;
		yourself
)
floatingPanel: fragment <Fragment> = (
	^FloatingPanelComposer panel: fragment
)
flow: definitions <Collection[Block]> ^<Block> = (
	^FlowComposer definitions: definitions
)
fork: workAction <[T]> thenUpdateUI: uiAction <[] | [:T]> = (
	(* Perform workAction in a separate thread of control then schedule uiAction in the UI event loop with the result of the work. *)
	[
		isInstalledInShell ifTrue:
			[ | work |
			work:: workAction value.
			schedule: [uiAction valueWithPossibleArgument: work]]
	] forkAt: Processor userBackgroundPriority named: 'UI Worker'
)
grabArea: content <Fragment> = (
	^CanvasItemGrabArea withContent: content
)
hasSubstance ^<Boolean> = (
	^substanceX ~~ nil
)
public hash = (
	^subject hash
)
heading: heading <Block> details: details <Block> ^<Block> = (
	^heading: heading details: details initiallyExpanded: false
)
heading: heading <Block> details: details <Block> initiallyExpanded: flag <Boolean>
^<Block> = (
	^DisclosureComposer new
		header: heading value bodyDefinition: details;
		expanded: flag
)
heading: heading <Block> detailsExpanded: details <Block> ^<Block> = (
	^heading: heading details: details initiallyExpanded: true
)
holder: definition = (
	^HolderComposer withContent: definition
)
public icon ^<Form | nil> = (
	(* The icon, if not nil, can be displayed together with the title where appropriate to better identify the presenter. *)

	^nil
)
image: image <Form | Block> = (
	^StaticImageFragment new
		image: image;
		yourself
)
imageButton: images <Array> action: block = (
	^ImageButtonFragment new
		images: images;
		action: block
)
imageButton: images <Array> action: block actOnMouseDown: shouldActOnMouseDown <Boolean> = (
	^ImageButtonFragment new
		images: images;
		actOnMouseDown: shouldActOnMouseDown;
		action: block
)
incrementalList: presenterSource <[:WriteStream[HPresenter]]> ^<PresenterList> = (
	^PresenterList new presenterSource:
		[Array streamContents: presenterSource]
)
initially: initialFragment <Fragment> deferred: contentSource <Block> ^<DeferredContentComposer> = (
	^DeferredContentComposer new
		initialContent: initialFragment;
		contentSource: contentSource
)
public isTransient = (
	(* Should visits of this presenter be omitted from the navigation history? *)

	^false
)
label: label <String> = (
	^StaticLabelFragment text: label
)
less: less <Block> label: showMoreLabel <String>
more: more <Block> label: showLessLabel <String>
^<Block> = (
	^	less: less label: showMoreLabel
		more: more label: showLessLabel
		initiallyMore: false
)
less: less <Block> label: showMoreLabel <String>
more: more <Block> label: showLessLabel <String>
initiallyMore: flag <Boolean>
^<Block> = (
	^MoreOrLessComposer new
		lessDefinition: less moreDefinition: more;
		lessCaption: showLessLabel;
		moreCaption: showMoreLabel;
		expanded: flag
)
less: less <Block> more: more <Block> ^<Block> = (
	^	less: less label: 'more...'
		more: more label: 'less...'
		initiallyMore: false
)
link: labelOrBlock <String | Block> action: block <Block> = (
	^HyperlinkFragment new
		label: labelOrBlock;
		action: block
)
link: labelOrBlock <String | Block>
action: block <Block>
dragSourceCreationBlock: dragSourceBlock <[DragSource]> = (
	^HyperlinkFragment new
		label: labelOrBlock;
		action: block;
		dragSourceCreationBlock: dragSourceBlock
)
link: labelOrBlock <String | Block>
action: block <Block>
dragSubject: dragSubject <Subject | [Subject]>
withImage: dragImage <Form> = (
	^HyperlinkFragment new
		label: labelOrBlock;
		action: block;
		dragSubject: dragSubject;
		dragImage: dragImage.
)
linkImage: image <Form> action: block = (
	^HyperlinkImageFragment image: image action: block
)
list = (
	^PresenterList new
)
list: presenterSource <Collection | Block> ^<PresenterList> = (
	^PresenterList new presenterSource: presenterSource
)
list: presenterSource <Collection | Block> dropExpecting: dropSelector action: dropAction = (
	^DropEnabledPresenterList new
		presenterSource: presenterSource;
		expectedSelector: dropSelector;
		dropAction: dropAction;
		yourself
)
public listElementMetapresenter ^<Presenter> = (
(* A presenter that can represent the receiver in a list of presenters such as the History. *)

	^row: {
		minimalMetapresenter.
		mediumBlank.
		deferred:
			[hasPendingChanges
				ifTrue: [label: 'has unsaved edits' asText allBold]
				ifFalse: [nothing]].
		filler compressibility: 0.
		(deferred: [extraInformationMetapresenter]) compressibility: 1.
	}
)
majorUpdate: aBlock = (
	(* aBlock is evaluated so that the UI avoids any incremental layout adjustments while the block is runs and does a single wholesale update afterwards. *)

	^showWaitCursorWhile:
		[visual blockIncrementalLayoutUpdatesWhile: aBlock]
)
mediumBlank = (
	^blank: 10
)
menuWithLabelsAndActions: labelsAndActions = (
	| menu |
	menu:: Menu forVisual: visual.
	labelsAndActions do:
		[:each |
		menu add: (#separator = each
			ifTrue: [SeparatorItem new]
			ifFalse: [MenuItem key: nil label: each key action: each value])].
	^menu
)
minimalMetapresenter ^<Presenter> = (
(* A minimal presenter that can represent the receiver in places such as the History. *)

	^row: {
		icon
			ifNotNil:
				[:it |
				draggableImage: it forSubject: subject]
			ifNil:
				[blank: 17].
		blank: 5.
		link: title action: [enterPresenter: self].
	}
)
more: more <Block> label: showLessLabel <String>
less: less <Block> label: showMoreLabel <String>
^<Block> = (
	^	less: less label: showMoreLabel
		more: more label: showLessLabel
		initiallyMore: false
)
more: more <Block> less: less <Block> ^<Block> = (
	^	less: less label: 'more...'
		more: more label: 'less...'
		initiallyMore: true
)
nothing = (
	^BlankFragment new
)
noticeSubstanceCreation = (
	(* Received after the #definition method of the receiver has been invoked and the result remembered as its substance. The substance hasn't been asked to create a visual yet. *)
)
openMenu: aMenu = (
	aMenu openIn: visual desktop
)
openMenuWithLabelsAndActions: labelsAndActions = (
	openMenu: (menuWithLabelsAndActions: labelsAndActions)
)
outlineItem ^<OutlineItem | nil> = (
	(* Create and answer an outline item that represents the presenter. Answer nil if the presenter should not be displayed in outlines. *)
	^nil
)
padded: def with: offsets = (
	(* Wrapping in a Column so that the color of the whole thing can be set. *)

	^column: {
		PaddedFrameComposer new
			content: def;
			paddingLeft: (offsets at: 1);
			paddingTop: (offsets at: 2);
			paddingRight: (offsets at: 3);
			paddingBottom: (offsets at: 4)
		}
)
padded: definition with: offsets roundedCornersColor: color = (
	(* Wrapping in a Column so that the color of the whole thing can be set. *)

	| composer |
	composer:: AdHocRoundedCornersHolderComposer
		withContent:
			(PaddedFrameComposer new
				content: definition;
				paddingLeft: (offsets at: 1);
				paddingTop: (offsets at: 2);
				paddingRight: (offsets at: 3);
				paddingBottom: (offsets at: 4)).
	composer color: color.
	^composer
)
public printOn: aStream = (
	super printOn: aStream.
	aStream
		nextPut: "(";
		print: subject;
		nextPut: ")"
)
progress = (
	^ProgressFragment new
)
progress: percentComplete = (
	^ProgressFragment new percentComplete: percentComplete
)
public receiveRequestFrom: dispatcher ^<Boolean> = (
	(* Receive and process a notice coming from one of the children (usually as the result of using #sendUp). *)

	(self respondsTo: dispatcher selector)
		ifTrue:
			[dispatcher message sendTo: self.
			^true]
		ifFalse:
			[^false]
)
refreshWhenDone: action <[]> = (
	(* Perform action in a separate thread of control, then schedule a refresh unless the result of the action is nil. *)
	||
	fork: action thenUpdateUI:
		[:result |
		result ifNotNil:
			[self refresh]]
)
replaceChild: aFragment with: anotherFragment = (
	error: 'should never receive this'
	(* The only child of a presenter is its substance, and the substance is a simple presentational fragment such as a HolderFragment or a Composer that we expect to handle any replacement requests within itself. *)
)
request ^<Request> = (
	(* Use this to request a file, newFile, or directory using native dialog if available *)
	^Request usingPlatform: cachedPlatform
)
resizableLeft: left <Fragment> right: right <Fragment> = (
	^SplitterComposer left: left right: right
)
respondToOutlineSelection = (
	requestVisibility
)
row: definitions <Collection[Fragment]> ^<Fragment> = (
	^RowComposer definitions: definitions
)
schedule: uiAction = (
	(* Schedule uiAction to be performed in the UI event loop. The uiAction will not be performed if this presenter is not installed in a shell. *)
	visual ifNotNil:
		[:v|
		v desktop ifNotNil:
			[:d |
			d scheduleUIAction:
				[isInstalledInShell ifTrue:
					[majorUpdate:
					[uiAction value]]]]]
)
sequence: definitions <Collection[Block]> ^<Block> = (
	^column: definitions
)
showWaitCursorWhile: action <BlockContext> = (
	World activeHand showTemporaryCursor: Cursor wait.
	World displayWorldSafely.
	^action ensure: [World activeHand showTemporaryCursor: nil]
)
spy: definition <Fragment> ^<Fragment> = (
	^SpyingHolderComposer content: definition
)
substance = (
	ensureSubstance.
	^substanceX
)
textDisplay: aString <String> = (
	^TextDisplayFragment text: aString
)
public title ^<String> = (
	(* The title identifies the presenter in places such as the browser title bar or the history menu. *)

	^subject title
)
unimplemented = (
	self error: 'not implemented yet'
)
zebra: sequence = (
	sequence addDecorator: ZebraDecorator lighterColorFirst.
	^sequence
)
) : (
)
class PresenterList = Fragment (
(* PresenterList is a fragment that manages a sequence of Presenters, displaying them as a column. The interesting functionality it provides beyond that is updating itself intelligently when receiving a new sequence of presenters to display. New presenters equal (as determined by #=) to those currently displayed remain displayed as before, with any state they had unaffected even if their order in the list has changed.

The presenters can be given to the list either as a collection or as a niladic block that evaluates to a collection. In the latter case, a PresenterList will re-evaluate the block and update itself from the result each time it receives the #refresh message.

Slots:

presenterSourceX <SequenceableCollection | Block> The presenters to display or the block providing them, as given to this instance when it was created.

presentersX <SequenceableCollection> If presenterSourceX is a collection, this slot holds the same object as presenterSourceX. It it is the block, it holds the last result produced by the block.
*)
|
	presenterSourceX ::= List new.
	presentersX
|) (
public add: aPresenter <Presenter> = (
	(* Append the argument to the end of the list of displayed presenters. If there is an equal presenter already displayed, remove it. *)
	(presenters includes: aPresenter) ifTrue:
		[presenters remove: aPresenter].
	presenters:: presenters copyWith: aPresenter
)
public add: aPresenter <Presenter> afterIndex: index <Integer> = (
	| newList |
	newList:: presenters copy.
	newList add: aPresenter afterIndex: index.
	presenters: newList.
)
public addAll: additionalPresenters <{Presenter}> = (
	presenters: presenters, additionalPresenters
)
public addFirst: aPresenter <Presenter> = (
	(* Add the argument at the beginning of the end of the list of displayed presenters. If there is an equal presenter already displayed, remove it. *)

	(presenters includes: aPresenter) ifTrue:
		[presenters remove: aPresenter].
	presenters:: {aPresenter}, presenters.
)
public childrenDo: aBlock = (
	presentersX ifNotNil: [:they | they do: aBlock]
)
public color: aColor = (
	addDecorator::
		ColorDecorator new color: aColor
)
createVisual = (
	| column |
	column:: Column new.
	updateColumn: column
		removingIndices: {}
		addingPresenters: presenters.
	^column
)
public detectPresenter: aBlock = (
	^presentersX detect: aBlock
)
public detectPresenter: aBlock ifNone: noneBlock = (
	^presentersX detect: aBlock ifNone: noneBlock
)
findFirst: aBlock = (
	(* Answer the index of my first element for which aBlock evaluates as true. *)
	^presentersX findFirst: aBlock
)
findLast: aBlock = (
	(* Answer the index of my last element for which aBlock evaluates as true. *)
	^presentersX findLast: aBlock
)
public presenterSource: niladicValuable <Sequence[Presenter] | [Presenter]> = (
	presenterSourceX:: niladicValuable.
	presentersX ifNotNil: [refreshPresenterList]
)
public presenters ^<Collection [Presenter]> = (
	(* Return the presenters we are currently showing, pulling them from the source if needed. *)

	presentersX == nil ifTrue:
		[setPresenters: presenterSourceX value].
	^presentersX
)
public presenters: newPresenterList <Sequence[Presenter]> = (
	self presenterSource: newPresenterList
)
public refresh = (
	| newPresenters |
	newPresenters:: refreshPresenterList asSet.
	presenters do:
		[:each |
		(newPresenters includes: each) ifFalse: [each refresh]]
)
refreshPresenterList = (
	(* Make it so that the displayed presenters match those provided by the source. For a list initialized with a presenter collection, this only does anything non-trivial when the instance is brand new. For a list initialized with a block, this re-evaluates the block and updates the list. *)

	^setPresenters: presenterSourceX value
)
refreshPresenters = (
	presenters do: [:each | each refresh]
)
public remove: aPresenter = (
	presenters:: presenters copyWithout: aPresenter
)
public removeAt: index <Integer> = (
	| copy |
	copy:: presenters copy.
	copy removeAt: index.
	presenters:: copy.
)
replaceChild: aFragment with: anotherFragment = (
	| index newPresenters |
	(presentersX includes: aFragment) ifTrue:
		[index:: presenters indexOf: aFragment.
		newPresenters:: presenters copy.
		newPresenters at: index put: anotherFragment.
		^presenters: newPresenters].
	error: 'the fragment is not a child'
)
public setPresenters: newPresenterList <Sequence[Presenter]> = (
	(* This is the workhorse of intelligent updates: massage the argument presenters into the currently displayed list, making sure that if there is an element of newPresenterList equal to a currently displayed presenter, we continue using the current presenter. *)

	| currentPresenters oldPresentersAndIndices removedPresenters removedIndices addedPresenters newFinalList |
	currentPresenters:: presentersX ifNil: [List new].
	oldPresentersAndIndices:: Map new: currentPresenters size.
	currentPresenters keysAndValuesDo:
		[:index :each | oldPresentersAndIndices at: each put: index].
	addedPresenters:: List new: newPresenterList size.
	newFinalList:: List new: newPresenterList size.

	newPresenterList do:
		[:each | | oldIndex |
		oldIndex:: oldPresentersAndIndices at: each ifAbsent: [nil].
		oldIndex notNil
			ifTrue: (* reusing a presenter we already have for this subject *)
				[newFinalList add: (presenters at: oldIndex).
				oldPresentersAndIndices removeKey: each]
			ifFalse:
				[newFinalList add: each.
				addedPresenters add: each]].

	removedPresenters:: oldPresentersAndIndices keys.
	removedIndices:: (1 to: currentPresenters size) select:
		[:index | removedPresenters includes: (currentPresenters at: index)].

	presentersX:: newFinalList.
	addedPresenters do: [:each | each parent: self].
	hasVisual ifTrue:
		[updateColumn: visualX
		 removingIndices: removedIndices
		 addingPresenters: addedPresenters].
	^addedPresenters
)
updateColumn: column removingIndices: indices addingPresenters: newPresenters = (
	indices asSortedCollection reverseDo:
		[:each | column removeAt: each].
	newPresenters do:
		[:each | column add: each visual].
	column reorder:
		(presenters collect: [:each | each visual])
)
) : (
)
public class Subject onModel: aModel = (
(* A Subject is the perspective of looking at a certain object in a particular way. The object, or the information necessary to retrieve it, is stored in the 'model' slot. *)
|
	model ::=aModel.
	presenterX
|) (
public class = (
	#ACCESSBOGUS. (* All known ordinary sends are for implementing equality, which should use isFoo instead. *)
	^super class
)
public createPresenter = (
	(* Subclasses should define this to create their presenter. In the future this process can be further factored so that presenter creation is controlled by a policy object, say to display the same subjects differently under different hardware constraints. For now, to keep things simple subjects themselves create their presenters. *)

	subclassResponsibility
)
public presenter = (
	(* The approved API for getting the current, or the default, presenter for this subject. *)

	presenterX ifNil:
		[presenterX:: createPresenter].
	^presenterX
)
public printOn: aStream = (
	super printOn: aStream.
	aStream
		nextPut: "(";
		print: model;
		nextPut: ")"
)
public refreshmentSubject ^<Subject> = (
	(* Answer a new subject representing the same thing as the receiver. *)
	^self class onModel: model
)
public title ^<String> = (
(* Return a string that can be shown to the user to identify this subject. A subclass will typically want to override this to return something more descriptive than the printString. *)

	^self printString
)
) : (
)
class UpwardRequestDispatcher = (
(* Responsible for delivering requests inside a fragment hierarchy from children to parents. Typically created by sending the #sendUp message to a fragment and then sending to the result the message to deliver as a request to parents. For example, in a method of a fragment:

	sendUp deleteSlotInPresenter: self.

The message #deleteSlotInPresenter: sent to the instance is catched by the doesNotUnderstand: method of the dispatcher. The dispatcher then walks the chain of parents of the instance sending to each the #receiveRequestFrom: message, searching for one that would return true from the message to indicate acceptance of the request. The argument of the #receiveRequestFrom: message is the dispatcher itself. A parent can communicate with the dispatcher to retrieve and examine the sender, the selector, and/or the arguments of the request.

What exactly constitutes the acceptance and handling of a request is up to each particular parent to define. However, the interpretation common to presenters is to accept a request with the selector understood by the presenter, and process it by sending the selector to the presenter.

By default, a request is delivered to the first (in the bottom-up order) presenter that accepts it, and the delivery finishes. A dispatcher can be flagged as #toAll by sending it this message before asking it to deliver a request. Such a presenter will deliver its requests to all interested parents of the sender.

If none of the parents of a presenter accept a request, an error is signaled by default. However, a dispatcher can be flagged as delivery-optional by sending to it the #deliveryOptional message after creation and before using it to send a request. A delivery-optional dispatcher will silently ignore an undelivered request. Alternatively, the user can provide a dispatcher with an #ifUndelivered: block (again, before using it to send requests).

The category ''SqueakCrap'' has a number of methods that must be present to avoid having the debugger croak.
*)
|
	public sender
	sendToAll ::= false.
	public message
	public ifUndelivered
	delivered ::=false.
|) (
arguments ^<Array> = (
	^message arguments
)
public deliverToAll = (
	| here |
	delivered:: false.
	here:: sender parent.
	[here notNil] whileTrue:
		[delivered:: delivered | (here receiveRequestFrom: self).
		here:: here parent]
)
public deliverToFirst = (
	| here |
	delivered:: false.
	here:: sender parent.
	[here notNil] whileTrue:
		[(here receiveRequestFrom: self) ifTrue:
			[^delivered:: true].
		here:: here parent]
)
public deliveryOptional = (
	(* Configure the receiver so that if a request is undelivered, no error is signaled. *)

	ifUndelivered: []
)
doesNotUnderstand: aMessage = (
	message:: aMessage.
	sendToAll
		ifTrue: [deliverToAll]
		ifFalse: [deliverToFirst].
	^delivered
		ifTrue: [sender]
		ifFalse:
			[ifUndelivered notNil
				ifTrue: [ifUndelivered value]
				ifFalse: [sender error: 'Undelivered notice']]
)
optional = (
	(* Configure the receiver so that if a request is undelivered, no error is signaled. *)

	ifUndelivered: []
)
public selector ^<Symbol> = (
	^message selector
)
toAll = (
	(* Configure the receiver so that it delivers requests to all parents of the sender, rather than only to the first one that will accept the request. *)

	sendToAll:: true
)
) : (
public sender: aPresenter <Presenter> = (
	^self new sender: aPresenter
)
)
public postInit = (
	CanvasComposer:: canvas CanvasComposer.
	CanvasItem:: canvas CanvasItem.
	CanvasItemGrabArea:: canvas CanvasItemGrabArea.

	AdHocRoundedCornersHolderComposer:: composers AdHocRoundedCornersHolderComposer.
	CellLayoutDecorator:: composers CellLayoutDecorator.
	CenteringFrameComposer:: composers CenteringFrameComposer.
	ColorDecorator:: composers ColorDecorator.
	ColumnComposer:: composers ColumnComposer.
	DeferredContentComposer:: composers DeferredContentComposer.
	DisclosureComposer:: composers DisclosureComposer.
	DragSubjectHolderComposer:: composers DragSubjectHolderComposer.
	DropTargetHolderComposer:: composers DropTargetHolderComposer.
	FlowComposer:: composers FlowComposer.
	FloatingHeaderComposer:: composers FloatingHeaderComposer.
	FloatingPanelComposer:: composers FloatingPanelComposer.
	HolderComposer:: composers HolderComposer.
	MoreOrLessComposer:: composers MoreOrLessComposer.
	PaddedFrameComposer:: composers PaddedFrameComposer.
	RowComposer:: composers RowComposer.
	SplitterComposer:: composers SplitterComposer.
	SpyingHolderComposer:: composers SpyingHolderComposer.
	ToggleComposer:: composers ToggleComposer.
	ZebraDecorator:: composers ZebraDecorator.

	BlankFragment:: fragments BlankFragment.
	ButtonFragment:: fragments ButtonFragment.
	CollapsibleLabelFragment:: fragments CollapsibleLabelFragment.
	DropDownMenuFragment:: fragments DropDownMenuFragment.
	HyperlinkFragment:: fragments HyperlinkFragment.
	HyperlinkImageFragment:: fragments HyperlinkImageFragment.
	ImageButtonFragment:: fragments ImageButtonFragment.
	ProgressFragment:: fragments ProgressFragment.
	StaticImageFragment:: fragments StaticImageFragment.
	StaticLabelFragment:: fragments StaticLabelFragment.
	TextDisplayFragment:: fragments TextDisplayFragment.

	Outliner:: outline Outliner.
)
) : (
)
class FragmentClasses = (|
	public LeafFragment = core LeafFragment.
	Presenter = core Presenter.
|) (
public class BlankFragment = LeafFragment (
(* A fragment displayed as white space in the document, created typically by the #blank: and #filler definition entries. *)
| sizeX elasticityX |) (
createVisual = (
	(* Only set area parameters if we in fact have them--this allows blanks with no parameters function outside of the visual sequence context. *)

	| blank |
	blank:: Blank new.
	size ifNotNil: [blank area principalSize: size].
	elasticity ifNotNil: [blank area elasticity: elasticity].
	^blank
)
elasticity = (
	^elasticityX
)
public elasticity: newValue <Number> = (
	elasticityX:: newValue.
	hasVisual ifTrue:
		[visual area elasticity: elasticityX]
)
size = (
	^sizeX
)
public size: newSize <Integer> = (
	sizeX:: newSize.
	hasVisual ifTrue:
		[visual area principalSize: sizeX]
)
) : (
public elasticity: elasticity <Number> = (
	^self new elasticity: elasticity
)
public size: size <Number> = (
	^self new size: size
)
)
public class ButtonFragment = LeafFragment (|
	labelX
	public action
	enabledX
|) (
createVisual ^<Visual> = (
	| button |
	button:: Button new.
	button
		label: label;
		enabled: enabled;
		action: action.
	^button
)
public enabled = (
	^(enabledX == false) not
)
public enabled: newValue <Boolean> = (
	enabledX:: newValue.
	hasVisual ifTrue: [visual enabled: enabled]
)
public label ^<String> = (
	^labelX
)
public label: newLabel <String> = (
	labelX:: 'frog'.
	hasVisual ifTrue: [visual label: label]
)
) : (
)
public class CollapsibleLabelFragment = LeafFragment (
(* Similar to LabelFragment, but allows the label to be set to nil in which case the fragment collapses to the size 0 x 0 and the space it occupied becomes available.
*)
| labelX textX |) (
buildWrapperContent = (
	^text isEmpty
		ifTrue: [Blank new]
		ifFalse: [Label new text: text]
)
createVisual = (
	^Wrapper with: buildWrapperContent
)
currentContent = (
	^label isNil
		ifTrue: [Blank new]
		ifFalse: [Label new label: label]
)
text ^<Text> = (
	^textX ifNil: [String new]
)
text: newContent <Text | nil> = (
	textX:: newContent.
	hasVisual ifTrue:
		[visual content: buildWrapperContent]
)
) : (
)
class DragSourceFragment = LeafFragment (
(* OBSOLETE, should be removed.
An icon representing a subject that can be dragged.
*)
| imageX subjectOrBlock responderX |) (
createDragSource = (
	^HopscotchSubjectDragSource new
		subject: subject;
		draggedImage: image;
		wastelandTarget: HopscotchWastelandDropTarget new
)
createVisual ^<Visual> = (
	| icon |
	icon:: SensitiveIcon new image: image.
	responderX:: DragDropTracker new
		attachTo: icon;
		sourceCreationBlock: [createDragSource].
	^icon
)
image = (
	^imageX value
)
image: imageOrBlock = (
	imageX:: imageOrBlock.
	refresh.
)
public refresh = (
	(imageX isClosure and: [hasVisual]) ifTrue:
		[visualX image: image]
)
subject ^<Subject> = (
	^subjectOrBlock isClosure
		ifTrue: [subjectOrBlock value]
		ifFalse: [subjectOrBlock]
)
subject: newSubject <Subject | [Subject]> = (
	subjectOrBlock:: newSubject
)
) : (
)
public class DropDownMenuFragment = LeafFragment (| public menuSupplier |) (
createVisual = (
	| button images |
	button:: ActiveIcon new.
	images:: HopscotchImages default.
	button
		image: images hsDropdownImage;
		disabledImage: images hsDropdownOutImage;
		hoverImage: images hsDropdownOverImage;
		downImage: images hsDropdownDownImage;
		actOnMouseDown: true;
		action:
			[menuSupplier value ifNotNil:
				[:menu |
				menu
					ownerVisual: visual;
					openIn: visual desktop]].
	^button
)
) : (
)
public class EditableLinePresenter onSubject: s = Presenter onSubject: s (
(* The superclass of presenters that display as a line of text (or other static representation) which can be transformed into an single-line text editor. A subclass will have to implement the logic that defines what the static display looks like, how the edit state is entered, and how the result of editing is mapped back onto the model state.
*)
| isEditing ::=false. editor |) (
definition = (
	^holder:
		[isEditing
			ifTrue: [editorDefinition]
			ifFalse: [viewerDefinition]]
)
definitionText = (
	subclassResponsibility
)
editorDefinition = (
	editor:: TextLineEditorFragment new.
	editor
		text: definitionText;
		cancelResponse: [respondToCancel];
		acceptResponse: [respondToAccept].
	^editor
)
public enterEditState = (
	isEditing:: true.
	refresh
)
public leaveEditState = (
	isEditing:: false.
	refresh
)
respondToAccept = (
	(* A subclass must redefine this to do whatever is needed to be done with <editor text> to save its as the new state of the subject, and send #leaveEditState if the save was successful. *)

	subclassResponsibility
)
respondToCancel = (
	leaveEditState
)
viewerDefinition = (
	subclassResponsibility
)
) : (
)
public class HopscotchSubjectDragSource = DragSource (
(* A generic Hopscotch drag source that allows dragging around the subject or a presenter.
*)
| public subject |) (
public identifyPayloadTo: identificationReceiver = (
	^identificationReceiver
		try: [identificationReceiver draggingHopscotchSubject: subject]
		or: [super identifyPayloadTo: identificationReceiver]
)
) : (
)
public class HopscotchWastelandDropTarget = (
(* This the drop target used by default to represent the wasteland, i.e. the space not occupied by any civilized Hopscotch or Brazil windows. Dropping things such as subjects onto the wasteland results in opening them in new Hopscotch windows.
*)
) (
acceptDropOfHopscotchSubject: subject <Subject> onto: desktop <Desktop> = (
	| newBrowser |
	newBrowser:: core HopscotchWindow withSubjectFromBlock:
		[:instance | subject refreshmentSubject].
	newBrowser initialOrigin: desktop mousePoint.
	newBrowser openOnDesktop: desktop
)
public dragStepFrom: dragSource <GenericDragSource> = (
	(* Do nothing for now. *)
)
public dropFrom: dragSource <GenericDragSource> = (
	dragSource identifyPayloadTo:
		(AdHocMessageReceiver new
			receive: #draggingHopscotchSubject:
			using:
				[:subject |
				acceptDropOfHopscotchSubject: subject
					onto: dragSource visual desktop])
)
isInterestedInDragSource: dragSource <DragSource> ^<Boolean> = (
	dragSource identifyPayloadTo:
		(AdHocMessageReceiver new
			receive: #draggingHopscotchSubject:
			using: [:subject | ^true]).
	^false
)
) : (
)
public class HyperlinkFragment = LeafFragment (
(* Renders itself as a clickable link in the document. *)
|
	labelX
	fontX
	colorX
	public action
	dragSourceCreationBlock
	dragSubjectOrBlock
	dragTracker
	public dragImage
|) (
public color ^<Color> = (
	^colorX
)
public color: newColor <Color> = (
	colorX:: newColor.
	hasVisual ifTrue: [visual color: newColor]
)
createDragSource = (
	^dragSourceCreationBlock notNil
		ifTrue: [dragSourceCreationBlock value]
		ifFalse: [HopscotchSubjectDragSource new
			subject: dragSubject;
			draggedImage: dragImage;
			wastelandTarget: HopscotchWastelandDropTarget new]
)
createVisual = (
	| link tracker |
	link:: Hyperlink new label: label; action: action.
	fontX ifNotNil: [link font: fontX].
	colorX ifNotNil: [link color: colorX].
	(dragSubject notNil | dragSourceCreationBlock notNil) ifTrue:
		[tracker:: DragDropTracker new
			visual: link;
			sourceCreationBlock: [createDragSource].
		link dragTracker: tracker].
	^link
)
dragSubject = (
	^dragSubjectOrBlock isClosure
		ifTrue: [dragSubjectOrBlock value]
		ifFalse: [dragSubjectOrBlock]
)
public dragSubject: newValue = (
	dragSubjectOrBlock:: newValue
)
public font ^<Font> = (
	^fontX
)
public font: newFont <Font> = (
	fontX:: newFont.
	hasVisual ifTrue: [visual font: newFont]
)
public hugeFont = (
	font: Font huge
)
public label = (
	^labelX value
)
public label: aStringOrBlock = (
	labelX:: aStringOrBlock.
	hasVisual ifTrue: [visual label: label]
)
largeFont = (
	font: Font large
)
public refresh = (
	(labelX isString not and: [hasVisual]) ifTrue:
		[visual label: label]
)
public smallFont = (
	font: Font small
)
public tinyFont = (
	font: Font tiny
)
) : (
public label: string action: block = (
	^self new
		label: string;
		action: block
)
)
public class HyperlinkImageFragment = LeafFragment (|
	imageX
	actOnMouseDownX
	public action
|) (
createVisual = (
	^ActiveIcon new
		image: imageX;
		hoverImage: imageX;
		downImage: imageX;
		action: [action value]
)
public image = (
	^imageX
)
public image: aForm = (
	imageX:: aForm.
	hasVisual ifTrue:
		[visual
			image: imageX;
			hoverImage: imageX;
			downImage: imageX]
)
) : (
public image: form action: block = (
	^self new
		image: form;
		action: block
)
)
public class ImageButtonFragment = LeafFragment (|
	stateImages
	public action
	shouldActOnMouseDown ::=false.
|) (
public actOnMouseDown: newState <Boolean> = (
	shouldActOnMouseDown:: newState.
	hasVisual ifTrue: [visual actOnMouseDown: newState]
)
createVisual = (
	^ActiveIcon new
		image: (stateImages at: 1);
		hoverImage: (stateImages at: 2);
		downImage: (stateImages at: 3);
		disabledImage: (stateImages at: 4);
		actOnMouseDown: shouldActOnMouseDown == true;
		action: [action value]
)
public images: imageArray = (
	(* Set the images used for the various states of the button. The array should contain them in the following order: normal, hover, down, disabled. *)

	stateImages:: imageArray, (Array new: 3 withAll: nil).
	(* Appending three nils so that we can always send #at: with an index between 1 and 4 and expect it not to fail. *)
)
) : (
)
public class ProgressFragment = LeafFragment (| percentCompleteX |) (
barWithColor: color andWidth: width = (
	| box |
	box:: (* Rounded *)RectangleShape new.
	box size: 0@20.
	box color: color.
	box area elasticity: width.
	^box
)
createVisual ^<Visual> = (
	| row |
	row:: Row new.
	row add: (barWithColor: (Color h: 240 s: 0.3 v: 0.5) andWidth: 0.0 + percentComplete).
	row add: (barWithColor: Color transparent andWidth: 100.0 - percentComplete).
	^row
)
percentComplete = (
	^percentCompleteX ifNil: [0.0]
)
public percentComplete: newValue = (
	percentCompleteX:: newValue.
	hasVisual ifTrue: [
		visual desktop ifNotNil:
			[:d |
			d scheduleUIAction:
				[isInstalledInShell ifTrue:
					[(visual at: 1) area elasticity: 0.0 + percentComplete.
					(visual at: 2) area elasticity: 100.0 - percentComplete]]]]
)
) : (
)
class SimpleTextEntryFragment = LeafFragment (
(* A line of text that the user can edit. The changeResponse block is invoked every time the text changes, with the current text passed as an (optional) argument. *)
|
	editor
	changeResponse <Block>
|) (
createVisual = (
editor:: TextView new.
	editor hasEditsFromUserChannel
		=> [:hasChanges | changeResponse ifNotNil: [:it | it cull: editor
 text asString]].
	^editor
)
) : (
)
public class StaticImageFragment = LeafFragment (| imageX |) (
createVisual = (
	^Icon new
		image: image;
		yourself
)
public image = (
	^imageX value
)
public image: imageOrBlock = (
	imageX:: imageOrBlock.
	(imageOrBlock isClosure and: [hasVisual]) ifTrue:
		[visualX image: image]
)
public refresh = (
	(imageX isClosure and: [hasVisual]) ifTrue:
		[visualX image: image]
)
) : (
)
public class StaticLabelFragment = LeafFragment (| textX fontX colorX |) (
public color ^<Color> = (
	^colorX
)
public color: newColor <Color> = (
	colorX:: newColor.
	hasVisual ifTrue: [visual color: newColor]
)
createVisual = (
	| label |
	label:: Label new text: text.
	fontX ifNotNil: [label font: fontX].
	colorX ifNotNil: [label color: colorX].
	^label
)
public font ^<Font> = (
	^fontX
)
public font: newFont <Font> = (
	fontX:: newFont.
	hasVisual ifTrue: [visual font: newFont]
)
public hugeFont = (
	font: Font huge
)
public largeFont = (
	font: Font large
)
public refresh = (
	(* If the text is actually a text-providing monadic block, run it to retrieve the current content. *)

	(textX isString not and: [hasVisual]) ifTrue:
		[visual text: text]
)
public smallFont = (
	font: Font small
)
public text ^<Text> = (
	^textX value
)
public text: newText <Text | Block> = (
	(* If the text is a block, the block is evaluated to retrieve the text every time the label receives the #refresh message. *)

	textX:: newText.
	hasVisual ifTrue: [visual text: text]
)
public tinyFont = (
	font: Font tiny
)
) : (
public text: text = (
	^self new text: text
)
)
public class TextDisplayFragment = LeafFragment (| textX fontX |) (
createVisual = (
	| textDisplay |
	textDisplay:: TextDisplay new text: text.
	fontX ifNotNil: [textDisplay font: fontX].
(*	colorX ifNotNil: [textDisplay color: colorX]. *)
	^textDisplay
)
public font ^<Font> = (
	^fontX
)
public font: newFont <Font> = (
	fontX:: newFont.
	hasVisual ifTrue: [visual font: newFont]
)
public largeFont = (
	font: Font large
)
public refresh = (
	(textX isString not and: [hasVisual]) ifTrue:
		[visual text: text]
)
public smallFont = (
	font: Font small
)
public text = (
	^textX value (* textX may be a monadic block *)
)
public text: aStringOrBlock = (
	textX:: aStringOrBlock.
	hasVisual ifTrue:
		[visual text: text]
)
public tinyFont = (
	font: Font tiny
)
) : (
public text: aString = (
	^self new text: aString
)
)
public class TextEditorFragment = LeafFragment (
(* Historical note: Self called the bar on the right the counterfactual bar because it indicates the source being viewed is not the live source in the system. -Ryan *)
|
	textX ::= String new.
	public acceptLabelText ::= 'save'.
	public cancelLabelText ::= 'cancel'.
	public controlBarColor ::= Color h: 45 s: 0.7 v: 1.
	public changeResponse
	public acceptResponse
	public cancelResponse
	public enterKeyResponse
	public escapeKeyResponse
	public menuBlock

	public textBeingAccepted
	public editor
	messagesContainer
	leftColumn
	editModeControls
	readOnlyVisual_
	isInReadOnlyState = false.
|) (
public addMessage: aString = (
	| messageLabel messageHolder |
	messageLabel:: Label new text: aString.
	messageLabel font: Font small.
	messageHolder:: Row new.
	messageHolder
		addBlankSize: 3;
		add: messageLabel.
	messagesContainer add: messageHolder
)
buildEditModeControls = (
	editModeControls:: Column new.
	(* NOTE: the #respondToScrollingInViewport: method makes assumptions about the structure of editModeControls. *)
	editModeControls
		addBlankSize: controlsPadding;
		addNew: Row setup:
			[:row |
			row
				addBlankSize: 3;
				add: createAcceptLabel.
			cancelLabelText ifNotNil:
					[row
						addBlankSize: 3;
						add: createCancelLabel].
			row
				addBlankSize: 3].
	controlBarColor ifNotNil:
		[editModeControls color: controlBarColor]
)
confirm: label ifConfirmed: block = (
	| menu |
	menu:: Menu forVisual: visual.
	menu add: (MenuItem key: #ok label: label action: block).
	menu openIn: visual desktop
)
controlsPadding ^<Integer> = (
	(* This accept/cancel buttons are displayed with this many pixels between them and the top of the yellow controls bar. *)
	^5
)
createAcceptLabel = (
	^ActiveIcon new
		image: (HopscotchImages default accept16px);
		hoverImage: (HopscotchImages default accept16pxOver);
		downImage: (HopscotchImages default accept16pxDown);
		action: [respondToAccept]
)
createCancelLabel = (
	^ActiveIcon new
		image: (HopscotchImages default cancel16px);
		hoverImage: (HopscotchImages default cancel16pxOver);
		downImage: (HopscotchImages default cancel16pxDown);
		action: [respondToCancel]
)
createEditor = (
	editor:: editorWidgetClass new.
	editor suppressScrollbars: true.
	editor text: text copy.
	editor hasEditsFromUserChannel =>
		[:hasChanges |
		textBeingAccepted:: editor text copy.
		hasChanges ifTrue: [respondToChange]].
	editor acceptKeyResponse:
		[:defaultResponse |
		respondToAccept].
	editor enterKeyResponse:
		[:defaultResponse |
		enterKeyResponse notNil
			ifTrue: [enterKeyResponse cull: self]
			ifFalse: [defaultResponse value]].
	editor escapeKeyResponse:
		[:defaultResponse |
		escapeKeyResponse notNil
			ifTrue: [escapeKeyResponse cull: self]
			ifFalse: [defaultResponse value]].
	editor menuBlock: menuBlock.
	^editor
)
createLeftColumn = (
	leftColumn:: Column new.
	leftColumn add: createEditor.
	messagesContainer:: Column new.
	messagesContainer color: (Color h: 40 s: 0.3 v: 1).
	leftColumn add: messagesContainer.
	^leftColumn
)
createVisual = (
	| row |
	row:: Row new.
	row add: createLeftColumn.
	(row at: 1) area elasticity: 1.
	^row
)
public defaultAcceptResponse = (
	textX:: textBeingAccepted.
	leaveEditState
)
public defaultCancelResponse = (
	setVisualText: textX.
	leaveEditState
)
public defaultChangeResponse = (
	enterEditState
)
public editedText = (
	(* On a second thought, this is a more palatable name. *)

	^textBeingAccepted
)
editorWidgetClass = (
	^TextView
)
public enterEditState = (
	isInEditState ifFalse:
		[buildEditModeControls.
		visual add: editModeControls].
	sendUp deliveryOptional adviseOnViewportScrollPosition: self
	(* The controls may be position outside the visible area. Holler up the chain to get a scroll position update from whoever owns the viewport. The update will come as the standard #respondToScrollingInViewport: message. *)
)
public enterReadOnlyState = (
	leftColumn at: 1 put: readOnlyVisual.
	isInReadOnlyState:: true.
)
public hasPendingChanges ^<Boolean> = (
	^isInEditState
)
public isInEditState = (
	^editModeControls notNil
)
public leaveEditState = (
	isInEditState ifTrue:
		[visual remove: editModeControls.
		editModeControls:: nil.
		removeMessages]
)
leaveReadOnlyState = (
	leftColumn at: 1 put: editor.
	isInReadOnlyState:: false.
)
public maybeSelectCurrentLine ^<String> = (
	^editor maybeSelectCurrentLine
)
readOnlyVisual = (
	readOnlyVisual_ isNil ifTrue:
		[readOnlyVisual_:: TextDisplay new].
	readOnlyVisual_ text: text.
	^readOnlyVisual_
)
public receiveRequestFrom: dispatcher <RequestDispatcher> ^<Boolean> = (
	(* Receive a request sent from somewhere using sendDown or sendUp. We are interested specifically in the scrolling notifications sent by the top-level presenter that manages the main viewport. *)
	^dispatcher selector = #respondToScrollingInViewport:
		and: [dispatcher message sendTo: self. true]
)
removeLastMessage = (
	messagesContainer children size > 0 ifTrue: [
		messagesContainer removeAt: messagesContainer children size]
)
public removeMessages = (
	[messagesContainer children size > 0]
		whileTrue: [messagesContainer removeAt: 1]
)
requestVisibilityOfTextInterval: range <Interval> = (
	requestVisibilityOfTextInterval: range withExtraLines: 0
)
requestVisibilityOfTextInterval: range <Interval> withExtraLines: extraLines <Integer> = (
	| startLine endLine textRectangle |
	editor linesDo:
		[:visibleLine :physicalLine :startPosition :endPosition |
		startPosition < range first ifTrue:
			[startLine:: visibleLine].
		(range last < endPosition and: [endLine isNil]) ifTrue:
			[endLine:: visibleLine]].
	(startLine isNil or: [endLine isNil]) ifTrue: [^self].
	textRectangle::
		0 @ ((startLine - 1 - extraLines) * editor lineHeight)
			corner: (0 @ ((endLine + extraLines) * editor lineHeight)).
	requestVisibilityOfRectangle: textRectangle
)
respondToAccept = (
	textBeingAccepted:: editor text asString withSqueakLineEndings.
	acceptResponse
		ifNil: [defaultAcceptResponse]
		ifNotNil: [acceptResponse valueWithPossibleArgument: self]
)
respondToCancel = (
	confirm: 'Confirm Cancel' ifConfirmed:
		[cancelResponse
			ifNil: [defaultCancelResponse]
			ifNotNil: [cancelResponse valueWithPossibleArgument: self]]
)
respondToChange = (
	changeResponse
		ifNil: [defaultChangeResponse]
		ifNotNil: [changeResponse valueWithPossibleArgument: self]
)
public respondToScrollingInViewport: viewport <VerticalViewport> = (
	(* When the visible area of the viewport changes, adjust the position of the accept/cancel buttons so they stay visible if at all possible. All currently existing editors receive this message, so be sure to bail out early if there's nothing to adjust. *)
	| visibleBounds firstBlankHeight |
	editModeControls isNil ifTrue: [^self].
	(* editModeControls is a column with at least 2 cells: a blank and a row with buttons *)
	visibleBounds:: editModeControls localBounds
		translateFrom: editModeControls to: viewport.
	visibleBounds bottom < 0 ifTrue:
		(* Scrolled up out of sight, don't bother adjusting. *)
		[^self].
	visibleBounds top > viewport localBounds bottom ifTrue:
		(* Scrolled down out of sight, don't bother adjusting. *)
	[^self].
	firstBlankHeight::
		((visibleBounds top negated + controlsPadding)
			min: editModeControls localBounds bottom - 30 (* BOGUS, but it's too much hassle to measure the controls properly *))
				max: controlsPadding.
	editModeControls children first area height: firstBlankHeight
)
public selectedText ^<String> = (
	^hasVisual
		ifTrue: [editor selectedText]
		ifFalse: ['']
)
public setText: newText = (
	(* Set the text remembered by the fragment as the original, without affecting the displayed text. *)
	textX:: newText
)
setVisualText: aText = (
	hasVisual ifTrue: [editor text: aText copy]
)
public showMessage: aString = (
	removeMessages.
	addMessage: aString
)
public text ^<String> = (
(* Answer the displayed text (or the text to be displayed, if the fragment hasn't been displayed yet). While the editor is in edit mode, including when acceptResponse is invoked, the result is the 'old' unedited text. *)
	^textX asString
)
public text: newText <Text | String> = (
	textX:: newText.
	setVisualText: textX.
)
) : (
)
public class TextLineEditorFragment = LeafFragment (|
	public text ::= String new.
	public acceptResponse
	public cancelResponse
	textView
|) (
controlBarColor = (
	^Color h: 40 s: 0.5 v: 0.95
)
createAcceptButton = (
	^ActiveIcon new
		image: (HopscotchImages default accept16px);
		hoverImage: (HopscotchImages default accept16pxOver);
		downImage: (HopscotchImages default accept16pxDown);
		action:
			[text:: textView text.
			acceptResponse valueWithPossibleArgument: self]
)
createCancelButton = (
	^ActiveIcon new
		image: (HopscotchImages default cancel16px);
		hoverImage: (HopscotchImages default cancel16pxOver);
		downImage: (HopscotchImages default cancel16pxDown);
		action:
			[cancelResponse valueWithPossibleArgument: self]
)
createTextView = (
	textView:: TextView new.
	textView
		suppressScrollbars: true;
		text: text;
		enterKeyResponse:
			[:defaultResponse |
			text:: textView text.
			acceptResponse valueWithPossibleArgument: self];
		acceptKeyResponse:
			[:defaultResponse |
			text:: textView text.
			acceptResponse valueWithPossibleArgument: self];
		escapeKeyResponse:
			[:defaultResponse |
			cancelResponse valueWithPossibleArgument: self];
		selectAll.
	^textView
)
createVisual = (
	^Row new
		add: createTextView;
		addBlankSize: 2;
		addNew: Wrapper setup:
			[:wrapper |
			wrapper content: createAcceptButton.
			wrapper content area beCentered];
		addBlankSize: 2;
		addNew: Wrapper setup:
			[:wrapper |
			wrapper content: createCancelButton.
			wrapper content area beCentered];
		addBlankSize: 2;
		color: controlBarColor;
		yourself
)
public hasPendingChanges ^<Boolean> = (
	(* Line editors are used in such a manner that they always have pending changes. When accepted, they are replaced with other fragments. *)
	^true
)
) : (
)
) : (
)
class OutlineClasses = (|
	Subject = core Subject.
	Presenter = core Presenter.
	Composer = core Composer.
|) (
public class OutlineItem onModel: m = Subject onModel: m (
(* OutlineItems are created by those presenters that want to include themselves in outlines. An item identifies the owner presenter, the image and the text to display in the outline, and the child items. It is also a subject, so that a presenter can be created on it directly. *)
| text image noImageBlankSize ::=0. childrenX |) (
addChild: newChild <OutlineItem> = (
	childrenX ifNil: [childrenX:: List new].
	childrenX add: newChild.
	^newChild
)
children = (
	^childrenX ifNil: [Array new]
)
public createPresenter = (
	^OutlineItemPresenter subject: self
)
hasChildren ^<Boolean> = (
	^childrenX notNil
)
) : (
)
public class OutlineItemPresenter onSubject: s = Presenter onSubject: s (
(* Displays an OutlineItem as an expandable/collapsible list. *)
) (
definition = (
^
	subject hasChildren
		ifTrue: [expandableDefinition]
		ifFalse: [
			subject text isNil
				ifTrue: [nothing]
				ifFalse: [row: {blank: 12. leafDefinition}]]
)
expandableDefinition = (
^
	subject text notNil
		ifTrue: [fullExpandableDefinition]
		ifFalse: [list: (subject children collect: [:each | each presenter])]
)
fullExpandableDefinition = (
^
	(heading:
		leafDefinition
	details: (
		list: (subject children collect: [:each | each presenter])
		)
	initiallyExpanded: true)
		useExplorerLikeImages: true
)
leafDefinition = (
^
	row: {
			subject image
				ifNil: [blank: subject noImageBlankSize]
				ifNotNil: [image: subject image].
			blank: 3.
			(link: subject text action: [respondToClick]) color: Color black
	}
)
respondToClick = (
	sendUp selectOutlineItem: subject
)
) : (
)
public class Outliner = Composer (
(* Responsible for displaying and managing an outline of a presenter. Displays as a two-part visual: the outline on the left and the actual content on the right.
*)
| outlinedPresenter outlinePresenter outlinedViewport outlineViewport refreshingOutline ::=true. isOutlineHidden ::=false. |) (
public childrenDo: aBlock = (
	aBlock value: outlinedPresenter
)
createOutline = (
	outlinePresenter:: createRootItem presenter.
	outlinePresenter parent: self
)
createRootItem = (
	| root |
	root:: (OutlineItem onModel: outlinedPresenter) text: outlinedPresenter title.
	outlinedPresenter addOutlineItemsTo: root.
	^root children size = 1
		ifTrue: [root children first]
		ifFalse: [root]
)
createVisual ^<Visual> = (
	| row |
	outlinedViewport:: outlinedPresenter viewport.
	(* It's important that the outline is created at the last possible moment,
	i.e. after the visuals of the outlinedPresenter have been created,
	to be sure that the presenter tree has been fully materialized. *)
	createOutline.
	outlineViewport:: Viewport new color: Color white.
	outlineViewport add: outlinePresenter visual in: Anchor.
	row:: Row new.
	row add: outlineViewport.
	row add: outlinedViewport.
	outlinedViewport area
		width: 0;
		elasticity: outlinedViewportElasticity.
	updateOutlineVisibility.
	refreshingOutline: false.
	^row
)
outlineMayHaveChanged = (
	refreshingOutline ifFalse:
		[refreshingOutline:: true.
		[refreshOutline] ensure: [refreshingOutline:: false]]
)
outlineViewportElasticity = (
	^0.25
)
outlinedViewportElasticity = (
	^0.75
)
public presenter: aPresenter <Presenter> = (
	outlinedPresenter:: aPresenter.
	outlinedPresenter parent: self.
)
public receiveRequestFrom: dispatcher ^<Boolean> = (
	(* Receive and process a notice coming from one of the children (usually as the result of using #sendUp). *)

	(self respondsTo: dispatcher selector)
		ifTrue:
			[dispatcher message sendTo: self.
			^true]
		ifFalse:
			[^false]
)
public refresh ^<Visual> = (
	outlinedPresenter refresh.
	refreshOutline
)
refreshOutline = (
	createOutline.
	outlineViewport remove: outlineViewport children first.
	outlineViewport add: outlinePresenter visual in: Anchor.
)
replaceChild: aFragment with: replacement = (
	outlinedPresenter == aFragment ifFalse:
		[^error: 'the argument is not a child of the receiver'].
	outlinedPresenter
		noticeConcealment;
		parent: nil.
	presenter: replacement.
	hasVisual ifTrue:
		[outlinedViewport:: outlinedPresenter viewport.
		visual at: 2 put: outlinedViewport.
		outlinedViewport area
			width: 0;
			elasticity: outlinedViewportElasticity].
	refresh.
)
selectOutlineItem: theItem <OutlineItem> = (
	theItem model respondToOutlineSelection
)
toggleOutline = (
	isOutlineHidden:: isOutlineHidden not.
	updateOutlineVisibility
)
updateOutlineVisibility = (
	outlineViewport area
		width: 0;
		elasticity:
			(isOutlineHidden
				ifTrue: [0]
				ifFalse: [outlineViewportElasticity])
)
public viewport = (
	(* Even when the parent invites us to create a viewport, we display ourselves in a regular visual because both of our components are viewports. *)
	^visual
)
) : (
)
) : (
)
BOGUS = ()
) : (
)