(* Analyse descendante récursive sur une liste *)
(*
 S ::= (S) | x
*)

exception Echec
type analist = char list -> char list

(* Consommation d'un caractère précis en début de mot *)
let p_parouv: analist = fun l -> match l with
  | '(' :: l1 -> l1
  | _ -> raise Echec

let p_parfer: analist = fun l -> match l with
  | ')' :: l1 -> l1
  | _ -> raise Echec

let p_x: analist = fun l -> match l with
  | 'x' :: l1 -> l1
  | _ -> raise Echec

let rec p_S = fun l ->
  try
    let l1 = p_parouv l in
    let l2 = p_S l1 in
    let l3 = p_parfer l2 in
    l3           (* l3 = p_parfer (p_S (p_parouv l)) *)
  with
    Echec -> p_x l

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

let ch1 = list_of_string "((x))()abc"
let _ = p_S ch1
let ch1 = list_of_string "((y))()"
let _ = p_S ch1
let ch1 = list_of_string "((x)x)"
let _ = p_S ch1


(* Pour séparer les règles *)
(* La fonction de consommation de S est passée en paramètre *)
let p_ouvfer: analist -> analist = fun p_S l ->
  let l1 = p_parouv l in
  let l2 = p_S l1 in
  let l3 = p_parfer l2 in
  l3

let rec p_S: analist = fun l ->
  try p_ouvfer p_S l with
  | Echec -> p_x l



(* Flots *)

(* #load "dynlink.cma" *)
(* #load "camlp4o.cma" *)
#use "topfind";;
#camlp4o;;

let flux_int_19 =[<'1; '9>]
let flux_char_ab =[<''a'; ''b'>]
let flux_char_cd =[<''c'; ''d'>]
let flux_char_ab_cd = [< flux_char_ab; flux_char_cd>]
let flux_char_1934 = Stream.of_string "1934"

let f1 = [< '19 ; '345 >]
let f1 = [< '"19" ; '"34" >]

let rec nat_list n = n :: nat_list (n+1)
let nat = nat_list 0

let rec nat_stream n = [< 'n ; nat_stream (n+1) >] 
let nat = nat_stream 0 

let next s = match s with parser
  | [<'x >] -> x

let next = parser
  | [<'x >] -> x

let rec lg l = match l with
  | [] -> 0
  | t::q -> 1 + lg q
let rec lg = function
  | [] -> 0
  | t::q -> 1 + lg q

let _ = next flux_char_ab
let _ = next flux_char_ab
let _ = next flux_char_ab
let _ = next flux_char_ab_cd
let _ = next flux_char_ab_cd
let _ = next flux_char_ab_cd
let _ = next flux_char_ab_cd
let _ = next flux_char_ab_cd
let _ = next flux_char_cd

let _ = next nat
let _ = next nat
let _ = next nat
let _ = next nat
let _ = next nat





let consomme_aveuglement s = match s with parser 
  [< '_ >] -> 0

(*   Grammaires      *)
(*   S ::= (S) | x   *)

let rec parent s = match s with parser
  | [< ''('; n = parent; '')'  >] -> n+1
  | [< ''x' >] -> 0

let s1 = Stream.of_string "(((x)))"
let s2 = Stream.of_string "((()))"
let s3 = Stream.of_string "((x))()"

let _ = parent s1
let _ = parent s2
let _ = parent s3

let _ = next s1;;
let _ = next s2;;
let _ = next s3;;



(* Lecture d'un entier *)

let digit c = int_of_char c - int_of_char '0';;

let rec horner n = parser
  | [< ''0'..'9' as c ; n =  horner (10 * n + digit c)>] ->  n
  | [< >] -> n;;

let s = Stream.of_string "132+422";;

horner 0 s;;

consomme_aveuglement s;;

horner 0 s;;

(* Traduction de E ::= T+T | T *)
(* Sans regroupement du préfixe commun ça ne fonctionne pas *)

let p_E = parser
  | [< t1 = horner 0 ; ''+' ; t2 = horner 0 >] -> t1 + t2
  | [< t = horner 0 >] -> t ;;

let s = Stream.of_string "132+422";;
p_E s;;
let s = Stream.of_string "132422";;
p_E s;;
let s = Stream.of_string "132+422+1";;
p_E s;;


(* Traduction de E ::= T+T | T *)
(* Avec regroupement du préfixe commun la grammaire devient *)
(* E ::= T SE *)
(* SE ::= + T | epsilon *) 

let rec p_SE = parser
  | [< ''+' ; t = horner 0 >] -> (fun x -> x+t)
  | [< >] -> (fun x -> x) ;;

let p_E2 = parser
  | [< t = horner 0 ; se = p_SE >] -> se t;;

let s = Stream.of_string "132+422";;
p_E2 s;;
let s = Stream.of_string "132422";;
p_E2 s;;
let s = Stream.of_string "132+422+1";;
p_E2 s;;


(* Analyse lexicale puis syntaxique *)

type token = 
  | Tident of char list
  | Tent of int
  | Tspeciaux of char list

(* Pour le test *)
let rec list_of_stream = parser
  | [< 'x; l = list_of_stream >] -> x :: l
  | [< >] -> []

(* Caracteres par categorie *)
let chiffre = parser  [< ''0'..'9' as x >] -> x

let lettre = parser  [< ''a'..'z' | 'A'..'Z' as x >] -> x

let alphanum = parser
  | [< x = lettre >] -> x
  | [< x = chiffre >] -> x

let special = parser  [< '':' | '=' | '<' | '>' | '+' as x >] -> x

(* Suites de caracteres de meme categorie *)

let rec lettres = parser
  | [< x = lettre; l = lettres >] -> x :: l
  | [< >] -> [] 

let rec alphanums = parser
  | [< x = alphanum; l = alphanums >] -> x :: l
  | [< >] -> [] 

let rec speciaux = parser
  | [< x = special; l = speciaux >] -> x :: l
  | [< >] -> [] 

(* *)

let rec lexeme = parser
  | [< '' ' | '\n' | '\t';  lx = lexeme >] -> lx
  | [< x = lettre; l = alphanums >] -> Tident (x :: l)
  | [< x = chiffre; n = horner  (digit x)>] ->  Tent (n)
  | [< x = special; l = speciaux >] -> Tspeciaux (x :: l)


(* *)

let rec liste_lexemes = parser 
  |  [< tk = lexeme ; ll = liste_lexemes >] -> tk :: ll
  |  [<  >] -> []

let _ = liste_lexemes (Stream.of_string "12 + x1")

let rec flot_lexemes = parser 
  |  [< tk = lexeme ; ll = flot_lexemes >]  ->  [< 'tk ;   ll >]
  |  [<  >] -> [< >]

let _ = list_of_stream (flot_lexemes (Stream.of_string "12+ x1"))

(* Version efficace *)

let  next_token = parser
  | [< tk = lexeme >] -> Some (tk)
  | [< >] -> None

let lex s = Stream.from (fun n -> next_token s)

let _ = list_of_stream (lex (Stream.of_string " 12 + x1"))