(* Implementation and correctness proof of fast mergeable priority queues
   using binomial queues.   Andrew W. Appel, October 2009.

 Required reading:
 "Binomial Queues", Section 9.7 of
  Algorithms 3rd Edition in Java, Parts 1-4:
    Fundamentals, Data Structures, Sorting, and Searching,
  by Robert Sedgewick.  Addison-Wesley, 2002.
  http://www.cs.princeton.edu/~appel/BQ.pdf
*)

(********************************* Preliminaries  *****************************)
Require Import SfLib.  (* SfLib is a module in "Software Foundations" by Pierce et al. *)
Require Import Permutation.
Notation "[ ]" := nil.
Notation "[ x , .. , y ]" := (cons x .. (cons y nil) ..).
Definition blt_nat (n m: nat) := ble_nat (S n) m.

Definition bgt_nat (n m : nat) := blt_nat m n.

Ltac inv H := inversion H; clear H; subst.

(****************** Binomial Heaps Implementation ****************************)

Definition key := nat.

Inductive tree : Type :=
|  Node: key -> tree -> tree -> tree
|  Leaf : tree.

(* A priority queue (using the binomial queues data structure)
   is a list of trees.
   The i'th element of the list is either Leaf or it is a
   power-of-2-heap with exactly 2^i nodes.
*)

Definition priqueue := list tree.

Definition emptyQ : priqueue := nil.

Definition smash (t u:  tree) : tree :=
  match t , u with
  |  Node x t1 Leaf, Node y u1 Leaf =>
                   if  bgt_nat x y then Node x (Node y u1 t1) Leaf
                                else Node y (Node x t1 u1) Leaf
  | _ , _ => Leaf  (* arbitrary bogus tree *)
  end.

Fixpoint carry (q: list tree) (t: tree) : list tree :=
  match q, t with
  | nil, Leaf        => nil
  | nil, _            => t :: nil
  | Leaf :: q', _  => t :: q'
  | u :: q', Leaf  => u :: q'
  | u :: q', _       => Leaf :: carry q' (smash t u)
 end.

Definition insert (q: priqueue) (x: key) : priqueue :=
     carry q (Node x Leaf Leaf).

(* Do the query "Print fold_left" to see how fold_left works.  *)
Definition queue1 := fold_left insert [3,1,4,1,5,9,2,3,5] emptyQ.

Fixpoint join (p q: priqueue) (c: tree) : priqueue :=
  match p, q, c with
    [], _ , _            => carry q c
  | _, [], _             => carry p c
  | Leaf::p', Leaf::q', _              => c :: join p' q' Leaf
  | Leaf::p', q1::q', Leaf            => q1 :: join p' q' Leaf
  | Leaf::p', q1::q', Node _ _ _  => Leaf :: join p' q' (smash c q1)
  | p1::p', Leaf::q', Leaf            => p1 :: join p' q' Leaf
  | p1::p', Leaf::q',Node _ _ _   => Leaf :: join p' q' (smash c p1)
  | p1::p', q1::q', _                   => c :: join p' q' (smash p1 q1)
 end.

Fixpoint unzip (t: tree) (cont: priqueue -> priqueue) : priqueue :=
  match t with
  |  Node x t1 t2   => unzip t2 (fun q => Node x t1 Leaf  :: cont q)
  | Leaf => cont nil
  end.

Definition heap_delete_max (t: tree) : priqueue :=
  match t with
    Node x t1 Leaf  => unzip t1 (fun u => u)
  | _ => nil   (* bogus value for ill-formed or empty trees *)
  end.

Fixpoint find_max' (current: key) (q: priqueue) : key :=
  match q with
  |  []         => current
  | Leaf::q' => find_max' current q'
  | Node x _ _ :: q' => find_max' (if bgt_nat x current then x else current) q'
  end.

Fixpoint find_max (q: priqueue) : key :=
  match q with
  | [] => O   (* bogus value *)
  | Leaf::q' => find_max q'
  | Node x _ _ :: q' => find_max' x q'
 end.

Fixpoint delete_max_aux (m: key) (p: priqueue) : priqueue * priqueue :=
           match p with
           | Leaf :: p'   => let (j,k) := delete_max_aux m p'  in (Leaf::j, k)
           | Node x t1 Leaf :: p' =>
                   if bgt_nat m x then (let (j,k) := delete_max_aux m p' in (Node x t1 Leaf::j,k))
                   else (Leaf::p', heap_delete_max (Node x t1 Leaf))
           | _ => (nil, nil) (* Bogus value *)
          end.

Definition delete_max (q: priqueue) : priqueue :=
   let m := find_max q
    in let (p',q') := delete_max_aux m q
         in join p' q' Leaf.

(********************** Useful things ************************************************)
(* Make sure you understand the statement of each theorem, because you may
  need to use these theorems in your own proofs.  You probably don't need to
  read and understand the proofs of the theorems.  But you might do that anyway,
  to see examples of what the "omega" tactic can solve. *)

Theorem ble_nat_e: forall n m, true = ble_nat n m -> n <= m.
Proof.
induction n as [|n']; intros.
omega.
destruct m; simpl in H.
inversion H.
apply IHn' in H.
omega.
Qed.

Theorem ble_nat_i: forall n m, n <= m -> true = ble_nat n m.
Proof.
induction n as [|n']; intros; simpl; auto.
destruct m.
elimtype False.
omega.
apply IHn'.
omega.
Qed.

Theorem bgt_nat_e: forall n m, true = bgt_nat n m -> n>m.
Proof.
unfold bgt_nat, blt_nat; intros.
apply ble_nat_e in H. omega.
Qed.

Theorem bgt_nat_i: forall n m, n > m -> true = bgt_nat n m.
Proof.
unfold bgt_nat, blt_nat; intros.
apply ble_nat_i.
omega.
Qed.

Theorem false_bgt_nat_i:  forall n m, n <= m -> false = bgt_nat n m.
Proof.
intros.
remember (bgt_nat n m) as GT; destruct GT; auto.
apply bgt_nat_e in HeqGT.
elimtype False; omega.
Qed.

Theorem false_bgt_nat_e: forall n m, false = bgt_nat n m -> n<=m.
Proof.
intros.
assert (n <= m \/ n > m) by omega.
destruct H0; auto.
apply bgt_nat_i in H0.
rewrite <- H0 in H.
inversion H.
Qed.

(******************************** Theorems about Binomial Queues ************************)

(* t is an a complete binary tree of depth n, with every key <= m *)
Fixpoint pow2heap' (n: nat) (m: key) (t: tree) :=
 match n, m, t with
    0, m, Leaf       => True
  | 0, m, Node _ _ _  => False
  | S _, m,Leaf    => False
  | S n', m, Node k l r  => m >= k /\ pow2heap' n' k l /\ pow2heap' n' m r
 end.

(* t is a power-of-2 heap of depth n *)
Definition pow2heap (n: nat) (t: tree) :=
  match t with
    Node m t1 Leaf => pow2heap' n m t1
  | _ => False
  end.

(* l is the i'th tail of a binomial heap *)
Fixpoint priq'  (i: nat) (l: list tree) : Prop :=
   match l with
  | t :: l' => (t=Leaf \/ pow2heap i t) /\ priq' (S i) l'
  | nil => True
 end.

(* q is a binomial heap *)
Definition priq (q: priqueue) : Prop := priq' 0 q.

(**********************  START YOUR WORK HERE *************************************)

(* This theorem shows a convenient way of proving theorems involving bgt_nat.
   It's worth studying the proof carefully. *)
Example example:  forall a b c d,
    true = bgt_nat a b ->
    false = bgt_nat c d ->
    true = bgt_nat (a+d) (b+c).
Proof.
intros.
(* Step one: Change hypotheses about bgt_nat to hypotheses about gt.  *)
 apply bgt_nat_e in H. apply false_bgt_nat_e in H0.
(* Step two: Change proof-goal about bgt_nat to proof-goal about gt. *)
apply bgt_nat_i.
(* Step three:  omega tactic can solve proof goals about lt, eq, gt,
  given hypotheses about lt, eq, gt of nats. *)
omega.
 (* Step through this example, and to see the principle of how to
      use the omega tactic. *)
Qed.

(** **** Exercise: 1 star (emptyQ_valid)  *)
Theorem emptyQ_valid: priq emptyQ.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (smash_valid) *)
Theorem smash_valid:
       forall n t u, pow2heap n t -> pow2heap n u -> pow2heap (S n) (smash t u).
(* FILL IN HERE *) Admitted.
(** [] *)

(*  tree_elems t l    means that the keys in t are the same as the elements of l (with repetition) *)
Inductive tree_elems: tree -> list key -> Prop :=
| tree_elems_leaf: tree_elems Leaf nil
| tree_elems_node:  forall bl br v tl tr b,
           tree_elems tl bl ->
           tree_elems tr br ->
           Permutation b (v::bl++br) ->
           tree_elems (Node v tl tr) b.

(* Notice that we use the "Permutation" relation.  "Permutation l1 l2" means that list l1 is
  some rearrangement of list l2.  In the Coq query window, do "SearchAbout Permutation"
  to learn about all sorts of useful theorems about permutations.  In the next
  proof, I applied Permutation_nil, Permutation_trans, and Permutation_sym.  But you might
  do it a different way.  In other proofs, I also use  Permutation_app, Permutation_app_swap,
  perm_skip, perm_swap, and others that I found with the SearchAbout command. *)

(** **** Exercise: 2 stars (tree_elems_ext) *)
(* Extensionality theorem for the tree_elems relation *)
Theorem tree_elems_ext: forall t e1 e2,
  Permutation e1 e2 -> tree_elems t e1 -> tree_elems t e2.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (permut_example) *)
(* To prove this next example, you'll also want to apply some theorems about the "app"
  function (which is the function behind the ++ notation.  Do "SearchAbout app" in the
  Query window.  My favorites are app_nil_end and app_ass.  *)
Example permut_example:
          forall (a b: list key),  Permutation (5::6::a++b) ((5::b)++(6::a++[])).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (smash_elems) *)
(*  Warning:  This next theorem is time-consuming.
  If you're pressed for time, this is one to leave out!  *)
Theorem smash_elems: forall n t u bt bu,
                     pow2heap n t -> pow2heap n u ->
                     tree_elems t bt -> tree_elems u bu ->
                     tree_elems (smash t u) (bt ++ bu).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (priqueue_elems) *)
(* Make an inductive definition, similar to tree_elems, to relate
  a priority queue  "l"  to a list of all its elements.  *)
Inductive priqueue_elems: list tree -> list key -> Prop :=
             (* FILL IN HERE *)
.
(** [] *)

(** **** Exercise: 2 stars (priqueue_elems_ext) *)
(* To prove priqueue_elems_ext, you should almost be able to cut-and-paste the
   proof of tree_elems_ext, with just a few edits.  *)
Theorem priqueue_elems_ext: forall q e1 e2,
  Permutation e1 e2 -> priqueue_elems q e1 -> priqueue_elems q e2.
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (carry_valid) *)
Theorem carry_valid:
           forall n q,  priq' n q ->
           forall t, (t=Leaf \/ pow2heap n t) -> priq' n (carry q t).
(* FILL IN HERE *) Admitted.
(** [] *)

(* Here ends the main part of the exercise.
   The rest are "extra challenge" problems,
   which you can do if you have the time and the inclination.  *)

(** **** Exercise: 4 stars (carry_elems) *)
Theorem carry_elems:
      forall n q,  priq' n q ->
      forall t, (t=Leaf \/ pow2heap n t) ->
      forall eq et, priqueue_elems q eq ->
                          tree_elems t et ->
                          priqueue_elems (carry q t) (eq++et).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (insert_valid) *)
Theorem insert_valid: forall q x, priq q -> priq (insert q x).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars (insert_elems) *)
Theorem insert_elems:
                  forall q x, priq q ->
                  forall e, priqueue_elems q e ->
                              priqueue_elems (insert q x) (x::e).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars (join_valid) *)
