 
 :: (grow-lr) ( r p m h -- )
   p pos set
+  h involved-set>> clone h (>>eval-set)
   r eval-rule
   dup fail = pos get m pos>> <= or [
     drop

SYMBOL: pos
SYMBOL: input
SYMBOL: fail

TUPLE: memo-entry ans pos ;
C: <memo-entry> memo-entry

TUPLE: left-recursion detected? ;
C: <left-recursion> left-recursion
 
: rule-parser ( rule -- parser ) 
  #! A rule is the parser compiled down to a word. It has
  #! a "peg" property containing the original parser.

  ] if ;
 
:: grow-lr ( r p m h -- ast )
  h p heads get set-at
  r p m h (grow-lr) 
  p heads get delete-at
  m pos>> pos set m ans>>
  ;

:: (setup-lr) ( r l s -- )
  s head>> l head>> eq? [
    l head>> s (>>head)
    l head>> [ s rule>> add ] change-involved-set drop
    r l s next>> (setup-lr)
  ] unless ;

:: setup-lr ( r l -- )
  l head>> [
    r V{ } clone V{ } clone <head> l (>>head)
  ] unless
  r l lrstack get (setup-lr) ;

:: lr-answer ( r p m -- ast )
  [let* |
          h [ m ans>> head>> ]
        |
    h rule>> r eq? [
      m ans>> seed>> m (>>ans)
      m ans>> fail = [
        fail
      ] [
        r p m h grow-lr
      ] if
    ] [
      m ans>> seed>>
    ] if
  ] ;

:: recall ( r p -- memo-entry )
  [let* |
          m [ p r memo ]
          h [ p heads get at ]
        |
    h [
      m r h involved-set>> h rule>> add member? not and [
        fail p <memo-entry>
      ] [
        r h eval-set>> member? [
          h [ r swap remove ] change-eval-set drop
          r eval-rule
          m (>>ans)
          pos get m (>>pos)
          m
        ] [ 
          m
        ] if
      ] if
    ] [
      m
    ] if
  ] ;

:: apply-non-memo-rule ( r p -- ast )
  [let* |
          lr  [ fail r f lrstack get <left-recursion> ]
          m   [ lr lrstack set lr p <memo-entry> dup p r set-memo ]
          ans [ r eval-rule ]
        |
    lrstack get next>> lrstack set
    pos get m (>>pos)
    lr head>> [
      ans lr (>>seed)
      r p m lr-answer
    ] [
      ans m (>>ans)
      ans
    ] if
  ] ;

:: apply-memo-rule ( r m -- ast )
  m pos>> pos set 
  m ans>> left-recursion? [ 
    r m ans>> setup-lr
    m ans>> seed>>
  ] [
    m ans>>
  ] if ;

:: apply-rule ( r p -- ast )
  [let* |
          m [ r p recall ]
        | 
    m [
      r m apply-memo-rule
    ] [
      r p apply-non-memo-rule
    ] if 
