% 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


declare
% because dictionary keys can only be literals
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
	 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
fun {LongestTrigger G}
   {List.foldL G fun {$ Old _#Trig#_} {Max Old {Length Trig}} end 0}
end
Gbottomup = [
	     det#[every]#nil
	     det#[a]#nil
	     n#[man]#nil
	     n#[woman]#nil
	     pn#[john]#nil
	     pn#[mary]#nil
	     vtrans#[loves]#nil
	     vintrans#[lives]#nil
	     np#[det n optrel]#nil
	     np#[pn]#nil
	     vp#[vtrans np]#nil
	     vp#[vintrans]#nil
	     optrel#[who vp]#nil
	     s#[np vp]#nil
	    ]
GDbottomup={DictByTrigger Gbottomup}
LTbottomup={LongestTrigger Gbottomup}
Gleftcorner = [
	     det#[every]#nil
	     det#[a]#nil
	     n#[man]#nil
	     n#[woman]#nil
	     pn#[john]#nil
	     pn#[mary]#nil
	     vtrans#[loves]#nil
	     vintrans#[lives]#nil
	     np#[det]#[n optrel]
	     np#[pn]#nil
	     vp#[vtrans]#[np]
	     vp#[vintrans]#nil
	     optrel#[who]#[vp]
	     s#[np]#[vp]
	    ]
GDleftcorner={DictByTrigger Gleftcorner}
LTleftcorner={LongestTrigger Gleftcorner}
Gtopdown = [
	     det#nil#[every]
	     det#nil#[a]
	     n#nil#[man]
	     n#nil#[woman]
	     pn#nil#[john]
	     pn#nil#[mary]
	     vtrans#nil#[loves]
	     vintrans#nil#[lives]
	     np#nil#[det n optrel]
	     np#nil#[pn]
	     vp#nil#[vtrans np]
	     vp#nil#[vintrans]
	     optrel#nil#[who vp]
	     s#nil#[np vp]
	    ]
GDtopdown={DictByTrigger Gtopdown}
LTtopdown={LongestTrigger Gtopdown}

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 {GLCApplicable Grammar Stack Acc I}
   local Prefix={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 L} % keep track of triggered rules in Acc
	 end
      else Acc % no prefix of negated symbols at this length I
      end
   end
end
fun {GLCCompleteApplicable Grammar Stack Acc I}
   local Prefix={List.take Stack I} in
      if {AllNegated Prefix} andthen ({Length Stack} > I) andthen {NonNegative {List.nth Stack (I+1)}}
      then
	 case {LookupTriggerAndParent Grammar {PositiveReversal Prefix} {List.nth Stack (I+1)} donthaveit} of
	    donthaveit then Acc
	 [] L then {List.append Acc L}
	 end
      else Acc
      end
   end
end
fun {GLCOptions TriggerLengths Grammar Goals}
   {List.append
    {List.map % project and match
     {List.foldL TriggerLengths  % safe here since we require matching parent
      fun {$ Sofar Width} {GLCCompleteApplicable Grammar Goals Sofar Width} end nil}
     fun {$ X} glccomplete(X) end
    }

    {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 Grammar Goals Sofar Width} end nil}
     fun {$ X} glc(X) end
    }
   }
end
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
proc {GLC LongestTriggerLength Grammar Goals InputString TreeList}
   Options I AllWidths ThisSubtree UnfoundSubtrees in
   AllWidths={List.number 0 {Min LongestTriggerLength {Length Goals}} 1}
   % assign to Options
   case Goals#InputString of
      nil#nil then Options=[success]
   [] nil#(_|_) then Options=nil
   [] (_|_)#nil then % can't shift or shiftcomplete. Potentially Project a rule w/no predictions
      Options={GLCOptions AllWidths Grammar Goals}
   [] (G|_)#(W|_) andthen G==W then % we can shiftcomplete and shift
      Options={List.append {GLCOptions AllWidths Grammar Goals} [shiftcomplete shift(W)]}
   [] (_|_)#(W|_) then % we can only shift, not shiftcomplete
      Options={List.append {GLCOptions AllWidths Grammar Goals} [shift(W)]}
   else
      raise unfamiliarGoalInputPair(Goals#InputString) end
   end
   % dispatch based on a selected element from Options
   case Options of
      nil then fail % no exits from this state
   [] success|nil then skip % 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
	 {MakeTrees ThisSubtree UnfoundSubtrees LHS Trigger Rest TreeList}
	 {GLC LongestTriggerLength Grammar
	  {List.append Rest neg(LHS)|{List.drop Goals {Length Trigger}}} % push negated goal
	  InputString
	  {List.append UnfoundSubtrees (ThisSubtree|{List.drop TreeList {Length Trigger}})} % push found node
	 }
	 
      [] glccomplete(LHS#Trigger#Rest) then
	 {MakeTrees ThisSubtree UnfoundSubtrees LHS Trigger Rest TreeList}
	 ThisSubtree={List.nth TreeList {Length Trigger}+1} % match with prediction
	 {GLC LongestTriggerLength Grammar
	  {List.append Rest {List.drop Goals {Length Trigger}+1}} % pop accomplished goal
	  InputString
	  {List.append UnfoundSubtrees {List.drop TreeList {Length Trigger}+1}}} % drop matched node
	 
      [] shift(W) then
	 {GLC LongestTriggerLength Grammar
	  (neg(W)|Goals) % push negated goal
	  InputString.2 % have consumed input word
	  (W|TreeList) % push found leaf
	 }
	 
      [] shiftcomplete then
	 (TreeList.1)=(Goals.1) % update tree with new leaf
	 {GLC LongestTriggerLength Grammar
	  Goals.2 % pop accomplished goal
	  InputString.2 % have consumed the word at the head of input sequence
	  TreeList.2 % drop matched leaf
	 }
      else raise unFamiliarGLCOption({List.nth Options I}) end
      end
   end
end

% left corner
% {Explorer.all proc {$ Sol} {GLC LTleftcorner GDleftcorner [s] [every man who lives loves mary] [Sol]} end }

% bottomup
% {Explorer.all proc {$ Sol} {GLC LTbottomup GDbottomup [s] [every man who lives loves mary] [Sol]} end }

% topdown
% {Explorer.all proc {$ Sol} {GLC LTtopdown GDtopdown [s] [every man who lives loves mary] [Sol]} end }