Theorem join_valid: forall p q c n, priq' n p -> priq' n q -> (c=Leaf \/ pow2heap n c) -> priq' n (join p q c).
(* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 4 stars (join_elems) *)
Theorem join_elems:
                forall p q c n,
                      priq' n p ->
                      priq' n q ->
                      (c=Leaf \/ pow2heap n c) ->
                  forall pe qe ce,
                             priqueue_elems p pe ->
                             priqueue_elems q qe ->
                             tree_elems c ce ->
                              priqueue_elems (join p q c) (ce++pe++qe).
(* FILL IN HERE *) Admitted.
(** [] *)


From Coq Require Import Arith.
From mathcomp Require Import ssreflect.

Require Import MyExtraction.

(* Section コマンド : スクリプトにセクションを導入する *)
Section ModusPonens.
  (* Variables コマンド : 変数宣言 *)
  (* ここでは Prop (命題) 型の変数 X, Y を宣言している *)
  Variables X Y : Prop.

  (* Hypothesis コマンド : セクション内の仮定を設定する *)
  Hypothesis XtoY_is_true : X -> Y.
  Hypothesis X_is_true : X.

  (* Theorem コマンド : 言明を宣言する *)
  Theorem MP : Y.
  Proof.
    (* move: タクティック : コンテキストにある型や証明済みの補題をスタックのトップに追加する *)
    move: X_is_true.
    (* ターミネータ (よって自明) *)
    by [].
  Qed.
End ModusPonens.

Theorem HA1 : forall (a b : Prop), a -> (b -> a).
Proof.
  intro.
  intro.
  trivial.
Qed.

Module Bar.
  Definition f x := x + 100.
  Definition g x := x - 100.

  Theorem g_f : forall x, g (f x) = x.
  Proof.
    intro.
    unfold f, g.
    rewrite Nat.add_sub.
    trivial.
  Qed.
End Bar.

Extraction "foo.ml" Bar.


Fixpoint eqb (n m : nat) : bool :=
  match n, m with
  | O, O => true
  | O, _ => false
  | _, O => false
  | S n', S m' => (eqb n' m')
  end.

Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.

Theorem plus_1_neq_0 : forall n : nat,
    (n + 1) =? 0 = false.

