% Generalized Left Corner parsing
% following Stabler's class notes chapter 6
% coded by John Hale October 3rd 2006
% expanded from recognizer to parser October 6th
%
% as of November 16th it also checks stack-consistency using an Oracle (beginning.oz)
% and implements Ford Bresnan & Kaplan's 1982 Final Arguments principle in a simple way.

declare

% Since dictionary keys can only be literals (not lists)
% convert lists into atoms. The Mozart documentation tells you not to do this
%
% "We recommend to avoid as much as possible dynamically creating atoms"
%      http://www.mozart-oz.org/documentation/limitations/
%
% because the atom table isn't garbage-collected. However there's only one new atom per grammar rule.
fun {AtomOfList L} {VirtualString.toAtom {List.foldR L fun {$ X Y} X#Y end nil}} end

% create a new dictionary indexed by triggers
fun {DictByTrigger L} MyD={Dictionary.new} in
   for LHS#Trigger#Predicted in L do
      local Key={AtomOfList Trigger} in
	 if {Dictionary.member MyD Key} % triggers more than one possible rule
	 then
	    {Dictionary.put MyD Key
	      (LHS#Trigger#Predicted)|{Dictionary.get MyD Key}} % cons the new one on

	    %% try adding them backwards -- PROVISIONAL
	    %% {List.append {Dictionary.get MyD Key} [(LHS#Trigger#Predicted)]}}
	    %% -- PROVISIONAL
	    
	 else {Dictionary.put MyD Key (LHS#Trigger#Predicted)|nil} % otherwise, start a new list
	 end
      end
   end
   MyD  % return a dictionary of grammar rules indexed by trigger sequence
end

% look up a trigger in D. if we have it, return the list of matches. if not, return DefaultValue
fun {LookupTrigger D Trigger DefaultValue}
   {Dictionary.condGet D {AtomOfList Trigger} DefaultValue}
end
fun {LookupTriggerAndParent D Trigger Parent DefaultValue}
   case {Dictionary.condGet D {AtomOfList Trigger} no_trigger} of
      no_trigger then DefaultValue
   [] L then
      % the alternative to this linear searching is another hash table by trigger+parent
      case {List.filter L fun {$ LHS#_#_} LHS==Parent end}  of
	 nil then DefaultValue
      [] SomeResults then SomeResults
      end
   end
end

% No need to ever look deeper into the stack than the longest possible trigger sequence for this grammar.
fun {LongestTrigger G}
   {List.foldL G fun {$ Old _#Trig#_} {Max Old {Length Trig}} end 0}
end
fun {NonNegative X} case X of neg(_) then false else true end end
fun {AllNegated L} {List.all L fun {$ X} case X of neg(_) then true else false end end} end
fun {PositiveReversal L}
   {List.reverse {List.map L fun {$ X} case X of neg(Y) then Y else raise notAPositive(X) end end end}}
end
fun {MatchesAsPrefix Long}
   fun {$ Short} 
      case Short#Long of
	 nil#_ then true
      [] (S|Srest)#(L|Lrest) andthen S==L then {{MatchesAsPrefix Lrest} Srest}
      else false
      end
   end
end
fun {Any P L}
   {List.foldL L fun {$ Old Cur} {Or Old {P Cur} } end false}
end

% higher-order function that takes a list of "special" rules (those that license Final Arguments)
% and returns a function that can pick them out of a list
fun {MakeMarkFinal Special} 
   fun {$ LHS#Trigger#Rest}
      fun {MarkFinalReal L}  % wrap the atom corresponding to a rule's Final Argument in a final() term
	 case {List.length L} of
	    0 then nil
	 [] 1 then [final(L.1)]
	 else
	    {List.append {List.take L {List.length L}-1 } [final({List.last L})]}
	 end
      end
   in
      if {List.member LHS#{List.append Trigger Rest} Special}
      then {MarkFinalReal Rest}
      else Rest
      end
   end
end

% eliminate any final() wrappings in the list L
fun {ClearFinal L}
	   fun {StripFinal X}
	      case X of
		 final(Foo) then Foo
	      [] Bar then Bar
	      end
	   end  in
	   {List.map L StripFinal}
end

% examine the first I elements of Stack
% are they all Found (=negated) categories? Do we have a rule triggered by this sequence?
% if so, run it by the Oracle and see if projecting this rule bottom up would yield a consistent stack
% If all these things are true, then using this rule is a bona fide option.
fun {GLCApplicable Oracle Grammar Stack Acc I}
	   local Prefix={ClearFinal {List.take Stack I}} in
	      if {AllNegated Prefix}
	      then
		 case {LookupTrigger Grammar {PositiveReversal Prefix} donthaveit} of
		    donthaveit then Acc % no rules triggered by this prefix
		 [] L then
		    {List.append Acc
		     {List.filter L
		      % in one of two ways, either
  		        fun {$ LHS#Trigger#_} % (1) consult the oracle
  			 WouldBe=neg(LHS)|{ClearFinal {List.drop Stack {Length Trigger}}} in
   			 if {Not {Any {MatchesAsPrefix WouldBe} Oracle}}
 			 then %% {System.show WouldBe#' not in oracle'}
			    false
   			 else true
   			 end
 		      end
%		      fun {$ X} true end % or (2) ignore oracle
  		     }
		     }
		 end
	      else Acc % no prefix of negated symbols at this length I
	      end
	   end
end

% examine the first I elements of Stack. Do we have a sequence of Found categories followed by a Sought parent?
% if so, collect any rules that can both project from the found and match the sought
% if we're completing a Final Argument in the sense of FBK82, indicate that as a different kind of option
fun {GLCCompleteApplicable Grammar Stack Acc I}
   local Prefix={ClearFinal {List.take Stack I}} in
      if {AllNegated Prefix} andthen ({Length Stack} > I) andthen {NonNegative {List.nth Stack (I+1)}}
      then
	 case {List.nth Stack (I+1)} of % depends if we are completing a Final Argument or not
	    final(Symbol) then  % we are
	    
            	    case {LookupTriggerAndParent Grammar {PositiveReversal Prefix} Symbol donthaveit} of
		       donthaveit then Acc
		    [] L then {List.append Acc {List.map L fun {$ X} glccompletefinal(X) end} }   % different operation name
		    end
		    
	 []       Symbol  then % we are not
	    
	            case {LookupTriggerAndParent Grammar {PositiveReversal Prefix} Symbol donthaveit} of
		       donthaveit then Acc
		    [] L then {List.append Acc {List.map L fun {$ X} glccomplete(X) end} }
		    end
	 end
      else Acc      % not all negated, or stack too short, or no positive parent
      end
   end
end

% Accumulate the various parser options for all TriggerLengths
fun {GLCOptions Oracle TriggerLengths Grammar Goals}  % only use Oracle in the aimlessly bottom-up GLCApplicable
   {List.append

    {List.foldL TriggerLengths
     fun {$ Sofar Width} {GLCCompleteApplicable Grammar Goals Sofar Width} end nil}

    {List.map % just project hoping to satisfy a deeper goal
     {List.foldL {List.filter TriggerLengths fun {$ X} X\=0 end} % avoid empties unless predicted
      fun {$ Sofar Width} {GLCApplicable Oracle Grammar Goals Sofar Width} end nil}
     fun {$ X} glc(X) end
    }
    
   }
end

% FBK82: if X is a Final Argument-completing action and Y is not then they are not ordered
% otherwise they are
fun {DemoteFinal X Y}
   case X#Y of
      glccompletefinal(_)#glccompletefinal(_) then true % no relative priority, assumed ordered
   [] glccompletefinal(_)#_ then false  % X should come later, not earlier
   else true % no opinion, must already be ordered OK
   end
end

% bind daughters to parents with unification
proc {MakeTrees ThisSubtree UnfoundSubtrees LHS Trigger Rest TreeList}
   FoundSubtrees={List.reverse {List.take TreeList {Length Trigger}}} in
   % construct new local subtree
   ThisSubtree={MakeTuple LHS {Length Trigger}+{Length Rest}}
   % bind in found daughters
   for J in 1..{Length Trigger} do
      ThisSubtree.J = {List.nth FoundSubtrees J}
   end
   % allocate unbound dataflow variables for each remaining daughter
   UnfoundSubtrees={MakeList {Length Rest}}
   % bind them to the new tree we just made
   for K in 1..{Length Rest} do
      ThisSubtree.(K+{Length Trigger}) = {List.nth UnfoundSubtrees K}
   end
end


% difference list append from CTM p142
fun {AppendD D1 D2}
   S1#E1=D1
   S2#E2=D2
in
   E1=S2
   S1#E2
end

% emit messages for ACT-R simulation
proc {CreateChunks P L}
   proc {CreateChunk Category}
      {Send P "created new chunk of category "#Category#"\n"}
   end in
   for X in L do
      {CreateChunk X}
   end
end
proc {RetrieveChunks P L}
   proc {RetrieveChunk C}
      {Send P "retrieval request for category "#C#"\n"}
   end in
   for X in L do
      {RetrieveChunk X}
   end
end
% the parser itself
proc {GLC MarkFinal Oracle LongestTriggerLength Grammar Goals InputString TreeList Derivation Portal}
   Options0 Options I AllWidths ThisSubtree UnfoundSubtrees in
   AllWidths={List.number 0 {Min LongestTriggerLength {Length Goals}} 1}
   % assign to Options0
   case Goals#InputString of
      nil#nil then Options0=[success]
   [] nil#(_|_) then Options0=nil
   [] (_|_)#nil then % can't shift or shiftcomplete. Potentially Project a rule w/no predictions
      Options0={GLCOptions Oracle AllWidths Grammar Goals}
   [] (G|_)#(W|_) andthen G==W then % we can shiftcomplete and shift
      Options0=if {Any {MatchesAsPrefix {ClearFinal neg(W)|Goals}} Oracle} % clear bottom-up action w/Oracle
	      then {List.append {GLCOptions Oracle AllWidths Grammar Goals} [shiftcomplete shift(W)]}
	      else {List.append {GLCOptions Oracle AllWidths Grammar Goals} [shiftcomplete]} % not allowed
	      end
   [] (_|_)#(W|_) then % we can only shift, not shiftcomplete
	 Options0=if {Any {MatchesAsPrefix {ClearFinal neg(W)|Goals}} Oracle}
		 then {List.append {GLCOptions Oracle AllWidths Grammar Goals} [shift(W)]}
		 else {GLCOptions Oracle AllWidths Grammar Goals} % append nil
		 end
   else
      raise unfamiliarGoalInputPair(Goals#InputString) end
   end
   Options={Sort Options0 DemoteFinal} % implement Ford Bresnan & Kaplan's Final Arguments principle
   % dispatch based on a selected element from Options
   case Options of
      nil then {Send Portal failing} fail % no exits from this state
   [] success|nil then {Send Portal done} % we're in the goal state
   else 
      I={Space.choose {Length Options}} % search engine chooses what to do
      case {List.nth Options I} of % and we do it
	 glc(LHS#Trigger#Rest) then
	 local Move=move(action:glc(LHS#Trigger#Rest) oldstack:Goals) More in
	    {Send Portal Move}
	    {CreateChunks Portal (LHS|Rest)}
	    % nothing retrieve --- there was no matching going on
	    
	    {MakeTrees ThisSubtree UnfoundSubtrees LHS Trigger Rest TreeList}
	    % our subtree isn't unified with anything pre-existing
	    
	    {GLC MarkFinal Oracle LongestTriggerLength Grammar
	     {List.append {MarkFinal LHS#Trigger#Rest} neg(LHS)|{List.drop Goals {Length Trigger}}} % push negated goal
	     InputString
	     {List.append UnfoundSubtrees (ThisSubtree|{List.drop TreeList {Length Trigger}})} % push found node
	     {AppendD Derivation (Move|More)#More}
	     Portal
	    }
	 end
	 
      [] glccomplete(LHS#Trigger#Rest) then
	 local Move=move(action:glccomplete(LHS#Trigger#Rest) oldstack:Goals) More in
	    {Send Portal Move}
	    {CreateChunks Portal Rest}
	    {RetrieveChunks Portal [LHS]}
	    {MakeTrees ThisSubtree UnfoundSubtrees LHS Trigger Rest TreeList}
	    ThisSubtree={List.nth TreeList {Length Trigger}+1} % match with prediction
	    
	    {GLC MarkFinal Oracle LongestTriggerLength Grammar
	     {List.append {MarkFinal LHS#Trigger#Rest} {List.drop Goals {Length Trigger}+1}} % pop accomplished goal
	     InputString
	     {List.append UnfoundSubtrees {List.drop TreeList {Length Trigger}+1}} % drop matched node
	     {AppendD Derivation (Move|More)#More}
	     Portal
	    }
	 end

      [] glccompletefinal(LHS#Trigger#Rest) then
	 local Move=move(action:glccompletefinal(LHS#Trigger#Rest) oldstack:Goals) More in
	    {Send Portal Move}
	    {CreateChunks Portal Rest}
	    {RetrieveChunks Portal [LHS]}
	    {MakeTrees ThisSubtree UnfoundSubtrees LHS Trigger Rest TreeList}
	    ThisSubtree={List.nth TreeList {Length Trigger}+1} % match with prediction
	    
	    {GLC MarkFinal Oracle LongestTriggerLength Grammar
	     {List.append {MarkFinal LHS#Trigger#Rest} {List.drop Goals {Length Trigger}+1}} % pop accomplished goal
	     InputString
	     {List.append UnfoundSubtrees {List.drop TreeList {Length Trigger}+1}} % drop matched node
	     {AppendD Derivation (Move|More)#More}
	     Portal
	    }
	 end

	 
      [] shift(W) then
	 local Move=move(action:shift(W) oldstack:Goals) More in
	    {Send Portal Move}
	    {CreateChunks Portal [W]}
	    {GLC MarkFinal Oracle LongestTriggerLength Grammar
	     (neg(W)|Goals) % push negated goal
	     InputString.2 % have consumed input word
	     (W|TreeList) % push found leaf
	     {AppendD Derivation (Move|More)#More}
	     Portal
	    }
	 end
	 
      [] shiftcomplete then
	 local Move=move(action:shiftcomplete oldstack:Goals) More in
	    {Send Portal Move}
	    {RetrieveChunks Portal [Goals.1]}
	    (TreeList.1)=(Goals.1) % update tree with new leaf
	    
	    {GLC MarkFinal Oracle LongestTriggerLength Grammar
	     Goals.2 % pop accomplished goal
	     InputString.2 % have consumed the word at the head of input sequence
	     TreeList.2 % drop matched leaf
	     {AppendD Derivation (Move|More)#More}
	     Portal
	    }
	 end
      else raise unFamiliarGLCOption({List.nth Options I}) end
      end
   end
end