* $Id$
*
* Practical Earley Parsing
* Aycock and Horspool

* This version takes any context free grammars but with nullable non-terminals
* (rules of a kind [E -> ] are not allowed).

Check {
  (e.grammar) (TYPE s.name) e.string,
    <Parse (e.grammar) (e.string) () (((TYPE START) (DOT (TYPE s.name)) ())) () ()> : e.sets (e.last) =
    <FindSuccessRule s.name e.last>;
}

FindSuccessRule {
  s.name ((TYPE s.name e.info) e.prod (DOT) ()) e.rules = (e.info) (e.prod);
  s.name t.rule e.rules = <FindSuccessRule s.name e.rules>;
  s.name = "Parsing failed";
}

Earley {
  (e.grammar) t.type e.string = <Parse (e.grammar) (e.string) () (((TYPE START) (DOT t.type) ())) () ()>;
}

* In: (e.grammar) (e.string) e.sets (e.rules) (e.current) (e.next)
Parse {
  (e.grammar) () (e.step) e.sets () (e.current) () = e.sets (e.current);
  (e.grammar) (s.char e.string) (e.step) e.sets () (e.current) (e.next) =
    <Parse (e.grammar) (e.string) (e.step I) e.sets (e.current) (e.next) () ()>;
  (e.grammar) (e.string) (e.step) e.sets (t.rule e.rules) (e.current) (e.next), t.rule : {
* Scanner
    ((TYPE s.name e.info) e.1 (DOT s.char e.2) (e.n)), e.string : {
      s.char e.rest_chars =
        <Parse (e.grammar) (e.string) (e.step) e.sets (e.rules) (e.current t.rule)
          (e.next ((TYPE s.name e.info s.char) e.1 s.char (DOT e.2) (e.n)))>;
      e.string =
        <Parse (e.grammar) (e.string) (e.step) e.sets (e.rules) (e.current t.rule) (e.next)>;
    };
* Predictor
    (t.type e.1 (DOT (TYPE s.name) e.2) (e.n)),
      e.current t.rule : e.current2 =
      <Parse (e.grammar) (e.string) (e.step) e.sets
        (<AddPredictions (e.grammar) (e.rules) (e.current2) s.name (e.step)>) (e.current2) (e.next)>;
* Completer
    ((TYPE s.name e.info) e.1 (DOT) (e.n)),
      e.current t.rule : e.current2 =
      <Parse (e.grammar) (e.string) (e.step) e.sets
        (<AddCompletions (e.n) (e.sets) (e.rules) (e.current2) s.name e.info>) (e.current2) (e.next)>;
  };
}

AddPredictions {
  ((PROD (TYPE s.name) e.prods) e.grammar) (e.rules) (e.current) s.name (e.step) =
    <AddPredictions (e.grammar) (<AddPredictions2 (e.prods) (e.rules) (e.current) s.name (e.step)>) (e.current) s.name (e.step)>;
  (t.prod e.grammar) (e.rules) (e.current) s.name (e.step) = <AddPredictions (e.grammar) (e.rules) (e.current) s.name (e.step)>;
  () (e.rules) (e.current) s.name (e.step) = e.rules;
}

AddPredictions2 {
  ((e.prod) e.rest_prods) (e.rules) (e.current) s.name (e.step),
    ((TYPE s.name) (DOT e.prod) (e.step)) : t.prediction,
    <IsIn e.rules t.prediction> : {
      True = <AddPredictions2 (e.rest_prods) (e.rules) (e.current) s.name (e.step)>;
      False, <IsIn e.current t.prediction> : {
        True = <AddPredictions2 (e.rest_prods) (e.rules) (e.current) s.name (e.step)>;
        False = <AddPredictions2 (e.rest_prods) (e.rules t.prediction) (e.current) s.name (e.step)>;
      };
    };
  () (e.rules) (e.current) s.name (e.step) = e.rules;
}

AddCompletions {
  (I e.n) (t.set e.rest_sets) (e.rules) (e.current) s.name e.info = <AddCompletions (e.n) (e.rest_sets) (e.rules) (e.current) s.name e.info>;
  () ((e.set) e.rest_sets) (e.rules) (e.current) s.name e.info = <AddCompletions2 (e.set) (e.rules) (e.current) s.name e.info>;
  () () (e.rules) (e.current) s.name e.info = e.rules;
}

AddCompletions2 {
  (((TYPE s.name2 e.info2) e.1 (DOT (TYPE s.name) e.2) (e.step)) e.set) (e.rules) (e.current) s.name e.info,
    ((TYPE s.name2 e.info2 (e.info)) e.1 (TYPE s.name) (DOT e.2) (e.step)) : t.completion,
    <IsIn e.rules t.completion> : {
      True = <AddCompletions2 (e.set) (e.rules) (e.current) s.name e.info>;
      False, <IsIn e.current t.completion> : {
        True = <AddCompletions2 (e.set) (e.rules) (e.current) s.name e.info>;
        False = <AddCompletions2 (e.set) (e.rules t.completion) (e.current) s.name e.info>;
      };
    };
  (t.rule e.set) (e.rules) (e.current) s.name e.info = <AddCompletions2 (e.set) (e.rules) (e.current) s.name e.info>;
  () (e.rules) (e.current) s.name e.info = e.rules;
}

IsIn {
  t.1 e.set t.1 = True;
  t.1 e.set t.2 = <IsIn e.set t.2>;
  t.2 = False;
}

$ENTRY Go {
  = <Prout
* E -> E '+' E | 'n'
      <Check ((PROD (TYPE "E") ((TYPE "E") '+' (TYPE "E")) ('n'))) (TYPE "E") 'n+n'> '\n'
      <Check ((PROD (TYPE "E") ((TYPE "E") '+' (TYPE "E"))) (PROD (TYPE "E") ('n'))) (TYPE "E") 'n+n+n'>>;
}

* Main =
*   <Init (PROD (TYPE ('E')) ((TYPE ('E')) '+' (TYPE ('E'))) ('n'))>,
*   <Check (TYPE ('E')) ('n+n')>,
*   <PrintLn>,
*   <Check (TYPE ('E')) ('n+n+n')>,
*   <PrintLn>,
*   <Init (PROD (TYPE ('S')) ((TYPE ('A')) (TYPE ('A')) (TYPE ('A')) (TYPE ('A'))))
*         (PROD (TYPE ('A')) ('a') ((TYPE ('E'))))
*         (PROD (TYPE ('E')) ())>,
*   <Check (TYPE ('S')) ('a')>,
*   <PrintLn>,
*   <Init (PROD (TYPE ('T')) ((TYPE ('A'))) ((TYPE ('B'))))
*         (PROD (TYPE ('A')) ('x'))
*         (PROD (TYPE ('B')) ('x'))>,
*   <Check (TYPE ('T')) ('x')>;