diff --git a/lam.ml b/lam.ml index 7c76a38..71f2341 100644 --- a/lam.ml +++ b/lam.ml @@ -8,7 +8,6 @@ type lam = | Var of id | Exf of lam * Types.ty - (** alpha renaming in a deterministic way *) let alpha_convert (e : lam) : lam = let cpt_var = ref 0 in (* id cpt for variables *) @@ -53,6 +52,7 @@ let rec subst (m : lam) (n : lam) (x : id) : lam = let e = subst e n x in Exf (e, t) +(* INVARIANT : e has already been alpha-converted *) let rec betastep (e : lam) : lam option = match e with Fun ((x, t), e) -> @@ -60,16 +60,19 @@ let rec betastep (e : lam) : lam option = None -> None | Some e -> Some (Fun ((x, t), e)) end - | App ((Fun ((x, t), e)), e2) -> - begin match betastep e with - None -> Some (subst e e2 x) - | Some e -> Some (App ((Fun ((x, t), e)), e2)) - end | App (e1, e2) -> + (* reduce leftmost redex. + e1 e2 -> e1' e2 then + e1_nf e2 -> e1_nf e2 then + (fun x -> e_nf) e2_nf -> e_nf[e2/x] *) begin match betastep e1 with None -> begin match betastep e2 with - None -> None + None -> + begin match e1 with + Fun ((x, _), e) -> Some (subst e e2 x) + | _ -> None + end | Some e2 -> Some (App (e1, e2)) end | Some e1 -> Some (App (e1, e2)) diff --git a/main.ml b/main.ml index 63c2ebf..2e175e0 100644 --- a/main.ml +++ b/main.ml @@ -3,9 +3,33 @@ open Typing type entry = Simple of Lam.lam + | Reduce of Lam.lam | AlphaEquiv of Lam.lam * Lam.lam +let beta_reduce e = + let rec aux = function + Some e -> + print_expr e; + print_newline (); + aux (Lam.betastep e); + | None -> () + in print_expr e; + print_newline (); + let e = Lam.alpha_convert e in + print_expr e; + print_newline (); + aux (Lam.betastep e) + +let alpha_get_lam where_from = + let input_str = In_channel.input_all where_from in + match Str.split (Str.regexp "&") input_str with + [s1; s2] -> AlphaEquiv ( + Parser.main Lexer.token (Lexing.from_string (s1^"\n")), + Parser.main Lexer.token (Lexing.from_string s2) + ) + | _ -> failwith "Alpha-equivalence: nombre de delimiteurs incorrect" + let interpret e = begin print_expr e; @@ -15,7 +39,9 @@ let interpret e = end let nom_fichier = ref "" +let reduce = ref false let alpha = ref false +let equiv_fichier = ref "" let parse_channel c = let lexbuf = Lexing.from_channel c in @@ -23,7 +49,12 @@ let parse_channel c = let recupere_entree () = let optlist = [ - ("-alpha", Arg.Set alpha, "Vérifie l'alpha équivalence de deux termes séparés par &"); + ("-alpha", + Arg.Set alpha, + "Vérifie l'alpha équivalence de deux termes séparés par &"); + ("-reduce", + Arg.Set reduce, + "Affiche les réductions successives du lambda-terme") ] in let usage = "Bienvenue à bord." in (* message d'accueil, option -help *) @@ -38,14 +69,10 @@ let recupere_entree () = let where_from = match !nom_fichier with | "" -> stdin | s -> open_in s in - if !alpha then - let input_str = In_channel.input_all where_from in - match Str.split (Str.regexp "&") input_str with - [s1; s2] -> AlphaEquiv ( - Parser.main Lexer.token (Lexing.from_string (s1^"\n")), - Parser.main Lexer.token (Lexing.from_string s2) - ) - | _ -> failwith "Alpha-equivalence: nombre de delimiteurs incorrect" + if !alpha + then alpha_get_lam where_from + else if !reduce + then Reduce (parse_channel where_from) else Simple (parse_channel where_from) with e -> (Printf.printf "problème de saisie\n"; raise e) @@ -54,6 +81,7 @@ let run () = try match recupere_entree () with Simple l -> let _ = interpret l in () + | Reduce l -> let _ = beta_reduce l in () | AlphaEquiv (l1, l2) -> begin if ((Lam.(=~)) l1 l2) then print_string "true\n" diff --git a/tests/betared1.lam b/tests/betared1.lam new file mode 100644 index 0000000..0028e53 --- /dev/null +++ b/tests/betared1.lam @@ -0,0 +1 @@ +(fun (x : A) => x) (fun (y : A) => y) z diff --git a/tests/betared2.lam b/tests/betared2.lam new file mode 100644 index 0000000..2733869 --- /dev/null +++ b/tests/betared2.lam @@ -0,0 +1 @@ +(fun (x : A) => fun (y : A) => y x) u (fun (t : A) => t t) diff --git a/tests/betared_rename.lam b/tests/betared_rename.lam new file mode 100644 index 0000000..c938257 --- /dev/null +++ b/tests/betared_rename.lam @@ -0,0 +1 @@ +(fun (x : A -> A) => (fun (y : A) => x y)) (fun (x : A) => x)