Require Import Program.
Require Import Psatz.
Require Import Omega.
Require Import Reals.
Require Import Bool.
Require Export Complex.
Require Export Matrix.

(* Using our (complex, unbounded) matrices, their complex numbers *)

Open Scope R_scope.
Open Scope C_scope.
Open Scope matrix_scope.

(* WARNING: Resize should only be used where m = m' and n = n'.
   It should be followed with a proof of this: resize_safe. *)
Definition resize (m n m' n' : nat) (A : Matrix m n) : Matrix m' n' := A.
Definition resize_safe (m n m' n' : nat) : Prop := m = m' /\ n = n'.
Transparent resize.

Definition ket0 : Matrix 2 1:=
  fun x y => match x, y with
          | 0, 0 => 1
          | 1, 0 => 0
          | _, _ => 0
          end.
Definition ket1 : Matrix 2 1 :=
  fun x y => match x, y with
          | 0, 0 => 0
          | 1, 0 => 1
          | _, _ => 0
          end.

Definition ket (x : nat) : Matrix 2 1 := if x =? 0 then ket0 else ket1.
Transparent ket0.
Transparent ket1.
Transparent ket.

Notation "|0⟩" := ket0.
Notation "|1⟩" := ket1.
Notation "⟨0|" := ket0†.
Notation "⟨1|" := ket1†.
Notation "|0⟩⟨0|" := (|0⟩×⟨0|).
Notation "|1⟩⟨1|" := (|1⟩×⟨1|).
Notation "|1⟩⟨0|" := (|1⟩×⟨0|).
Notation "|0⟩⟨1|" := (|0⟩×⟨1|).

Definition hadamard : Matrix 2 2 :=
  (fun x y => match x, y with
          | 0, 0 => (1 / √2)
          | 0, 1 => (1 / √2)
          | 1, 0 => (1 / √2)
          | 1, 1 => -(1 / √2)
          | _, _ => 0
          end).

Fixpoint hadamard_k (k : nat) : Matrix (2^k) (2^k):=
  match k with
  | 0 => Id 1
  | S k' => hadamard ⊗ hadamard_k k'
  end.

(*
Lemma hadamard_1 : hadamard_k 1 = hadamard.
Proof. apply kron_1_r. Qed.
*)

Definition pauli_x : Matrix 2 2 :=
  (fun x y => match x, y with
          | 0, 0 => 0
          | 0, 1 => 1
          | 1, 0 => 1
          | 1, 1 => 0
          | _, _ => 0
          end).

Definition pauli_y : Matrix 2 2 :=
  (fun x y => match x, y with
          | 0, 1 => -Ci
          | 1, 0 => Ci
          | _, _ => 0
          end).

Definition pauli_z : Matrix 2 2 :=
  (fun x y => match x, y with
          | 0, 0 => 1
          | 1, 1 => -1
          | _, _ => 0
          end).

Definition control {n : nat} (A : Matrix n n) : Matrix (2*n) (2*n) :=
  (fun x y => if (x <? n) && (y <? n) then (Id n) x y
          else if (n <=? x) && (n <=? y) then A (x-n)%nat (y-n)%nat
          else 0).

(* Definition cnot := control pauli_x. *)
(* Direct definition makes our lives easier *)
Definition cnot : Matrix 4 4 :=
  fun x y => match x, y with
          | 0, 0 => 1
          | 1, 1 => 1
          | 2, 3 => 1
          | 3, 2 => 1
          | _, _ => 0
          end.

(* Swap Matrices *)

Definition swap : Matrix 4 4 :=
  (fun x y => match x, y with
          | 0, 0 => 1
          | 1, 2 => 1
          | 2, 1 => 1
          | 3, 3 => 1
          | _, _ => 0
          end).

Lemma double_mult : forall (n : nat), (n + n = 2 * n)%nat. Proof. intros. omega. Qed.
Lemma pow_two_succ_l : forall x, (2^x * 2 = 2 ^ (x + 1))%nat.
Proof. intros. rewrite mult_comm. rewrite <- Nat.pow_succ_r'. intuition. Qed.
Lemma pow_two_succ_r : forall x, (2 * 2^x = 2 ^ (x + 1))%nat.
Proof. intros. rewrite <- Nat.pow_succ_r'. intuition. Qed.
Lemma double_pow : forall (n : nat), (2^n + 2^n = 2^(n+1))%nat.
Proof. intros. rewrite double_mult. rewrite pow_two_succ_r. reflexivity. Qed.
Lemma pow_components : forall (a b m n : nat), a = b -> m = n -> (a^m = b^n)%nat.
Proof. intuition. Qed.

Ltac unify_pows_two :=
  repeat match goal with
  (* NB: this first thing is potentially a bad idea, do not do with 2^1 *)
  | [ |- context[ 4%nat ]]                  => replace 4%nat with (2^2)%nat by reflexivity
  | [ |- context[ (0 + ?a)%nat]]            => rewrite plus_0_l
  | [ |- context[ (?a + 0)%nat]]            => rewrite plus_0_r
  | [ |- context[ (2 * 2^?x)%nat]]          => rewrite <- Nat.pow_succ_r'
  | [ |- context[ (2^?x * 2)%nat]]          => rewrite pow_two_succ_l
  | [ |- context[ (2^?x + 2^?x)%nat]]       => rewrite double_pow
  | [ |- context[ (2^?x * 2^?y)%nat]]       => rewrite <- Nat.pow_add_r
  | [ |- context[ (?a + (?b + ?c))%nat ]]   => rewrite plus_assoc
  | [ |- (2^?x = 2^?y)%nat ]                => apply pow_components; try omega
  end.

(* The input k is really k+1, to appease to Coq termination gods *)
(* NOTE: Check that the offsets are right *)
(* Requires: i + 1 < n *)
Fixpoint swap_to_0_aux (n i : nat) {struct i} : Matrix (2^n) (2^n) :=
  match i with
  | O => swap ⊗ Id (2^(n-2))
  | S i' =>  (Id (2^i') ⊗ swap ⊗ Id (2^(n-i'-2))) × (* swap i-1 with i *)
            swap_to_0_aux n i' ×
            (Id (2^i') ⊗ swap ⊗ Id (2^(n-i'-2))) (* swap i-1 with 0 *)
  end.

(* Requires: i < n *)
Definition swap_to_0 (n i : nat) : Matrix (2^n) (2^n) :=
  match i with
  | O => Id (2^n)
  | S i' => swap_to_0_aux n i'
  end.

(* Requires i < j, j < n *)
Fixpoint swap_two_aux (n i j : nat) : Matrix (2^n) (2^n) :=
  match i with
  | O => swap_to_0 n j
  | S i' => Id 2 ⊗ swap_two_aux (n-1) (i') (j-1)
  end.

(* Requires i < n, j < n *)
Definition swap_two (n i j : nat) : Matrix (2^n) (2^n) :=
  if i =? j then Id (2^n)
  else if i <? j then swap_two_aux n i j
  else swap_two_aux n j i.

(* Simpler version of swap_to_0 that shifts other elements *)
(* Requires: i+1 < n *)
Fixpoint move_to_0_aux (n i : nat) {struct i}: Matrix (2^n) (2^n) :=
  match i with
  | O => swap ⊗ Id (2^(n-2))
  | S i' =>  (resize (2^i' * 4 * 2^(n-i'-2)) (2^i' * 4 * 2^(n-i'-2)) (2^n) (2^n)
             (Id (2^i') ⊗ swap ⊗ Id (2^(n-i'-2)))) × swap_to_0_aux n i
  end.

Lemma move_to_0_aux_safe : forall (i' n : nat), (i'+2 < n)%nat ->
  resize_safe (2^i' * 4 * 2^(n-i'-2)) (2^i' * 4 * 2^(n-i'-2)) (2^n) (2^n).
Proof. intros. unfold resize_safe. split; unify_pows_two. Qed.

(* Requires: i < n *)
Definition move_to_0 (n i : nat) : Matrix (2^n) (2^n) :=
  match i with
  | O => Id (2^n)
  | S i' => move_to_0_aux n i'
  end.

(* Always moves up in the matrix from i to k *)
(* Requires: k < i < n *)
Fixpoint move_to (n i k : nat) : Matrix (2^n) (2^n) :=
  match k with
  | O => move_to_0 n i
  | S k' => Id 2 ⊗ move_to (n-1) (i-1) (k')
  end.

Lemma swap_two_base : swap_two 2 1 0 = swap.
Proof. unfold swap_two. simpl. apply kron_1_r. Qed.

Lemma swap_second_two : swap_two 3 1 2 = Id 2 ⊗ swap.
Proof. unfold swap_two.
       simpl.
       rewrite kron_1_r.
       reflexivity.
Qed.

(*
Eval compute in ((swap_two 1 0 1) 0 0)%nat.
Eval compute in (print_matrix (swap_two 1 0 2)).
*)

(** Unitaries are well-formed **)

Lemma WF_hadamard : WF_Matrix 2 2 hadamard. Proof. show_wf. Qed.
Lemma WF_pauli_x : WF_Matrix 2 2 pauli_x. Proof. show_wf. Qed.
Lemma WF_pauli_y : WF_Matrix 2 2 pauli_y. Proof. show_wf. Qed.
Lemma WF_pauli_z : WF_Matrix 2 2 pauli_z. Proof. show_wf. Qed.

Hint Resolve WF_hadamard.
Hint Resolve WF_pauli_x.
Hint Resolve WF_pauli_y.
Hint Resolve WF_pauli_z.

Lemma WF_braket1 : WF_Matrix 2 2 |1⟩⟨1|.
Proof. show_wf. Qed.
Lemma WF_braket0 : WF_Matrix 2 2 |0⟩⟨0|.
Proof. show_wf. Qed.
Hint Resolve WF_braket1.
Hint Resolve WF_braket0.

Lemma braket0_conj_transpose : |0⟩⟨0|† = |0⟩⟨0|.
Admitted.
Lemma braket1_conj_transpose : |1⟩⟨1|† = |1⟩⟨1|.
Admitted.

Lemma WF_control : forall {n} (U : Matrix n n),
      WF_Matrix n n U -> WF_Matrix (2* n) (2*n) (control U).
Proof.
  intros n U WFU.
  unfold control, WF_Matrix in *.
  intros x y [Hx | Hy]; simpl.
  + replace (x <? n) with false by (symmetry; apply Nat.ltb_ge; omega). simpl.
    rewrite WFU.
    * destruct (n <=? x), (n <=? y); reflexivity.
    * left. omega.
  + replace (y <? n) with false by (symmetry; apply Nat.ltb_ge; omega).
    rewrite andb_false_r.
    rewrite WFU.
    * destruct (n <=? x), (n <=? y); reflexivity.
    * right. omega.
Qed.
Hint Resolve WF_control.

Lemma WF_cnot : WF_Matrix 4 4 cnot. Proof. show_wf. Qed.
(* Proof. replace 4%nat with (2*2)%nat by auto. apply WF_control. apply WF_pauli_x. Qed. *)
Lemma WF_swap : WF_Matrix 4 4 swap. Proof. show_wf. Qed.

(** Unitaries are unitary **)

Definition is_unitary {n: nat} (U : Matrix n n): Prop :=
  WF_Matrix n n U /\ U † × U = Id n.

