'From Moshi of 3 March 2007 [latest update: #1377] on 30 April 2010 at 12:39:40 am'!
"Change Set:		MenuStructure-yo
Date:			30 April 2010
Author:			Yoshiki Ohshima

Change the structure around menus.

	- A layout is a component and stored in the components dictionary.
	- The component name is #Layout.  The word wrap layouts names are changed to #Layout as well.
	- Components are invited to contribute to the LBox' menu.  invokeMenu:with: asks the box' components.
	- As some illustration of the mechanism, fontChoose: is moved to LWordWrapLayoutF, and beStackButton: is moved to LButtonHandler.
	- Make sure that even if the same component is being installed to the same object, nothing bad happens."!


!LObject methodsFor: 'components' stamp: 'yo 4/29/2010 21:10'!
hasSpecialMenu

	^ false.
! !

!LObject methodsFor: 'components' stamp: 'yo 4/29/2010 23:33'!
installTo: anObject
	"Make self (a Handler) be the listener for announcements that are meant for anObject.  Self is an agent, listening on behalf of anObject.  The kinds of announcements are specified by listensTo method in me (the handler)."
	anObject install: self as: self handlerName.
	whole := anObject.
! !

!LObject methodsFor: 'components' stamp: 'yo 4/29/2010 23:02'!
install: aComponent as: aName

	components ifNil: [components := self identityDictionaryClass new].
	components at: aName ifPresent: [:v | v uninstall].
	aComponent listensTo do: [:cls | (self on: cls to: aComponent) makeWeak].
	aName ifNotNilDo: [:sym | components at: aName put: aComponent].! !

!LObject methodsFor: 'components' stamp: 'yo 4/29/2010 21:10'!
menu

	^ #()
! !

!LObject methodsFor: 'components' stamp: 'yo 4/29/2010 22:00'!
removeComponentAt: aName

	| c |
	components ifNil: [^ self].
	c := components at: aName ifAbsent: [nil].
	c ifNotNil: [self unsubscribe: c. components removeKey: aName].
! !

!LObject methodsFor: 'components' stamp: 'yo 4/29/2010 22:01'!
removeComponent: aComponent

	components ifNotNil: [self removeComponentAt: (components keyAtValue: aComponent)].! !


!LBox methodsFor: 'collection' stamp: 'yo 4/29/2010 23:54'!
checkContentsClass
	"Make sure that contents is an OrderedCollectionLoc if there are a lot of elements"

	| chk |
	chk := contents size.
	contents size < 15 ifTrue: [^ self].
	(contents class == LCollection or: [contents class == OrderedCollection]) ifTrue: [
		contents := contents asOrderedCollectionLoc.
		wholeContents at: 2 put: contents.
		contents size = chk ifFalse: [self error: 'size changed'] ].! !

!LBox methodsFor: 'collection' stamp: 'yo 4/29/2010 21:53'!
ensureTextLayout
	"Force me to have a layout that is able to handle text."

	| lay |
	lay := self layout.
	(lay respondsTo: #font) ifFalse: [
		self layout: LWordWrapLayoutF new.
		lay := self layout.
		lay inset: 2@3;
			client: self;
			tabArray: (30 to: 500 by: 30); 
			font: (LFamily defaultFont "face withSize: 18")].
! !

