[Indigo]<KRL>code>alignControl.bravo!1

[AlignCompleted ((success (MEMQ ABORT FAIL SUCCEED))
(RETURNS ANY (* does a RETFROM FullAlign)))
(* this is the systematic way to get out of a FullAlign. It probes the signal table for a return value, and releases the goal records used in the alignment. Any other exit will cause the goals not to be released, but they will be garbage collected anyway if nobody is pointing to them (including the printname table))

(DPROGN ((alignValue ANY (BOUNDIN FullAlign)))
(activeGoals (LST OF Goal) (BOUNDIN FullAlign))
(oldGoals (LST OF Goal) (BOUNDIN FullAlign))
(topLevelGoal Goal (BOUNDIN FullAlign)))
(OR success (alignValue ← NIL))
(if (NEQ ’OK (Signal (if success then ’ValueForAlign else ’ValueForAlignFailed)
matchTable)))
then (KHelp "Bad value for signal ValueForAlign(Failed)" signalValue
"The value returned from FullAlign will be the value of the free variable alignValue. Signal should set it and return OK. Normal exit from this error causes FullAlign to return current value of alignValue")
(ReleaseGoal topLevelGoal)
(RETFROM FullAlign alignValue))]

[FullAlign ((datum (ONEOF Link DHandle) (USEDIN alignment including action specs))
(pattern (ONEOF Link DHandle)
(USEDIN alignment including action specs))
(matchTable MatchTable (USEDIN alignment including action specs))
(bindings (LISTP OF Binding)
(USEDIN alignment including action specs))
(RETURNS ANY))

(DPROG(alignValue NIL ANY (USEDIN alignment)
(* set by signal response to give value to be returned)
(fullAlign T BOOL (USEDIN alignment)
(* so signals, triggers, etc. know that the full alignment environment is there)
(alignEnvironment (STKNTH ’FullAlign) STACKP
(USEDIN alignment) (* to evaluate forms in actions and binding specs)
(structuralMatch (MSignalC StructuralMatch (OK T) NIL)
BOOL (USEDIN alignment))
(canMatch (MSignalC SimpleCanMatch (OK T) NIL)
BOOL (USEDIN alignment))
(describe (MSignalC ImplicitDescribe (OK T) NIL)
BOOL (USEDIN alignment))
(overWrite (MSignalC OverWrite (OK T) NIL)
(topLevelGoal NIL Goal (USEDIN AlignCompleted))
(pat NIL DHandle)
(dat NIL DHandle)
(patternContext NIL (ONEOF NIL FullContext))
(datumContext NIL (ONEOF NIL FullContext)))

(if (FMEMB (TypeK datum) ’(Descriptor Anchor))
then (dat ← datum)
elseif (IsLink datum)
then (datumContext ← datum:fullContext) (dat ← datum:structure)
else (KHelp "Illegal datum type" datum
"The datum for FullAlign must be an anchor or descriptor. Type SUCCEED or FAIL to return normally from FullAlign, Any other exit aborts whole alignment."
(SUCEEED(AlignCompleted ’SUCCEED))
(FAIL (AlignCompleted ’FAIL))
(AlignCompleted ’ABORT))))

(if (FMEMB (TypeK pattern) ’(Descriptor Anchor))
then (patternContext ← NIL) (pat ← pattern)
elseif (IsLink pattern)
then (patternContext ← pattern:fullContext) (pat ← pattern:structure)
else (KHelp "Illegal pattern type" pattern
"The pattern for a FullAlign must be an anchor or descriptor. Type SUCCEED or FAIL to return normally from FullAlign,. Any other exit aborts whole alignment."
(SUCEEED(AlignCompleted ’SUCCEED))
(FAIL (AlignCompleted ’FAIL))
(AlignCompleted ’ABORT))))

(topLevelGoal ← (CREATE Goal
resultType ← ’TopLevelGoal
goalDesc ← pat
patternContext ← patternContext
datum ← dat
datumContext ← datumContext
anchorPath ← <dat>)
(* Goal type will be filled in by the appropriate SETUP recipient based on the pattern)

(if (EQ (TypeK pat) ’Anchor)
then (SetUpAnchorMatch topLevelGoal)
else (SetUpGoalForDescriptor topLevelGoal pat))
(AlignCompleted (RunGoal topLevelGoal)]

[RunGoal ((goal Goal) (RETURNS Irrelevant))
(DPROG((activeGoals NIL (LST OF Goal) (USEDIN alignment))
(oldGoals NIL (LST OF Goal) (USEDIN alignment))
(oldResults NIL (LST OF Result) (USEDIN alignment))
(somethingHappened T BOOL
(* used to stop the looping when an entire goaround doesn’t cause any new action))
(goalPos NIL LISTP (* used in deleting elements from activeGoals))
(dummy ’(DUMMY) LISTP
(* used as a header for goalPos in deleting elements from activeGoals)))

(SELECTQ goal:goalStatus
((FAILED ABORTED) (RETURN ’FAIL))
(SUCCEEDED (RETURN ’SUCCEED))
((NEW AFTERFIRST)(StartUpGoal goal))
((ACTIVE WAITING) (activeGoals ← goal))
(KHelp "Bad goal status" goal))

(* the following loop is exited by a RETFROM FullAlign or RunGoal.)
(do (if (NOT activeGoals)
then (MSignal NothingToDo
(SUCCEED (RETFROM ’RunGoal ’SUCCEED))
(FAIL (RETFROM ’RunGoal ’FAIL)))
elseif (NOT (for goal in activeGoals thereis (NOT goal:suspended)))
then (MSignal AllGoalsSuspended
(OK (for goal in activeGoals do (GoalResumed goal)))
(SUCCEED (RETFROM ’RunGoal ’SUCCEED))
(FAIL (RETFROM ’RunGoal ’FAIL)))
elseif (NOT somethingHappened)
then (MSignalC NothingHappened
(OK (for goal in activeGoals do (GoalResumed goal)))
(SUCCEED (RETFROM ’RunGoal ’SUCCEED))
(FAIL (RETFROM ’RunGoal ’FAIL)))
(somethingHappened ← NIL)
(for goal in activeGoals
when (NOT goal:suspended)
do (SELECTQ goal:goalStatus
((NEW AFTERFIRST) (StartUpGoal goal) (somethingHappened ← T))
(ACTIVE
(if (NEQ goal:links goal:oldLinks)
then (somethingHappened ← T)
(DPROG ((theseLinks goal:links (LISTP OF Link))
(oldLinks
goal:oldLinks
(LST OF Link)
(SATISFIES (TAILP oldLinks theseLinks)))
(fullContext NIL FullContext))
(while (AND (NEQ theseLinks oldLinks)
(NOT goal:suspended)
(EQ goal:goalStatus ’ACTIVE))
do (oldLinks ← (NLEFT theseLinks 1 oldLinks))
(OR (UseLink goal link)
(AND (POP oldLinks)(RETURN)))
(* so this one will get done again if the goal is resumed))
(goal:oldLinks ← oldLinks)))))
(WAITING NIL)
(PUSHNEW oldGoals goal))))

(* the deletion is done this way, so that goals which become inactive while the process
is going on will not be deleted from the middle of the list, screwing up the
iterative statement above)
(goalPos ← (RPLACD dummy activeGoals))
(while goalPos::1
do (if (FMEMB (goalPos:2:goalStatus)
’(NEW ACTIVE AFTERFIRST WAITING))
then (* step on through the list)
(goalPos ← goalPos::1)
else (* clobber out the top goal)
(goalPos::1 ← goalPos::2)))
(* end of the top-level do loop. go around again and see if anything happened]

[SetUpGoal ((goal Goal)
(parent (ONEOF Goal NIL))
(goalType LITATOM (* can be NIL))
(RETURNS BOOL))
(OR goal:goalType (goal:goalType ← goalType))
(SendMessage (OR goalType goal:goalType) goal ’SETUP)
(if (EQ goal:goalStatus ’NOTSETUP) then (goal:goalStatus ← ’NEW))
(if (EQ (TypeK goal:goalDesc) ’Descriptor) then (NoDescriptorMeta goal))
(if canMatch
then (GoalDone self ’SUCCEEDED)
elseif structuralMatch
then (GoalDone self ’FAILED)
elseif parent
then (if goal:suspended
then (ReleaseGoal goal) NIL
else (PUSH parent:children goal) T)
else T]

[StartUpGoal ((goal Goal)(RETURNS Irrelevant))

(DPROG((value NIL ANY))
(if (AND (EQ goal:goalStatus ’NEW) (NOT goal:suspended))
then (value ← (SendMessage goal:goalType goal ’STARTUP))
(SELECTQ value
(OK (for descriptor descriptorOf goal:datum
do (if (NOT goal:suspended)
then (TryDescriptor descriptor goal goal:datumContext T))
else (KHELP "goal suspended in initial pass" goal))))
(SKIP T)
(KHelp "illegal return for STARTUP" value))

(if goal:suspended
then (goal:goalStatus ← ’AFTERFIRST) (RETURN)
else (SendMessage goal:goalType goal ’AFTERFIRST)
(if (FMEMB goal:status ’(NEW AFTERFIRST))
then (goal:goalStatus ← ’ACTIVE)))

(for child in goal:children do (StartUpGoal child))
(if (FMEMB goal:goalStatus ’(ACTIVE WAITING)) then (PUSH activeGoals goal)]

[SuccessfulResults ((pendingResults (LST OF Result))(RETURNS Irrelevant))
(DPROG ((newResult NIL Result))
(DECL ((oldResults (LST OF Result)(BOUNDIN FullAlign))
(alignValue ANY (BOUNDIN FullAlign)))
(while pendingResults
do (newResult ← (POP pendingResults))
(MSignal FoundTopGoalResult
(STOP (AlignCompleted ’SUCCEED))
(OK (DoActions newResult)
(PUSH oldResults newResult)
(MSignal CompletedTopGoalResult
(STOP (PUSH alignValue (OR newResult:resultValue
newResult:bindings))
(AlignCompleted ’SUCCEED))
(OK (PUSH alignValue (OR newResult:resultValue
newResult:bindings))]

[TryDescriptor ((descriptor Descriptor (USEDIN message NEWDESCRIPTOR))
(goal Goal (USEDIN message TRY))
(fullContext (ONEOF FullContext NIL) (USEDIN messages))
(knownCompatible (ONEOF NIL T NO)
(* world has been checked as compatible))
(RETURNS Irrelevant))
(DPROG((type (TypeD descriptor) LITATOM (USEDIN messages))
(descriptorCategory NIL Anchor)
(if (OR (EQ knownCompatible ’NO)
(AND (NOT knownCompatible)
(NOT (CompatibleWorld fullContext:world goal:patternContext:world))))
then (OR structuralMatch (SendMessage type descriptor ’ADDLINK))
(RETURN))

(if (AND goal:patCategories
(descriptorCategory ←
(SELECTQ type
(MapDescriptor (FetchMem descriptor focusSlot (ConstantHandle)))
((KrlPointer LispPointer) (GetSystemCategory descriptor))
NIL))
(for anchor in goal:patCategories
thereis (EQ ’CONFLICT (TreeRelation anchor descriptorCategory))))
then (GoalDone goal ’FAILED)(RETURN)
elseif (NOT structuralMatch)
then (SELECTQ (SendMessage type descriptor ’TRY)
(OK T)
(SKIP (RETURN))
(DHelp "illegal response for TRY" descriptor)))

(SendMessage goal:goalType goal ’NEWDESCRIPTOR)

(OR structuralMatch
(goal:suspended)
(SendMessage type descriptor ’ADDLINK))]