(* More precise *)
(* Definition unitary_matrix' {n: nat} (A : Matrix n n): Prop := Minv A A†. *)

Lemma H_unitary : is_unitary hadamard.
Proof.
  split.
  show_wf.
  unfold Mmult, Id.
  prep_matrix_equality.
  destruct x as [| [|x]]; destruct y as [|[|y]]; try Csolve.
  simpl.
  replace ((S (S x) <? 2)) with (false) by reflexivity.
  rewrite andb_false_r.
  clra.
Qed.

Lemma σx_unitary : is_unitary pauli_x.
Proof.
  split.
  show_wf.
  unfold Mmult, Id.
  prep_matrix_equality.
  destruct x as [| [|x]]; destruct y as [|[|y]]; try Csolve.
  simpl.
  replace ((S (S x) <? 2)) with (false) by reflexivity.
  rewrite andb_false_r.
  clra.
Qed.

Lemma σy_unitary : is_unitary pauli_y.
Proof.
  split.
  show_wf.
  unfold Mmult, Id.
  prep_matrix_equality.
  destruct x as [| [|x]]; destruct y as [|[|y]]; try Csolve.
  simpl.
  replace ((S (S x) <? 2)) with (false) by reflexivity.
  rewrite andb_false_r.
  clra.
Qed.

Lemma σz_unitary : is_unitary pauli_z.
Proof.
  split.
  show_wf.
  unfold Mmult, Id.
  prep_matrix_equality.
  destruct x as [| [|x]]; destruct y as [|[|y]]; try Csolve.
  simpl.
  replace ((S (S x) <? 2)) with (false) by reflexivity.
  rewrite andb_false_r.
  clra.
Qed.

Lemma control_unitary : forall n (A : Matrix n n),
                          is_unitary A -> is_unitary (control A).
Proof.
  intros n A.
  split.
  apply WF_control. destruct H; assumption.
  induction n.
  + unfold control, is_unitary, conj_transpose, Mmult, Id.
    prep_matrix_equality.
    replace (x <? 0) with false by reflexivity.
    rewrite andb_false_r.
    reflexivity.
  + unfold control, is_unitary, Mmult, Id.
    prep_matrix_equality.
    simpl.

(*
  intros.
  unfold control.
  prep_matrix_equality.
  unfold conj_transpose, Mmult, Id in *.
  destruct (x <? n) eqn:Ltxn, (y <? n) eqn:Ltyn.
  simpl.
*)

Admitted.

Lemma transpose_unitary : forall n (A : Matrix n n), is_unitary A -> is_unitary (A†).
  intros.
  simpl.
  split.
  + apply WF_conj_transpose. destruct H. assumption.
  + unfold is_unitary in *.
    rewrite conj_transpose_involutive.
    destruct H as [_ H].
    apply Minv_left in H as [_ S]. (* NB: Admitted lemma *)
    assumption.
Qed.

Lemma cnot_unitary : is_unitary cnot.
Proof.
  split.
  apply WF_cnot.
  unfold Mmult, Id.
  prep_matrix_equality.
  do 4 (try destruct x; try destruct y; try clra).
  replace ((S (S (S (S x))) <? 4)) with (false) by reflexivity.
  rewrite andb_false_r.
  clra.
Qed.

Lemma id_unitary : forall n, is_unitary (Id n).
Proof.
  split.
  apply WF_Id.
  unfold is_unitary.
  rewrite id_conj_transpose_eq.
  apply Mmult_1_l.
  apply WF_Id.
Qed.

Lemma swap_unitary : is_unitary swap.
Proof.
  split.
  apply WF_swap.
  unfold is_unitary, Mmult, Id.
  prep_matrix_equality.
  do 4 (try destruct x; try destruct y; try clra).
  replace ((S (S (S (S x))) <? 4)) with (false) by reflexivity.
  rewrite andb_false_r.
  clra.
Qed.

Lemma kron_unitary : forall {m n} (A : Matrix m m) (B : Matrix n n),
  is_unitary A -> is_unitary B -> is_unitary (A ⊗ B).
Admitted.

Lemma unitary_swap_to_0 : forall n i, (i < n)%nat -> is_unitary (swap_to_0 n i).
Proof.
  intros n i.
  generalize dependent n.
  unfold is_unitary; split.
  + (* well-formedness *)
    induction i.
    simpl. apply WF_Id.
    simpl in *.
    unfold swap_to_0 in IHi.
    destruct i; simpl in *.
    replace (2 ^ n)%nat with (4 * 2^(n-2))%nat by unify_pows_two.
    (* We need a tactic here *)
    apply WF_kron; try (apply Nat.pow_nonzero; omega).
    apply WF_swap.
    apply WF_Id.
    replace (2^n)%nat with  (2 ^ i * 4 * 2 ^ (n - i - 2))%nat by unify_pows_two.
    apply WF_mult.
    apply WF_mult.
    apply WF_kron; try (apply Nat.pow_nonzero; omega).
    apply WF_kron; try omega.
    apply WF_Id.
    apply WF_swap.
    apply WF_Id.
    replace (2 ^ i * 4 * 2 ^ (n - i - 2))%nat with (2^n)%nat by unify_pows_two.
    apply IHi.
    omega.
    apply WF_kron; try (apply Nat.pow_nonzero; omega).
    apply WF_kron; try omega.
    apply WF_Id.
    apply WF_swap.
    apply WF_Id.
  + induction i; simpl.
    - apply id_unitary.
    - unfold swap_to_0 in IHi.
      destruct i.
      * simpl.
        remember ( Id (2 ^ (n - 2))) as A.
        remember swap as B.
        setoid_rewrite (kron_conj_transpose B A).

(*    rewrite (kron_mixed_product B† A† B A). *)

        specialize (kron_mixed_product B† A† B A); intros H'.
        assert (is_unitary B). subst. apply swap_unitary.
        assert (is_unitary A). subst. apply id_unitary.
        destruct H0 as [_ H0], H1 as [_ H1].
        rewrite H0 in H'.
        rewrite H1 in H'.
        replace (Id (2 ^ n)) with (Id 4 ⊗ Id (2 ^ (n - 2))).
        (* apply H doesn't work.
         Surprisingly, that's the matrix types failing to line up *)
        rewrite <- H'.
        replace (4 * (2 ^ (n - 2)))%nat with (2 ^ n)%nat.
        reflexivity.
        unify_pows_two.
        unify_pows_two.
        replace (2^n)%nat with (2^2 * 2^(n-2))%nat by unify_pows_two.
        rewrite id_kron.
        reflexivity.
      * simpl.
Admitted.

Lemma unitary_swap_two : forall n i j, (i < n)%nat -> (j < n)%nat ->
                                  is_unitary (swap_two n i j).
Proof.
  intros n i j P1 P2.
  unfold is_unitary.
  unfold swap_two.
  destruct (lt_eq_lt_dec i j) as [[ltij | eq] | ltji].
  + induction i.
    simpl.
Admitted.

(* Pure and Mixed States *)

(* Wiki:
In operator language, a density operator is a positive semidefinite, hermitian
operator of trace 1 acting on the state space. A density operator describes
a pure state if it is a rank one projection. Equivalently, a density operator ρ
describes a pure state if and only if ρ = ρ ^ 2 *)

Notation Density n := (Matrix n n) (only parsing).

Definition Pure_State {n} (ρ : Density n) : Prop := WF_Matrix n n ρ /\ ρ = ρ × ρ.

Lemma pure0 : Pure_State |0⟩⟨0|. Proof. split; [show_wf|mlra]. Qed.
Lemma pure1 : Pure_State |1⟩⟨1|. Proof. split; [show_wf|mlra]. Qed.

(* Wiki:
For a finite-dimensional function space, the most general density operator
is of the form:

  ρ =∑_j p_j |ψ_j⟩⟨ ψ_j|

where the coefficients p_j are non-negative and add up to one. *)

Inductive Mixed_State {n} : (Matrix n n) -> Prop :=
| Pure_S : forall ρ, Pure_State ρ -> Mixed_State ρ
| Mix_S : forall (p : R) ρ1 ρ2, 0 < p < 1 -> Mixed_State ρ1 -> Mixed_State ρ2 ->
                                        Mixed_State (p .* ρ1 .+ (1-p)%R .* ρ2).

Lemma WF_Pure : forall {n} (ρ : Density n), Pure_State ρ -> WF_Matrix n n ρ.
Proof.
  unfold Pure_State. intuition.
Qed.
Hint Resolve WF_Pure.
Lemma WF_Mixed : forall {n} (ρ : Density n), Mixed_State ρ -> WF_Matrix n n ρ.
Proof.
  induction 1; auto.
  show_wf_safe.
Qed.
Hint Resolve WF_Mixed.

(** Density matrices and superoperators **)

Definition Superoperator m n := Density m -> Density n.

Definition WF_Superoperator {m n} (f : Superoperator m n) :=
  (forall ρ, Mixed_State ρ -> Mixed_State (f ρ)).

(* Transparent Density. *)

Definition super {m n} (M : Matrix m n) : Superoperator n m := fun ρ =>
  M × ρ × M†.

Definition compose_super {m n p} (g : Superoperator n p) (f : Superoperator m n)
                      : Superoperator m p :=
  fun ρ => g (f ρ).
Lemma compose_super_correct : forall {m n p}
                              (g : Superoperator n p) (f : Superoperator m n),
      WF_Superoperator g -> WF_Superoperator f ->
      WF_Superoperator (compose_super g f).
Proof.
  intros m n p g f pf_g pf_f.
  unfold WF_Superoperator.
  intros ρ mixed.
  unfold compose_super.
  apply pf_g. apply pf_f. auto.
Qed.

Definition sum_super {m n} (f g : Superoperator m n) : Superoperator m n :=
  fun ρ => (1/2)%R .* f ρ .+ (1 - 1/2)%R .* g ρ.
Lemma WF_sum_super : forall m n (f g : Superoperator m n),
      WF_Superoperator f -> WF_Superoperator g -> WF_Superoperator (sum_super f g).
Proof.
  intros m n f g wf_f wf_g ρ pf_ρ.
  unfold sum_super.
  set (wf_f' := wf_f _ pf_ρ).
  set (wf_g' := wf_g _ pf_ρ).
  apply (Mix_S (1/2) (f ρ) (g ρ)); auto. Rsolve.
Qed.

(* To do: correctness conditions for density matrices and superoperators *)
(* NOTE: I think these all need fixing *)

Definition new0_op : Superoperator 1 2 := super |0⟩.
Definition new1_op : Superoperator 1 2 := super |1⟩.
Definition meas_op : Superoperator 2 2 := fun ρ => super |0⟩⟨0| ρ .+ super |1⟩⟨1| ρ.
Definition discard_op : Superoperator 2 1 := fun ρ => super ⟨0| ρ .+ super ⟨1| ρ.

Lemma pure_unitary : forall {n} (U ρ : Matrix n n),
  is_unitary U -> Pure_State ρ -> Pure_State (super U ρ).
Proof.
  intros n U ρ [WFU H] [WFρ P].
  unfold Pure_State, is_unitary, super in *.
  split.
  show_wf.
  remember (U × ρ × (U) † × (U × ρ × (U) †)) as rhs.
  rewrite P.
  replace (ρ × ρ) with (ρ × Id n × ρ) by (rewrite Mmult_1_r; trivial).
  rewrite <- H.
  rewrite Heqrhs.
  repeat rewrite Mmult_assoc. (* Admitted *)
  reflexivity.
Qed.

Lemma pure_hadamard_1 : Pure_State (super hadamard |1⟩⟨1|).
Proof. apply pure_unitary.
       + apply H_unitary.
       + apply pure1.
Qed.

Definition dm12 : Matrix 2 2 :=
  (fun x y => match x, y with
          | 0, 0 => 1 / 2
          | 0, 1 => 1 / 2
          | 1, 0 => 1 / 2
          | 1, 1 => 1 / 2
          | _, _ => 0
          end).

Lemma pure_dm12 : Pure_State dm12. Proof.
  split.
  show_wf.
  unfold dm12, conj_transpose, super, Mmult.
  prep_matrix_equality.
  destruct x as [| [|x]]; destruct y as [|[|y]]; clra.
Qed.

Lemma mixed_meas_12 : Mixed_State (meas_op dm12).
Proof. unfold meas_op.
       replace (super |0⟩⟨0| dm12) with ((1/2)%R .* |0⟩⟨0|)
         by (unfold dm12, super; mlra).
       replace (super |1⟩⟨1| dm12) with ((1 - 1/2)%R .* |1⟩⟨1|)
         by (unfold dm12, super; mlra).
       apply Mix_S.
       lra.
       constructor; split; [show_wf|mlra].
       constructor; split; [show_wf|mlra].
Qed.

Lemma mixed_unitary : forall {n} (U ρ : Matrix n n),
  WF_Matrix n n U -> is_unitary U -> Mixed_State ρ -> Mixed_State (super U ρ).
Proof.
  intros n U ρ WFU H M.
  induction M.
  + apply Pure_S.
    apply pure_unitary; trivial.
  + unfold is_unitary, super in *.
    rewrite Mmult_plus_distr_l.
    rewrite Mmult_plus_distr_r.
    rewrite 2 Mscale_mult_dist_r.
    rewrite 2 Mscale_mult_dist_l.
    apply Mix_S; trivial.
Qed.

(* *)


Require Export SfLib.

(* ********************************************** *)
(* Problem 1 *)
(* ********************************************** *)

Inductive member {X : Type} : X -> list X -> Prop :=
  | member_here : forall x xs,
      member x (x :: xs)
  | member_later : forall x y xs,
      member x xs -> member x (y :: xs).

Theorem app_member_left : forall (X : Type) (x : X) (xs ys : list X),
  member x xs -> member x (xs ++ ys).
Proof.
  intros.
  induction H.
  + apply member_here.
  + simpl. apply member_later.
     assumption.
Qed.

Theorem app_member_right : forall (X : Type) (x : X) (xs ys : list X),
  member x ys -> member x (xs ++ ys).
Proof.
  intros.
  induction xs.
  + simpl. assumption.
  + simpl. apply member_later. assumption.
Qed.

Theorem or_app_member: forall (X:Type) (x:X) (xs ys : list X),
  member x xs \/ member x ys -> member x (xs ++ ys).
Proof.
  intros.
  induction H.
  + apply app_member_left. assumption.
  + apply app_member_right. assumption.
Qed.

Theorem app_or_member : forall (X : Type) (x : X) (xs ys : list X),
  member x (xs ++ ys) -> member x xs \/ member x ys.
Proof.
  intros.
  induction xs.
  + right. simpl in H. assumption.
  + inversion H. subst. simpl in H.
     * left. constructor.
     * apply IHxs in H2. destruct H2.
       - left. constructor. assumption.
       - right. assumption.
Qed.

(* ********************************************** *)
(* Problem 2 *)
(* ********************************************** *)

(* States *)

Definition state := id -> nat.

Definition empty_state : state :=
  fun _ => 0.

Definition update (st : state) (x : id) (n : nat) : state :=
  fun x' => if eq_id_dec x x' then n else st x'.

(* Arithmetic and boolean expressions *)

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Tactic Notation "aexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ANum" | Case_aux c "AId" | Case_aux c "APlus"
  | Case_aux c "AMinus" | Case_aux c "AMult" ].

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Tactic Notation "bexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "BTrue" | Case_aux c "BFalse" | Case_aux c "BEq"
  | Case_aux c "BLe" | Case_aux c "BNot" | Case_aux c "BAnd" ].

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => ble_nat (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

(* Commands *)

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CRepeat : com -> bexp -> com.

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP" | Case_aux c "::=" | Case_aux c ";;"
  | Case_aux c "IFB" | Case_aux c "WHILE"
  | Case_aux c "CRepeat" ].

Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'IFB' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'REPEAT' c 'UNTIL' b 'END'" :=
  (CRepeat c b) (at level 80, right associativity).

(* Evaluation relation *)

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st || st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st || (update st x n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  || st' ->
      c2 / st' || st'' ->
      (c1 ;; c2) / st || st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st || st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = true ->
      c / st || st' ->
      (WHILE b DO c END) / st' || st'' ->
      (WHILE b DO c END) / st || st''
  (* !!! *)
  | E_RepeatEnd : forall st st' b c,
      c / st || st' ->
       beval st' b = true ->
       (REPEAT c UNTIL b END) / st || st'
  | E_LoopLoop : forall st st' st'' b c,
        c / st || st' ->
        beval st' b = false ->
        (REPEAT c UNTIL b END) / st' || st'' ->
        (REPEAT c UNTIL b END) / st || st''

  where "c1 '/' st '||' st'" := (ceval c1 st st').

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Ass" | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop"
  | Case_aux c "E_RepeatEnd" | Case_aux c "E_LoopLoop" ].

(* Assertions *)

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop :=
  forall st, P st -> Q st.

Notation "P ->> Q" :=
  (assert_implies P Q) (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

(* Hoare triples *)

Definition hoare_triple
           (P:Assertion) (c:com) (Q:Assertion) : Prop :=
  forall st st',
       c / st || st'  ->
       P st  ->
       Q st'.

Notation "{{ P }}  c  {{ Q }}" :=
  (hoare_triple P c Q) (at level 90, c at next level)
  : hoare_spec_scope.

(* Assertions *)

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Lemma bexp_eval_true : forall b st,
  beval st b = true -> (bassn b) st.
Proof.
  intros b st Hbe.
  unfold bassn. assumption.  Qed.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  intros b st Hbe contra.
  unfold bassn in contra.
  rewrite -> contra in Hbe. inversion Hbe.  Qed.

(* Assignment *)

(*
             ------------------------------ (hoare_asgn)
             {{Q [X |-> a]}} X::=a {{Q}}
*)

Definition assn_sub X a P : Assertion :=
  fun (st : state) =>
    P (update st X (aeval st a)).

Notation "P [ X |-> a ]" := (assn_sub X a P) (at level 10).

Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X ::= a) {{Q}}.
Proof.
  unfold hoare_triple.
  intros Q X a st st' HE HQ.
  inversion HE. subst.
  unfold assn_sub in HQ. assumption.  Qed.

(* Consequence *)

(*
                {{P'}} c {{Q'}}
                   P ->> P'
                   Q' ->> Q
         -----------------------------   (hoare_consequence)
                {{P}} c {{Q}}
*)

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q c Hhoare Himp.
  intros st st' Hc HP. apply (Hhoare st st').
  assumption. apply Himp. assumption. Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P Q Q' c Hhoare Himp.
  intros st st' Hc HP.
  apply Himp.
  apply (Hhoare st st').
  assumption. assumption. Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  intros P P' Q Q' c Hht HPP' HQ'Q.
  apply hoare_consequence_pre with (P' := P').
  apply hoare_consequence_post with (Q' := Q').
  assumption. assumption. assumption.  Qed.

(* Skip *)

(*
             --------------------  (hoare_skip)
             {{ P }} SKIP {{ P }}
*)

Theorem hoare_skip : forall P,
     {{P}} SKIP {{P}}.
Proof.
  intros P st st' H HP. inversion H. subst.
  assumption.  Qed.

(* Sequencing *)

(*
               {{ P }} c1 {{ Q }}
               {{ Q }} c2 {{ R }}
              ---------------------  (hoare_seq)
              {{ P }} c1;;c2 {{ R }}
*)

Theorem hoare_seq : forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1;;c2 {{R}}.
Proof.
  intros P Q R c1 c2 H1 H2 st st' H12 Pre.
  inversion H12; subst.
  apply (H1 st'0 st'); try assumption.
  apply (H2 st st'0); assumption. Qed.

(* Conditional *)

(*
              {{P /\  b}} c1 {{Q}}
              {{P /\ ~b}} c2 {{Q}}
      ------------------------------------  (hoare_if)
      {{P}} IFB b THEN c1 ELSE c2 FI {{Q}}
*)

Theorem hoare_if : forall P Q b c1 c2,
  {{fun st => P st /\ bassn b st}} c1 {{Q}} ->
  {{fun st => P st /\ ~(bassn b st)}} c2 {{Q}} ->
  {{P}} (IFB b THEN c1 ELSE c2 FI) {{Q}}.
Proof.
  intros P Q b c1 c2 HTrue HFalse st st' HE HP.
  inversion HE; subst.
  Case "b is true".
    apply (HTrue st st').
      assumption.
      split. assumption.
             apply bexp_eval_true. assumption.
  Case "b is false".
    apply (HFalse st st').
      assumption.
      split. assumption.
             apply bexp_eval_false. assumption. Qed.

(* While *)

(*
               {{P /\ b}} c {{P}}
        -----------------------------------  (hoare_while)
        {{P}} WHILE b DO c END {{P /\ ~b}}
    The proposition [P] is called an _invariant_ of the loop.
*)

Lemma hoare_while : forall P b c,
  {{fun st => P st /\ bassn b st}} c {{P}} ->
  {{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  intros P b c Hhoare st st' He HP.
  (* Like we've seen before, we need to reason by induction
     on [He], because, in the "keep looping" case, its hypotheses
     talk about the whole loop instead of just [c]. *)
  remember (WHILE b DO c END) as wcom eqn:Heqwcom.
  ceval_cases (induction He) Case;
    try (inversion Heqwcom); subst; clear Heqwcom.
  Case "E_WhileEnd".
    split. assumption. apply bexp_eval_false. assumption.
  Case "E_WhileLoop".
    apply IHHe2. reflexivity.
    apply (Hhoare st st'). assumption.
      split. assumption. apply bexp_eval_true. assumption.
Qed.

(* Repeat *)
(*
                      {{P}} c {{Q}}
                     Q /\ ~b ->> P
      --------------------------------------------------------(hoare_loop)
        {{P}} REPEAT c UNTIL b END {{Q /\ b }}
*)

(* !!! *)

Theorem hoare_loop: forall P Q b c,
  {{P}} c {{Q}} ->
  (fun st => Q st /\ ~ ((bassn b) st)) ->> P ->
  {{P}} REPEAT c UNTIL b END {{fun st => Q st /\ ((bassn b) st)}}.
Proof.
  intros P Q b c Htriple Himp st st' He HP.
  remember (REPEAT c UNTIL b END) as rcom eqn : Heqrcom.
  ceval_cases (induction He) Case;
  inversion Heqrcom; subst; clear Heqrcom.
  + (* E_RepeatEnd *)
     split.
     - apply (Htriple st st'). assumption. assumption.
     - apply bexp_eval_true. assumption.
  + (* E_LoopLoop *)
     apply IHHe2. reflexivity.
     apply (Himp st').
     split.
     - apply (Htriple st st'). assumption. assumption.
     - apply bexp_eval_false. assumption.
Qed.

(* ********************************************** *)
(* Problem 3 *)
(* ********************************************** *)

(* Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty
  | TTree   : ty -> ty.

(* Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm
  | tbranch : tm -> tm -> tm -> tm
  | tcase : tm -> tm -> id -> id -> id -> tm -> tm
  | tleaf : tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp"
  | Case_aux c "tabs" | Case_aux c "ttrue"
  | Case_aux c "tfalse" | Case_aux c "tif"
  | Case_aux c "tbranch" | Case_aux c "tcase"
  | Case_aux c "tleaf" ].

(* Values *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse
  | v_leaf:
      value tleaf
  | v_branch : forall v1 v2 v3,
      value v1 -> value v2 -> value v3 ->
      value (tbranch v1 v2 v3).

Hint Constructors value.

(* Substitution *)

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if eq_id_dec x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if eq_id_dec x x' then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  | tbranch t1 t2 t3 =>
      tbranch ([x:=s] t1) ([x:=s] t2)([x:=s] t3)
  | tcase t1 t2 xt y zt t3 =>
      tcase ([x:=s] t1) ([x:=s] t2) xt y zt
      (if eq_id_dec x xt then
            t3
        else if eq_id_dec x y then
            t3
        else if eq_id_dec x zt then
            t3
        else
            ([x:=s] t3))
  | tleaf =>
     tleaf
  end

where "'[' x ':=' s ']' t" := (subst x s t).

(* Evaluation relation *)

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)
  (* !!! *)
  | ST_BranchLeft : forall t1 t2 t3 t1',
       t1 ==> t1' ->
      (tbranch t1 t2 t3) ==> (tbranch t1' t2 t3)
  | ST_BranchMiddle : forall v1 t2 t3 t2',
       value v1 ->
       t2 ==> t2' ->
      (tbranch v1 t2 t3) ==> (tbranch v1 t2' t3)
  | ST_BranchRight : forall t3 v1 v2 t3',
       t3 ==> t3' -> value v1 -> value v2 ->
      (tbranch v1 v2 t3) ==> (tbranch v1 v2 t3')
  | ST_TCase : forall t1 t1' t2 t3 xt y zt,
       t1 ==> t1' ->
      (tcase t1 t2 xt y zt t3) ==> (tcase t1' t2 xt y zt t3)
  | ST_TCaseLeaf : forall t2 t3 xt y zt,
      (tcase tleaf t2 xt y zt t3) ==> t2
  | ST_TCaseBranch : forall v11 v12 v13 t2 t3 xt y zt,
       value v11 -> value v12 -> value v13 ->
      (tcase (tbranch v11 v12 v13) t2 xt y zt t3) ==> ([xt := v11]([y := v12]([zt:=v13] t3)))

where "t1 '==>' t2" := (step t1 t2).

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1"
  | Case_aux c "ST_App2" | Case_aux c "ST_IfTrue"
  | Case_aux c "ST_IfFalse" | Case_aux c "ST_If"
  | Case_aux c "ST_BranchLeft" | Case_aux c "ST_BranchMiddle"
  | Case_aux c "ST_BranchRight" | Case_aux c "ST_TCase"
  | Case_aux c "ST_TCaseLeaf" | Case_aux c "ST_TCaseBranch"].

Hint Constructors step.

Notation multistep := (multi step).
Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

(* Contexts *)

Module PartialMap.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

(** Informally, we'll write [Gamma, x:T] for "extend the partial
    function [Gamma] to also map [x] to [T]."  Formally, we use the
    function [extend] to add a binding to a partial map. *)

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if eq_id_dec x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite eq_id. auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  x2 <> x1 ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite neq_id; auto.
Qed.

End PartialMap.

Definition context := partial_map ty.

(* Typing relation *)

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      extend Gamma x T11 |- t12 \in T12 ->
      Gamma |- tabs x T11 t12 \in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 \in TArrow T11 T12 ->
      Gamma |- t2 \in T11 ->
      Gamma |- tapp t1 t2 \in T12
  | T_True : forall Gamma,
       Gamma |- ttrue \in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse \in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 \in TBool ->
       Gamma |- t2 \in T ->
       Gamma |- t3 \in T ->
       Gamma |- tif t1 t2 t3 \in T
  (* !!! *)
  | T_Leaf : forall Gamma T,
        Gamma |- tleaf \in (TTree T)
  | T_Branch : forall Gamma T t1 t2 t3,
        Gamma |- t1 \in (TTree T) ->
        Gamma |- t2 \in T ->
        Gamma |- t3 \in (TTree T) ->
        Gamma |- (tbranch t1 t2 t3) \in (TTree T)
  | T_TCase : forall Gamma t0 t1 t2 T T' xt y zt,
        Gamma |- t0 \in (TTree T) ->
        Gamma |- t1 \in T' ->
        extend (extend (extend Gamma xt (TTree T)) y T) zt (TTree T)
               |- t2 \in T' ->
        Gamma |- (tcase t0 t1 xt y zt t2) \in T'

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs"
  | Case_aux c "T_App" | Case_aux c "T_True"
  | Case_aux c "T_False" | Case_aux c "T_If"
  | Case_aux c "T_Leaf" | Case_aux c "T_Branch"
  | Case_aux c "T_TCase"].

Hint Constructors has_type.

(* Canonical Forms *)

Lemma cannonical_forms_bool : forall t,
  empty |- t \in TBool ->
  value t ->
  (t = ttrue) \/ (t = tfalse).
Proof.
  intros t HT HVal.
  inversion HVal; intros; subst; try inversion HT; auto.
Qed.

Lemma cannonical_forms_fun : forall t T1 T2,
  empty |- t \in (TArrow T1 T2) ->
  value t ->
  exists x u, t = tabs x T1 u.
Proof.
  intros t T1 T2 HT HVal.
  inversion HVal; intros; subst; try inversion HT; subst; auto.
  exists x. exists t0.  auto.
Qed.

(* Progress, by induction on type derivation *)

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t ==> t'.

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  has_type_cases (induction Ht) Case; subst Gamma...
  Case "T_Var".
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  Case "T_App".
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    SCase "t1 is a value".
      destruct IHHt2...
      SSCase "t2 is also a value".
        assert (exists x0 t0, t1 = tabs x0 T11 t0).
        eapply cannonical_forms_fun; eauto.
        destruct H1 as [x0 [t0 Heq]]. subst.
        exists ([x0:=t2]t0)...

      SSCase "t2 steps".
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    SCase "t1 steps".
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  Case "T_If".
    right. destruct IHHt1...

    SCase "t1 is a value".
      destruct (cannonical_forms_bool t1); subst; eauto.

    SCase "t1 also steps".
      inversion H as [t1' Hstp]. exists (tif t1' t2 t3)...
  (* !!! *)
  Case "T_Branch".
    destruct IHHt1...
       SCase "t1 is a value".
          destruct IHHt2...
          SSCase "t2 is also a value".
            destruct IHHt3...
                SSSCase "t3 is a step".
                right. inversion H1.  exists (tbranch t1 t2 x)...
          SSCase "t2 steps".
            inversion H0.
            right. exists (tbranch t1 x t3)...
        SCase "t1 steps".
        right. inversion H. exists (tbranch x t2 t3)...

   Case "T_TCase".
       destruct IHHt1...
       SCase "t0 is a value".
           inversion H... inversion Ht1.
           inversion H1. rewrite <- H0 in H4. inversion H4.
           rewrite <- H0 in H5. inversion H5.
           rewrite <- H0 in H2. inversion H2.
           rewrite <- H0 in H5. inversion H5.
           rewrite <- H0 in H5. inversion H5.
           inversion Ht1.  inversion H1.
           rewrite <- H0 in H4. inversion H4.
           rewrite <- H0 in H5. inversion H5.
           rewrite <- H0 in H2. inversion H2.
           rewrite <- H0 in H5. inversion H5.
           rewrite <- H0 in H5. inversion H5.
           inversion Ht1.  inversion H1.
           rewrite <- H0 in H4. inversion H4.
           rewrite <- H0 in H5. inversion H5.
           rewrite <- H0 in H2. inversion H2.
           rewrite <- H0 in H5. inversion H5.
           rewrite <- H0 in H5. inversion H5.
       SCase "t0 steps".
           right. inversion H. exists (tcase x t1 xt y zt t2)...
Qed.


Require Import core fintype.

Require Import core_axioms fintype_axioms.
Require Import Setoid Morphisms Relation_Definitions.

Module renSubst.

Inductive ty : Type :=
  | Base : ty
  | Fun : ty -> ty -> ty.

Lemma congr_Base : Base = Base.
Proof.
exact (eq_refl).
Qed.

Lemma congr_Fun {s0 : ty} {s1 : ty} {t0 : ty} {t1 : ty} (H0 : s0 = t0)
  (H1 : s1 = t1) : Fun s0 s1 = Fun t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => Fun x s1) H0))
         (ap (fun x => Fun t0 x) H1)).
Qed.

Inductive tm (n_tm : nat) : Type :=
  | var_tm : fin n_tm -> tm n_tm
  | app : tm n_tm -> tm n_tm -> tm n_tm
  | lam : ty -> tm (S n_tm) -> tm n_tm.

Lemma congr_app {m_tm : nat} {s0 : tm m_tm} {s1 : tm m_tm} {t0 : tm m_tm}
  {t1 : tm m_tm} (H0 : s0 = t0) (H1 : s1 = t1) :
  app m_tm s0 s1 = app m_tm t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => app m_tm x s1) H0))
         (ap (fun x => app m_tm t0 x) H1)).
Qed.

Lemma congr_lam {m_tm : nat} {s0 : ty} {s1 : tm (S m_tm)} {t0 : ty}
  {t1 : tm (S m_tm)} (H0 : s0 = t0) (H1 : s1 = t1) :
  lam m_tm s0 s1 = lam m_tm t0 t1.
Proof.
exact (eq_trans (eq_trans eq_refl (ap (fun x => lam m_tm x s1) H0))
         (ap (fun x => lam m_tm t0 x) H1)).
Qed.

Lemma upRen_tm_tm {m : nat} {n : nat} (xi : fin m -> fin n) :
  fin (S m) -> fin (S n).
Proof.
exact (up_ren xi).
Defined.

Lemma upRen_list_tm_tm (p : nat) {m : nat} {n : nat} (xi : fin m -> fin n) :
  fin (plus p m) -> fin (plus p n).
Proof.
exact (upRen_p p xi).
Defined.

Fixpoint ren_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm)
(s : tm m_tm) {struct s} : tm n_tm :=
  match s with
  | var_tm _ s0 => var_tm n_tm (xi_tm s0)
  | app _ s0 s1 => app n_tm (ren_tm xi_tm s0) (ren_tm xi_tm s1)
  | lam _ s0 s1 => lam n_tm s0 (ren_tm (upRen_tm_tm xi_tm) s1)
  end.

Lemma up_tm_tm {m : nat} {n_tm : nat} (sigma : fin m -> tm n_tm) :
  fin (S m) -> tm (S n_tm).
Proof.
exact (scons (var_tm (S n_tm) var_zero) (funcomp (ren_tm shift) sigma)).
Defined.

Lemma up_list_tm_tm (p : nat) {m : nat} {n_tm : nat}
  (sigma : fin m -> tm n_tm) : fin (plus p m) -> tm (plus p n_tm).
Proof.
exact (scons_p p (funcomp (var_tm (plus p n_tm)) (zero_p p))
         (funcomp (ren_tm (shift_p p)) sigma)).
Defined.

Fixpoint subst_tm {m_tm : nat} {n_tm : nat} (sigma_tm : fin m_tm -> tm n_tm)
(s : tm m_tm) {struct s} : tm n_tm :=
  match s with
  | var_tm _ s0 => sigma_tm s0
  | app _ s0 s1 => app n_tm (subst_tm sigma_tm s0) (subst_tm sigma_tm s1)
  | lam _ s0 s1 => lam n_tm s0 (subst_tm (up_tm_tm sigma_tm) s1)
  end.

Lemma upId_tm_tm {m_tm : nat} (sigma : fin m_tm -> tm m_tm)
  (Eq : forall x, sigma x = var_tm m_tm x) :
  forall x, up_tm_tm sigma x = var_tm (S m_tm) x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap (ren_tm shift) (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma upId_list_tm_tm {p : nat} {m_tm : nat} (sigma : fin m_tm -> tm m_tm)
  (Eq : forall x, sigma x = var_tm m_tm x) :
  forall x, up_list_tm_tm p sigma x = var_tm (plus p m_tm) x.
Proof.
exact (fun n =>
       scons_p_eta (var_tm (plus p m_tm))
         (fun n => ap (ren_tm (shift_p p)) (Eq n)) (fun n => eq_refl)).
Qed.

Fixpoint idSubst_tm {m_tm : nat} (sigma_tm : fin m_tm -> tm m_tm)
(Eq_tm : forall x, sigma_tm x = var_tm m_tm x) (s : tm m_tm) {struct s} :
subst_tm sigma_tm s = s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (idSubst_tm sigma_tm Eq_tm s0) (idSubst_tm sigma_tm Eq_tm s1)
  | lam _ s0 s1 =>
      congr_lam (eq_refl s0)
        (idSubst_tm (up_tm_tm sigma_tm) (upId_tm_tm _ Eq_tm) s1)
  end.

Lemma upExtRen_tm_tm {m : nat} {n : nat} (xi : fin m -> fin n)
  (zeta : fin m -> fin n) (Eq : forall x, xi x = zeta x) :
  forall x, upRen_tm_tm xi x = upRen_tm_tm zeta x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap shift (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma upExtRen_list_tm_tm {p : nat} {m : nat} {n : nat} (xi : fin m -> fin n)
  (zeta : fin m -> fin n) (Eq : forall x, xi x = zeta x) :
  forall x, upRen_list_tm_tm p xi x = upRen_list_tm_tm p zeta x.
Proof.
exact (fun n =>
       scons_p_congr (fun n => eq_refl) (fun n => ap (shift_p p) (Eq n))).
Qed.

Fixpoint extRen_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm)
(zeta_tm : fin m_tm -> fin n_tm) (Eq_tm : forall x, xi_tm x = zeta_tm x)
(s : tm m_tm) {struct s} : ren_tm xi_tm s = ren_tm zeta_tm s :=
  match s with
  | var_tm _ s0 => ap (var_tm n_tm) (Eq_tm s0)
  | app _ s0 s1 =>
      congr_app (extRen_tm xi_tm zeta_tm Eq_tm s0)
        (extRen_tm xi_tm zeta_tm Eq_tm s1)
  | lam _ s0 s1 =>
      congr_lam (eq_refl s0)
        (extRen_tm (upRen_tm_tm xi_tm) (upRen_tm_tm zeta_tm)
           (upExtRen_tm_tm _ _ Eq_tm) s1)
  end.

Lemma upExt_tm_tm {m : nat} {n_tm : nat} (sigma : fin m -> tm n_tm)
  (tau : fin m -> tm n_tm) (Eq : forall x, sigma x = tau x) :
  forall x, up_tm_tm sigma x = up_tm_tm tau x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap (ren_tm shift) (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma upExt_list_tm_tm {p : nat} {m : nat} {n_tm : nat}
  (sigma : fin m -> tm n_tm) (tau : fin m -> tm n_tm)
  (Eq : forall x, sigma x = tau x) :
  forall x, up_list_tm_tm p sigma x = up_list_tm_tm p tau x.
Proof.
exact (fun n =>
       scons_p_congr (fun n => eq_refl)
         (fun n => ap (ren_tm (shift_p p)) (Eq n))).
Qed.

Fixpoint ext_tm {m_tm : nat} {n_tm : nat} (sigma_tm : fin m_tm -> tm n_tm)
(tau_tm : fin m_tm -> tm n_tm) (Eq_tm : forall x, sigma_tm x = tau_tm x)
(s : tm m_tm) {struct s} : subst_tm sigma_tm s = subst_tm tau_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (ext_tm sigma_tm tau_tm Eq_tm s0)
        (ext_tm sigma_tm tau_tm Eq_tm s1)
  | lam _ s0 s1 =>
      congr_lam (eq_refl s0)
        (ext_tm (up_tm_tm sigma_tm) (up_tm_tm tau_tm) (upExt_tm_tm _ _ Eq_tm)
           s1)
  end.

Lemma up_ren_ren_tm_tm {k : nat} {l : nat} {m : nat} (xi : fin k -> fin l)
  (zeta : fin l -> fin m) (rho : fin k -> fin m)
  (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x, funcomp (upRen_tm_tm zeta) (upRen_tm_tm xi) x = upRen_tm_tm rho x.
Proof.
exact (up_ren_ren xi zeta rho Eq).
Qed.

Lemma up_ren_ren_list_tm_tm {p : nat} {k : nat} {l : nat} {m : nat}
  (xi : fin k -> fin l) (zeta : fin l -> fin m) (rho : fin k -> fin m)
  (Eq : forall x, funcomp zeta xi x = rho x) :
  forall x,
  funcomp (upRen_list_tm_tm p zeta) (upRen_list_tm_tm p xi) x =
  upRen_list_tm_tm p rho x.
Proof.
exact (up_ren_ren_p Eq).
Qed.

Fixpoint compRenRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm)
(rho_tm : fin m_tm -> fin l_tm)
(Eq_tm : forall x, funcomp zeta_tm xi_tm x = rho_tm x) (s : tm m_tm) {struct
 s} : ren_tm zeta_tm (ren_tm xi_tm s) = ren_tm rho_tm s :=
  match s with
  | var_tm _ s0 => ap (var_tm l_tm) (Eq_tm s0)
  | app _ s0 s1 =>
      congr_app (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s0)
        (compRenRen_tm xi_tm zeta_tm rho_tm Eq_tm s1)
  | lam _ s0 s1 =>
      congr_lam (eq_refl s0)
        (compRenRen_tm (upRen_tm_tm xi_tm) (upRen_tm_tm zeta_tm)
           (upRen_tm_tm rho_tm) (up_ren_ren _ _ _ Eq_tm) s1)
  end.

Lemma up_ren_subst_tm_tm {k : nat} {l : nat} {m_tm : nat}
  (xi : fin k -> fin l) (tau : fin l -> tm m_tm) (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp tau xi x = theta x) :
  forall x, funcomp (up_tm_tm tau) (upRen_tm_tm xi) x = up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap (ren_tm shift) (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma up_ren_subst_list_tm_tm {p : nat} {k : nat} {l : nat} {m_tm : nat}
  (xi : fin k -> fin l) (tau : fin l -> tm m_tm) (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp tau xi x = theta x) :
  forall x,
  funcomp (up_list_tm_tm p tau) (upRen_list_tm_tm p xi) x =
  up_list_tm_tm p theta x.
Proof.
exact (fun n =>
       eq_trans (scons_p_comp' _ _ _ n)
         (scons_p_congr (fun z => scons_p_head' _ _ z)
            (fun z =>
             eq_trans (scons_p_tail' _ _ (xi z))
               (ap (ren_tm (shift_p p)) (Eq z))))).
Qed.

Fixpoint compRenSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm)
(theta_tm : fin m_tm -> tm l_tm)
(Eq_tm : forall x, funcomp tau_tm xi_tm x = theta_tm x) (s : tm m_tm) {struct
 s} : subst_tm tau_tm (ren_tm xi_tm s) = subst_tm theta_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s0)
        (compRenSubst_tm xi_tm tau_tm theta_tm Eq_tm s1)
  | lam _ s0 s1 =>
      congr_lam (eq_refl s0)
        (compRenSubst_tm (upRen_tm_tm xi_tm) (up_tm_tm tau_tm)
           (up_tm_tm theta_tm) (up_ren_subst_tm_tm _ _ _ Eq_tm) s1)
  end.

Lemma up_subst_ren_tm_tm {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : fin k -> tm l_tm) (zeta_tm : fin l_tm -> fin m_tm)
  (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp (ren_tm zeta_tm) sigma x = theta x) :
  forall x,
  funcomp (ren_tm (upRen_tm_tm zeta_tm)) (up_tm_tm sigma) x =
  up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n =>
           eq_trans
             (compRenRen_tm shift (upRen_tm_tm zeta_tm)
                (funcomp shift zeta_tm) (fun x => eq_refl) (sigma fin_n))
             (eq_trans
                (eq_sym
                   (compRenRen_tm zeta_tm shift (funcomp shift zeta_tm)
                      (fun x => eq_refl) (sigma fin_n)))
                (ap (ren_tm shift) (Eq fin_n)))
       | None => eq_refl
       end).
Qed.

Lemma up_subst_ren_list_tm_tm {p : nat} {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : fin k -> tm l_tm) (zeta_tm : fin l_tm -> fin m_tm)
  (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp (ren_tm zeta_tm) sigma x = theta x) :
  forall x,
  funcomp (ren_tm (upRen_list_tm_tm p zeta_tm)) (up_list_tm_tm p sigma) x =
  up_list_tm_tm p theta x.
Proof.
exact (fun n =>
       eq_trans (scons_p_comp' _ _ _ n)
         (scons_p_congr
            (fun x => ap (var_tm (plus p m_tm)) (scons_p_head' _ _ x))
            (fun n =>
             eq_trans
               (compRenRen_tm (shift_p p) (upRen_list_tm_tm p zeta_tm)
                  (funcomp (shift_p p) zeta_tm)
                  (fun x => scons_p_tail' _ _ x) (sigma n))
               (eq_trans
                  (eq_sym
                     (compRenRen_tm zeta_tm (shift_p p)
                        (funcomp (shift_p p) zeta_tm) (fun x => eq_refl)
                        (sigma n))) (ap (ren_tm (shift_p p)) (Eq n)))))).
Qed.

Fixpoint compSubstRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm)
(theta_tm : fin m_tm -> tm l_tm)
(Eq_tm : forall x, funcomp (ren_tm zeta_tm) sigma_tm x = theta_tm x)
(s : tm m_tm) {struct s} :
ren_tm zeta_tm (subst_tm sigma_tm s) = subst_tm theta_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s0)
        (compSubstRen_tm sigma_tm zeta_tm theta_tm Eq_tm s1)
  | lam _ s0 s1 =>
      congr_lam (eq_refl s0)
        (compSubstRen_tm (up_tm_tm sigma_tm) (upRen_tm_tm zeta_tm)
           (up_tm_tm theta_tm) (up_subst_ren_tm_tm _ _ _ Eq_tm) s1)
  end.

Lemma up_subst_subst_tm_tm {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : fin k -> tm l_tm) (tau_tm : fin l_tm -> tm m_tm)
  (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp (subst_tm tau_tm) sigma x = theta x) :
  forall x,
  funcomp (subst_tm (up_tm_tm tau_tm)) (up_tm_tm sigma) x = up_tm_tm theta x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n =>
           eq_trans
             (compRenSubst_tm shift (up_tm_tm tau_tm)
                (funcomp (up_tm_tm tau_tm) shift) (fun x => eq_refl)
                (sigma fin_n))
             (eq_trans
                (eq_sym
                   (compSubstRen_tm tau_tm shift
                      (funcomp (ren_tm shift) tau_tm) (fun x => eq_refl)
                      (sigma fin_n))) (ap (ren_tm shift) (Eq fin_n)))
       | None => eq_refl
       end).
Qed.

Lemma up_subst_subst_list_tm_tm {p : nat} {k : nat} {l_tm : nat} {m_tm : nat}
  (sigma : fin k -> tm l_tm) (tau_tm : fin l_tm -> tm m_tm)
  (theta : fin k -> tm m_tm)
  (Eq : forall x, funcomp (subst_tm tau_tm) sigma x = theta x) :
  forall x,
  funcomp (subst_tm (up_list_tm_tm p tau_tm)) (up_list_tm_tm p sigma) x =
  up_list_tm_tm p theta x.
Proof.
exact (fun n =>
       eq_trans
         (scons_p_comp' (funcomp (var_tm (plus p l_tm)) (zero_p p)) _ _ n)
         (scons_p_congr
            (fun x => scons_p_head' _ (fun z => ren_tm (shift_p p) _) x)
            (fun n =>
             eq_trans
               (compRenSubst_tm (shift_p p) (up_list_tm_tm p tau_tm)
                  (funcomp (up_list_tm_tm p tau_tm) (shift_p p))
                  (fun x => eq_refl) (sigma n))
               (eq_trans
                  (eq_sym
                     (compSubstRen_tm tau_tm (shift_p p) _
                        (fun x => eq_sym (scons_p_tail' _ _ x)) (sigma n)))
                  (ap (ren_tm (shift_p p)) (Eq n)))))).
Qed.

Fixpoint compSubstSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
(sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm)
(theta_tm : fin m_tm -> tm l_tm)
(Eq_tm : forall x, funcomp (subst_tm tau_tm) sigma_tm x = theta_tm x)
(s : tm m_tm) {struct s} :
subst_tm tau_tm (subst_tm sigma_tm s) = subst_tm theta_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s0)
        (compSubstSubst_tm sigma_tm tau_tm theta_tm Eq_tm s1)
  | lam _ s0 s1 =>
      congr_lam (eq_refl s0)
        (compSubstSubst_tm (up_tm_tm sigma_tm) (up_tm_tm tau_tm)
           (up_tm_tm theta_tm) (up_subst_subst_tm_tm _ _ _ Eq_tm) s1)
  end.

Lemma rinstInst_up_tm_tm {m : nat} {n_tm : nat} (xi : fin m -> fin n_tm)
  (sigma : fin m -> tm n_tm)
  (Eq : forall x, funcomp (var_tm n_tm) xi x = sigma x) :
  forall x, funcomp (var_tm (S n_tm)) (upRen_tm_tm xi) x = up_tm_tm sigma x.
Proof.
exact (fun n =>
       match n with
       | Some fin_n => ap (ren_tm shift) (Eq fin_n)
       | None => eq_refl
       end).
Qed.

Lemma rinstInst_up_list_tm_tm {p : nat} {m : nat} {n_tm : nat}
  (xi : fin m -> fin n_tm) (sigma : fin m -> tm n_tm)
  (Eq : forall x, funcomp (var_tm n_tm) xi x = sigma x) :
  forall x,
  funcomp (var_tm (plus p n_tm)) (upRen_list_tm_tm p xi) x =
  up_list_tm_tm p sigma x.
Proof.
exact (fun n =>
       eq_trans (scons_p_comp' _ _ (var_tm (plus p n_tm)) n)
         (scons_p_congr (fun z => eq_refl)
            (fun n => ap (ren_tm (shift_p p)) (Eq n)))).
Qed.

Fixpoint rinst_inst_tm {m_tm : nat} {n_tm : nat}
(xi_tm : fin m_tm -> fin n_tm) (sigma_tm : fin m_tm -> tm n_tm)
(Eq_tm : forall x, funcomp (var_tm n_tm) xi_tm x = sigma_tm x) (s : tm m_tm)
{struct s} : ren_tm xi_tm s = subst_tm sigma_tm s :=
  match s with
  | var_tm _ s0 => Eq_tm s0
  | app _ s0 s1 =>
      congr_app (rinst_inst_tm xi_tm sigma_tm Eq_tm s0)
        (rinst_inst_tm xi_tm sigma_tm Eq_tm s1)
  | lam _ s0 s1 =>
      congr_lam (eq_refl s0)
        (rinst_inst_tm (upRen_tm_tm xi_tm) (up_tm_tm sigma_tm)
           (rinstInst_up_tm_tm _ _ Eq_tm) s1)
  end.

Lemma renRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm)
  (s : tm m_tm) :
  ren_tm zeta_tm (ren_tm xi_tm s) = ren_tm (funcomp zeta_tm xi_tm) s.
Proof.
exact (compRenRen_tm xi_tm zeta_tm _ (fun n => eq_refl) s).
Qed.

Lemma renRen_tm_pointwise {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm)
  :
    pointwise_relation _ eq (funcomp (ren_tm zeta_tm ) (ren_tm xi_tm)) (ren_tm (funcomp zeta_tm xi_tm)).
Proof.
exact (fun s => compRenRen_tm xi_tm zeta_tm _ (fun n => eq_refl) s).
Qed.

Lemma substRen_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm)
  (s : tm m_tm) :
  ren_tm zeta_tm (subst_tm sigma_tm s) =
  subst_tm (funcomp (ren_tm zeta_tm) sigma_tm) s.
Proof.
exact (compSubstRen_tm sigma_tm zeta_tm _ (fun n => eq_refl) s).
Qed.

Lemma substRen_tm_pointwise {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm)
  :
    pointwise_relation _ eq (funcomp (ren_tm zeta_tm) (subst_tm sigma_tm)) (subst_tm (funcomp (ren_tm zeta_tm) sigma_tm)).
Proof.
exact (fun s => compSubstRen_tm sigma_tm zeta_tm _ (fun n => eq_refl) s).
Qed.

Lemma renSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm) (s : tm m_tm)
  : subst_tm tau_tm (ren_tm xi_tm s) = subst_tm (funcomp tau_tm xi_tm) s.
Proof.
exact (compRenSubst_tm xi_tm tau_tm _ (fun n => eq_refl) s).
Qed.

Lemma renSubst_tm_pointwise {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm)
  :
    pointwise_relation _ eq (funcomp (subst_tm tau_tm) (ren_tm xi_tm)) (subst_tm (funcomp tau_tm xi_tm)).
Proof.
exact (fun s => compRenSubst_tm xi_tm tau_tm _ (fun n => eq_refl) s).
Qed.

Lemma substSubst_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm)
  (s : tm m_tm) :
  subst_tm tau_tm (subst_tm sigma_tm s) =
  subst_tm (funcomp (subst_tm tau_tm) sigma_tm) s.
Proof.
exact (compSubstSubst_tm sigma_tm tau_tm _ (fun n => eq_refl) s).
Qed.

Lemma substSubst_tm_pointwise {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm)
  :
    pointwise_relation _ eq (funcomp (subst_tm tau_tm) (subst_tm sigma_tm)) (subst_tm (funcomp (subst_tm tau_tm) sigma_tm)).
Proof.
exact (fun s => compSubstSubst_tm sigma_tm tau_tm _ (fun n => eq_refl) s).
Qed.

Lemma rinstInst'_tm_pointwise {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm):
  pointwise_relation _ eq (ren_tm xi_tm) (subst_tm (funcomp (var_tm n_tm) xi_tm)).
Proof.
exact (fun s => rinst_inst_tm xi_tm _ (fun n => eq_refl) s).
Qed.

Lemma instId'_tm_pointwise {m_tm : nat} :
  pointwise_relation _ eq (subst_tm (var_tm m_tm)) id.
Proof.
exact (fun s => idSubst_tm (var_tm m_tm) (fun n => eq_refl) s).
Qed.

Lemma rinstId'_tm_pointwise {m_tm : nat} :
  pointwise_relation _ eq (@ren_tm m_tm m_tm id) id.
Proof.
exact (fun s => eq_ind_r (fun t => t = s) (instId'_tm_pointwise s) (rinstInst'_tm_pointwise id s)).
Qed.

Lemma varL'_tm_pointwise {m_tm : nat} {n_tm : nat} (sigma_tm : fin m_tm -> tm n_tm) :
  pointwise_relation _ eq (funcomp (subst_tm sigma_tm) (var_tm m_tm)) sigma_tm.
Proof.
exact (fun x => eq_refl).
Qed.

Lemma varLRen'_tm_pointwise {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm) :
  pointwise_relation _ eq (funcomp (ren_tm xi_tm) (var_tm m_tm)) (funcomp (var_tm n_tm) xi_tm).
Proof.
exact (fun x => eq_refl).
Qed.

Lemma rinstInst'_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm)
  (s : tm m_tm) : ren_tm xi_tm s = subst_tm (funcomp (var_tm n_tm) xi_tm) s.
Proof.
exact (rinst_inst_tm xi_tm _ (fun n => eq_refl) s).
Qed.

Lemma instId'_tm {m_tm : nat} (s : tm m_tm) : subst_tm (var_tm m_tm) s = s.
Proof.
exact (idSubst_tm (var_tm m_tm) (fun n => eq_refl) s).
Qed.

Lemma rinstId'_tm {m_tm : nat} (s : tm m_tm) : ren_tm id s = s.
Proof.
exact (eq_ind_r (fun t => t = s) (instId'_tm s) (rinstInst'_tm id s)).
Qed.

Lemma varL'_tm {m_tm : nat} {n_tm : nat} (sigma_tm : fin m_tm -> tm n_tm)
  (x : fin m_tm) : subst_tm sigma_tm (var_tm m_tm x) = sigma_tm x.
Proof.
exact (eq_refl).
Qed.

Lemma varLRen'_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm)
  (x : fin m_tm) : ren_tm xi_tm (var_tm m_tm x) = var_tm n_tm (xi_tm x).
Proof.
exact (eq_refl).
Qed.

Class Up_tm X Y :=
    up_tm : X -> Y.

Instance Subst_tm  {m_tm n_tm : nat}: (Subst1 _ _ _) := (@subst_tm m_tm n_tm).

Instance Up_tm_tm  {m n_tm : nat}: (Up_tm _ _) := (@up_tm_tm m n_tm).

Instance Ren_tm  {m_tm n_tm : nat}: (Ren1 _ _ _) := (@ren_tm m_tm n_tm).

Instance VarInstance_tm  {n_tm : nat}: (Var _ _) := (@var_tm n_tm).

Notation "[ sigma_tm ]" := (subst_tm sigma_tm)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s [ sigma_tm ]" := (subst_tm sigma_tm s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "↑__tm" := up_tm (only printing) : subst_scope.

Notation "↑__tm" := up_tm_tm (only printing) : subst_scope.

Notation "⟨ xi_tm ⟩" := (ren_tm xi_tm)
  ( at level 1, left associativity, only printing) : fscope.

Notation "s ⟨ xi_tm ⟩" := (ren_tm xi_tm s)
  ( at level 7, left associativity, only printing) : subst_scope.

Notation "'var'" := var_tm ( at level 1, only printing) : subst_scope.

Notation "x '__tm'" := (@ids _ _ VarInstance_tm x)
  ( at level 5, format "x __tm", only printing) : subst_scope.

Notation "x '__tm'" := (var_tm x) ( at level 5, format "x __tm") :
  subst_scope.

Instance subst_tm_morphism  {m_tm : nat} {n_tm : nat}:
 (Proper (respectful (pointwise_relation _ eq) (respectful eq eq))
    (@subst_tm m_tm n_tm)).
Proof.
exact (fun f_tm g_tm Eq_tm s t Eq_st =>
       eq_ind s (fun t' => subst_tm f_tm s = subst_tm g_tm t')
         (ext_tm f_tm g_tm Eq_tm s) t Eq_st).
Qed.

Instance ren_tm_morphism  {m_tm : nat} {n_tm : nat}:
 (Proper (respectful (pointwise_relation _ eq) (respectful eq eq))
    (@ren_tm m_tm n_tm)).
Proof.
exact (fun f_tm g_tm Eq_tm s t Eq_st =>
       eq_ind s (fun t' => ren_tm f_tm s = ren_tm g_tm t')
         (extRen_tm f_tm g_tm Eq_tm s) t Eq_st).
Qed.

Ltac auto_unfold := repeat
                     unfold VarInstance_tm, Var, ids, Ren_tm, Ren1, ren1,
                      Up_tm_tm, Up_tm, up_tm, Subst_tm, Subst1, subst1.

Tactic Notation "auto_unfold" "in" "*" := repeat
                                           unfold VarInstance_tm, Var, ids,
                                            Ren_tm, Ren1, ren1, Up_tm_tm,
                                            Up_tm, up_tm, Subst_tm, Subst1,
                                            subst1 in *.

Ltac asimpl' := repeat (first
                 [ progress setoid_rewrite substSubst_tm
                 | progress setoid_rewrite substSubst_tm_pointwise
                 | progress setoid_rewrite renSubst_tm
                 | progress setoid_rewrite renSubst_tm_pointwise
                 | progress setoid_rewrite substRen_tm
                 | progress setoid_rewrite substRen_tm_pointwise
                 | progress setoid_rewrite renRen_tm
                 | progress setoid_rewrite renRen_tm_pointwise
                 | progress setoid_rewrite varLRen'_tm
                 | progress setoid_rewrite varLRen'_tm_pointwise
                 | progress setoid_rewrite varL'_tm
                 | progress setoid_rewrite varL'_tm_pointwise
                 | progress setoid_rewrite rinstId'_tm
                 | progress setoid_rewrite rinstId'_tm_pointwise
                 | progress setoid_rewrite instId'_tm
                 | progress setoid_rewrite instId'_tm_pointwise
                 | progress
                    unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm,
                     upRen_tm_tm, up_ren
                 | progress cbn[subst_tm ren_tm shift scons scons_p]
                 | progress fsimpl ]).

Ltac asimpl := check_no_evars; repeat try unfold_funcomp;
                repeat
                 unfold VarInstance_tm, Var, ids, Ren_tm, Ren1, ren1,
                  Up_tm_tm, Up_tm, up_tm, Subst_tm, Subst1, subst1 in *;
                asimpl'; minimize.

Tactic Notation "asimpl" "in" hyp(J) := revert J; asimpl; intros J.

Tactic Notation "auto_case" := auto_case ltac:(asimpl; cbn; eauto).

Ltac substify := auto_unfold; try setoid_rewrite rinstInst'_tm.

Ltac renamify := auto_unfold; try setoid_rewrite_left rinstInst'_tm.

End renSubst.

Module fext.

Import
renSubst.

Lemma rinstInst_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm) :
  ren_tm xi_tm = subst_tm (funcomp (var_tm n_tm) xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => rinst_inst_tm xi_tm _ (fun n => eq_refl) x)).
Qed.

Lemma instId_tm {m_tm : nat} : subst_tm (var_tm m_tm) = id.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => idSubst_tm (var_tm m_tm) (fun n => eq_refl) (id x))).
Qed.

Lemma rinstId_tm {m_tm : nat} : @ren_tm m_tm m_tm id = id.
Proof.
exact (eq_trans (rinstInst_tm (id _)) instId_tm).
Qed.

Lemma varL_tm {m_tm : nat} {n_tm : nat} (sigma_tm : fin m_tm -> tm n_tm) :
  funcomp (subst_tm sigma_tm) (var_tm m_tm) = sigma_tm.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => eq_refl)).
Qed.

Lemma varLRen_tm {m_tm : nat} {n_tm : nat} (xi_tm : fin m_tm -> fin n_tm) :
  funcomp (ren_tm xi_tm) (var_tm m_tm) = funcomp (var_tm n_tm) xi_tm.
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun x => eq_refl)).
Qed.

Lemma renRen'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (zeta_tm : fin k_tm -> fin l_tm) :
  funcomp (ren_tm zeta_tm) (ren_tm xi_tm) = ren_tm (funcomp zeta_tm xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => renRen_tm xi_tm zeta_tm n)).
Qed.

Lemma substRen'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (zeta_tm : fin k_tm -> fin l_tm) :
  funcomp (ren_tm zeta_tm) (subst_tm sigma_tm) =
  subst_tm (funcomp (ren_tm zeta_tm) sigma_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => substRen_tm sigma_tm zeta_tm n)).
Qed.

Lemma renSubst'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (xi_tm : fin m_tm -> fin k_tm) (tau_tm : fin k_tm -> tm l_tm) :
  funcomp (subst_tm tau_tm) (ren_tm xi_tm) = subst_tm (funcomp tau_tm xi_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => renSubst_tm xi_tm tau_tm n)).
Qed.

Lemma substSubst'_tm {k_tm : nat} {l_tm : nat} {m_tm : nat}
  (sigma_tm : fin m_tm -> tm k_tm) (tau_tm : fin k_tm -> tm l_tm) :
  funcomp (subst_tm tau_tm) (subst_tm sigma_tm) =
  subst_tm (funcomp (subst_tm tau_tm) sigma_tm).
Proof.
exact (FunctionalExtensionality.functional_extensionality _ _
         (fun n => substSubst_tm sigma_tm tau_tm n)).
Qed.

Ltac asimpl_fext' := repeat (first
                      [ progress setoid_rewrite substSubst_tm
                      | progress setoid_rewrite renSubst_tm
                      | progress setoid_rewrite substRen_tm
                      | progress setoid_rewrite renRen_tm
                      | progress setoid_rewrite substSubst'_tm
                      | progress setoid_rewrite renSubst'_tm
                      | progress setoid_rewrite substRen'_tm
                      | progress setoid_rewrite renRen'_tm
                      | progress setoid_rewrite varLRen_tm
                      | progress setoid_rewrite varL_tm
                      | progress setoid_rewrite rinstId_tm
                      | progress setoid_rewrite instId_tm
                      | progress
                         unfold up_list_tm_tm, up_tm_tm, upRen_list_tm_tm,
                          upRen_tm_tm, up_ren
                      | progress cbn[subst_tm ren_tm]
                      | fsimpl_fext ]).

