(* * Copyright (c) 2009 Robert Dockins and Aquinas Hobor. * *)
Definition unary_primop (f:nat -> nat) : expr :=
Lam (prim (v_Nat oo f) (Var 0)).
Program Definition bin_primop (f:nat -> nat -> nat) : expr :=
Lam (prim (fun n1 => Lam (prim (fun n2 => v_Nat (f n1 n2)) (Var 0))) (Var 0)).
Next Obligation.
compute; split; auto.
Qed.
Definition ty_bool := ALL a:pred world, ty_lam a (ty_lam a a).
Definition e_true := Lam (Lam (Var 1)).
Definition e_false := Lam (Lam (Var 0)).
Definition e_if b t f :=
(App (App (App b (Lam t)) (Lam f)) (Nat 0)).
Program Definition isZ : expr -> expr :=
prim (fun n => if beq_nat n 0 then e_true else e_false).
Solve Obligations using (compute; split; auto).
Definition e_let (def body:expr) :=
(App (Lam body) def).
Definition option (a:pred world) :=
ALL b:pred world, ty_lam b (ty_lam (ty_lam a b) b).
Definition none : expr := Lam (Lam (Var 1)).
Definition some : expr := Lam (Lam (Lam (App (Var 0) (Var 2)))).
Definition out  : expr := Lam (Lam (App (App (Var 0) (Var 1)) (Lam (Var 0)))).
Definition W := (Lam (App (Var 0) (Var 0))).
Definition diverge := App W W.
Definition W_ty Z := fun X => ty_lam X Z.
(* The standard CBV fixpoint combinator *)
Definition Wf := (Lam (App (Var 1) (Lam (App (App (Var 1) (Var 1)) (Var 0))))).
Definition Y := Lam (App Wf Wf).
Definition Wf_ty A B := fun X => ty_lam X (ty_lam A B).
Definition e_fix f := App Y (Lam f).
(* The "backpatching" fixpoint combinator, AKA Landin's knot. *)
Definition refY :=
Lam (e_let (New (Lam diverge))
(Update (Var 0) (Lam (App (App (Var 2) (Deref (Var 1))) (Var 0))) (Deref (Var 0)) )).
Definition r_fix f := App refY (Lam f).
(* Factorial function *)
Definition e_fac : expr :=
r_fix (Lam
(e_if (isZ (Var 0))
(* base case *)
(Nat 1)
(* recursive case *)
(App (App (bin_primop mult) (Var 1))
(App (Var 2) (App (unary_primop Peano.pred) (Var 1)))))).
(* Demonstrate an example of the factorial program working correctly. *)
Eval vm_compute in (snd (eval 100 empty_mem (App e_fac (Nat 6)))).
(* Our typed calculus is turing-complete. We demonstrate this by embedding the "untyped" CBV lambda terms. First we define a type U with the characteristic equation U = U -> U, and then we show that all closed terms formed from abstraction, application and variables can be given this type.  Turing-completeness follows from the fact that untyped CBV l-calc is turing-complete. *)
Fixpoint isULTerm (e:expr) : Prop :=
match e with
| Lam e' => isULTerm e'
| App e1 e2 => isULTerm e1 /\ isULTerm e2
| Var _ => True
| _ => False
end.

Lemma U_contractive : contractive (fun X => ty_lam X X).