(* Analyse descendante récursive sur une liste avec des combinateurs *)
(* Complément à anacom_decouverte.ml, dédié à l'étoire de Kleene     *)
(* Dans toute la suite, les listes sont implicitement des
   listes de caractères. *)

(* Utilitaire pour les tests *)

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

(* ============================================================ *)
(* Échauffement : combinateurs d'analyseurs purs                *)
(* ------------------------------------------------------------ *)

(* Le type des aspirateurs de listes de caractères  *)
type analist = char list -> char list

exception Echec

(* terminal constant *)
let terminal c : analist = fun l -> match l with
  | x :: l when x = c -> l
  | _ -> raise Echec

(* terminal conditionnel *)
let terminal_cond (p : 'term -> bool) : analist = function
  | x :: l when p x -> l
  | _ -> raise Echec

(* non-terminal vide *)
let epsilon : analist = fun l -> l

(* Composition séquentielle : a1 suivi de a2 *)
let (-->) (a1 : analist) (a2 : analist) : analist =
  fun l -> let l = a1 l in a2 l

(* Choix entre a1 ou a2 *)
let (-|) (a1 : analist) (a2 : analist) : analist =
  fun l -> try a1 l with Echec -> a2 l

(* Répétition (étoile de Kleene) *)
(* Remarque : l'opétateur étoile de Kleene est défini récursivement *)
(* Grammaire :  A* ::=  A A* | ε *)
let rec star (a : analist) : analist = fun l -> l |>
  ( a --> star a ) -| epsilon

(* Exemples d'utilisation *)
let _ = star (terminal 'x') (list_of_string "xxx-reste")

let est_chiffre : char -> bool = function
  | '0' .. '9' -> true
  | _ -> false

(* (n,)*  où n est un chiffre *)
let p_repet : analist = star (terminal_cond est_chiffre --> terminal ',')
let _ = p_repet (list_of_string "1,2,345")
   
(* ---------------------------------- *)
(* Grammaire non récursive *)

(*
    S0  ::=  'x'
    S   ::=  '(' S0 ')'  |  'x'
*)

let p_S0 : analist = terminal 'x'

let p_S : analist =
    (terminal '('  -->  p_S0  -->  terminal ')')
 -| (terminal 'x')

(* Tests *)

let echec test s = try (let _ = test s in false) with Echec -> true

let test s = p_S (list_of_string s)
let _ = test "(x)abc"
let _ = test "xabc"

(* ---------------------------------- *)
(* Grammaire récursive *)

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


(*
   En OCaml, x |> f est une autre notation de f x.
   Le let rec impose l'explicitation d'au moins un argument,
   d'où le démarrage par fun l -> l |>
*)

let rec p_S : analist = fun l ->  l |>
     (terminal '('  -->  p_S  -->  terminal ')')
  -| (terminal 'x')

let test s = p_S (list_of_string s)
let _ = test "(((x)))abc"
let _ = test "xabc"
let _ = test "((x))abc"
let _ = echec test "()abc"

(* Variante avec ε
    S   ::=  '(' S ')'  |  ε
*)


let rec p_S : analist = fun l ->  l |>
     (terminal '('  -->  p_S  -->  terminal ')')
  -| epsilon

(* Il faut mettre epsilon en second pour effectuer l'analyse
   du plus grand préfixe correspondant à la grammaire *)

let test s = p_S (list_of_string s)
let _ = test "((()))abc"
let _ = test "abc"
let _ = test "((x))abc"
let _ = test "()abc"
    
(* ==================================================================== *)
(* Combinateurs d'analyseurs avec calcul supplémentaire (ex. un AST)    *)
(* -------------------------------------------------------------------- *)

(* Le type des aspirateurs de listes qui rendent un résultat de type 'res *)
type 'res ranalist = char list -> 'res * char list

let epsilon_res (info : 'res) : 'res ranalist =
  fun l -> (info, l)

(* Terminal conditionnel avec résultat *)
(* [f] ne retourne pas un booléen mais un résultat optionnel *)
let terminal_res (f : char -> 'res option) : 'res ranalist =
  fun l -> match l with
  | x :: l -> (match f x with Some y -> y, l | None -> raise Echec)
  | _ -> raise Echec

(* Choix entre a1 ou a2 informatifs *)
let (+|) (a1 : 'res ranalist) (a2 : 'res ranalist) : 'res ranalist =
  fun l -> try a1 l with Echec -> a2 l

(* Composition séquentielle *)
(* a1 sans résultat suivi de a2 donnant un résultat *)
let ( -+>) (a1 : analist) (a2 : 'res ranalist) : 'res ranalist =
  fun l -> let l = a1 l in a2 l

(* a1 rendant un résultat suivi de a2 rendant un résultat *)
let (++>) (a1 : 'resa ranalist) (a2 : 'resa -> 'resb ranalist) :
      'resb ranalist =
  fun l -> let (x, l) = a1 l in a2 x l

(* ---------------------------------- *)
(*
    S   ::=  '(' S ')'  |  'x'
*)

type ast = Fin | Pa of ast

let rec p_S : ast ranalist = fun l ->  l |>
     (terminal '('  -+>  p_S  ++>  (fun a -> terminal ')'  -+>  epsilon_res (Pa (a))))
  +| (terminal 'x'  -+>  epsilon_res Fin)

let test s = p_S (list_of_string s)
let _ = test "(((x)))a(bc"
let _ = test "xabc"
let _ = echec test "()abc"

(* ---------------------------------- *)
(* Exemple avec récursion mutuelle

  B  ::=  (B)  |  C
  C  ::=  x    |  yC   |  zBC  |  ε

 *)

type boite = Emb of boite | Cont of contenu
and contenu = X | Y of contenu | Z of boite * contenu | Quedalle

let rec p_B : boite ranalist = fun l ->  l |>
    (terminal '('  -+>  p_B  ++>  fun b -> terminal ')'  -+>  epsilon_res (Emb (b)))
 +| (p_C  ++>  fun c -> epsilon_res (Cont (c)))

and p_C : contenu ranalist = fun l ->  l |>
    (terminal 'x'  -+>  epsilon_res X)
 +| (terminal 'y'  -+>  p_C  ++>  fun c -> epsilon_res (Y (c)))
 +| (terminal 'z'  -+>  p_B  ++>  fun b -> p_C  ++>  fun c -> epsilon_res (Z (b, c)))
 +| epsilon_res Quedalle

let _ = p_B (list_of_string "((yz(yyx)yx))a")
let _ = p_B (list_of_string "((yz(yyx)y))a")
let _ = p_B (list_of_string "(())a")

(* ==================================================================== *)

(* ----------------------------- *)
(* Répétition (étoile de Kleene) *)
(* Grammaire :  A* ::=  A A* | ε *)
(* Dans le style de List.fold_right *)
let star_res (f : 'r -> 's -> 's) (s0 : 's) (a : 'r ranalist) : 's ranalist =
  let rec sa = fun l -> l |>
    ( a ++> fun r -> sa ++> fun rs -> epsilon_res (f r rs)) +| epsilon_res s0
  in sa

let _ = star_res (+) 0 (terminal 'x' -+> epsilon_res 1) (list_of_string "xxx-reste")

(* Critique (comme pour les fold de OCaml) :
  le code de star_res est simple, mais son utilisation est délicate
  - deux types 'r et 's
  - deux arguments f et s0 en plus du reste
  - deux arguments et un résultat dans f, avec quels types ?
 ce qui donne beaucoup d'occasions de se perdre
 *)

(* Adoptons des pipelines à la unix, c'est plus simple *)

let (<<) f g = fun x -> f (g x)
let (>>) f g = fun x -> g (f x)

(* Pipeline right to left*)
let star_pipe_R2L (a : ('r -> 'r) ranalist) : ('r -> 'r) ranalist =
  let rec a_star = fun l ->
    ( ( a ++> fun f -> a_star ++> fun f_star -> epsilon_res (f << f_star) )
      +|
        epsilon_res (fun x -> x)
    ) l
  in a_star

let star_R2L (a : ('r -> 'r) ranalist) (r0 : 'r) : 'r ranalist =
  star_pipe_R2L a ++> fun f -> epsilon_res (f r0)

(* Special case: building lists *)
let star_list (a : 'a ranalist) : ('a list) ranalist =
  star_R2L (a ++> fun x -> epsilon_res (fun l -> x :: l)) []

(* Pipeline left to right*)
let star_pipe_L2R (a : ('r -> 'r) ranalist) : ('r -> 'r) ranalist =
  let rec a_star = fun l ->
    ( ( a ++> fun f -> a_star ++> fun f_star -> epsilon_res (f >> f_star) )
      +|
        epsilon_res (fun x -> x)
    ) l
  in a_star

let star_L2R (r0 : 'r) (a : ('r -> 'r) ranalist) : 'r ranalist =
  star_pipe_L2R a ++> fun f -> epsilon_res (r0 |> f)

(* ----------------------------- *)
(* Exemple avec étoile de Kleene *)

let valchiffre : char -> int option = fun c ->
  match c with
  | '0' .. '9' -> Some (Char.code c - Char.code '0')
  |_ -> None

let chiffre : int ranalist = terminal_res valchiffre
let pluschiffre : (int -> int) ranalist =
  chiffre ++> fun n -> epsilon_res ((+) n)
let plus10chiffre : (int->int) ranalist =
  chiffre ++> fun n -> epsilon_res (fun x -> 10 * x + n)
let sommechiffres : int ranalist = star_R2L pluschiffre 0
let horner : int ranalist = star_L2R 0 plus10chiffre

let _ = sommechiffres (list_of_string "123-reste")
let _ = horner (list_of_string "123-reste")


let lettre : char ranalist =
  let char_lettre : char -> char option = fun c ->
    match c with
    | 'a' .. 'z' -> Some c
    |_ -> None
  in terminal_res char_lettre

let lettres : (char list) ranalist = star_list lettre

let cons_lettre : (char list -> char list) ranalist = lettre ++> fun c -> epsilon_res (fun l -> c :: l)

let _ = star_list (terminal 'x' -+> epsilon_res 1) (list_of_string "xxx-reste")
let _ = star_R2L pluschiffre 0                     (list_of_string "132-reste")
let _ = star_L2R 0 pluschiffre                     (list_of_string "132-reste")
let _ = star_L2R 0 plus10chiffre                   (list_of_string "123-reste")
let _ = (chiffre ++> fun n -> terminal '.' -+> star_L2R n plus10chiffre)
        (list_of_string "7.123-reste")
let _ = (lettre ++> fun c -> terminal ',' -+> star_list lettre ++> fun l -> epsilon_res (c :: l))
        (list_of_string "a,bcd-reste")