Ltac asimpl_fext := check_no_evars; repeat try unfold_funcomp;
                     repeat
                      unfold VarInstance_tm, Var, ids, Ren_tm, Ren1, ren1,
                       Up_tm_tm, Up_tm, up_tm, Subst_tm, Subst1, subst1
                       in *; asimpl_fext'; repeat try unfold_funcomp.

Tactic Notation "asimpl_fext" "in" hyp(J) := revert J; asimpl_fext; intros J.

Ltac substify_fext := auto_unfold; try repeat erewrite ?rinstInst_tm.

Ltac renamify_fext := auto_unfold; try repeat erewrite <- ?rinstInst_tm.

End fext.

Module interface.

Export renSubst.

Export
fext.

Hint Opaque subst_tm : rewrite.
Hint Opaque ren_tm : rewrite.

Arguments lam {n_tm}.

Arguments app {n_tm}.

Arguments var_tm {n_tm}.

End interface.

Export interface.


Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelNC.
Require Export GeoCoq.Elements.OriginalProofs.lemma_parallelsymmetric.
Require Export GeoCoq.Elements.OriginalProofs.proposition_29B.
Require Export GeoCoq.Elements.OriginalProofs.lemma_NCdistinct.
Require Export GeoCoq.Elements.OriginalProofs.lemma_samesidetransitive.

