source: applications/trunk/LFC/Earley/Earley.rf @ 3893

$module Earley;

$use Access Box List StdIO;

$box Grammar;

$func Init e.grammar = ;
Init e.grammar = <Store &Grammar e.grammar>; 

$func? Check e.prod (e.string) = ;
Check e.prod (e.string) =
  <Parse (e.string) (((TYPE 0) DOT e.prod 0))> :: e.sets,
  <Map &WriteLn (e.sets)> : e,
  e.sets : e (e ((TYPE 0 e.info) e.prod DOT 0) e);

$public $func Earley t.type e.string = e.set;
Earley t.type e.string =
  <Parse (e.string) (((TYPE 0) DOT t.type 0))> : e (e.set),
  e.set;

$func Parse (e.string) e.sets = e.sets;
Parse (e.string) e.sets =
  <Completer <Predictor e.sets>> :: e.new_sets,
  {
    e.new_sets : e.sets = e.string : {
      /*empty*/ = e.sets;
      s.ch e.rest = <Parse (e.rest) <Scanner s.ch e.sets ()>>;
    };
    <Parse (e.string) e.new_sets>;
  };

$func Scanner s.ch e.sets = e.sets;
Scanner s.ch e.sets (e.current) (e.new) = 
  (e.current) (e.new) $iter {
    e.items : e ((TYPE t.name e.info) e1 DOT s.ch e2 s.n) e.rest =
      (e.rest) (e.new ((TYPE t.name e.info s.ch) e1 s.ch DOT e2 s.n));
    () (e.new);
  } :: (e.items) (e.new),
  e.items : /*empty*/ =
  e.sets (e.current) (e.new);

$func Predictor e.sets = e.sets;
Predictor e.sets (e.current) =
  (e.current) (/*e.new*/) $iter e.current : {
    (t.type e1 DOT (TYPE t.name) e2 s.n) e.rest =
      (e.rest)
      (<Or (e.new) (t.type e1 DOT (TYPE t.name) e2 s.n)
        <GetRules (<Get &Grammar>) t.name <Length e.sets>>>);
    t.item e.rest =
      (e.rest) (<Or (e.new) t.item>);
  } :: (e.current) (e.new),
  e.current : /*empty*/ =
  e.sets (e.new);

$func GetRules (e.grammar) t.name s.n = e.rules;
GetRules {
  (e (PROD (TYPE t.name) e.prods) e.rest) t.name s.n =
    (e.prods) (/*e.rules*/) $iter {
      e.prods : (e.prod) e.rest_prods =
        (e.rest_prods) (e.rules ((TYPE t.name) DOT e.prod s.n));
    } :: (e.prods) (e.rules),
    e.prods : /*empty*/ =
    e.rules <GetRules (e.rest) t.name s.n>;
  (e) t.name s.n = /*empty*/;
};

$func Completer e.sets = e.sets;
Completer e.sets =
  e.sets : e.head (e.current),
  (e.current) (/*e.new*/) $iter {
    e.items : e ((TYPE t.name1 e.info1) e1 DOT s.n) e.rest =
      <L s.n e.sets> : (e.prev_items),
      (e.prev_items) (e.new) $iter {
        e.prev_items : e ((TYPE t.name2 e.info2) e2 DOT (TYPE t.name1) e3 s.m) e.rest2 =
          (e.rest2) (e.new ((TYPE t.name2 e.info2 (e.info1)) e2 (TYPE t.name1) DOT e3 s.m));
        () (e.new);
      } :: (e.prev_items) (e.new),
      e.prev_items : /*empty*/ =
      (e.rest) (e.new);
    () (e.new);
  } :: (e.items) (e.new),
  e.items : /*empty*/ =
  e.head (<Or (e.current) e.new>);

$func Main = e;

Main =
  <Init (PROD (TYPE ('E')) ((TYPE ('E')) '+' (TYPE ('E'))) ('n'))>,
  <Check (TYPE ('E'))/* '+' (TYPE ('E'))*/ ('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')>;