Proof.
  intros n. destruct n as [| n'] eqn:E.
  - reflexivity.
  - reflexivity.
Qed.


Require Import Coq.Setoids.Setoid.

Reserved Infix "≃" (at level 70).

Inductive cat_eq {A : Type} (f g : A -> Type) : Prop :=
    | eq  : f = g -> cat_eq f g
    | ext : (forall a, eq (f a) (g a)) -> cat_eq f g.

Notation "f ≃ g" := (cat_eq f g).

Lemma cat_eq_sym_aux {A : Type} (f g : A -> Type) : f ≃ g -> g ≃ f.
Proof.
    intro. induction H.
    - now apply eq.
    - apply ext. intro. symmetry. exact (H a).
Qed.

Lemma cat_eq_sym {A : Type} (f g : A -> Type) : f ≃ g <-> g ≃ f.
Proof.
    split; now apply cat_eq_sym_aux.
Qed.

Lemma cat_eq_refl {A : Type} (f : A -> Type) : f ≃ f.
Proof.
    now apply eq.
Qed.

Lemma cat_eq_trans {A : Type} (f g h : A -> Type) : f ≃ g -> g ≃ h -> f ≃ h.
Proof.
    intros. induction H.
    - now rewrite <- H in H0.
    - induction H0.
        + rewrite H0 in H. now apply ext.
        + apply ext. congruence.
Qed.

Add Parametric Relation (A : Type) : (A -> Type) (@cat_eq A)
    reflexivity proved by (cat_eq_refl)
    symmetry proved by (cat_eq_sym_aux)
    transitivity proved by (cat_eq_trans)
      as cat_eq_rel.


Require Import Arith.
Require Import Omega.
Require Import ClassicalRealizability.Kbase.
Require Import ClassicalRealizability.Integers.
Require Import ClassicalRealizability.KBool.

Ltac Keval := basic_Keval ltac:(idtac; int_Keval fail).

(** Non deterministic boolean **)

Parameter fork : instruction.

Axiom red_fork1 : forall t u e π, fork↓e ★ t·u·π ≻ t ★ π.
Axiom red_fork2 : forall t u e π, fork↓e ★ t·u·π ≻ u ★ π.

(** We cannot put automatization tactics for evaluating fork,
    as there are two possible choices. **)
Ltac fork1 :=
  match goal with
    | |- Cst fork↓_ ★ ?t·?u·?π ∈ ⫫ => apply anti_evaluation with (t ★ π);
          [now apply red_fork1 |]
  end.

Ltac fork2 :=
  match goal with
    | |- Cst fork↓_ ★ ?t·?u·?π ∈ ⫫ => apply anti_evaluation with (u ★ π);
          [now apply red_fork2 |]
  end.

Transparent inter.

Theorem fork_spec1 : forall A B e, fork↓e ⊩ A → B → (A ∩ B).
Proof. Ksolve; [fork1 | fork2]; Ksolve. Qed.

(** *  Recurrence axiom  **)

(** Proved with primitive integers rather than Krivine ones. **)
Definition rec := Y @ λ"n" fork @ (mℕ @ Int 0) @ ("n" @ succℕ).

Theorem recurrence_axiom : forall x e, rec↓e ⊩ ℕ x.
Proof.
Ksolve. apply (Y_realizer lt_wf). find.
Ksolve. destruct x0.
  fork1. Keval. apply mℕ_storage. now find.
  fork2. Ksolve. now apply lt_n_Sn. start. apply succℕ_realizer.
  replace (S x0) with (x0 + 1) in Hπ. find. ring.
Qed.

(** *  Equivalent statements  **)

(** **  Subtype equivalent statements  **)

Lemma equiv_fork_inter : (∀A B, A → B → (A ∩ B)) ≈ (∀A B, A → B → A) ∩ (∀A B, A → B → B).
Proof.
apply subtype_eqtype.
  apply sub_inter; subtyping.
  intros π Hπ. dec π. left. find. right. find.
Qed.

Lemma equiv_inter_Bool : (∀A B, A → B → A) ∩ (∀A B, A → B → B) ≈ 𝔹 0 ∩ 𝔹 1.
Proof.
apply subtype_eqtype; apply inter_sub_compat.
  subtyping.
  subtyping.
  apply sub_Forall_add. intro A. apply sub_Forall_add. intro B.
  etransitivity. apply (sub_Forall _ (fun n : nat => if eq_nat_dec n 0 then A else B)). simpl. reflexivity.
  apply sub_Forall_add. intro A. apply sub_Forall_add. intro B.
  etransitivity. apply (sub_Forall _ (fun n : nat => if eq_nat_dec n 0 then A else B)). simpl. reflexivity.
Qed.

Corollary equiv_fork_Bool : (∀A B, A → B → (A ∩ B)) ≈ 𝔹 0 ∩ 𝔹 1.
Proof.
transitivity ((∀A B, A → B → A) ∩ (∀A B, A → B → B)).
  now apply equiv_fork_inter.
  now apply equiv_inter_Bool.
Qed.

(** **  Universally equivalent statements  **)

(** We prove that having a universal realizer for one of these formulæ gives
    one for all the others, according the following chain:

    [𝔹 0 ∩ 𝔹 1]  ⇒  [∀x, x ∈ ℕ]  ⇒  [∀x, x = 0 ∨ ∃y, x = S y]  ⇒  [(⊥ → ⊤ → ⊥) ∩ (⊤ → ⊥ → ⊥)]  ⇒  [𝔹 0 ∩ 𝔹 1]
**)
Definition fork_rec := λ"fork" Y @ λ"n" "fork" @ (mℕ @ Int 0) @ ("n" @ succℕ).

Lemma equiv_fork_rec : forall e, fork_rec↓e ⊩ (𝔹 0 ∩ 𝔹 1) → ∀x, ℕ x.
Proof.
Ksolve. apply (Y_realizer lt_wf). find.
Ksolve. destruct x0.
  left. exists (fun n : nat => if eq_nat_dec n 0 then ℕ 0 else ⊤). Ksolve.
    Ksolve. apply mℕ_storage. exists 0. now find.
    simpl. ok.
  right. exists (fun n : nat => if eq_nat_dec n 0 then ⊤ else ℕ (S x0)). simpl. Ksolve.
  Ksolve. now apply lt_n_Sn. start. apply succℕ_realizer.
  replace (S x0) with (x0 + 1) in Hπ. find. ring.
Qed.

Definition rec_case := λ"rec" λ"left" λ"right" "rec" @ λ"n" (mℕ @ Int 0) @ ℤeq @ "n"
  @ ("left" @ Id)
  @ ("right" @ λ"f" "f" @ Id).

Lemma equiv_rec_case : forall e, rec_case↓e ⊩ (∀x, ℕ x) → (∀x, x ≡ 0 ∨ ∃y, x ≡ S y).
Proof.
do 2 Ksolve. apply mℕ_storage. exists 0. find.
  start. apply ℕeq_realizer2. exists 0. exists x. find.
  Ksolve.
    Ksolve. subst. start. apply Id_realizer. destruct Hπ as [[Hc0 Hπ] | [Hc0 Hπ]].
      ok.
      now elim Hc0.
    Ksolve. Kmove. exists (pred x). Kmove. start. apply Id_realizer. destruct Hπ as [[Hc0 Hπ] | [Hc0 Hπ]].
      ok.
      elim Hc0. apply (S_pred x 0). omega.
Qed.

Definition case_TopBot := λ"t" λ"x" λ"y" "t" @ (λ"f" "f" @ "x") @ (λ"f" "f" @ λ"g" "g" @ "y").

Lemma equiv_case_TopBot : forall e, case_TopBot↓e ⊩ (∀x, x ≡ 0 ∨ ∃y, x ≡ S y) → (⊥ → ⊤ → ⊥) ∩ (⊤ → ⊥ → ⊥).
Proof.
Kmove.
  exists 0. Ksolve.
    Ksolve. left. now find.
    do 2 Ksolve. right. find. omega.
  exists 1. Ksolve.
    Ksolve. right. find. omega.
    Ksolve. Kmove. destruct y.
      left. now find.
      right. find. omega.
Qed.

Definition TopBot_Bool := λ"t" λ"x" λ"y" callcc @ λ"k" "t" @ ("k" @ "x") @ ("k" @ "y").

Lemma equiv_TopBot_Bool : forall e, TopBot_Bool↓e ⊩ (⊥ → ⊤ → ⊥) ∩ (⊤ → ⊥ → ⊥) → 𝔹 0 ∩ 𝔹 1.
Proof. unfold 𝔹. Ksolve. left. do 2 Ksolve. right. do 2 Ksolve. Qed.

(*
Lemma subtype_Bool_TopBot : 𝔹 0 ∩ 𝔹 1 ⊆ (⊥ → ⊤ → ⊥) ∩ (⊤ → ⊥ → ⊥).
Proof. rewrite <- equiv_inter_Bool. subtyping. Qed.

*)


Require Import Setoid Omega RelationClasses Morphisms.

Require Export Bool Omega List Setoid Morphisms.

Global Set Implicit Arguments.
Global Unset Strict Implicit.
Global Unset Printing Records.
Global Unset Printing Implicit Defensive.
Global Set Regular Subst Tactic.

Instance le_preorder : PreOrder le.
Proof.
  constructor. all:cbv. all:intros;omega.
Qed.

Instance S_le_proper : Proper (le ==> le) S.
Proof.
  cbv. fold plus. intros. omega.
Qed.

Instance plus_le_proper : Proper (le ==> le ==> le) plus.
Proof.
  cbv. fold plus. intros. omega.
Qed.

Instance mult_le_proper : Proper (le ==> le ==> le) mult.
Proof.
  cbv. intros.
  apply mult_le_compat. all:eauto.
Qed.

Instance max_le_proper : Proper (le ==> le ==> le) max.
repeat intro. repeat eapply Nat.max_case_strong;omega.
Qed.

Instance min_le_proper : Proper (le ==> le ==> le) min.
repeat intro. repeat eapply Nat.min_case_strong;omega.
Qed.

Instance Nat_log2_le_Proper : Proper (le ==> le) Nat.log2.
Proof.
  repeat intro. apply Nat.log2_le_mono. assumption.
Qed.
Instance Pos_to_nat_le_Proper : Proper (Pos.le ==> le) Pos.to_nat.
Proof.
  repeat intro. apply Pos2Nat.inj_le. assumption.
Qed.

Instance Pos_add_le_Proper : Proper (Pos.le ==> Pos.le ==>Pos.le) Pos.add.
Proof.
  repeat intro. eapply Pos.add_le_mono. 3:eauto. all:eauto.
Qed.


Require Import List Lia.
Import ListNotations.
Require Import ssreflect ssrbool ssrfun.

Require Import Undecidability.HilbertCalculi.HSC.

Set Default Goal Selector "!".

(* number of nodes in the syntax tree of a formula *)
Fixpoint size s :=
  match s with
  | var _ => 1
  | arr s t => S (size s + size t)
  end.

(* list of first k arguments *)
Fixpoint arguments (k: nat) (t: formula) :=
  match k with
  | 0 => []
  | S k =>
    match t with
    | var _ => []
    | arr s t => s :: (arguments k t)
    end
  end.

(* target after first k arguments *)
Fixpoint target (k: nat) (t: formula) :=
  match k with
  | 0 => t
  | S k =>
    match t with
    | var _ => t
    | arr _ t => target k t
    end
  end.

(* Hilbert-style calculus with derivation depth *)
Inductive der (Gamma: list formula) : nat -> formula -> Prop :=
  | der_var {ζ: nat -> formula} {s t: formula} {k n: nat} :
      In s Gamma ->
      Forall (der Gamma n) (arguments k (substitute ζ s)) ->
      target k (substitute ζ s) = t ->
      der Gamma (S n) t.

Lemma derE {n Gamma t} : der Gamma n t ->
  match n with
  | 0 => False
  | S m =>
      exists (ζ: nat -> formula) (s: formula) (k: nat),
        In s Gamma /\
        Forall (der Gamma m) (arguments k (substitute ζ s)) /\
        target k (substitute ζ s) = t
  end.
Proof. case=> *. do 3 eexists. by eauto. Qed.

Lemma der_mon {n m t Gamma} : der Gamma n t -> n <= m -> der Gamma m t.
Proof.
  elim: n m Gamma t; first by move=> > /derE.
  move=> n IH m Gamma t.
  move /derE => [ζ [s' [k']]] [? [? ?]] ?.
  have -> : m = S (Nat.pred m) by lia.
  apply: der_var; try eassumption.
  apply: Forall_impl; last by eassumption.
  move=> ? /IH. apply. by lia.
Qed.

Lemma target_S {r s t k} : target k r = arr s t -> target (S k) r = t.
Proof.
  elim: k r s t; first by move=> > /= ->.
  by move=> k IH [> /= |  > /= /IH <-].
Qed.

Lemma arguments_S {r s t k} : target k r = arr s t -> arguments (S k) r = (arguments k r) ++ [s].
Proof.
  elim: k r s t; first by move=> > /= ->.
  by move=> k IH [> /= |  > /= /IH <-].
Qed.

(* every hsc derivation has a depth *)
Lemma hsc_der {Gamma t} : hsc Gamma t -> exists n, der Gamma n t.
Proof.
  elim.
  - move=> ζ s /der_var => /(_ ζ (substitute ζ s) 0 0).
    move=> H. exists 1. apply: H; by [|constructor].
  - move=> s' t' _ [[|n1] /derE]; [done|].
    move=> + _ [[|n2] /derE]; [done|].
    move=> [ζ1 [s1 [k1 [Hs1 [? Hk1]]]]].
    move=> [ζ2 [s2 [k2 [? [? ?]]]]].
    exists (S (S (n1+n2))). apply: (der_var _ (ζ := ζ1) (s := s1) (k := S k1)).
    + done.
    + rewrite (arguments_S Hk1). apply /Forall_app. constructor.
      * apply: Forall_impl; last eassumption.
        move=> ? /der_mon. apply. by lia.
      * constructor; last done.
        apply: der_var; last eassumption; first done.
        apply: Forall_impl; last eassumption.
        move=> ? /der_mon. apply. by lia.
    + apply: target_S. by eassumption.
