open Format

type terminal = string

type non_terminal = string

type symbol = 
  | Terminal of terminal
  | NonTerminal of non_terminal

type production = symbol list

type rule = non_terminal * production

type grammar = {
  start : non_terminal;
  rules : rule list;
}

(* point fixe *)

let rec fixpoint f x0 =
  let (x1,isnew) = f x0 in 
  if isnew then fixpoint f x1 else x1

(* calcul des null *)

module Ntset = Set.Make(String)

type nulls = Ntset.t

let is_null_production nulls p =
  let is_null_symbol = function
    | Terminal _ -> false
    | NonTerminal nt -> Ntset.mem nt nulls
  in
  List.for_all is_null_symbol p

let null g = 
  let step nulls =
    List.fold_left 
      (fun ((n,_) as nb) (nt,p) -> 
         if (not (Ntset.mem nt n)) && is_null_production n p then 
           (Ntset.add nt n, true)
         else
           nb)
      (nulls,false)
      g.rules
  in
  fixpoint step Ntset.empty

(* calcul des first *)

module Ntmap = Map.Make(String)
module Tset = Set.Make(String)

type firsts = Tset.t Ntmap.t

let empty_map g = 
  List.fold_left (fun f (s,_) -> Ntmap.add s Tset.empty f) Ntmap.empty g.rules

let first_production_step nulls firsts p =
  let rec fold_prod = function
    | [] -> 
        Tset.empty
    | Terminal c :: _ -> 
        Tset.add c Tset.empty
    | NonTerminal nt :: p -> 
        if Ntset.mem nt nulls then 
          Tset.union (Ntmap.find nt firsts) (fold_prod p)
        else
          Ntmap.find nt firsts
  in
  fold_prod p

let first g nulls =
  let step firsts =
    List.fold_left
      (fun (f,b) (nt,p) ->
         let fnt = Ntmap.find nt f in
         let fp = first_production_step nulls f p in
         if Tset.subset fp fnt then 
           (f,b)
         else
           (Ntmap.add nt (Tset.union fnt fp) f, true))
      (firsts,false)
      g.rules
  in
  fixpoint step (empty_map g)

(* follow *)

type follows = Tset.t Ntmap.t

let follow g nulls firsts = 
  let update (follows,b) nt s =
    let ntn = Ntmap.find nt follows in
    if Tset.subset s ntn then 
      (follows,b) 
    else 
      (Ntmap.add nt (Tset.union s ntn) follows,true)
  in
  let rec update_prod ((follows,b) as acc) nty = function
    | [] -> 
        acc
    | NonTerminal ntx :: beta -> 
        let acc' = update acc ntx (first_production_step nulls firsts beta) in
        let acc'' = 
          if is_null_production nulls beta then
            update acc' ntx (Ntmap.find nty follows)
          else
            acc'
        in
        update_prod acc'' nty beta
    | Terminal _ :: beta -> 
        update_prod acc nty beta
  in
  let step follows = 
    List.fold_left 
      (fun acc (nt,p) -> update_prod acc nt p) 
      (follows,false) g.rules 
  in
  fixpoint step (empty_map g)

(* table d'analyse descendante *)

module Tmap = Map.Make(String)
module Pset = Set.Make(struct type t = production let compare = compare end)

type expansion_table = Pset.t Tmap.t Ntmap.t

let add_entry table nt t p =
  let line = try Ntmap.find nt table with Not_found -> Tmap.empty in
  let s = try Tmap.find t line with Not_found -> Pset.empty in
  Ntmap.add nt (Tmap.add t (Pset.add p s) line) table

let expansions g =
  let nulls = null g in
  let firsts = first g nulls in
  let follows = follow g nulls firsts in
  List.fold_left 
    (fun table (nt,p) -> 
       let ts = first_production_step nulls firsts p in
       let ts' = 
         if is_null_production nulls p then 
           Tset.union ts (Ntmap.find nt follows)
         else 
           ts 
       in
       Tset.fold (fun t table -> add_entry table nt t p) ts' table)
    Ntmap.empty g.rules


let g1 = {
  start = "S#";
  rules = ["S#", [NonTerminal "S"; Terminal "#"];
           "S", [];
           "S", [Terminal "a"; NonTerminal "A"; NonTerminal "S"];
           "S", [Terminal "b"; NonTerminal "B"; NonTerminal "S"];
           "A", [Terminal "a"; NonTerminal "A"; NonTerminal "A"];
           "A", [Terminal "b"];
           "B", [Terminal "b"; NonTerminal "B"; NonTerminal "B"];
           "B", [Terminal "a"];
          ] };;

#use "pp.ml";;

let is_ll1 t =
  try
    Ntmap.iter 
      (fun _ m -> 
         Tmap.iter (fun _ rs -> if Pset.cardinal rs > 1 then raise Exit) m) 
      t;
    true
  with Exit -> 
    false

let analyze start table w = 
  let rec scan = function
    | [], [] -> 
        true
    | NonTerminal n :: s, (t :: _ as w) -> 
        let p = Pset.choose (Tmap.find t (Ntmap.find n table)) in
        scan (p @ s, w)
    | Terminal t' :: s, t :: w when t' = t -> 
        scan (s, w)
    | _ -> 
        raise Not_found
  in
  try scan ([NonTerminal start], w @ ["#"])
  with Not_found -> false

let explode s = 
  let n = String.length s in
  let rec make i = if i = n then [] else String.make 1 s.[i] :: make (i+1) in
  make 0

let test1 s = analyze g1.start (expansions g1) (explode s)

(* positifs *)

let _ = test1 ""
let _ = test1 "ab"
let _ = test1 "ba"
let _ = test1 "abab"
let _ = test1 "aaabbb"
let _ = test1 "aaabababbbababab"

(* négatifs *)

let _ = test1 "a"
let _ = test1 "b"
let _ = test1 "aab"
let _ = test1 "aaabbba"
let _ = test1 "aaabbbaabab"
let _ = test1 "aaaaaaaaaaaaaaaaaaaaabbbbbbbbbbbbbbbbbbbb"

This document was generated using caml2html