-- <<<-


------------------------------------------------------------------------


global dropActor
global dropReactor


------------------------------------------------------------------------


function defineClasses -> (
	function defineClasses -> ok


------------------------------------------------------------------------


-- Class RulePresenter is a presenter which represents a behavioral rule for 
-- an object.
class RulePresenter (TrackerTwoDSpace)
instance variables
	manager
	actorText
	actionList
	reactionList
	grabParent:undefined
	grabPosition
	grabOffset
end


method init self {class RulePresenter} #rest args #key manager: ->
(
	apply nextMethod self args
	self.manager := manager

	-- Add a label for the actor.
	local t := new TextPresenter target:"" \
		fill:(new Brush color:(new RGBColor red:200 green:200 blue:200)) \
		stroke:blackBrush \
		boundary:(new Rect x2:68 y2:13)
	setDefaultAttr t @size 10
	setDefaultAttr t @font (new PlatformFont name:"Times")
	setDefaultAttr t @leading 0
	setDefaultAttr t @paraIndent 5
	t.x := 6
	t.y := 4
	prepend self t
	self.actorText := t

	-- Add a pick list for the actions.
	local actionList := new PickList boundary:(new Rect x2:78 y2:13) \
		fill:(new Brush color:(new RGBColor red:200 green:200 blue:200)) \
		stroke:blackBrush
	actionList.x := 84
	actionList.y := 4
	prepend self actionList
	actionList.selectionAction := (target selection -> 
		selectAction self selection)
	self.actionList := actionList

	-- Add a pick list for the reactions.
	local reactionList := new PickList boundary:(new Rect x2:78 y2:13) \
		fill:whiteBrush stroke:blackBrush
	reactionList.x := 174
	reactionList.y := 4
	prepend self reactionList
	reactionList.selectionAction := (target selection -> 
		selectReaction self selection)
	self.reactionList := reactionList
	
	-- Update actor and action list, if there is an actor.
	local r := self.target
	local actor := r.actor
	if (actor <> undefined) do
	(
		self.actorText.target := actor.name
		self.actorText.fill := whiteBrush
		local actions := getActions actor
		setChoices actionList actions
		if (r.action <> undefined) do
		(
			setSelection actionList r.action
			actionList.fill := whiteBrush
		)
	)
	-- Update reaction list.
	local perp := r.reactor
	local actions := getActions perp
	setChoices reactionList actions
	if (r.reaction <> undefined) then
	(
		setSelection reactionList r.reaction
	) else
		r.reaction := reactionList.selection
)


-- Method selectAction is the callback for the action picklist. When a new 
-- action is selected, the old rule is deleted, because the action name is 
-- used as a key for the rule. Then, the new rule is added with the updated 
-- key.
method selectAction self {class RulePresenter} selection ->
(
	local r := self.target
	updateRuleAction r.reactor r selection
)


-- Method trackStart is called by the tracking service. Translate the tracking 
-- matrix so that coordinates are in the grandparent's coordinate system.
method trackStart self {class RulePresenter} service ev state ->
(
	-- See if subpresenters want tracking..
	if (nextMethod self service ev state) do
		return true

	state[@trackMatrix] := translate state[@trackMatrix] \
		(self.presentedBy.x + self.x) (self.presentedBy.y + self.y)
	self.grabOffset := copy ev.localCoords
	return true
)


-- Method trackDown is called by the tracking service. Move self into 
-- grandparent space, and change the outline to a thick patterned light gray.
method trackDown self {class RulePresenter} service ev ->
(
	self.grabPosition := self.position
	self.grabParent := self.presentedBy

	-- Move self into grandparent space.
	self.x := self.presentedBy.x + self.x
	self.y := self.presentedBy.y + self.y
	prepend self.presentedBy.presentedBy self
	local outline := new Brush color:(new RGBColor red:200 green:200 blue:200) \
		pattern:@dkGrayPattern
	outline.lineWidth := 3
	self.stroke := outline
)


-- Method trackMove is called by the tracking service. Follow the mouse.
method trackMove self {class RulePresenter} service ev ->
(
	local position := ev.localCoords
	self.x := position.x - self.grabOffset.x
	self.y := position.y - self.grabOffset.y
)


-- Method trackUp is called by the tracking service. Notify the manager that 
-- I have been dropped.
method trackUp self {class RulePresenter} service ev ->
(
	if (self.grabParent <> undefined) do
		dropRule self.manager self
	self.grabParent := undefined
)


-- Method selectReaction is the callback for the reaction picklist. Simply 
-- change the reaction in the existing rule.
method selectReaction self {class RulePresenter} selection ->
(
	-- Simply change reaction in rule.
	local r := self.target
	r.reaction := selection
)


-- Method setActor sets the actor for the rule. It creates a label for the 
-- actor, and updates the action picklist with a list of the actor's 
-- available actions.
method setActor self {class RulePresenter} perp ->
(
	-- Display the name of the actor..
	self.actorText.target := perp.name as StringConstant
	self.actorText.fill := whiteBrush
	self.actionList.fill := whiteBrush

	-- Set the choices of the action pick list.
	local actions := getActions perp
	setChoices self.actionList actions

	-- Add rule to perpetrator's reaction table.
	local r := self.target
	r.actor := perp
	r.action := self.actionList.selection
	addRule r.reactor r
)


------------------------------------------------------------------------


-- Class BehaviorLab is a tool for modifying the behavior of Perpetrator
-- objects. It edits the reaction table of a Perpetrator. It lists the
-- actions of objects using the getActions method.
class BehaviorLab (TrackerTwoDSpace, Tool)
instance variables
	images
	activeRule:undefined	-- The currently selected rule.
	reactor:undefined		-- The object whose rules are being edited.
	actorSlot		-- A drop slot for the actor.
	reactorSlot		-- A drop slot for the reactor.
	ruleListBox		-- List box for all of the rule presenters.
	ruleList			-- List of rule presenters.
	scrollOffset:0		-- Offset in rule list box.
	upArrow		-- Presenter for scrolling up.
	downArrow		-- Presenter for scrolling down.
	bellSound
	dropSound		-- Sound to play when an object is dropped.
end


method init self {class BehaviorLab} #rest args #key \
	images:(undefined) \
	sounds:(undefined) ->
(
	apply nextMethod self \
					 boundary: (new Rect x2:374 y2:163) \
				     onIcon: images["onicon"] \
				     offIcon: images["officon"] \
				     name: @pavlov \
					 args

	self.images := images

	local dropSound := sounds["drop sound"]
	addTimeCallback dropSound (plyr ->
		stop plyr
		goToBegin plyr
		playPrepare plyr 1.0
	) dropSound #() dropSound.duration false
	self.dropSound := dropSound

	-- Add the title bar.
	local t := new TitleBar boundary:(new Rect x2:self.width y2:20)
	prepend self t

	-- Add the backdrop
	t := new TwoDShape boundary:images["pavlov"]
	append self t

	-- Add object slots.
	local s := new DropSlot boundary:(new Rect x2:66 y2:72) 
	s.target := self
	s.dropAction := dropReactor
	s.x := 14
	s.y := 48
	prepend self s
	self.reactorSlot := s

	local s := new DropSlot boundary:(new Rect x2:62 y2:128)
	s.target := self
	s.dropAction := dropActor
	s.x := 90
	s.y := 21
	prepend self s
	self.actorSlot := s

	-- Add rule list.
	local ruleListBox := new TrackerTwoDSpace boundary:(new Rect x2:258 y2:128)
	ruleListBox.position := new Point x:88 y:22
	prepend self ruleListBox
	self.ruleListBox := ruleListBox
	self.ruleList := new Array

	-- Add a close box.
	local t := createCloseBox self
	t.x := 9
	t.y := 7
	prepend self t

	-- Create scroll up and scroll down presenters.
	t := new TrackerTwoDShape boundary:images["up arrow"]
	t.x := 349
	t.y := 21
	method trackUp obj {object t} service ev ->
	(
		if (inside obj.boundary ev.localCoords) do
		(
			scrollUp self
		)
	)
	self.upArrow := t

	t := new TrackerTwoDShape boundary:images["down arrow"]
	t.x := 349
	t.y := 136
	method trackUp obj {object t} service ev ->
	(
		if (inside obj.boundary ev.localCoords) do
		(
			scrollDown self
		)
	)
	self.downArrow := t

	registerTool theNavigator self
)


method scrollUp self {class BehaviorLab} ->
(
	self.scrollOffset := max 0 (self.scrollOffset - 1)
	layoutRules self
)


method scrollDown self {class BehaviorLab} ->
(
	self.scrollOffset := self.scrollOffset + 1
	layoutRules self
)


method scaleThumbnail self {class BehaviorLab} icon -> (
	local ibbox := icon.bbox
	local width := 32
	local height := 32
	if ((ibbox.x1 == 0) and 
		(ibbox.y1 == 0) and 
		(ibbox.x2 == width) and 
		(ibbox.y2 == height)) then (
		return icon
	) else (
		local bm := new BitmapSurface \
						bbox: (new Rect x2: width y2: height) \
						colorMap: theDefault8Colormap
		local icolor := icon.invisibleColor
		if (icolor == undefined) do (icolor := whiteColor)
		erase bm (new Brush color: icolor)
		local mat := mutableCopy identityMatrix
		translate mat (-ibbox.x1) (-ibbox.y1)
		local sc
		if (ibbox.width > ibbox.height) then (
			sc := width / ibbox.width
			scale mat sc sc
			translate mat 0 ((height - (ibbox.height * sc)) / 2)
		) else (
			sc := height / ibbox.height
			scale mat sc sc
			translate mat ((width - (ibbox.width * sc)) / 2) 0
		)
		transfer bm (icon as BitmapSurface) bm mat
		bm := bm as Bitmap
		bm.invisibleColor := icolor
		return bm
	)
)


method layoutRules self {class BehaviorLab} ->
(
	local ruleList := self.ruleList
	local scrollOffset := self.scrollOffset
	local height := self.activeRule.height
	local visibleRules := 6
	local rulesToDisplay := min (visibleRules - 1) ((size ruleList - 1) - scrollOffset)
	rulesToDisplay := max 0 rulesToDisplay
	local count := 0

	-- Move all offscreen, then set positions of displayed rules.
	for rp in ruleList do rp.y := -100
	if (rulesToDisplay > 0) do
	(
		for i := (scrollOffset + 1) to (scrollOffset + rulesToDisplay) do
		(
			ruleList[i].y := count * height
			count := count + 1
		)
	)
	-- Put dummy rule at the bottom.
	self.activeRule.y := rulesToDisplay * height

	-- Determine if up arrow should be shown or hidden.
	if (scrollOffset > 0) then
	(
		if (self.upArrow.presentedBy = undefined) do
			prepend self self.upArrow
	) else
	(
		if (self.upArrow.presentedBy <> undefined) do
			deleteOne self self.upArrow
	)

	-- Determine if down arrow should be shown or hidden.
	if (((size ruleList) - scrollOffset) > visibleRules) then
	(
		if (self.downArrow.presentedBy = undefined) do
			prepend self self.downArrow
	) else
	(
		if (self.downArrow.presentedBy <> undefined) do
			deleteOne self self.downArrow
	)
)


-- Method dropReactor is called when an object is dropped in the reactor slot.
method dropReactor self {class BehaviorLab} perp x y ->
(
	play self.dropSound

	-- Clear out old rules.
	emptyOut self.reactorSlot
	for rp in self.ruleList do deleteOne rp.presentedBy rp
	emptyOut self.ruleList
	self.scrollOffset := 0

	-- Add a thumbnail to the drop slot.
	local b := scaleThumbnail self (getThumbnail perp)
	local t := new TwoDShape boundary:(new Rect x2:54 y2:58) \
		fill:(new Brush color: (new RGBColor red: 128 green: 128 blue: 128)) \
		stroke:blackBrush
	t.x := 6
	t.y := 7
	prepend self.reactorSlot t
	t := new TwoDShape boundary:b
	t.x := (self.reactorSlot.width - t.width) / 2
	t.y := (self.reactorSlot.height - t.height) / 2
	prepend self.reactorSlot t

	-- Update rule list box.
	if (self.reactor <> undefined) do
	(
		emptyOut self.ruleListBox
		emptyOut self.ruleList
	)
	self.reactor := perp
	forEachBinding perp.rules (k v a ->
	(
		addRule self v
	)) undefined

	-- Add a new dummy rule.
	local r := new Rule
	r.reactor := perp
	addRule self r
	layoutRules self

	-- XX Until we can move it to its original location.
--	perp.dy := 0
)


-- Method addRule adds a rule to the list.
method addRule self {class BehaviorLab} aRule ->
(
	local rp := new RulePresenter manager:self target:aRule boundary:(new Rect x2:258 y2:21)
	append self.ruleListBox rp
	append self.ruleList rp
	self.activeRule := rp
)


-- Method dropActor is called when an object is dropped in the actor slot.
method dropActor self {class BehaviorLab} perp x y ->
(
	-- Prevent reaction to own actions.
	if (perp = self.reactor) do
		return undefined

	-- If there is an active rule, set the actor, and add a dummy rule.
	if (self.activeRule <> undefined) do
	(
		setActor self.activeRule perp

		-- Add a new dummy rule.
		local r := new Rule
		r.reactor := self.reactor
		addRule self r
		self.scrollOffset := max 0 ((size self.ruleList) - 6)
		layoutRules self
	)

	-- XX Until we can move it to its original location.
	perp.dy := 5
)


-- Method dropRule is called when a rule has been dropped. If it is dropped on the trash can,
-- delete the rule presenter and the rule.Otherwise, put the rule back where it was grabbed.
method dropRule self {class BehaviorLab} rp ->
(
	-- If rule is "complete" (has an actor) and is dropped on trash, delete it.
	local mousePosition := new Point x:(rp.position.x + rp.grabOffset.x) \
		y:(rp.position.y + rp.grabOffset.y)
	if ((inside (new Rect x1:52 y1:124 x2:77 y2:151) mousePosition) and \
		(rp.target.actor <> undefined)) then
	(
		deleteOne self.ruleList rp
		deleteOne rp.presentedBy rp
		local r := rp.target
		deleteRule r.reactor r
		if (size self.ruleList >= 6) do
			self.scrollOffset := max 0 (self.scrollOffset - 1)
		layoutRules self
	) else
	-- Otherwise, put the rule back where it was grabbed.
	(
		prepend rp.grabParent rp
		rp.position := rp.grabPosition
		rp.stroke := undefined
	)
)


------------------------------------------------------------------------


) -- defineClasses


------------------------------------------------------------------------


#(
	@sounds: #(
		"drop sound": #(
			@name: "join.aif"
		)
	),

	@images: #(
		"icon": #(
			@name: "bellicon.bmp",
			@invisibleColor: whiteColor
		),
		"pavlov": #(
			@name: "pavlov.bmp",
			@invisibleColor: whiteColor
		),
		"up arrow": #(
			@name: "uparrow.bmp",
			@invisibleColor: undefined
		),
		"down arrow": #(
			@name: "dnarrow.bmp",
			@invisibleColor: undefined
		),
		"onicon": #(
			@name: "pavon.bmp",
			@invisibleColor: whiteColor
		),
		"officon": #(
			@name: "pavoff.bmp",
			@invisibleColor: whiteColor
		)
	),

	@products: #(
		#(
			@name: #(" System", "Pavlov", theProductId),
			@icon: "icon",
			
			@factory: (prodDesc #rest args ->
				defineClasses()

				local cont := prodDesc[@container]

				apply new BehaviorLab \
						  images: cont[@images] \
						  sounds: cont[@sounds] \
						  args
			),
			
			@args: #(
				@x: 50,
				@y: 100,
				@visible: false
			)
		)
	)
)


------------------------------------------------------------------------


-- >>>