Qed.


Require Import BinNat.
Require Import Omega.
Require Import Logic.FunctionalExtensionality.
Require Import Program.Basics.
Require Import micromega.Lia.
Require Import Nnat.
Require Import bin_prelims.
Require countdown.

(*
==================================================================================
***************************** SECTION 11: COUNTDOWN  *****************************
==================================================================================
 *)

(*
 * In Section 4 (inverse.v)
 * we explored how to compute inverse of a function's repeater
 * solely from the function's own inverse, without directly computing the
 * repeater itself. The first lemma addresses this.
 *
 * We base the definition of "contractions" and "countdown" on this observation.
 * We also give a computation for countdown and prove several useful results
 * about it.
 *
 * The inverse of (repeater_from a F) is the minimum number of applications
 * of (inverse F) to the input to get a result less than or equal to a.
 *  This serves as motivation to contractions and countdown
 *)

Open Scope N_scope.

(* ****** CONTRACTIONS ****************** *)

Definition bin_contracting (f : N -> N) : Prop :=
  forall n, f n <= n.

Definition bin_contract_strict_above (a : N) (f : N -> N) : Prop :=
  (bin_contracting f) /\ (forall n, a < n -> f n <= (n + a) / 2).

(* ****** PROPERTIES OF CONTRACTIONS ************ *)

(* Correct counterpart of contractions on nat *)
Lemma contract_Nnat : forall f,
    bin_contracting f <-> countdown.contracting (to_nat_func f).
Proof.
  intro f. unfold to_nat_func. split; intros H n.
  - rewrite le_nat_N. rewrite N2Nat.id. apply H.
  - specialize (H (N.to_nat n)). simpl in H. rewrite le_nat_N in H.
    repeat rewrite N2Nat.id in H. apply H.
Qed.

(* strict binary contractions are strict contractions on nat *)
Lemma bin_contract_strict_Nnat : forall a f,
   bin_contract_strict_above a f ->
    countdown.contract_strict_above (N.to_nat a) (to_nat_func f).
Proof.
  intros a f [Hf Haf]. split.
  - rewrite <- contract_Nnat. apply Hf.
  - intros n. unfold to_nat_func. repeat rewrite lt_nat_N.
    repeat rewrite N2Nat.id. intro Han.
    apply (N.le_lt_trans _ (((N.of_nat n) + a) / 2) _);
    [apply Haf|apply N.div_lt_upper_bound]; lia.
Qed.

(* repeat of contractions make the result smaller *)
Lemma repeat_contract :
  forall f n k l,
    bin_contracting f -> (k <= l)%nat -> repeat f l n <= repeat f k n.
Proof.
  intros f n k l Hf Hkl.
  induction l; inversion Hkl; [lia |lia |].
  apply IHl in H0.
  apply (N.le_trans _ (repeat f l n) _); [apply Hf | apply H0].
Qed.

(* strict version *)
Lemma repeat_bin_contract_strict :
  forall a f n k,
    bin_contract_strict_above a f ->
    a < repeat f k n ->
    ((S k) + nat_size (repeat f (S k) n - a) <= nat_size (n - a))%nat.
Proof.
  intros a f n k [Hf Haf] Han. induction k.
  - simpl in *. apply div2_nat_size; [lia|]. apply Haf in Han.
    rewrite le_div_mul_N; [rewrite le_div_mul_N in Han|]; lia.
  - apply (Nat.le_trans _ (S k + nat_size (repeat f (S k) n - a)) _).
    + simpl in *. rewrite <- Nat.add_succ_r.
      rewrite <- Nat.succ_le_mono, <- Nat.add_le_mono_l.
      apply div2_nat_size; [lia|]. apply Haf in Han.
      rewrite le_div_mul_N; [rewrite le_div_mul_N in Han|]; lia.
    + assert (a < repeat f k n) as Han0.
      * apply (N.lt_le_trans _ (repeat f (S k) n) _);
          [apply Han| apply Hf].
      * apply (IHk Han0).
Qed.

(* ****** COUNTDOWN *************************************)

Fixpoint bin_cdn_wkr (f : N -> N) (a n : N) (b : nat) : N :=
  match b with
  | O    => 0
  | S b' => if (n <=? a) then 0
             else 1 + bin_cdn_wkr f a (f n) b'
  end.

Definition bin_countdown_to (f : N -> N) (a n : N) : N
  := bin_cdn_wkr f a n (nat_size (n - a)).

Lemma bin_contract_strict_threshold : forall a f n,
    bin_contract_strict_above a f -> exists (t : nat),
    (repeat f t n <= a
    /\ forall k, repeat f k n <= a -> (t <= k)%nat).
Proof.
  intros a f n Haf. destruct Haf as [Hf Haf].
  remember (N.to_nat (n - a)) as m eqn: Hm.
  symmetry in Hm. rewrite <- Nat2N.id in Hm.
  apply N2Nat.inj in Hm. generalize dependent a.
  induction m.
  - exists 0%nat. simpl. split.
    + rewrite <- N.sub_0_le. apply Hm.
    + intros. omega.
  - intros a Haf Hm. rewrite Nat2N.inj_succ in Hm.
    destruct (IHm (N.succ a)) as [x [Hax Haxn]];
    [intros; apply (N.le_trans _ ((n0 + a)/2) _);
       [apply Haf|apply N.div_le_mono]; lia| lia| ].
    apply N.le_lteq in Hax. rewrite N.lt_succ_r in Hax.
    destruct Hax as [Hax | Hax]; [exists x| exists (S x)];
    split; try assumption.
    + intros k Hk. apply Haxn. lia.
    + rewrite <- N.lt_succ_r. simpl. rewrite Hax.
      apply (N.le_lt_trans _ ((N.succ a + a) / 2) _).
      * apply Haf. lia.
      * rewrite N.lt_nge. rewrite le_div_mul_N; lia.
    + intros k Hk. assert (repeat f k n <= N.succ a) as H by lia.
      apply Haxn in H. destruct H; [lia| omega].
Qed.

Lemma bin_countdown_base : forall f a n b,
    n <= a -> bin_cdn_wkr f a n b = 0.
Proof.
  intros f a n b Han. destruct b; trivial.
  rewrite <- N.leb_le in Han. simpl. rewrite Han. trivial.
Qed.

Lemma bin_countdown_intermediate : forall f a n b i,
    bin_contracting f -> ((S i) <= b)%nat -> (a < repeat f i n)
    -> bin_cdn_wkr f a n b =
         N.of_nat (S i) + bin_cdn_wkr f a (repeat f (S i) n) (b - (S i)).
Proof.
  intros f a n b i Hf.
  generalize dependent b. generalize dependent n.
  induction i; intros n b Hib Han; rewrite <- N.leb_gt in Han.
  - destruct b. inversion Hib. replace (S b - 1)%nat with b by omega.
    unfold bin_cdn_wkr. simpl in Han. rewrite Han. trivial.
  - rewrite IHi.
    + replace (b - S i)%nat with (S (b - S(S i))) by omega.
      unfold bin_cdn_wkr. rewrite Han.
      replace (N.of_nat (S(S i))) with (N.of_nat (S i) + 1).
      apply N.add_assoc. rewrite N.add_1_r.
      repeat rewrite Nat2N.inj_succ. trivial.
    + omega.
    + rewrite N.leb_gt in Han.
      apply (N.lt_le_trans _ (repeat f (S i) n) _).
      apply Han. apply Hf.
Qed.

Theorem bin_countdown_repeat : forall f a n m,
    bin_contract_strict_above a f ->
    bin_countdown_to f a n <= m <-> repeat f (N.to_nat m) n <= a.
Proof.
  intros f a n m Hf. unfold bin_countdown_to.
  destruct (bin_contract_strict_threshold a f n Hf) as [t [Ht0 Ht1]].
  destruct t.
  - simpl in Ht0. rewrite (bin_countdown_base _ _ _ _ Ht0).
    split; intro; try lia. apply (N.le_trans _ (repeat f 0 n) _).
    apply repeat_contract. apply Hf. omega. apply Ht0.
  - assert (a < repeat f t n) as Ht.
    { rewrite N.lt_nge. intro. apply Ht1 in H. omega. }
    rewrite (bin_countdown_intermediate _ _ _ _ t).
    rewrite (bin_countdown_base _ _ _ _ Ht0). rewrite N.add_0_r.
    replace m with (N.of_nat (N.to_nat m)) at 1 by apply N2Nat.id.
    unfold N.le at 1. rewrite <- Nat2N.inj_compare.
    rewrite Nat.compare_le_iff.
    split; intro.
    + apply (N.le_trans _ (repeat f (S t) n) _).
      apply repeat_contract. apply Hf. apply H. apply Ht0.
    + apply (Ht1 _ H).
    + apply Hf.
    + apply (Nat.le_trans _ (S t + nat_size (repeat f (S t) n - a))%nat _).
      omega. apply (repeat_bin_contract_strict a _ _ _ Hf Ht).
    + apply Ht.
Qed.

(* This bin_countdown_to definition is consistent with its nat counterpart for
   strict binary contractions *)
Theorem bin_countdown_correct : forall f a,
    bin_contract_strict_above a f ->
      bin_countdown_to f a =
        to_N_func (countdown.countdown_to (to_nat_func f) (N.to_nat a)).