!LBox methodsFor: 'layout' stamp: 'yo 4/29/2010 23:23'!
fullDrawingBounds

	| boundRects i newBounds |
	(fullDrawingBounds isNil) ifTrue: [
		self layout ifNotNilDo: [:layout |
			layout layoutChildrenFirst ifFalse: [layout layOut: self]].
		i := 1.
		(self hasParticles or: [(self valueOfProperty: #opaqueDamageRect) == true]) ifTrue: [
			boundRects := self arrayClass new: 1]
		ifFalse: [
			boundRects := self arrayClass new: self wholeContentsSize + 1.
			self wholeContentsDo: [:t | boundRects at: i put: t fullDrawingBounds. i := i + 1]].
		self layout ifNotNilDo: [:layout |
			layout layoutChildrenFirst ifTrue: [layout layOut: self]].
		boundRects at: i put: (0@0 extent: self extent).
		newBounds := Rectangle merging: boundRects.
		self clipping ifTrue: [
			newBounds := newBounds intersect: (0@0 extent: self extent)].
		newBounds ~= fullDrawingBounds ifTrue: [
			self invalidRect: (fullDrawingBounds ifNil: [newBounds] ifNotNil: [newBounds quickMerge: fullDrawingBounds]).
			fullDrawingBounds := newBounds].
	].
	^ transformation localBoundsToGlobal: fullDrawingBounds
! !

!LBox methodsFor: 'layout' stamp: 'yo 4/29/2010 23:38'!
layout

	(shape isMemberOf: LGlyphShape) ifTrue: [^ nil].
	^ self componentAt: #Layout
! !

!LBox methodsFor: 'layout' stamp: 'yo 4/29/2010 22:01'!
layout: anObject

	anObject ifNil: [^ self removeComponentAt: #Layout].
	anObject handlerName ~= #Layout ifTrue: [self error: 'it should be a layout object'].
	anObject installTo: self.
! !

!LBox methodsFor: 'user actions' stamp: 'yo 4/30/2010 00:18'!
menu
	"Answer specs that define the generic LBox menu -- an array of (selector item-wording) pairs.   An item consisting of a simple #- signifies a 'line' in the menu.  The receiver of the selectors indicated will be the LBoxMenuHandler associated with the box.      self removeProperty: #menu  "

	| basic |
	^ self valueOfProperty: #menu ifAbsent: [
		basic  := #(
			(chooseColor: 'choose color')
			(border1: 'border width 1')
			(border2: 'border width 2')
			(pickUp:		'pick up')
			(acceptDrops:	'accept drops')
			(sendToRear:		'send to rear')
			(delete:		'delete')
			(userCopy:		'duplicate')).

		(self hasProperty: #ouBackground ) ifFalse: [
			basic  := basic, #((newStack: 'be page in a new stack'))].
		self stack ifNotNil: [
			basic  := basic, #((editScripts: 'edit button script'))].
		(self hasProperty: #ouBackground ) ifTrue: [
			basic  := basic, #((addNavBarAt: 'add navigation bar'))].
		(container isKindOf: LWindow) ifTrue: [
			basic  := basic, #((saveAsSISS: 'save to disk'))].

		basic, #(
			(inspect:	'inspect')
			(viewFields:		'view fields')
		"	(browseProtocol:	'browse protocol')
			(watchVariable:	'watch variable...')"
			-
			(newBox: 		'new box')
			(newButton: 	'new button')
			(newTextField: 'new text field')
			(newBrowser: 	'new browser')
			(newScriptor: 	'new scriptor')
			(newPaintingTool: 	'new painting')
			-
			(inspectInMorphic:		'inspect - morphic')
			(exploreInMorphic:		'explore - morphic')
			-
			(editThisMenu:				'edit this menu'))]! !


!LBox class methodsFor: 'instance creation' stamp: 'yo 4/30/2010 00:25'!
invokeMenu: aMenuBox near: event
	"Put up the menu and let the user choose an item."

	aMenuBox shape color: Color veryLightGray.
	aMenuBox shape borderWidth: 2.
	aMenuBox topLeft: event hand position + (50@-15).
	event root worldState menu: aMenuBox.
	event root addAsParts: aMenuBox.
	event root worldState hand focus: aMenuBox.! !

!LBox class methodsFor: 'instance creation' stamp: 'yo 4/29/2010 21:54'!
newLabel: label width: aNumber justification: aSymbol

	| inst gl layout space inset |
	inst := super new.
	inset := 2.
	aSymbol ~= #left ifTrue: [
		space := LBox extent: 0@0 color: Color transparent.
		(LGlue new stretch: 100000; length: 0) installTo: space.
		inst add: space].
	label do: [:char |
		gl := LFamily defaultFont glyphAt: char asciiValue.
		gl name == #controlHT ifTrue: [gl := gl asTabOfWidth: 12].
		inst add: (LBox withShape: gl   "sets pivot")].
	aSymbol ~= #right ifTrue: [
		space := LBox extent: 0@0 color: Color transparent.
		(LGlue new stretch: 100000; length: 0) installTo: space.
		inst add: space].
	inst shape: (LBoxShape extent: 0@0 color: Color transparent).
	layout := LHorizontalLayout new.
	layout desiredHeight: LFamily defaultFont height.
	layout leftMargin: inset;
		rightMargin: inset;
		topMargin: inset;
		bottomMargin: inset;
		wrap: false;
		baseline: LFamily defaultFont ascent.
	inst layout: layout.
	layout layOut: inst.
	layout naturalLength: (aNumber max: inst width).
	inst pivotRatio: 0@0.
	^ inst.
! !

!LBox class methodsFor: 'instance creation' stamp: 'yo 4/29/2010 21:51'!
newScrollTextExtent: ext

	| scrollText scroll text |
	scrollText := self extent: ext color: Color white.
	scrollText name: 'scroll text field'.

	scrollText layout: (LSimpleLayout new
		keep: #topLeft of: 'textField' to: 0@0;
		keep: #right of: 'textField' to: #right offset: 0;

		keep: #topRight of: 'slider' to: #topRight offset: 0@0;
		keep: #bottom of: 'slider' to: #bottom offset: 0;
		keep: #left of: 'slider' to: #right offset: -10;
	yourself
	).

	text := self newTextField: '' extent: (ext - (10@0)) color: Color white withResizer: false.
	(text componentAt: #Layout) autoVerticalResize: true.
	scroll := self newSliderExtent: 10@ext y.
	scroll on: LSliderChanged to: scrollText.
	scrollText add: text.
	scrollText addAsParts: scroll.
	scroll topRight: ext x+1@0.
	scroll extent: scroll extent x@ext y.
	scrollText setProperty: #text toValue: text.
	scrollText extent: ext.
	scrollText clipping: true.
	text clipping: false.
	LScrollHandler installTo: scrollText.
	(text componentAt: #BoxHandleInvoker) uninstall.
	LBoxHandleInvoker installTo: scrollText.
	^ scrollText.! !

!LBox class methodsFor: 'instance creation' stamp: 'yo 4/29/2010 21:55'!
newTextField: initialContents extent: ext color: aColor withResizer: aBoolean
	"Create a new text field"
	| aa cc rr gg lay  |
	aa := LBox extent: ext color: aColor.
	aa name: 'textField'.
	aa setProperty: #opaqueDamageRect toValue: true.
	aa layout: (lay := LWordWrapLayoutF new).
	lay inset: 2@3;
		client: aa;
		tabArray: (30 to: 500 by: 30); 
		font: (LFamily defaultFont "face withSize: 18") .
		"(LFamily defaultFont face withSize: 18) SavoyeLET  BitstreamVeraSans"
	initialContents do: [:char |
		gg := lay font glyphAt: char asciiValue.
		cc := LBox withShape: gg.
		lay installTo: cc.
		aa add: cc].
	LBoxHandleInvoker installTo: aa.
	aa clipping: true.

	aBoolean ifTrue: [
		rr := LBox extent: (10@10) color: Color green.
		(LResizeHandler withTarget: aa) installTo: rr.
		aa addAsParts: rr.
		rr pivotRatio: 1@1.
		rr pivotPosition: aa extent].
	^ aa
! !


!LButtonHandler methodsFor: 'menu' stamp: 'yo 4/30/2010 00:19'!
beStackButton: evt
	"add a button component to this box.  set target to a forwarder to the current page.  Leave selector unchanged."

	| ef bh |
	evt root worldState deleteHalo.
	bh :=self.
	bh ifNil: [
		ef := LDBJrEventForwarder new ouBackground: whole stack page.
		bh := LButtonHandler withTarget: ef.
		bh installTo: whole].
	bh target useCurrentPage ifFalse: [
		ef := LDBJrEventForwarder new ouBackground: whole stack page.
		bh target: ef].
	evt handled: self.! !

!LButtonHandler methodsFor: 'menu' stamp: 'yo 4/30/2010 00:20'!
menu

	^ #((beStackButton: 'be stack button')).
! !


!LBoxMenuHandler methodsFor: 'as yet unclassified' stamp: 'yo 4/29/2010 21:41'!
addMenuItems: c into: m menuTarget: t with: event

	| items mi |
	items := c menu.
	items size > 0 ifTrue: [items := #(-), items].
	items do: [:pair |
		pair = #-
			ifTrue:
				[mi := LBox extent: (0@8) color: Color transparent]
			ifFalse:
				[mi := LBox newMenuItem: pair second target: t selector: pair first argument: event for: m].
		m add: mi.
	].
! !

!LBoxMenuHandler methodsFor: 'as yet unclassified' stamp: 'yo 4/29/2010 21:34'!
invokeMenu: dummy with: event
	"The button came up inside the receiver; dispatch accordingly."

	| m |
	m := LBox newMenu.
	target componentsDo: [:c |
		c hasSpecialMenu
			ifTrue: [
				self addMenuItems: c into: m menuTarget: c with: event.
				self presentMenu: m with: event.
				^ self]].
	self addMenuItems: target into: m menuTarget: self with: event.
	target componentsDo: [:c |
		self addMenuItems: c into: m menuTarget: c with: event].
	self presentMenu: m with: event.
! !

!LBoxMenuHandler methodsFor: 'as yet unclassified' stamp: 'yo 4/29/2010 21:36'!
presentMenu: m with: event

	m shape color: (target valueOfProperty: #menuColor ifAbsent: [Color veryLightGray]).
	m shape borderWidth: (target valueOfProperty: #menuBorderWidth ifAbsent: [2]).
	event root addAsParts: m.
	event root worldState menu: m.
	event hand focus: m.
	m layout layOut: m.
	m position: (whole globalPointFor: 0@0).
	m left < 0 ifTrue: [m left: 0].
	m right >= event root extent x ifTrue: [m right: event root extent x ].
	m top < 0 ifTrue: [m top: 0].
	m bottom > event root extent y ifTrue: [m bottom: event root extent y].
	event handled: self.


! !

!LBoxMenuHandler methodsFor: 'menu commands' stamp: 'yo 4/30/2010 00:23'!
newButton: event
	"Create a default button"

	| button |
	button :=  LBox newLabel: ' Click here ' width: 0 justification: #center.
	(target canInclude: button) ifFalse: [self beep.  ^ false].
	button shape color: Color yellow.
	(LButtonHandler withTarget: target withSelector: #beep) installTo: button.
	target addFirst: button.
	button position: (event localPointFor: target) + (0,50).
	button shape borderWidth: 1.
	button name:  'button'.
	LBoxHandleInvoker installTo: button.
	event root worldState deleteHalo.
! !


!LCollection methodsFor: 'copying' stamp: 'yo 4/29/2010 23:52'!
asOrderedCollectionLoc
	"Answer an OrderedCollectionLoc whose elements are the elements of the
	receiver.  Used when indexOf: needs to run fast."

	^ self as: OrderedCollectionLoc! !

!LCollection methodsFor: 'enumerating' stamp: 'yo 4/29/2010 23:39'!
inject: thisValue into: binaryBlock 
	"Accumulate a running value associated with evaluating the argument, 
	binaryBlock, with the current value of the argument, thisValue, and the 
	receiver as block arguments. For instance, to sum the numeric elements 
	of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal + 
	next]."

	| nextValue |
	nextValue _ thisValue.
	self do: [:each | nextValue _ binaryBlock value: nextValue value: each].
	^nextValue! !


!LLayout methodsFor: 'all' stamp: 'yo 4/29/2010 21:47'!
handlerName

	^ #Layout
! !


!LHorizontalLayout methodsFor: 'all' stamp: 'yo 4/29/2010 23:41'!
basicLayOut: aBox
	"all text in one line.  For labels"

	| x y h w |
	aBox ifEmpty: [^self].
	desiredHeight ifNotNil: [
		h := desiredHeight
	] ifNil: [
		h := aBox contents inject: 0 into: [:hh :b | hh max: b height]
	].
	h := h + topMargin + bottomMargin.
	x := leftMargin.
	y := relativeBaseline ifTrue: [baseline * h] ifFalse: [baseline + topMargin].
	aBox contentsDo: [:tr |
		tr pivotPosition:(x - tr pivotOffset x)@y.
		x := x + tr extent x.
	].
	w := x + rightMargin.
	naturalLength ifNotNil: [w := naturalLength].
	aBox extent: w@h.
! !

!LHorizontalLayout methodsFor: 'all' stamp: 'yo 4/29/2010 21:46'!
receive: ann from: anLObject

	(ann isMemberOf: LExtentChanged) ifTrue: [
		ann object = whole ifTrue: [
			naturalLength ifNotNil: [
				naturalLength := whole width]]].
! !


!LListHandler methodsFor: 'as yet unclassified' stamp: 'yo 4/30/2010 00:16'!
receive: ann from: anObject

	super receive: ann from: anObject.
	ann handled ifTrue: [^ ann].
	(ann isMemberOf: LListSelected) ifTrue: [
		isMenu ifTrue: [
			ann hand focus: nil.
			whole delete.
			"ann hand owner worldState deleteMenu."
		] ifFalse: [
			whole ~= anObject ifTrue: [whole announce: ann].
		].
	].
	(ann isMemberOf: LListChanged) ifTrue: [
		whole top: 0.
		whole removeAll.
		whole addAll: (self makeListFrom: ann list).
	].
	(ann isMemberOf: LListSelectionChanged) ifTrue: [
		ann index notNil ifTrue: [
			selected ifNotNil: [(selected componentAt: #ListItemHandler) ifNotNilDo: [:e | e unselect]].
			((selected := whole contents at: ann index) componentAt: #ListItemHandler) ifNotNilDo: [:e | e select].
		].
	].
	(ann isMemberOf: LButtonDownEvent) ifTrue: [
		isMenu ifTrue: [
			ann hand focus: nil.
			"whole delete."
			ann root worldState deleteMenu.
			ann handled: self]].
! !


!LMotionLayout methodsFor: 'as yet unclassified' stamp: 'yo 4/29/2010 21:51'!
handlerName

	^ #Layout
! !


!LVerticalLayout methodsFor: 'as yet unclassified' stamp: 'yo 4/29/2010 21:45'!
receive: ann from: anLObject

	(ann isMemberOf: LExtentChanged) ifTrue: [
		ann object = whole ifTrue: [
			naturalLength ifNotNil: [
				naturalLength := whole height]]].
! !


!LWordWrapLayoutPre methodsFor: 'events' stamp: 'yo 4/29/2010 21:51'!
handlerName

	^ #Layout

! !


!LWordWrapLayoutF methodsFor: 'menu' stamp: 'yo 4/30/2010 00:10'!
fontChoose: evt
	"Change the selection to a new font"

	evt handled: self.
	evt root worldState deleteHalo.
	LBox chooseFont: evt inLayout: self.
! !

!LWordWrapLayoutF methodsFor: 'menu' stamp: 'yo 4/30/2010 00:02'!
menu

	^ #((fontChoose: 'choose font'))! !

LWorldState removeSelector: #menu!
LObject removeSelector: #addComponent:as:!