Section Euclid.

Context `{Ax:euclidean_euclidean}.

Lemma lemma_Playfairhelper :
   forall A B C D E,
   Par A B C D -> Par A B C E -> CR A D B C -> CR A E B C ->
   Col C D E.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists M, (BetS A M D /\ BetS B M C)) by (conclude_def CR );destruct Tf as [M];spliter.
let Tf:=fresh in
assert (Tf:exists m, (BetS A m E /\ BetS B m C)) by (conclude_def CR );destruct Tf as [m];spliter.
assert (neq B C) by (forward_using lemma_betweennotequal).
assert (BetS E m A) by (conclude axiom_betweennesssymmetry).
assert (BetS D M A) by (conclude axiom_betweennesssymmetry).
assert (Col B M C) by (conclude_def Col ).
assert (Col B m C) by (conclude_def Col ).
assert (Col C B M) by (forward_using lemma_collinearorder).
assert (Col C B m) by (forward_using lemma_collinearorder).
assert (nCol B C E) by (forward_using lemma_parallelNC).
assert (nCol C B E) by (forward_using lemma_NCorder).
assert (nCol B C D) by (forward_using lemma_parallelNC).
assert (nCol C B D) by (forward_using lemma_NCorder).
assert (TS E C B A) by (conclude_def TS ).
assert (TS D C B A) by (conclude_def TS ).
assert (Par C D A B) by (conclude lemma_parallelsymmetric).
assert (Par C E A B) by (conclude lemma_parallelsymmetric).
assert (Par E C B A) by (forward_using lemma_parallelflip).
assert (Par D C B A) by (forward_using lemma_parallelflip).
assert (CongA E C B C B A) by (conclude proposition_29B).
assert (CongA D C B C B A) by (conclude proposition_29B).
assert (CongA C B A D C B) by (conclude lemma_equalanglessymmetric).
assert (CongA E C B D C B) by (conclude lemma_equalanglestransitive).
assert (neq C E) by (forward_using lemma_NCdistinct).
assert (neq C D) by (forward_using lemma_NCdistinct).
let Tf:=fresh in
assert (Tf:exists e, (Out C E e /\ Cong C e C D)) by (conclude lemma_layoff);destruct Tf as [e];spliter.
assert (eq B B) by (conclude cn_equalityreflexive).
assert (neq C B) by (conclude lemma_inequalitysymmetric).
assert (Out C B B) by (conclude lemma_ray4).
assert (Cong C B C B) by (conclude cn_congruencereflexive).
assert (nCol E C B) by (forward_using lemma_NCorder).
assert (CongA E C B E C B) by (conclude lemma_equalanglesreflexive).
assert (CongA E C B e C B) by (conclude lemma_equalangleshelper).
assert (CongA e C B E C B) by (conclude lemma_equalanglessymmetric).
assert (CongA e C B D C B) by (conclude lemma_equalanglestransitive).
assert (Col C E e) by (conclude lemma_rayimpliescollinear).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Col C E C) by (conclude_def Col ).
assert (nCol C E B) by (forward_using lemma_NCorder).
assert (neq C e) by (conclude lemma_raystrict).
assert (nCol C e B) by (conclude lemma_NChelper).
assert (nCol e C B) by (forward_using lemma_NCorder).
assert (Triangle e C B) by (conclude_def Triangle ).
assert (nCol D C B) by (forward_using lemma_NCorder).
assert (Triangle D C B) by (conclude_def Triangle ).
assert (Cong e B D B) by (conclude proposition_04).
assert (nCol B C E) by (forward_using lemma_parallelNC).
assert (nCol C B E) by (forward_using lemma_NCorder).
assert (nCol B C D) by (forward_using lemma_parallelNC).
assert (nCol C B D) by (forward_using lemma_NCorder).
assert (OS E D C B) by (conclude_def OS ).
assert (nCol C B e) by (forward_using lemma_NCorder).
assert (Col C C B) by (conclude_def Col ).
assert (Out C e E) by (conclude lemma_ray5).
assert (OS e e C B) by (conclude lemma_samesidereflexive).
assert (OS e E C B) by (conclude lemma_sameside2).
assert (OS e D C B) by (conclude lemma_samesidetransitive).
assert (Cong e C D C) by (forward_using lemma_congruenceflip).
assert (eq e D) by (conclude proposition_07).
assert (Col C E D) by (conclude cn_equalitysub).
assert (Col C D E) by (forward_using lemma_collinearorder).
close.
Qed.

End Euclid.


(** **********************************************************

Benedikt Ahrens, Chris Kapulkin, Mike Shulman

january 2013

************************************************************)

(** **********************************************************

Contents :

Precomposition with a full and
           essentially surjective functor yields
           a full and faithful, i.e. a fully faithful,
           functor

************************************************************)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.whiskering.

Local Open Scope cat.

Ltac simp_rew lem := let H:=fresh in
     assert (H:= lem); simpl in *; rewrite H; clear H.
Ltac simp_rerew lem := let H:=fresh in
     assert (H:= lem); simpl in *; rewrite <- H; clear H.

Local Notation "G 'O' F" := (functor_compose _ _ _ F G : functor _ _ ) (at level 25).

Section pre_composition.

(** Section variables *)

Variables A B C : category.
Variable H : functor A B.

(** * Precomposition with an essentially surjective functor is faithful. *)

Lemma pre_composition_with_ess_surj_is_faithful (p : essentially_surjective H) :
           faithful (pre_composition_functor A B C H).
Proof.
  intros F G.
  apply isinclbetweensets.
  - apply isaset_nat_trans. apply C.
  - apply isaset_nat_trans. apply C.
  - simpl in *.
    intros gamma delta ex.
    apply nat_trans_eq.
    + apply C.
    + intro b.
      apply (p b (make_hProp _ (homset_property C _ _ _ _))).
      intro t; induction t as [a f]; simpl.
      apply (pre_comp_with_z_iso_is_inj (pr2(pr2(functor_on_z_iso _ f)))).
      cbn.
      do 2 rewrite nat_trans_ax.
      apply cancel_postcomposition.
      apply (nat_trans_eq_pointwise ex a).
Defined.

(** * Precomposition with an essentially surjective and full functor is full *)

Section precomp_with_ess_surj_full_functor_is_full.

Hypothesis p : essentially_surjective H.
Hypothesis Hf : full H.

(** We prove that [_ O H] yields a full functor. *)

Section full.

Variables F G : functor B C.

(** We have to show that for [F] and [G], the map
     [(_ O H) (F,G) : (F --> G) -> (F O H --> G O H)]  is surjective. *)

(** Fixing a [gamma], we produce its preimage. *)

Variable gamma : nat_trans
     (functor_composite H F)
     (functor_composite H G).

Lemma iscontr_aux_space (b : B) :
   iscontr (total2 (fun g : F b --> G b =>
      ∏ a : A, ∏ f : z_iso (H a) b,
           g = functor_on_z_iso F (z_iso_inv_from_z_iso f) · gamma a · #G f)).
Proof.
  apply (p b (make_hProp _ (isapropiscontr _))).
  intro t; induction t as [anot h]; simpl.
  set (g := functor_on_z_iso F (z_iso_inv_from_z_iso h) · gamma anot · #G h).
  assert (gp : ∏ (a : A) (f : z_iso (H a) b),
                 g = #F (inv_from_z_iso f) · gamma a · #G f).
  - intros a f.
    apply (Hf _ _ (h · inv_from_z_iso f) (make_hProp _ (homset_property C  _ _ _ _))).
    intro sur.
    simpl.
    unfold g.
    rewrite functor_on_z_iso_inv; simpl.
    rewrite <- assoc.
    apply z_iso_inv_on_right.
    rewrite 2 assoc.
    simpl.
    rewrite <- functor_comp.
    rewrite <- (pr2 sur).
    simp_rew (nat_trans_ax gamma).
    rewrite (pr2 sur).
    rewrite <- assoc.
    apply cancel_precomposition.
    rewrite <- functor_comp.
    apply maponpaths.
    rewrite <- assoc.
    rewrite z_iso_after_z_iso_inv.
    apply pathsinv0, id_right.
  - exists (g,, gp).
    intro t; induction t as [g' gp'].
    apply subtypePath.
    { intro; do 2 (apply impred; intro).
      apply C. }
    simpl.
    rewrite (gp anot h).
    rewrite (gp' anot h).
    apply idpath.
Defined.

Definition pdelta : ∏ b : B, F b --> G b :=
         λ b, pr1 (pr1 (iscontr_aux_space b)).

Lemma is_nat_trans_pdelta :
     is_nat_trans F G pdelta.
Proof.
  intros b b' f.
  apply (p b (make_hProp _ (homset_property C _ _ _ _) )).
  intro t; induction t as [a h]; simpl.
  apply (p b' (make_hProp _ (homset_property C _ _ _ _) )).
  intro t; induction t as [a' h']; simpl.
  unfold pdelta.
  rewrite (pr2 ((pr1 (iscontr_aux_space b))) a h).
  rewrite (pr2 ((pr1 (iscontr_aux_space b'))) a' h').
  rewrite <- 3 assoc.
  apply pathsinv0.
  rewrite functor_on_z_iso_inv.
  apply z_iso_inv_on_right.
  rewrite 4 assoc.
  simpl.
  rewrite <- 2 functor_comp.
  apply (Hf _ _ (h · f · (inv_from_z_iso h')) (make_hProp _ (homset_property C _ _ _ _))).
  intro sur.
  simpl.
  rewrite <- (pr2 sur).
  simp_rew (nat_trans_ax gamma).
  rewrite (pr2 sur).
  rewrite <- 3 assoc.
  rewrite <- 2 functor_comp.
  apply cancel_precomposition, maponpaths.
  rewrite <- 2 assoc.
  rewrite z_iso_after_z_iso_inv.
  rewrite id_right.
  apply idpath.
Defined.

Definition delta : nat_trans F G :=
  (pdelta,, is_nat_trans_pdelta).

Lemma pdelta_preimage : pre_whisker H delta = gamma.
Proof.
  apply nat_trans_eq.
  - apply C.
  - intro a.
    intermediate_path (pr1 (pr1 (iscontr_aux_space (H a)))).
    + apply idpath.
    + rewrite (pr2 (pr1 (iscontr_aux_space (H a))) a (identity_z_iso _)).
      rewrite z_iso_inv_of_z_iso_id.
      simpl.
      rewrite 2 functor_id.
      rewrite id_right.
      apply id_left.
Defined.

End full.

(** * Precomposition with an essentially surjective and full functor is fully faithful *)

Lemma pre_composition_with_ess_surj_and_full_is_full :
  full (pre_composition_functor A B C H).
Proof.
  intros F G gamma.
  apply hinhpr.
  exists (delta F G gamma).
  apply pdelta_preimage.
Defined.

Lemma pre_composition_with_ess_surj_and_full_is_full_and_faithful :
   full_and_faithful (pre_composition_functor A B C H).
Proof.
  split.
  apply pre_composition_with_ess_surj_and_full_is_full.
  apply pre_composition_with_ess_surj_is_faithful. assumption.
Defined.

Lemma pre_composition_with_ess_surj_and_full_is_fully_faithful :
   fully_faithful (pre_composition_functor A B C H).
Proof.
  apply full_and_faithful_implies_fully_faithful.
  apply pre_composition_with_ess_surj_and_full_is_full_and_faithful.
Defined.

End precomp_with_ess_surj_full_functor_is_full.

Lemma pre_composition_with_ess_surj_and_fully_faithful_is_fully_faithful
  (p : essentially_surjective H) (Hff : fully_faithful H):
  fully_faithful (pre_composition_functor A B C H).
Proof.
  apply pre_composition_with_ess_surj_and_full_is_fully_faithful.
  - exact p.
  - apply fully_faithful_implies_full_and_faithful.
    exact Hff.
Defined.

End pre_composition.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** * DecimalBin : conversions between Decimal and binary numbers *)

Require Import Decimal PArith NArith ZArith.

(** We provide these conversions as extensions of modules Pos, N, Z. *)

Module Pos.
Include BinPos.Pos.
Local Open Scope positive.

Local Notation ten := 1~0~1~0.

Fixpoint of_uint_acc (d:Decimal.uint)(acc:positive) :=
  match d with
  | Decimal.Nil => acc
  | Decimal.D0 l => of_uint_acc l (mul ten acc)
  | Decimal.D1 l => of_uint_acc l (add 1 (mul ten acc))
  | Decimal.D2 l => of_uint_acc l (add 1~0 (mul ten acc))
  | Decimal.D3 l => of_uint_acc l (add 1~1 (mul ten acc))
  | Decimal.D4 l => of_uint_acc l (add 1~0~0 (mul ten acc))
  | Decimal.D5 l => of_uint_acc l (add 1~0~1 (mul ten acc))
  | Decimal.D6 l => of_uint_acc l (add 1~1~0 (mul ten acc))
  | Decimal.D7 l => of_uint_acc l (add 1~1~1 (mul ten acc))
  | Decimal.D8 l => of_uint_acc l (add 1~0~0~0 (mul ten acc))
  | Decimal.D9 l => of_uint_acc l (add 1~0~0~1 (mul ten acc))
  end.

Fixpoint of_uint (d:Decimal.uint) : N :=
  match d with
  | Decimal.Nil => N0
  | Decimal.D0 l => of_uint l
  | Decimal.D1 l => Npos (of_uint_acc l 1)
  | Decimal.D2 l => Npos (of_uint_acc l 1~0)
  | Decimal.D3 l => Npos (of_uint_acc l 1~1)
  | Decimal.D4 l => Npos (of_uint_acc l 1~0~0)
  | Decimal.D5 l => Npos (of_uint_acc l 1~0~1)
  | Decimal.D6 l => Npos (of_uint_acc l 1~1~0)
  | Decimal.D7 l => Npos (of_uint_acc l 1~1~1)
  | Decimal.D8 l => Npos (of_uint_acc l 1~0~0~0)
  | Decimal.D9 l => Npos (of_uint_acc l 1~0~0~1)
  end.

Definition of_int (d:Decimal.int) : option positive :=
  match d with
  | Decimal.Pos d =>
    match of_uint d with
    | N0 => None
    | Npos p => Some p
    end
  | Decimal.Neg _ => None
  end.

Fixpoint to_little_uint p :=
  match p with
  | 1 => Decimal.D1 Decimal.Nil
  | p~1 => Decimal.Little.succ_double (to_little_uint p)
  | p~0 => Decimal.Little.double (to_little_uint p)
  end.

Definition to_uint p := Decimal.rev (to_little_uint p).

Definition to_int n := Decimal.Pos (to_uint n).

End Pos.

Module N.
Include BinNat.N.

Definition of_uint (d:Decimal.uint) := Pos.of_uint d.

Definition of_int (d:Decimal.int) :=
  match Decimal.norm d with
  | Decimal.Pos d => Some (Pos.of_uint d)
  | Decimal.Neg _ => None
  end.

Definition to_uint n :=
  match n with
  | N0 => Decimal.zero
  | Npos p => Pos.to_uint p
  end.

Definition to_int n := Decimal.Pos (to_uint n).

End N.

Module Z.
Include BinInt.Z.

Definition of_uint (d:Decimal.uint) := of_N (Pos.of_uint d).

Definition of_int (d:Decimal.int) :=
  match d with
  | Decimal.Pos d => of_uint d
  | Decimal.Neg d => opp (of_uint d)
  end.

Definition to_int n :=
  match n with
  | Z0 => Decimal.Pos Decimal.zero
  | Zpos p => Decimal.Pos (Pos.to_uint p)
  | Zneg p => Decimal.Neg (Pos.to_uint p)
  end.

End Z.


(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA        LRI-CNRS        ENS-CNRS                *)
(*              Rocquencourt         Orsay          Lyon                    *)
(*                                                                          *)
(*                                 Coq V6.3                                 *)
(*                               July 1st 1999                              *)
(*                                                                          *)
(****************************************************************************)
(*                                ListSet.v                                 *)
(****************************************************************************)

(* A Library for finite sets, implemented as lists *)
(* A Library with similar interface will soon be available under
  the name TreeSet in the theories/TREES directory *)

(* PolyList is loaded, but not exported *)
(* This allow to "hide" the definitions, functions and theorems of PolyList
 and to see only the ones of ListSet *)
Require Import List.

Set Implicit Arguments.
Unset Strict Implicit.
Section first_definitions.

Variable A : Set.
Hypothesis Aeq_dec : forall x y : A, {x = y} + {x <> y}.

Definition set := list A.

Definition empty_set := nil (A:=A).

  Fixpoint set_add (a : A) (x : set) {struct x} : set :=
    match x with
    | nil => a :: nil
    | a1 :: x1 =>
        match Aeq_dec a a1 with
        | left _ => a1 :: x1
        | right _ => a1 :: set_add a x1
        end
    end.

  Fixpoint set_mem (a : A) (x : set) {struct x} : bool :=
    match x with
    | nil => false
    | a1 :: x1 =>
        match Aeq_dec a a1 with
        | left _ => true
        | right _ => set_mem a x1
        end
    end.

  (* If a belongs to x, removes a from x. If not, does nothing *)
  Fixpoint set_remove (a : A) (x : set) {struct x} : set :=
    match x with
    | nil => empty_set
    | a1 :: x1 =>
        match Aeq_dec a a1 with
        | left _ => set_remove a x1
        | right _ => a1 :: set_remove a x1
        end
    end.

  Fixpoint set_inter (x : set) : set -> set :=
    match x with
    | nil => fun y => nil (A:=A)
    | a1 :: x1 =>
        fun y =>
        if set_mem a1 y then a1 :: set_inter x1 y else set_inter x1 y
    end.

  Fixpoint set_union (x y : set) {struct y} : set :=
    match y with
    | nil => x
    | a1 :: y1 => set_add a1 (set_union x y1)
    end.

  (* returns the set of all els of x that does not belong to y *)
  Fixpoint set_diff (x : set) : set -> set :=
    fun y =>
    match x with
    | nil => nil (A:=A)
    | a1 :: x1 =>
        if set_mem a1 y then set_diff x1 y else set_add a1 (set_diff x1 y)
    end.

  (**
  Inductive set_In : A -> set -> Prop :=
    set_In_singl : (a:A)(x:set)(set_In a (cons a (nil A)))
  | set_In_add : (a,b:A)(x:set)(set_In a x)->(set_In a (set_add b x))
  .
  **)

  Definition set_In : A -> set -> Prop := In (A:=A).

Lemma Set_remove1 : forall (B : set) (x : A), ~ set_In x (set_remove x B).
intro; intro.
induction  B as [| a B HrecB].
auto.

simpl in |- *.
elim (Aeq_dec x a).
intro.
unfold not in |- *.
unfold not in HrecB.
intro.
apply HrecB; auto.

intro.
unfold not in |- *.
unfold not in HrecB.
simpl in |- *.
intro.
elim H.
intro.
cut (a = x /\ a <> x).
intro.
auto.

split.
auto.

auto.

auto.

Qed.

Lemma set_In_dec : forall (a : A) (x : set), {set_In a x} + {~ set_In a x}.

unfold set_In in |- *.
simple induction x.
auto.

intros.
cut ({a = a0} + {a <> a0}).
intro Eq_dec; elim Eq_dec.
intro Eq; rewrite Eq; left; auto with datatypes.

elim H.
auto with datatypes.

unfold not in |- *; intros; right; intro.
elim H0; auto.

auto.

Qed.

  Lemma set_mem_ind :
   forall (B : Set) (P : B -> Prop) (y z : B) (a : A) (x : set),
   (set_In a x -> P y) -> P z -> P (if set_mem a x then y else z).

  Proof.
    simple induction x; simpl in |- *; intros.
    assumption.
    elim (Aeq_dec a a0); auto with datatypes.
  Qed.

  Lemma set_mem_correct1 :
   forall (a : A) (x : set), set_mem a x = true -> set_In a x.
  Proof.
    simple induction x; simpl in |- *.
    discriminate.
    intros a0 l; elim (Aeq_dec a a0); auto with datatypes.
  Qed.

  Lemma set_mem_correct2 :
   forall (a : A) (x : set), set_In a x -> set_mem a x = true.
  Proof.
    simple induction x; simpl in |- *.
    intro Ha; elim Ha.
    intros a0 l; elim (Aeq_dec a a0); auto with datatypes.
    intros H1 H2 [H3| H4].
    absurd (a0 = a); auto with datatypes.
    auto with datatypes.
  Qed.

  Lemma set_mem_complete1 :
   forall (a : A) (x : set), set_mem a x = false -> ~ set_In a x.
  Proof.
    simple induction x; simpl in |- *.
    tauto.
    intros a0 l; elim (Aeq_dec a a0).
    intros; discriminate H0.
    unfold not in |- *; intros; elim H1; auto with datatypes.
  Qed.

  Lemma set_mem_complete2 :
   forall (a : A) (x : set), ~ set_In a x -> set_mem a x = false.
  Proof.
    simple induction x; simpl in |- *.
    tauto.
    intros a0 l; elim (Aeq_dec a a0).
    intros; elim H0; auto with datatypes.
    tauto.
  Qed.

  Lemma set_add_intro1 :
   forall (a b : A) (x : set), set_In a x -> set_In a (set_add b x).

  Proof.
    unfold set_In in |- *; simple induction x; simpl in |- *.
    auto with datatypes.
    intros a0 l H [Ha0a| Hal].
    elim (Aeq_dec b a0); left; assumption.
    elim (Aeq_dec b a0); right; [ assumption | auto with datatypes ].
  Qed.

  Lemma set_add_intro2 :
   forall (a b : A) (x : set), a = b -> set_In a (set_add b x).

  Proof.
    unfold set_In in |- *; simple induction x; simpl in |- *.
    auto with datatypes.
    intros a0 l H Hab.
    elim (Aeq_dec b a0);
     [ rewrite Hab; intro Hba0; rewrite Hba0; simpl in |- *;
        auto with datatypes
     | auto with datatypes ].
  Qed.

  Hint Resolve set_add_intro1 set_add_intro2 Set_remove1.

  Lemma set_add_intro :
   forall (a b : A) (x : set), a = b \/ set_In a x -> set_In a (set_add b x).

  Proof.
    intros a b x [H1| H2]; auto with datatypes.
  Qed.

  Lemma set_add_elim :
   forall (a b : A) (x : set), set_In a (set_add b x) -> a = b \/ set_In a x.

  Proof.
    unfold set_In in |- *.
    simple induction x.
    simpl in |- *; intros [H1| H2]; auto with datatypes.
    simpl in |- *; do 3 intro.
    elim (Aeq_dec b a0).
    tauto.
    simpl in |- *; intros; elim H0.
    trivial with datatypes.
    tauto.
    tauto.
  Qed.

  Hint Resolve set_add_intro set_add_elim.

  Lemma set_add_not_empty :
   forall (a : A) (x : set), set_add a x <> empty_set.
  Proof.
    simple induction x; simpl in |- *.
    discriminate.
    intros; elim (Aeq_dec a a0); intros; discriminate.
  Qed.

  Lemma set_union_intro1 :
   forall (a : A) (x y : set), set_In a x -> set_In a (set_union x y).
  Proof.
    simple induction y; simpl in |- *; auto with datatypes.
  Qed.

  Lemma set_union_intro2 :
   forall (a : A) (x y : set), set_In a y -> set_In a (set_union x y).
  Proof.
    simple induction y; simpl in |- *.
    tauto.
    intros; elim H0; auto with datatypes.
  Qed.

  Hint Resolve set_union_intro2 set_union_intro1.

  Lemma set_union_intro :
   forall (a : A) (x y : set),
   set_In a x \/ set_In a y -> set_In a (set_union x y).
  Proof.
    intros; elim H; auto with datatypes.
  Qed.

  Lemma set_union_elim :
   forall (a : A) (x y : set),
   set_In a (set_union x y) -> set_In a x \/ set_In a y.
  Proof.
    simple induction y; simpl in |- *.
    auto with datatypes.
    intros.
    generalize (set_add_elim H0).
    intros [H1| H1].
    auto with datatypes.
    tauto.
  Qed.

  Lemma set_inter_intro :
   forall (a : A) (x y : set),
   set_In a x -> set_In a y -> set_In a (set_inter x y).
  Proof.
    simple induction x.
    auto with datatypes.
    simpl in |- *; intros a0 l Hrec y [Ha0a| Hal] Hy.
    simpl in |- *; rewrite Ha0a.
    generalize (set_mem_correct1 (a:=a) (x:=y)).
    generalize (set_mem_complete1 (a:=a) (x:=y)).
    elim (set_mem a y); simpl in |- *; intros.
    auto with datatypes.
    absurd (set_In a y); auto with datatypes.
    elim (set_mem a0 y); [ right; auto with datatypes | auto with datatypes ].
  Qed.

  Lemma set_inter_elim1 :
   forall (a : A) (x y : set), set_In a (set_inter x y) -> set_In a x.
  Proof.
    simple induction x.
    auto with datatypes.
    simpl in |- *; intros a0 l Hrec y.
    generalize (set_mem_correct1 (a:=a0) (x:=y)).
    elim (set_mem a0 y); simpl in |- *; intros.
    elim H0; eauto with datatypes.
    eauto with datatypes.
  Qed.

  Lemma set_inter_elim2 :
   forall (a : A) (x y : set), set_In a (set_inter x y) -> set_In a y.
  Proof.
    simple induction x.
    unfold set_In, set_inter in |- *; unfold In in |- *; tauto.
    simpl in |- *; intros a0 l Hrec y.
    generalize (set_mem_correct1 (a:=a0) (x:=y)).
    elim (set_mem a0 y); simpl in |- *; intros.
    elim H0;
     [ intro Hr; rewrite <- Hr; eauto with datatypes | eauto with datatypes ].
    eauto with datatypes.
  Qed.

  Hint Resolve set_inter_elim1 set_inter_elim2.

  Lemma set_inter_elim :
   forall (a : A) (x y : set),
   set_In a (set_inter x y) -> set_In a x /\ set_In a y.
  Proof.
    eauto with datatypes.
  Qed.

  Lemma set_diff_intro :
   forall (a : A) (x y : set),
   set_In a x -> ~ set_In a y -> set_In a (set_diff x y).
  Proof.
    simple induction x.
    tauto.
    simpl in |- *; intros a0 l Hrec y [Ha0a| Hal] Hay.
    rewrite Ha0a; generalize (set_mem_complete2 Hay).
    elim (set_mem a y);
     [ intro Habs; discriminate Habs | auto with datatypes ].
    elim (set_mem a0 y); auto with datatypes.
  Qed.

  Lemma set_diff_elim1 :
   forall (a : A) (x y : set), set_In a (set_diff x y) -> set_In a x.
  Proof.
    simple induction x.
    tauto.
    simpl in |- *; intros a0 l Hrec y; elim (set_mem a0 y).
    eauto with datatypes.
    intro; generalize (set_add_elim H).
    intros [H1| H2]; eauto with datatypes.
  Qed.

End first_definitions.

Section other_definitions.

  Variable A B : Set.

  Definition set_prod : set A -> set B -> set (A * B) :=
    list_prod (A:=A) (B:=B).

  (* B^A, set of applications from A to B *)
  Definition set_power : set A -> set B -> set (set (A * B)) :=
    list_power (A:=A) (B:=B).

  Definition set_map : (A -> B) -> set A -> set B := map (A:=A) (B:=B).

  Definition set_fold_left : (B -> A -> B) -> set A -> B -> B :=
    fold_left (A:=B) (B:=A).

  Definition set_fold_right (f : A -> B -> B) (x : set A)
    (b : B) : B := fold_right f b x.

End other_definitions.

Set Strict Implicit.
Unset Implicit Arguments.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Supplementary Coq material: subset types
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/
  * Much of the material comes from CPDT <http://adam.chlipala.net/cpdt/> by the same author. *)

Require Import FrapWithoutSets.
(* We import a pared-down version of the book library, to avoid notations that
 * clash with some we want to use here. *)

Set Implicit Arguments.
Set Asymmetric Patterns.

(** * Introducing Subset Types *)

Definition pred (n : nat) : nat :=
  match n with
  | O => O
  | S n' => n'
  end.

Extraction pred.

(** * Decidable Proposition Types *)

Print sumbool.

Notation "'Yes'" := (left _ _).
Notation "'No'" := (right _ _).
Notation "'Reduce' x" := (if x then Yes else No) (at level 50).

Definition eq_nat_dec : forall n m : nat, {n = m} + {n <> m}.
Admitted.

Compute eq_nat_dec 2 2.
Compute eq_nat_dec 2 3.

Extraction eq_nat_dec.

Section In_dec.
  Variable A : Set.
  Variable A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  (* The final function is easy to write using the techniques we have developed
   * so far. *)

  Definition In_dec : forall (x : A) (ls : list A), {In x ls} + {~ In x ls}.
  Admitted.
End In_dec.

Compute In_dec eq_nat_dec 2 (1 :: 2 :: nil).
Compute In_dec eq_nat_dec 3 (1 :: 2 :: nil).

Extraction In_dec.

(** * Partial Subset Types *)

Inductive maybe (A : Set) (P : A -> Prop) : Set :=
| Unknown : maybe P
| Found : forall x : A, P x -> maybe P.

Notation "{{ x | P }}" := (maybe (fun x => P)).
Notation "??" := (Unknown _).
Notation "[| x |]" := (Found _ x _).

Print sumor.

Notation "!!" := (inright _ _).
Notation "[|| x ||]" := (inleft _ [x]).

(** * Monadic Notations *)

Notation "x <- e1 ; e2" := (match e1 with
                            | Unknown => ??
                            | Found x _ => e2
                           end)
(right associativity, at level 60).

Definition doublePred : forall n1 n2 : nat, {{p | n1 = S (fst p) /\ n2 = S (snd p)}}.
Admitted.

Notation "x <-- e1 ; e2" := (match e1 with
                             | inright _ => !!
                             | inleft (exist x _) => e2
                             end)
(right associativity, at level 60).

Definition doublePred' : forall n1 n2 : nat,
  {p : nat * nat | n1 = S (fst p) /\ n2 = S (snd p)}.
Admitted.

(** * A Type-Checking Example *)

Inductive exp :=
| Nat (n : nat)
| Plus (e1 e2 : exp)
| Bool (b : bool)
| And (e1 e2 : exp).

Inductive type := TNat | TBool.

Inductive hasType : exp -> type -> Prop :=
| HtNat : forall n,
  hasType (Nat n) TNat
| HtPlus : forall e1 e2,
  hasType e1 TNat
  -> hasType e2 TNat
  -> hasType (Plus e1 e2) TNat
| HtBool : forall b,
  hasType (Bool b) TBool
| HtAnd : forall e1 e2,
  hasType e1 TBool
  -> hasType e2 TBool
  -> hasType (And e1 e2) TBool.

Definition typeCheck : forall e : exp, {{t | hasType e t}}.
Admitted.

Compute typeCheck (Nat 0).
Compute typeCheck (Plus (Nat 1) (Nat 2)).
Compute typeCheck (Plus (Nat 1) (Bool false)).

Extraction typeCheck.