Proof.
  intros f a Haf. apply functional_extensionality. intro n.
  assert (countdown.contract_strict_above (N.to_nat a) (to_nat_func f))
  as Haf0 by apply (bin_contract_strict_Nnat a f Haf).
  unfold to_N_func. apply le_antisym.
  - rewrite bin_countdown_repeat by apply Haf. rewrite Nat2N.id.
    rewrite le_N_nat. rewrite to_N_func_repeat. unfold to_N_func.
    rewrite Nat2N.id. rewrite <- countdown.countdown_repeat; trivial.
  - rewrite le_N_nat. rewrite Nat2N.id.
    rewrite countdown.countdown_repeat by apply Haf0.
    rewrite to_nat_func_repeat. rewrite <- N_nat_func_id.
    unfold to_nat_func. rewrite N2Nat.id. rewrite <- le_N_nat.
    rewrite <- bin_countdown_repeat. lia. trivial.
Qed.

Corollary bin_countdown_recursion : forall f a n,
    bin_contract_strict_above a f ->
    bin_countdown_to f a n = if n <=? a then 0
                              else 1 + bin_countdown_to f a (f n).
Proof.
  intros f a n Haf.
  rewrite bin_countdown_correct by apply Haf. unfold to_N_func.
  rewrite N.add_1_l, <- Nat2N.inj_succ, <- (N2Nat.id 0).
  destruct (N.le_gt_cases n a) as [Hna|Hna]; assert (T:=Hna);
  [rewrite <- N.leb_le in T|rewrite <- N.leb_gt in T]; rewrite T;
  generalize Hna; rewrite Nat2N.inj_iff;
    [rewrite le_N_nat|rewrite lt_N_nat];
  replace (N.to_nat (f n)) with ((to_nat_func f) (N.to_nat n))
    by (unfold to_nat_func; rewrite N2Nat.id; trivial);
  apply countdown.countdown_recursion, bin_contract_strict_Nnat, Haf.
Qed.


(** * Maps: Total and Partial Maps *)

(** Maps (or dictionaries) are ubiquitous data structures both
    generally and in the theory of programming languages in
    particular; we're going to need them in many places in the coming
    chapters.  They also make a nice case study using ideas we've seen
    in previous chapters, including building data structures out of
    higher-order functions (from [Basics] and [Poly]) and the use of
    reflection to streamline proofs (from [IndProp]).

    We'll define two flavors of maps: _total_ maps, which include a
    "default" element to be returned when a key being looked up
    doesn't exist, and _partial_ maps, which return an [option] to
    indicate success or failure.  The latter is defined in terms of
    the former, using [None] as the default element. *)

(* ################################################################# *)
(** * The Coq Standard Library *)

(** One small digression before we get to maps.

    Unlike the chapters we have seen so far, this one does not
    [Require Import] the chapter before it (and, transitively, all the
    earlier chapters).  Instead, in this chapter and from now, on
    we're going to import the definitions and theorems we need
    directly from Coq's standard library stuff.  You should not notice
    much difference, though, because we've been careful to name our
    own definitions and theorems the same as their counterparts in the
    standard library, wherever they overlap. *)

Require Import Coq.Arith.Arith.
Require Import Coq.Bool.Bool.
Require Import Coq.Strings.String.
Require Import Coq.Logic.FunctionalExtensionality.

(** Documentation for the standard library can be found at
    http://coq.inria.fr/library/.

    The [Search] command is a good way to look for theorems involving
    objects of specific types.  Take a minute now to experiment with it. *)

(* ################################################################# *)
(** * Identifiers *)

(** First, we need a type for the keys that we use to index into our
    maps.  For this purpose, we again use the type [id] from the
    [Lists] chapter.  To make this chapter self contained, we repeat
    its definition here, together with the equality comparison
    function for [id]s and its fundamental property. *)

Inductive id : Type :=
  | Id : string -> id.

Definition beq_id x y :=
  match x,y with
    | Id n1, Id n2 => if string_dec n1 n2 then true else false
  end.

(** (The function [string_dec] comes from Coq's string library.
    If you check its result type, you'll see that it does not actually
    return a [bool], but rather a type that looks like [{x = y} + {x
    <> y}], called a [sumbool], which can be thought of as an
    "evidence-carrying boolean."  Formally, an element of [sumbool] is
    either a proof that two things are equal or a proof that they are
    unequal, together with a tag indicating which.  But for present
    purposes you can think of it as just a fancy [bool].) *)

Theorem beq_id_refl : forall id, true = beq_id id id.
Proof.
  intros [n]. simpl. destruct (string_dec n n).
  - reflexivity.
  - destruct n0. reflexivity.
Qed.

(** The following useful property of [beq_id] follows from an
    analogous lemma about strings: *)

Theorem beq_id_true_iff : forall x y : id,
  beq_id x y = true <-> x = y.
Proof.
   intros [n1] [n2].
   unfold beq_id.
   destruct (string_dec n1 n2).
   - subst. split. reflexivity. reflexivity.
   - split.
     + intros contra. inversion contra.
     + intros H. inversion H. subst. destruct n. reflexivity.
Qed.

(** Similarly: *)

Theorem beq_id_false_iff : forall x y : id,
  beq_id x y = false
  <-> x <> y.
Proof.
  intros x y. rewrite <- beq_id_true_iff.
  rewrite not_true_iff_false. reflexivity. Qed.

(** This useful variant follows just by rewriting: *)

Theorem false_beq_id : forall x y : id,
   x <> y
   -> beq_id x y = false.
Proof.
  intros x y. rewrite beq_id_false_iff.
  intros H. apply H. Qed.

(* ################################################################# *)
(** * Total Maps *)

(** Our main job in this chapter will be to build a definition of
    partial maps that is similar in behavior to the one we saw in the
    [Lists] chapter, plus accompanying lemmas about its behavior.

    This time around, though, we're going to use _functions_, rather
    than lists of key-value pairs, to build maps.  The advantage of
    this representation is that it offers a more _extensional_ view of
    maps, where two maps that respond to queries in the same way will
    be represented as literally the same thing (the very same function),
    rather than just "equivalent" data structures.  This, in turn,
    simplifies proofs that use maps.

    We build partial maps in two steps.  First, we define a type of
    _total maps_ that return a default value when we look up a key
    that is not present in the map. *)

Definition total_map (A:Type) := id -> A.

(** Intuitively, a total map over an element type [A] is just a
    function that can be used to look up [id]s, yielding [A]s.

    The function [t_empty] yields an empty total map, given a default
    element; this map always returns the default element when applied
    to any id. *)

Definition t_empty {A:Type} (v : A) : total_map A :=
  (fun _ => v).

(** More interesting is the [update] function, which (as before) takes
    a map [m], a key [x], and a value [v] and returns a new map that
    takes [x] to [v] and takes every other key to whatever [m] does. *)

Definition t_update {A:Type} (m : total_map A)
                    (x : id) (v : A) :=
  fun x' => if beq_id x x' then v else m x'.

(** This definition is a nice example of higher-order programming:
    [t_update] takes a _function_ [m] and yields a new function
    [fun x' => ...] that behaves like the desired map.

    For example, we can build a map taking [id]s to [bool]s, where [Id
    3] is mapped to [true] and every other key is mapped to [false],
    like this: *)

Definition examplemap :=
  t_update (t_update (t_empty false) (Id "foo") false)
           (Id "bar") true.

(** This completes the definition of total maps.  Note that we don't
    need to define a [find] operation because it is just function
    application! *)

Example update_example1 : examplemap (Id "baz") = false.
Proof. reflexivity. Qed.

Example update_example2 : examplemap (Id "foo") = false.
Proof. reflexivity. Qed.

Example update_example3 : examplemap (Id "quux") = false.
Proof. reflexivity. Qed.

Example update_example4 : examplemap (Id "bar") = true.
Proof. reflexivity. Qed.

(** To use maps in later chapters, we'll need several fundamental
    facts about how they behave.  Even if you don't work the following
    exercises, make sure you thoroughly understand the statements of
    the lemmas!  (Some of the proofs require the functional
    extensionality axiom, which is discussed in the [Logic]
    chapter.) *)

(** **** Exercise: 1 star, optional (t_apply_empty)  *)
(** First, the empty map returns its default element for all keys: *)

Lemma t_apply_empty:  forall A x v, @t_empty A v x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_eq)  *)
(** Next, if we update a map [m] at a key [x] with a new value [v]
    and then look up [x] in the map resulting from the [update], we
    get back [v]: *)

Lemma t_update_eq : forall A (m: total_map A) x v,
  (t_update m x v) x = v.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_neq)  *)
(** On the other hand, if we update a map [m] at a key [x1] and then
    look up a _different_ key [x2] in the resulting map, we get the
    same result that [m] would have given: *)

Theorem t_update_neq : forall (X:Type) v x1 x2
                         (m : total_map X),
  x1 <> x2 ->
  (t_update m x1 v) x2 = m x2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (t_update_shadow)  *)
(** If we update a map [m] at a key [x] with a value [v1] and then
    update again with the same key [x] and another value [v2], the
    resulting map behaves the same (gives the same result when applied
    to any key) as the simpler map obtained by performing just
    the second [update] on [m]: *)

