type e = | Var of string | App of e * e | Abs of string * e let rec str = function | Var x -> x | App (e1, e2) -> Printf.sprintf "(%s %s)" (str e1) (str e2) | Abs (x, e) -> Printf.sprintf "(λ%s. %s)" x (str e) let isval = function | Var _ -> false | App _ -> false | Abs _ -> true let rec subst e v x = match e with | Var y -> if x = y then v else e | App (e1, e2) -> App (subst e1 v x, subst e2 v x) | Abs (y, e') -> if x = y then e else Abs (y, subst e' v x) let rec step = function | Var _ -> failwith "stuck: cannot step var" | App (Abs (x, e1), e2) -> if isval e2 then subst e1 e2 x else App (Abs (x, e1), step e2) | App (e1, e2) -> App (step e1, e2) | Abs _ -> failwith "done: cannot step abstraction" let rec sstep = function | Var x -> Var x | App (Abs (x, e1), e2) -> subst e1 e2 x | App (e1, e2) -> App (sstep e1, sstep e2) | Abs (x, e) -> Abs (x, sstep e) let rec simp e = let e' = sstep e in if e = e' then e' else simp e' let rec trace ?simplify:(simplify = true) e = Printf.printf "%s\n\n" (str e); if isval e then begin print_string "DONE.\n\n"; begin if simplify then Printf.printf "%s\n\n" (str (simp e)) end end else trace ~simplify:simplify (step e) let lcID = Abs ("x", Var "x") let lcTRUE = Abs ("x", Abs ("y", Var "x")) let lcFALSE = Abs ("x", Abs ("y", Var "y")) let lcCOND = Abs ("b", Abs ("p", Abs ("q", App (App (Var "b", Var "p"), Var "q")))) let lcNOT = Abs ("a", App (App (Var "a", lcFALSE), lcTRUE)) let lcAND = Abs ("a", Abs ("b", App (App (Var "a", Var "b"), lcFALSE))) let lcOR = Abs ("a", Abs ("b", App (App (Var "a", lcTRUE), Var "b"))) let lcOMEGA = App ( Abs ("x", App (Var "x", Var "x")) , Abs ("x", App (Var "x", Var "x"))) let lcMKPAIR = Abs ("x", Abs ("y", Abs ("s", App (App (Var "s", Var "x"), Var "y")))) let lcFST = Abs ("p", App (Var "p", lcTRUE)) let lcSND = Abs ("p", App (Var "p", lcFALSE)) let lcNIL = App (App (lcMKPAIR, lcFALSE), lcFALSE) let lcCONS = Abs ("h", Abs ("t", App ( App (lcMKPAIR, lcTRUE) , App (App (lcMKPAIR, Var "h"), Var "t")))) let lcISEMPTY = Abs ("l", App (lcFST, Var "l")) let lcHEAD = Abs ("l", App (lcFST, App (lcSND, Var "l"))) let lcTAIL = Abs ("l", App (lcSND, App (lcSND, Var "l"))) let lcZERO = Abs ("s", Abs ("z", Var "z")) let lcSUCC = Abs ("n", Abs ("s", Abs ("z", App (Var "s", (App (App (Var "n", Var "s"), Var "z")))))) (* \p. mkpair (succ (fst p)) (fst p) \p. (\n. mkpair (succ n) n) (fst p) *) let lcPREDaux = Abs ("p", App ( Abs ("n", App (App (lcMKPAIR, App (lcSUCC, Var "n")), Var "n")) , App (lcFST, Var "p"))) let lcPRED = Abs ("n", App (lcSND, App (App (Var "n", lcPREDaux), App (App (lcMKPAIR, lcZERO), lcZERO)))) let lcMKNUM n = let rec loop i = if i <= 0 then Var "z" else App (Var "s", loop (i - 1)) in Abs ("s", Abs ("z", loop n)) let lcONE = lcMKNUM 1 let lcTWO = lcMKNUM 2 let lcTHREE = lcMKNUM 3 let lcISZERO = Abs ("n", App (App (Var "n", Abs ("x", lcFALSE)), lcTRUE)) let lcADD = Abs ("m", Abs ("n", App (App (Var "m", lcSUCC), Var "n"))) let lcMUL = Abs ("m", Abs ("n", App (App (Var "m", App (lcADD, Var "n")), lcZERO))) let lcPOW = Abs ("m", Abs ("n", App (App (Var "n", App (lcMUL, Var "m")), lcONE))) let lcSUB = Abs ("m", Abs ("n", App (App (Var "n", lcPRED), Var "m"))) let lcTHUNK t = Abs ("x", App (t, Var "x")) let lcFACT = Abs ("f", Abs ("n", App ( App (App (lcCOND, App (lcISZERO, Var "n")), lcTHUNK lcONE) , lcTHUNK (App (App (lcMUL, Var "n"), App (Var "f", App (lcPRED, Var "n")))) ))) let lcY = Abs ("f", App ( Abs ("x", App (Var "f", Abs ("v", App (App (Var "x", Var "x"), Var "v")))) , Abs ("x", App (Var "f", Abs ("v", App (App (Var "x", Var "x"), Var "v")))) )) let _ = trace ~simplify:true ( App (App (lcY, lcFACT), lcTWO) ) (* App (lcY, lcFACT) App (App (lcSUB, lcMKNUM 3), lcMKNUM 2) App (App (lcSUB, lcMKNUM 2), lcMKNUM 3) App (lcPRED, lcTHREE) App (lcISZERO, lcONE) App (lcISZERO, lcZERO) App (lcTAIL, App (App (lcCONS, lcZERO), lcNIL)) App (lcHEAD, App (App (lcCONS, lcZERO), lcNIL)) App (App (lcCONS, lcZERO), lcNIL) App (lcSND, App (App (lcMKPAIR, lcTRUE), lcFALSE)) App (App (App (lcCOND, lcTRUE), lcTRUE), lcOMEGA) lcOMEGA App (App (lcOR, lcTRUE), lcFALSE) App (App (lcMUL, lcMKNUM 2), lcMKNUM 3) App (App (lcPOW, lcMKNUM 2), lcMKNUM 3) (Abs ("x", Var "x")) (App ( Abs ("x", Var "x") , Abs ("x", Var "x"))) *)