Lemma t_update_shadow : forall A (m: total_map A) v1 v2 x,
    t_update (t_update m x v1) x v2
  = t_update m x v2.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** For the final two lemmas about total maps, it's convenient to use
    the reflection idioms introduced in chapter [IndProp].  We begin
    by proving a fundamental _reflection lemma_ relating the equality
    proposition on [id]s with the boolean function [beq_id]. *)

(** **** Exercise: 2 stars, optional (beq_idP)  *)
(** Use the proof of [beq_natP] in chapter [IndProp] as a template to
    prove the following: *)

Lemma beq_idP : forall x y, reflect (x = y) (beq_id x y).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Now, given [id]s [x1] and [x2], we can use the [destruct (beq_idP
    x1 x2)] to simultaneously perform case analysis on the result of
    [beq_id x1 x2] and generate hypotheses about the equality (in the
    sense of [=]) of [x1] and [x2]. *)

(** **** Exercise: 2 stars (t_update_same)  *)
(** With the example in chapter [IndProp] as a template, use
    [beq_idP] to prove the following theorem, which states that if we
    update a map to assign key [x] the same value as it already has in
    [m], then the result is equal to [m]: *)

Theorem t_update_same : forall X x (m : total_map X),
  t_update m x (m x) = m.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, recommended (t_update_permute)  *)
(** Use [beq_idP] to prove one final property of the [update]
    function: If we update a map [m] at two distinct keys, it doesn't
    matter in which order we do the updates. *)

Theorem t_update_permute : forall (X:Type) v1 v2 x1 x2
                             (m : total_map X),
  x2 <> x1 ->
    (t_update (t_update m x2 v2) x1 v1)
  = (t_update (t_update m x1 v1) x2 v2).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Partial maps *)

(** Finally, we define _partial maps_ on top of total maps.  A partial
    map with elements of type [A] is simply a total map with elements
    of type [option A] and default element [None]. *)

Definition partial_map (A:Type) := total_map (option A).

Definition empty {A:Type} : partial_map A :=
  t_empty None.

Definition update {A:Type} (m : partial_map A)
                  (x : id) (v : A) :=
  t_update m x (Some v).

(** We now straightforwardly lift all of the basic lemmas about total
    maps to partial maps.  *)

Lemma apply_empty : forall A x, @empty A x = None.
Proof.
  intros. unfold empty. rewrite t_apply_empty.
  reflexivity.
Qed.

Lemma update_eq : forall A (m: partial_map A) x v,
  (update m x v) x = Some v.
Proof.
  intros. unfold update. rewrite t_update_eq.
  reflexivity.
Qed.

Theorem update_neq : forall (X:Type) v x1 x2
                       (m : partial_map X),
  x2 <> x1 ->
  (update m x2 v) x1 = m x1.
Proof.
  intros X v x1 x2 m H.
  unfold update. rewrite t_update_neq. reflexivity.
  apply H. Qed.

Lemma update_shadow : forall A (m: partial_map A) v1 v2 x,
  update (update m x v1) x v2 = update m x v2.
Proof.
  intros A m v1 v2 x1. unfold update. rewrite t_update_shadow.
  reflexivity.
Qed.

Theorem update_same : forall X v x (m : partial_map X),
  m x = Some v ->
  update m x v = m.
Proof.
  intros X v x m H. unfold update. rewrite <- H.
  apply t_update_same.
Qed.

Theorem update_permute : forall (X:Type) v1 v2 x1 x2
                                (m : partial_map X),
  x2 <> x1 ->
    (update (update m x2 v2) x1 v1)
  = (update (update m x1 v1) x2 v2).
Proof.
  intros X v1 v2 x1 x2 m. unfold update.
  apply t_update_permute.
Qed.

(** $Date: 2017-03-05 16:25:50 -0500 (Sun, 05 Mar 2017) $ *)


Require Import CSet NaturalRep PidgeonHole SafeFirst.

Set Implicit Arguments.

Section LeastFresh.
  Variable V : Type.
  Context `{NaturalRepresentationSucc V}.
  Context `{@NaturalRepresentationMax V H H0}.

  Definition fresh (s : set V) : V :=
    succ (fold max s (ofNat 0)).

  Lemma max_transpose
    : transpose _eq max.
  Proof.
    hnf; intros.
    rewrite !max_asNat.
    rewrite !asNat_ofNat.
    rewrite Max.max_comm. rewrite <- Max.max_assoc.
    setoid_rewrite Max.max_comm at 2. reflexivity.
  Qed.

  Lemma fold_max_lt (G:set V)
    : forall (x:V), x ∈ G -> _lt x (succ (fold max G (ofNat 0))).
  Proof.
    pattern G. pattern (fold max G (ofNat 0)). eapply fold_rec.
    - cset_tac.
    - intros ? ? ? ? IN NOTIN ADD LT y yIn.
      eapply ADD in yIn. destruct yIn.
      + rewrite fold_2; eauto.
        * rewrite <- H3.
          nr.
          eapply Peano.le_n_S.
          eapply Nat.max_le_iff. left. reflexivity.
        * eapply max_proper.
        * eapply max_transpose.
      + rewrite fold_2; eauto.
        * exploit LT; eauto.
          nr.
          eapply Peano.le_n_S.
          rewrite Nat.max_le_iff. right. omega.
        * eapply max_proper.
        * eapply max_transpose.
  Qed.

  Lemma fresh_spec G : fresh G ∉ G.
  Proof.
    intro A. unfold fresh in A.
    pose proof (fold_max_lt A) as B.
    eapply lt_antirefl in B; eauto.
  Qed.

  Lemma fresh_variable_always_exists (lv:set V) n
    : safe (fun x => x ∉ lv) n.
  Proof.
    - decide (_lt (fold max lv (ofNat 0)) n).
      + econstructor; intro.
        exploit fold_max_lt. cset_tac.
        nr.
        omega.
      + eapply safe_antitone with (n:=succ (fold max lv (ofNat 0))).
        * unfold Proper, respectful. intros. rewrite H3. reflexivity.
        * econstructor. intro. exploit fold_max_lt; eauto.
          cset_tac. nr. omega.
        * nr. omega.
  Qed.

  Definition least_fresh_gen (lv:set V) : V.
    refine (@safe_first _ _ _ _ (fun x => x ∉ lv) _ (ofNat 0) _).
    - eapply fresh_variable_always_exists.
  Defined.

  Lemma least_fresh_full_spec G
    : least_fresh_gen G ∉ G
      /\ asNat (least_fresh_gen G) <= cardinal G
      /\ forall m, _lt m (least_fresh_gen G) -> m ∈ G.
  Proof.
    unfold least_fresh_gen.
    eapply safe_first_spec
      with (I:= fun n => le (asNat n) (cardinal G) /\ forall m, _lt m n -> m ∈ G).
    - intros ? [A B] NOTIN.
      assert (IN:n ∈ G) by cset_tac. clear NOTIN.
      split.
      + eapply all_in_lv_cardinal.
        intros. decide (x === n); try rewrite e in *; eauto; nr.
        eapply B. omega.
      + intros. decide (m === n); try rewrite e in *; eauto; nr.
        eapply B. omega.
    - intuition.
    - split; intros; nr; omega.
  Qed.

  Lemma least_fresh_gen_ext (G G':set V)
    : G [=] G'
      -> least_fresh_gen G = least_fresh_gen G'.
  Proof.
    intros. unfold least_fresh_gen.
    eapply safe_first_ext; eauto.
    split; intros.
    - rewrite <- H3; eauto.
    - rewrite H3; eauto.
  Qed.

End LeastFresh.

Require LeastFresh.

Section FreshList.
  Variable V : Type.
  Context `{OrderedType V}.
  Variable fresh : set V -> V.

  Fixpoint fresh_list (G:set V) (n:nat) : list V :=
    match n with
      | 0 => nil
      | (S n) => let y := fresh G in y::fresh_list {y;G} n
    end.

  Lemma fresh_list_length (G:set V) n
  : length (fresh_list G n) = n.
  Proof.
    general induction n; eauto. simpl. f_equal; eauto.
  Qed.

  Hypothesis fresh_spec : forall G, fresh G ∉ G.

  Definition fresh_set (G:set V) L : set V :=
    of_list (fresh_list G L).

  Lemma fresh_list_spec : forall (G:set V) n, disj (of_list (fresh_list G n)) G.
  Proof.
    intros. general induction n; simpl; intros; eauto.
    - hnf; intros. cset_tac'.
      + rewrite <- H2 in H1. eauto.
      + specialize (H0 ({fresh G; G})).
        eapply H0; eauto.
        cset_tac.
  Qed.

  Lemma fresh_set_spec
  : forall (G:set V) L, disj (fresh_set G L) G.
  Proof.
    unfold fresh_set. eapply fresh_list_spec.
  Qed.

  Lemma fresh_list_nodup (G: set V) n
    : NoDupA eq (fresh_list G n).
  Proof.
    general induction n; simpl; eauto.
    econstructor; eauto. intro.
    eapply fresh_list_spec.
    eapply InA_eq_of_list; eauto.
    cset_tac.
  Qed.

  Lemma fresh_list_ext n G G'
    : (forall G G', G [=] G' -> fresh G = fresh G')
      -> G [=] G'
      -> fresh_list G n = fresh_list G' n.
  Proof.
    intros EXT EQ. general induction n; simpl.
    - reflexivity.
    - f_equal. eauto.
      eapply IHn; eauto.
      erewrite EXT, EQ; eauto; reflexivity.
  Qed.

End FreshList.

Hint Resolve fresh_list_length : len.

Require Import LeastFresh.

Instance LeastFreshNat : LeastFresh.LeastFresh nat :=
  {
    least_fresh := @least_fresh_gen nat _ NaturalRepresentationNat _ _
  }.
Proof.
  - intros. eapply least_fresh_full_spec.
  - intros. eapply least_fresh_full_spec; eauto.
  - intros. eapply least_fresh_gen_ext; eauto.
Qed.

Lemma least_fresh_list_small X H `{@LeastFresh X H} `{@NaturalRepresentation X H} (G:set X) n
: forall i x, get (fresh_list least_fresh G n) i x -> asNat x < cardinal G + n.
Proof.
  general induction n; simpl in *; isabsurd.
  - invc H2.
    + clear IHn.
      pose proof (least_fresh_least G).
      eapply all_in_lv_cardinal in H2.
      omega.
    + exploit IHn; eauto.
      erewrite cardinal_2 with (s:=G) in H2. omega.
      eapply (least_fresh_spec). cset_tac.
Qed.

Lemma least_fresh_list_ext X `{LeastFresh X}  n (G:set X) G'
  : G [=] G'
    -> fresh_list least_fresh G n = fresh_list least_fresh G' n.
Proof.
  intros.
  eapply fresh_list_ext; eauto.
  eapply least_fresh_spec.
  eapply least_fresh_ext.
Qed.


Require Import Coq.Structures.Equalities.
Module Valuation_mod (SetVars : UsualDecidableTypeFull).
(** (\pi + (\xi \mapsto ?) ) **)
Section a.
Context {X:Type}.

Definition cng (val:SetVars.t -> X) (xi:SetVars.t) (m:X) :=
 (fun r:SetVars.t =>
 match SetVars.eqb r xi with
 | true => m
 | false => (val r)
 end).

Lemma dbl_cng  pi xi m1 m2: forall q,(cng (cng pi xi m1) xi m2) q = (cng pi xi m2) q.
Proof. intro q. unfold cng. destruct (SetVars.eqb q xi); reflexivity. Defined.

Lemma twice_the_same (pi:SetVars.t->X) x m0 m1 :
forall u, (cng (cng pi x m0) x m1) u = (cng pi x m1) u.
Proof.
intro u.
unfold cng.
destruct (SetVars.eqb u x).
reflexivity.
reflexivity.
Defined.

End a.

End Valuation_mod.


Import Nat.

Module PartialMap.

Inductive id : Type :=
  | Id : nat -> id.

Definition eqb_id k k' :=
  match k,k' with
  | Id n, Id n' => n =? n'
  end.

Definition beq_id x y : bool :=
  match x,y with
  | Id a, Id b => eqb a b
  end.

Theorem eqb_refl : forall x, eqb x x = true.
Proof.
  intros.
  induction x.
    simpl. reflexivity.
    simpl. rewrite IHx. reflexivity.
Qed.

Theorem eqb_id_refl : forall x, eqb_id x x = true.
Proof.
  intros.
  destruct x as [x].
  destruct x.
    simpl. reflexivity.
    simpl. rewrite eqb_refl. reflexivity.
Qed.

Inductive partial_map : Type :=
  | empty  : partial_map
  | record : id -> nat -> partial_map -> partial_map.

Definition update m k v : partial_map :=
  record k v m.

Fixpoint find k m : option nat :=
  match m with
  | empty => None
  | record k' v m' =>
      if eqb_id k k'
      then Some v
      else find k m'
  end.

Theorem update_eq : forall m k v, find k (update m k v) = Some v.
Proof.
  intros.
  induction m.
    simpl. rewrite eqb_id_refl. reflexivity.
    simpl. rewrite eqb_id_refl. reflexivity.
Qed.

Theorem update_neq :
  forall m k k' v,
  eqb_id k k' = false ->
  find k (update m k' v) = find k m.
Proof.
  intros.
  induction m.
    simpl. rewrite H. reflexivity.
    simpl. rewrite H. reflexivity.
Qed.

End PartialMap.


Require Export C6_Parallele_Prop.

Section SECANT_LINES_PROPERTIES.

Lemma  StrictlyParallel : forall A B C D,
	EquiOriented A B C D ->
	~Collinear A B C ->
	~Collinear A B D.
Proof.
	intros A B C D H Hn H0; elim Hn.
	exact (ParallelCollinearABC A B C D H H0).
Qed.

Lemma NotClockwiseTwoCases : forall A B C : Point,
	~Clockwise A B C ->
	Clockwise B A C \/ Collinear A B C.
Proof.
	intros; decompose [or] (FourCases A B C); intuition.
	 right; apply HalfLineCollinear; trivial.
	 right; apply CollinearBAC; apply HalfLineCollinear; trivial.
Qed.

Lemma FourPointsSecantLine : forall A B C D,
	Clockwise A B C ->
	~Clockwise A B D ->
	~EquiDirected A B C D.
Proof.
	intros.
	assert (Hcd : C <> D).
	 intro; subst; elim H0; trivial.
	 generalizeChange.
	  elim (NotClockwiseABA C D); autoClockwise.
	  elim (NotClockwiseBAA C D); autoClockwise.
	  destruct (NotClockwiseTwoCases _ _ _ H0).
	   elim (NotClockwiseBAA D C); auto.
	   elim (ClockwiseNotCollinear A B C H); apply CollinearBAC.
 	    apply (ParallelCollinearABC B A C D H2); autoCollinear.
	  destruct (NotClockwiseTwoCases _ _ _ H0).
	   elim (NotClockwiseABA D C); auto.
	   elim (ClockwiseNotCollinear A B C H); apply CollinearBAC.
	     apply (ParallelCollinearABD B A D C H1); autoCollinear.
	  destruct (NotClockwiseTwoCases _ _ _ H0).
	   elim (NotClockwiseABA D C); auto.
	   elim (ClockwiseNotCollinear A B C H); apply CollinearBAC.
	     apply (ParallelCollinearABD B A D C H3); autoCollinear.
	  elim (NotClockwiseBAA C D); autoClockwise.
	  destruct (NotClockwiseTwoCases _ _ _ H0).
	   elim (NotClockwiseBAA D C); auto.
	   elim (ClockwiseNotCollinear A B C H); apply CollinearBAC.
	     apply (ParallelCollinearABC B A C D H3); autoCollinear.
	  elim (NotClockwiseABA C D); autoClockwise.
Qed.

Lemma NotEquidirectedDistinctAB : forall A B C D,
	~EquiDirected A B C D->
	A<>B.
Proof.
	canonize.
	elim H1; intros E H9.
	elim (ClockwiseDistinctAB A B E H9); trivial.
Qed.

Lemma NotEquidirectedDistinctCD : forall A B C D,
	~EquiDirected A B C D->
	C<>D.
Proof.
	canonize.
	elim H4; intros E H9.
	elim (ClockwiseDistinctAB C D E H9); trivial.
Qed.

Lemma LinesIntersectionPoint : forall A B C D,
	~EquiDirected A B C D->
	{I : Point | Collinear A B I /\ Collinear C D I}.
Proof.
	intros.
	setLine A B (NotEquidirectedDistinctAB A B C D H) ipattern:(F1) ipattern:(L1).
	setLine C D (NotEquidirectedDistinctCD A B C D H) ipattern:(F2) ipattern:(L2).
	setLinterL F1 F2 L1 L2 ipattern:(J) ipattern:(H2) ipattern:(H3) ipattern:(H4).
	 unfold SecantLines , F1, F2, L1, L2 in |- *; simpl in |- *; trivial.
	 exists J; intuition.
Qed.

Lemma UniqueIntersectionLines : forall A B C D I J : Point,
	A <> B ->
	C <> D ->
	~EquiDirected A B C D ->
	Collinear A B I ->
	Collinear A B J ->
	Collinear C D I ->
	Collinear C D J ->
	I = J.
Proof.
	intros.
	setLine A B H ipattern:(F1) ipattern:(L1).
	setLine C D H0 ipattern:(F2) ipattern:(L2).
	setLinterL F1 F2 L1 L2 ipattern:(E) ipattern:(H6) ipattern:(H7) ipattern:(H8).
	 trivial.
	 unfold Unicity in *.
	   rewrite <- (H8 I).
	  apply H8.
	    intuition.
	  intuition.
Qed.

Lemma FourPointsIntersectionPoint : forall A B C D,
	Clockwise A B C ->
	Clockwise B A D ->
	{I : Point | Collinear A B I /\ Between C I D}.
Proof.
	intros A B C D H H0;
	 destruct (LinesIntersectionPoint A B C D) as (E, (H1, H2)).
	 apply FourPointsSecantLine; autoClockwise.
	 exists E; canonize.
	  subst; autoClockwise.
	  destruct (ExclusiveCollinear E D C).
	   apply (CollinearClockwiseDistinct B A E D); canonize.
	   autoDistinct.
	   apply CollinearCAB; autoClockwise.
	     destruct (CollinearHalfLine A B E).
	    autoClockwise.
	    canonize.
	      elim (ClockwiseNotClockwise C E A).
	     generalizeChangeSense.
	       apply H7; apply ClockwiseCAB; auto.
	     apply ClockwiseBCA; auto.
	    canonize.
	      elim (ClockwiseNotClockwise E C B).
	     apply H6; apply ClockwiseBCA; auto.
	     apply ClockwiseCAB; generalizeChange.
	   canonize.
Qed.

Lemma PaschABC  : forall A B C M N,
	Clockwise A B C ->
	Between A M B  ->
	~Collinear A M N ->
	~Collinear B M N ->
	~Collinear C M N ->
	(exists P : Point, Collinear M N P /\ Between A P C) \/
	(exists P : Point, Collinear M N P /\ Between B P C).
Proof.
	intros A B C M N H (H0, H1) H2 H3 H4.
	decompose [or] (ThreeCases A M N).
	 clear H2; decompose [or] (ThreeCases B M N).
	  clear H3 H4; elim (ClockwiseNotClockwise B M N); canonize.
	  clear H3; decompose [or] (ThreeCases C M N).
	   clear H4; destruct (FourPointsIntersectionPoint N M B C) as (P, (H3, H4)).
	    autoClockwise.
	    autoClockwise.
	    right; exists P; canonize.
	   clear H4; destruct (FourPointsIntersectionPoint M N A C) as (P, (H2, H4)).
	    autoClockwise.
	    autoClockwise.
	    left; exists P; canonize.
	   canonize.
	  canonize.
	 clear H2; decompose [or] (ThreeCases B M N).
	  clear H3; decompose [or] (ThreeCases C M N).
	   clear H4; destruct (FourPointsIntersectionPoint N M A C) as (P, (H5, H4)).
	    autoClockwise.
	    autoClockwise.
	    left; exists P; canonize.
	   clear H4; destruct (FourPointsIntersectionPoint M N B C) as (P, (H3, H4)).
	    autoClockwise.
	    autoClockwise.
	    right; exists P; canonize.
	   canonize.
	  clear H3 H4; assert (EquiOriented M B A M).
	   apply EquiOrientedRev; canonize.
	   elim (ClockwiseNotClockwise M A N); canonize.
	  canonize.
	 canonize.
Qed.

End SECANT_LINES_PROPERTIES.


Require Import Basics Types.
Require Import Diagrams.Sequence.
Require Import Homotopy.Join.
Require Import Colimits.Colimit Colimits.Sequential.

Local Open Scope nat_scope.

(** * Propositonal truncation as a colimit. *)

(** In this file we give an alternative construction of the propositional truncation using colimits. This can serve as a metatheoretic justification that propositional truncations exist. *)

(** The sequence of increasing joins. *)
Definition Join_seq (A : Type) : Sequence.
Proof.
  srapply Build_Sequence.
  1: exact (Join_power A).
  intros n.
  exact joinr.
Defined.

(** Propositional truncation can be defined as the colimit of this sequence. *)
Definition PropTrunc A : Type := Colimit (Join_seq A).

(** The constructor is given by the colimit constructor. *)
Definition ptr_in {A} : A -> PropTrunc A := colim (D:=Join_seq A) 0.

(** The sequential colimit of this sequence is the propositional truncation. *)

(** Universal property of propositional truncation. *)
Lemma equiv_PropTrunc_rec `{Funext} (A P : Type) `{IsHProp P}
  : (PropTrunc A -> P) <~> (A -> P).
Proof.
  refine (_ oE equiv_colim_seq_rec _ P).
  srapply equiv_iff_hprop.
  { intros h.
    exact (h 0). }
  intros f.
  induction n.
  - exact f.
  - cbn.
    srapply Join_rec.
    1,2: assumption.
    intros a b.
    rapply path_ishprop.
Defined.

(** The propositional truncation is a hprop. *)
Global Instance ishprop_proptrunc `{Funext} (A : Type)
  : IsHProp (PropTrunc A).
Proof.
  rapply hprop_inhabited_contr.
  rapply (equiv_PropTrunc_rec _ _)^-1.
  intros x.
  srapply contr_colim_seq_into_prop.
  - intros n.
    destruct n.
    1: exact x.
    exact (joinl x).
  - intros n.
    rapply jglue.
Defined.


(* Encoding of Types *)
Definition Zero := forall (a : Prop), a.
Notation "'0" := Zero (at level 1).

Lemma Zero_uninhabited : forall t : '0, False.
  intros.
  unfold Zero in t. apply t.
Defined.

Definition One := forall (a : Prop), a -> a.
Notation "'1" := One (at level 1).
Definition unit : '1 := (fun (a : Prop) (x : a) => x).
Implicit Arguments unit [a].
Notation "'()" := unit (at level 1).

Definition And (a : Prop) (b : Prop) := forall (z : Prop),
(* pair *) (a -> b -> z) ->
z.
Notation "a |*| b" := (And a b) (at level 90, b at next level).

Definition pair : forall (a b : Prop), a -> b -> And a b :=
    fun (a b : Prop) =>
      fun (x : a) (y : b) =>
        fun (z : Prop) (f : a -> b -> z) => f x y.
Implicit Arguments pair [a b].
Notation "[ x , y ]" := (pair x y) (at level 1, y at next level).

Definition fst : forall (a b : Prop), a |*| b -> a :=
  fun (a b : Prop) =>
    fun (p : forall (z : Prop), (a -> b -> z) -> z) =>
      p a (fun (x : a) (y : b) => x).
Implicit Arguments fst [a b].

Definition snd : forall (a b : Prop), a |*| b -> b :=
  fun (a b : Prop) =>
    fun (p : forall (z : Prop), (a -> b -> z) -> z) =>
      p b (fun (x : a) (y : b) => y).
Implicit Arguments snd [a b].

Definition Or (a : Prop) (b : Prop) := forall (z : Prop),
(* inl *) (a -> z) ->
(* inr *) (b -> z) ->
z.
Notation "a |+| b" := (Or a b) (at level 90, b at next level).

Definition inl : forall (a b : Prop), a -> a |+| b :=
    fun (a b : Prop) =>
      fun (x : a) =>
        fun (z : Prop) (left : a -> z) (right : b -> z) => left x.
Implicit Arguments inl [a].
Definition inr : forall (a b : Prop), b -> a |+| b :=
    fun (a b : Prop) =>
      fun (y : b) =>
        fun (z : Prop) (left : a -> z) (right : b -> z) => right y.
Implicit Arguments inr [b].

Definition Nat := forall n : Prop,
(* z *) n ->
(* s *) (n -> n) ->
n.
Definition z : Nat := fun (n : Prop) (z : n) (s : n -> n) => z.
Definition s : Nat -> Nat :=
  fun (m : Nat) =>
    fun (n : Prop) (z : n) (s : n -> n) => s (m n z s).

Definition Bool := forall (n : Prop),
(* true  *) n ->
(* false *) n ->
n.
Definition true : Bool := fun (b : Prop) (t : b) (f : b) => t.
Definition false : Bool := fun (b : Prop) (t : b) (f : b) => f.
Definition andb : Bool -> Bool -> Bool :=
  fun (x : Bool) (y : Bool) =>
    x Bool y false.
Definition orb : Bool -> Bool -> Bool :=
  fun (x : Bool) (y : Bool) =>
    x Bool true y.

Definition List (A : Prop) := forall (X : Prop), X -> (A -> X -> X) -> X.
Definition nil := fun (A : Prop) (X : Prop) (n : X) (c : A -> X -> X) => n.
Definition cons := fun (A : Prop) (a : A) (l : List A) =>
  fun (X : Prop) (n : X) (c : A -> X -> X) => c a (l X n c).
Implicit Arguments cons [A].

Definition iszero : Nat -> Bool :=
  fun (n : Nat) =>
    n Bool true (fun _ => false).

Definition plus : Nat -> Nat -> Nat :=
  fun (n m: Nat) =>
    n Nat m s.

Definition aux : Nat -> (Nat |*| Nat) :=
  fun (n : Nat) =>
    n (Nat |*| Nat)
    [z,z]
    (fun p : Nat |*| Nat =>
      [s (fst p),fst p]).

Definition pred : Nat -> Nat :=
  fun (n : Nat) => snd (aux n).

Definition monus : Nat -> Nat -> Nat :=
  fun (n m : Nat) => m Nat n pred.

Definition eqn : Nat -> Nat -> Bool :=
  fun (n m: Nat) =>
    andb (iszero (monus n m)) (iszero (monus m n)).

Definition le : Nat -> Nat -> Bool :=
  fun (n m : Nat) => iszero (monus n m).

Definition Lambda := forall (X : Prop),
(* var *) (Nat -> X) ->
(* app *) (X -> X -> X) ->
(* abs *) (X -> X) ->
X.
Definition var : Nat -> Lambda:=
  fun (n : Nat) =>
    fun (X : Prop) (var : Nat -> X) (app : X -> X -> X) (abs : X -> X) =>
      var n.
Definition app : Lambda -> Lambda -> Lambda :=
  fun (x y : Lambda) =>
    fun (X : Prop) (var : Nat -> X) (app : X -> X -> X) (abs : X -> X) =>
      app (x X var app abs) (y X var app abs).
Definition abs : Lambda -> Lambda :=
  fun (x : Lambda) =>
    fun (X : Prop) (var : Nat -> X) (app : X -> X -> X) (abs : X -> X) =>
      abs (x X var app abs).

Definition shift_below : Nat -> Lambda -> Lambda.
Proof.
  refine
    (fun (c : Nat) (l : Lambda) =>
      l (Nat |*| Lambda)
      (fun (n : Nat) => (*if *)(le c n)
                        (*then*)(var (s n))
var (s n))
      (fun (f : Lambda) (g : Lambda) => app f g)
      (fun (t : Lambda) => abs t)).

Definition shift (abs (var z)).

Definition sub : Lambda ->