Require SQIR.UnitaryOps.
Require SQIR.DensitySem.
Require SQIR.NDSem.

(** Unitary Teleportation Circuit and Proof **)
Module UTeleport.

Import UnitaryOps.

Open Scope ucom.

(* a = alice; b = bob; q = qubit to be teleported *)
Definition bell {n} (a b : nat) : base_ucom n := H a ; CNOT a b.
Definition alice {n} (q a : nat) : base_ucom n := CNOT q a ; H q.
Definition bob {n} (q a b: nat) : base_ucom n := CNOT a b; CZ q b.
Definition teleport {n} (q a b : nat) : base_ucom n := alice q a; bob q a b.

Definition epr00 : Vector 4 :=
  fun x y => match x, y with
             | 0, 0 => 1/√2
             | 3, 0 => 1/√2
             | _, _ => 0
             end.

Lemma epr_correct :
  forall (ψ : Vector 2), WF_Matrix ψ -> (@uc_eval 3 (bell 1 2)) × (ψ ⊗ ∣0⟩ ⊗ ∣0⟩) = ψ ⊗ epr00.
Proof.
  intros.
  unfold bell.
  simpl; autorewrite with eval_db; simpl.
  solve_matrix.
Qed.

Lemma teleport_correct : forall (ψ : Vector 2),
    WF_Matrix ψ -> @uc_eval 3 (teleport 0 1 2) × (ψ ⊗ epr00) = (∣ + ⟩ ⊗ ∣ + ⟩ ⊗ ψ).
Proof.
  intros.
  unfold teleport. simpl.
  autorewrite with eval_db. simpl.
  solve_matrix.
  all: repeat (try rewrite Cmult_plus_distr_l;
               try rewrite Cmult_plus_distr_r;
               try rewrite <- Copp_mult_distr_r;
               try rewrite <- Copp_mult_distr_l).
  all: group_radicals.
  all: lca.
Qed.

End UTeleport.

(** Non-unitary teleport, proof with density matrices **)
Module DensityTeleport.

Import DensitySem.

Local Open Scope com.

Definition q : nat := 0. (* qubit for transmission *)
Definition a : nat := 1. (* alice's qubit *)
Definition b : nat := 2. (* bob's qubit *)

Definition bell : base_com 3 := H a ; CNOT a b.
Definition alice : base_com 3 := CNOT q a ; H q; measure a; measure q.
Definition bob : base_com 3 := CNOT a b; CZ q b; reset a; reset q.
Definition teleport : base_com 3 := bell; alice; bob.

(* Short proof, but very very slow.

Lemma teleport_correct : forall (ρ : Density 2),
  WF_Matrix ρ ->
  c_eval teleport (ρ ⊗ ∣0⟩⟨0∣ ⊗ ∣0⟩⟨0∣) = (∣0⟩⟨0∣ ⊗ ∣0⟩⟨0∣ ⊗ ρ).
Proof.
  intros.
  simpl.
  repeat rewrite compose_super_eq.
  unfold compose_super.
  autorewrite with eval_db; simpl.
  Msimpl_light.
  unfold Splus, super.
  Msimpl.
  solve_matrix. (* very slow! *)
  all: group_radicals; lca.
Qed. *)

Lemma combine_super : forall {n} (A B : Square n) ρ,
  super A (super B ρ) = super (A × B) ρ.
Proof.
  intros.
  unfold super.
  rewrite Mmult_adjoint.
  repeat rewrite Mmult_assoc.
  reflexivity.
Qed.

Lemma super_add : forall {n} (A B C : Square n) ρ,
  super A (super B ρ .+ super C ρ) = super (A × B) ρ .+ super (A × C) ρ.
Proof.
  intros.
  unfold super.
  repeat rewrite Mmult_adjoint.
  distribute_plus.
  repeat rewrite Mmult_assoc.
  reflexivity.
Qed.

Lemma teleport_correct : forall (ρ : Density 2),
  WF_Matrix ρ ->
  c_eval teleport (ρ ⊗ ∣0⟩⟨0∣ ⊗ ∣0⟩⟨0∣) = (∣0⟩⟨0∣ ⊗ ∣0⟩⟨0∣ ⊗ ρ).
Proof.
  intros.
  simpl.
  repeat rewrite compose_super_eq.
  repeat rewrite compose_super_assoc.
  rewrite compose_super_eq.
  unfold compose_super.
  unfold proj.
  autorewrite with eval_db; simpl.
  Msimpl_light.
  replace (I 4) with (I 2 ⊗ I 2).
  2: { rewrite id_kron. reflexivity. }
  repeat (distribute_plus;
          repeat rewrite <- kron_assoc by auto with wf_db;
          restore_dims).
  repeat rewrite kron_mixed_product.
  repeat rewrite <- (Mmult_assoc _ _ hadamard).
  Qsimpl.
  replace (hadamard × σx × hadamard) with σz by solve_matrix.
  unfold Splus.
  repeat rewrite combine_super.
  restore_dims.
  distribute_plus.
  repeat rewrite kron_mixed_product.
  repeat rewrite <- (Mmult_assoc _ _ hadamard).
  Qsimpl.
  repeat (try rewrite super_add; try rewrite combine_super).
  repeat (distribute_plus;
          repeat rewrite <- kron_assoc by auto with wf_db;
          restore_dims).
  repeat rewrite kron_mixed_product.
  repeat rewrite <- (Mmult_assoc _ _ hadamard).
  Qsimpl.
  unfold super; Msimpl_light.
  (* Tired of manually simplifying; solve_matrix should be reasonable now. *)
  solve_matrix.
Qed.

End DensityTeleport.

(** Non-unitary teleport, proof with non-deterministic semantics **)
Module NDTeleport.

Import UnitaryOps.
Import NDSem.
Import Proportional.

Local Open Scope com.

Definition q : nat := 0. (* qubit for transmission *)
Definition a : nat := 1. (* alice's qubit *)
Definition b : nat := 2. (* bob's qubit *)

Definition bell : base_com 3 := H a ; CNOT a b.
Definition alice : base_com 3 := CNOT q a ; H q; measure a; measure q.
Definition bob : base_com 3 := CNOT a b; CZ q b; reset a; reset q.
Definition teleport : base_com 3 := bell; alice; bob.

Local Open Scope R_scope.
Local Open Scope C_scope.

Definition epr00 : Vector 4 := / √ 2 .* ∣ 0, 0 ⟩ .+ / √ 2 .* ∣ 1, 1 ⟩.

(* Alternative form of proportional for unscaled vectors. *)
Definition proportional {m n : nat} (A B : Matrix m n) :=
  exists s, A = s .* B.

Lemma teleport_correct : forall (ψ : Vector (2^1)) (ψ' : Vector (2^3)),
  WF_Matrix ψ ->
  teleport / (ψ  ⊗ ∣ 0 , 0 ⟩) ⇩ ψ' -> proportional ψ' (∣ 0 , 0 ⟩ ⊗ ψ).
Proof.
  intros ψ ψ' WF S.
  dependent destruction S.
  dependent destruction S1.
  rename S1_1 into Bell.
  rename S1_2 into Alice.
  rename S2 into Bob.
  (* compute the result of the bell program *)
  assert (E00 : ψ' = ψ ⊗ epr00).
  { clear Alice Bob.
    repeat match goal with
    | H : _ / _ ⇩ _ |- _ => dependent destruction H
    end.
    autorewrite with eval_db; simpl.
    Msimpl.
    setoid_rewrite cnot_decomposition.
    restore_dims.
    rewrite kron_assoc by auto with wf_db.
    restore_dims.
    rewrite kron_mixed_product.
    Msimpl.
    autorewrite with ket_db.
    unfold epr00.
    autorewrite with ket_db.
    reflexivity.
  }
  subst. clear Bell.
  (* simplify the unitary part of the Alice program *)
  repeat match goal with
  | H : (_ ; _) / _ ⇩ _ |- _ => dependent destruction H
  end.
  dependent destruction Alice1_1_1.
  dependent destruction Alice1_1_2.
  dependent destruction Bob1_1_1.
  dependent destruction Bob1_1_2.
  evar (ψA : Vector (2^3)).
  assert (EA : uc_eval (H q) × (uc_eval (CNOT q a) × (ψ ⊗ epr00)) = ψA).
  { clear Alice1_2 Alice2 Bob1_2 Bob2.
    autorewrite with eval_db; simpl.
    Msimpl.
    unfold epr00.
    replace 4%nat with (2 * 2)%nat by reflexivity.
    rewrite <- id_kron.
    repeat rewrite <- kron_assoc by auto with wf_db.
    restore_dims.
    rewrite cnot_decomposition.
    autorewrite with Q_db ket_db.
    repeat rewrite <- kron_assoc by auto with wf_db.
    restore_dims.
    repeat rewrite kron_mixed_product.
    Msimpl.
    rewrite (ket_decomposition ψ) by auto.
    autorewrite with Q_db ket_db.
    Qsimpl.
    autorewrite with Q_db ket_db.
    rewrite <- Copp_mult_distr_r.
    group_radicals.
    subst ψA.
    reflexivity.
  }
  subst ψA. rewrite EA in Alice1_2. clear EA.
  (* now destruct measurements to get four cases: a ∈ {0,1}, q ∈ {0,1} *)
  dependent destruction Alice1_2.
  - (* measured a = 1 *)
    evar (ψ'pad : Vector (2^3)).
    assert(Epad : ψ' = ψ'pad).
    { subst ψ'.
      unfold proj, pad_u, pad; simpl.
      repeat rewrite Mmult_plus_distr_l.
      repeat rewrite Mscale_mult_dist_r.
      restore_dims.
      repeat rewrite kron_mixed_product.
      replace (∣1⟩⟨1∣ × ∣ 1 ⟩) with (∣ 1 ⟩) by solve_matrix.
      replace (∣1⟩⟨1∣ × ∣ 0 ⟩) with (@Zero 2 1) by solve_matrix.
      Msimpl_light.
      subst ψ'pad.
      reflexivity.
    }
    subst ψ'pad. rewrite Epad in Alice1_2. clear H Epad ψ'.
    dependent destruction Alice1_2.
    dependent destruction Alice2.
    + (* measured q = 1 *)
      evar (ψ'pad : Vector (2^3)).
      assert(Epad : ψ' = ψ'pad).
      { subst ψ'.
        unfold proj, pad_u, pad; simpl.
        replace 4%nat with (2 * 2)%nat by reflexivity.
        rewrite <- id_kron.
        repeat rewrite <- kron_assoc by auto with wf_db.
        Msimpl_light.
        restore_dims.
        repeat rewrite Mmult_plus_distr_l.
        repeat rewrite Mscale_mult_dist_r.
        restore_dims.
        repeat rewrite kron_mixed_product.
        replace (∣1⟩⟨1∣ × ∣ 1 ⟩) with (∣ 1 ⟩) by solve_matrix.
        replace (∣1⟩⟨1∣ × ∣ 0 ⟩) with (@Zero 2 1) by solve_matrix.
        Msimpl_light.
        subst ψ'pad.
        reflexivity.
      }
      subst ψ'pad. rewrite Epad in Alice2. clear H Epad ψ'.
      evar (ψBob : Vector (2^3)).
      assert(EBob : uc_eval (CZ 0 b) × (uc_eval (CNOT 1 b) × ψ'') = ψBob).
      { simpl; autorewrite with eval_db; simpl.
        replace 4%nat with (2 * 2)%nat by reflexivity.
        rewrite <- id_kron.
        Msimpl_light.
        restore_dims.
        distribute_plus.
        repeat rewrite <- kron_assoc by auto with wf_db.
        restore_dims.
        repeat rewrite kron_mixed_product; Msimpl_light.
        distribute_plus.
        repeat rewrite <- Mmult_assoc.
        repeat rewrite kron_mixed_product; Qsimpl.
        replace (hadamard × σx × hadamard) with σz by solve_matrix.
        subst ψBob.
        reflexivity.
      }
      subst ψBob. rewrite EBob in Bob1_2. clear EBob.
      repeat match goal with
      | H : _ / _ ⇩ _ |- _ => dependent destruction H
      end.
      all: unfold proj; simpl; autorewrite with eval_db; simpl.
      all: replace 4%nat with (2 * 2)%nat by reflexivity;
           rewrite <- id_kron;
           repeat rewrite <- kron_assoc by auto with wf_db;
           Msimpl_light;
           restore_dims.
      all: repeat rewrite <- Mmult_assoc;
           repeat rewrite kron_mixed_product;
           Qsimpl.
      all: distribute_plus; distribute_scale.
      all: repeat rewrite kron_mixed_product.
      all: Qsimpl.
      all: replace (∣1⟩⟨1∣ × ∣ 1 ⟩) with (∣ 1 ⟩) by solve_matrix;
           replace (∣0⟩⟨0∣ × ∣ 1 ⟩) with (@Zero 2 1) by solve_matrix;
           Qsimpl.
      (* last 3 cases are Zero because values measured by Bob are pre-determined *)
      2,3,4: exists 0; solve_matrix. (* or show that the norm ≠ 0 condition is violated *)
      replace (∣0⟩⟨1∣ × ∣ 1 ⟩) with (∣ 0 ⟩) by solve_matrix.
      rewrite (ket_decomposition ψ WF).
      exists (/ 2).
      solve_matrix.
    + (* measured q = 0 *)
      evar (ψ'pad : Vector (2^3)).
      assert(Epad : ψ' = ψ'pad).
      { subst ψ'.
        unfold proj, pad_u, pad; simpl.
        replace 4%nat with (2 * 2)%nat by reflexivity.
        rewrite <- id_kron.
        repeat rewrite <- kron_assoc by auto with wf_db.
        Msimpl_light.
        restore_dims.
        repeat rewrite Mmult_plus_distr_l.
        repeat rewrite Mscale_mult_dist_r.
        restore_dims.
        repeat rewrite kron_mixed_product.
        replace (∣0⟩⟨0∣ × ∣ 0 ⟩) with (∣ 0 ⟩) by solve_matrix.
        replace (∣0⟩⟨0∣ × ∣ 1 ⟩) with (@Zero 2 1) by solve_matrix.
        Msimpl_light.
        subst ψ'pad.
        reflexivity.
      }
      subst ψ'pad. rewrite Epad in Alice2. clear H Epad ψ'.
      evar (ψBob : Vector (2^3)).
      assert(EBob : uc_eval (CZ 0 b) × (uc_eval (CNOT 1 b) × ψ'') = ψBob).
      { simpl; autorewrite with eval_db; simpl.
        replace 4%nat with (2 * 2)%nat by reflexivity.
        rewrite <- id_kron.
        Msimpl_light.
        restore_dims.
        distribute_plus.
        repeat rewrite <- kron_assoc by auto with wf_db.
        restore_dims.
        repeat rewrite kron_mixed_product; Msimpl_light.
        distribute_plus.
        repeat rewrite <- Mmult_assoc.
        repeat rewrite kron_mixed_product; Qsimpl.
        replace (hadamard × σx × hadamard) with σz by solve_matrix.
        subst ψBob.
        reflexivity.
      }
      subst ψBob. rewrite EBob in Bob1_2. clear EBob.
      repeat match goal with
      | H : _ / _ ⇩ _ |- _ => dependent destruction H
      end.
      all: unfold proj; simpl; autorewrite with eval_db; simpl.
      all: replace 4%nat with (2 * 2)%nat by reflexivity;
           rewrite <- id_kron;
           repeat rewrite <- kron_assoc by auto with wf_db;
           Msimpl_light;
           restore_dims.
      all: repeat rewrite <- Mmult_assoc;
           repeat rewrite kron_mixed_product;
           Qsimpl.
      all: distribute_plus; distribute_scale.
      all: repeat rewrite kron_mixed_product.
      all: Qsimpl.
      all: replace (∣1⟩⟨1∣ × ∣ 1 ⟩) with (∣ 1 ⟩) by solve_matrix;
           replace (∣0⟩⟨0∣ × ∣ 1 ⟩) with (@Zero 2 1) by solve_matrix;
           Qsimpl.
      all: replace (∣0⟩⟨0∣ × ∣ 0 ⟩) with (∣ 0 ⟩) by solve_matrix;
           replace (∣1⟩⟨1∣ × ∣ 0 ⟩) with (@Zero 2 1) by solve_matrix;
           Qsimpl.
      all: replace (∣0⟩⟨0∣ × ∣ 0 ⟩) with (∣ 0 ⟩) by solve_matrix;
           replace (∣0⟩⟨1∣ × ∣ 0 ⟩) with (@Zero 2 1) by solve_matrix;
           Qsimpl.
      1,2,4: exists 0; solve_matrix.
      rewrite (ket_decomposition ψ WF).
      exists (/ 2).
      solve_matrix.
  - (* measured a = 0 *)
    evar (ψ'pad : Vector (2^3)).
    assert(Epad : ψ' = ψ'pad).
    { subst ψ'.
      unfold proj, pad_u, pad; simpl.
      repeat rewrite Mmult_plus_distr_l.
      repeat rewrite Mscale_mult_dist_r.
      restore_dims.
      repeat rewrite kron_mixed_product.
      replace (∣0⟩⟨0∣ × ∣ 0 ⟩) with (∣ 0 ⟩) by solve_matrix.
      replace (∣0⟩⟨0∣ × ∣ 1 ⟩) with (@Zero 2 1) by solve_matrix.
      Msimpl_light.
      subst ψ'pad.
      reflexivity.
    }
    subst ψ'pad. rewrite Epad in Alice1_2. clear H Epad ψ'.
    dependent destruction Alice1_2.
    dependent destruction Alice2.
    + (* measured q = 1 *)
      evar (ψ'pad : Vector (2^3)).
      assert(Epad : ψ' = ψ'pad).
      { subst ψ'.
        unfold proj, pad_u, pad; simpl.
        replace 4%nat with (2 * 2)%nat by reflexivity.
        rewrite <- id_kron.
        repeat rewrite <- kron_assoc by auto with wf_db.
        Msimpl_light.
        restore_dims.
        repeat rewrite Mmult_plus_distr_l.
        repeat rewrite Mscale_mult_dist_r.
        restore_dims.
        repeat rewrite kron_mixed_product.
        replace (∣1⟩⟨1∣ × ∣ 1 ⟩) with (∣ 1 ⟩) by solve_matrix.
        replace (∣1⟩⟨1∣ × ∣ 0 ⟩) with (@Zero 2 1) by solve_matrix.
        Msimpl_light.
        subst ψ'pad.
        reflexivity.
      }
      subst ψ'pad. rewrite Epad in Alice2. clear H Epad ψ'.
      evar (ψBob : Vector (2^3)).
      assert(EBob : uc_eval (CZ 0 b) × (uc_eval (CNOT 1 b) × ψ'') = ψBob).
      { simpl; autorewrite with eval_db; simpl.
        replace 4%nat with (2 * 2)%nat by reflexivity.
        rewrite <- id_kron.
        Msimpl_light.
        restore_dims.
        distribute_plus.
        repeat rewrite <- kron_assoc by auto with wf_db.
        restore_dims.
        repeat rewrite kron_mixed_product; Msimpl_light.
        distribute_plus.
        repeat rewrite <- Mmult_assoc.
        repeat rewrite kron_mixed_product; Qsimpl.
        replace (hadamard × σx × hadamard) with σz by solve_matrix.
        subst ψBob.
        reflexivity.
      }
      subst ψBob. rewrite EBob in Bob1_2. clear EBob.
      repeat match goal with
      | H : _ / _ ⇩ _ |- _ => dependent destruction H
      end.
      all: unfold proj; simpl; autorewrite with eval_db; simpl.
      all: replace 4%nat with (2 * 2)%nat by reflexivity;
           rewrite <- id_kron;
           repeat rewrite <- kron_assoc by auto with wf_db;
           Msimpl_light;
           restore_dims.
      all: repeat rewrite <- Mmult_assoc;
           repeat rewrite kron_mixed_product;
           Qsimpl.
      all: distribute_plus; distribute_scale.
      all: repeat rewrite kron_mixed_product.
      all: Qsimpl.
      all: replace (∣0⟩⟨0∣ × ∣ 0 ⟩) with (∣ 0 ⟩) by solve_matrix;
           replace (∣1⟩⟨1∣ × ∣ 0 ⟩) with (@Zero 2 1) by solve_matrix;
           Qsimpl.
      all: replace (∣0⟩⟨0∣ × ∣ 0 ⟩) with (∣ 0 ⟩) by solve_matrix;
           replace (∣1⟩⟨1∣ × ∣ 1 ⟩) with (∣ 1 ⟩) by solve_matrix;
           replace (∣0⟩⟨1∣ × ∣ 0 ⟩) with (@Zero 2 1) by solve_matrix;
           replace (∣0⟩⟨0∣ × ∣ 1 ⟩) with (@Zero 2 1) by solve_matrix;
           Qsimpl.
      1,3,4: exists 0; solve_matrix.
      replace (∣0⟩⟨1∣ × ∣ 1 ⟩) with (∣ 0 ⟩) by solve_matrix.
      replace (σz × ∣ 0 ⟩) with (∣ 0 ⟩) by solve_matrix.
      replace (σz × ∣ 1 ⟩) with (- 1 .* ∣ 1 ⟩) by solve_matrix.
      rewrite (ket_decomposition ψ WF).
      exists (/ 2).
      solve_matrix.
    + (* measured q = 0 *)
      evar (ψ'pad : Vector (2^3)).
      assert(Epad : ψ' = ψ'pad).
      { subst ψ'.
        unfold proj, pad_u, pad; simpl.
        replace 4%nat with (2 * 2)%nat by reflexivity.
        rewrite <- id_kron.
        repeat rewrite <- kron_assoc by auto with wf_db.
        Msimpl_light.
        restore_dims.
        repeat rewrite Mmult_plus_distr_l.
        repeat rewrite Mscale_mult_dist_r.
        restore_dims.
        repeat rewrite kron_mixed_product.
        replace (∣0⟩⟨0∣ × ∣ 0 ⟩) with (∣ 0 ⟩) by solve_matrix.
        replace (∣0⟩⟨0∣ × ∣ 1 ⟩) with (@Zero 2 1) by solve_matrix.
        Msimpl_light.
        subst ψ'pad.
        reflexivity.
      }
      subst ψ'pad. rewrite Epad in Alice2. clear H Epad ψ'.
      evar (ψBob : Vector (2^3)).
      assert(EBob : uc_eval (CZ 0 b) × (uc_eval (CNOT 1 b) × ψ'') = ψBob).
      { simpl; autorewrite with eval_db; simpl.
        replace 4%nat with (2 * 2)%nat by reflexivity.
        rewrite <- id_kron.
        Msimpl_light.
        restore_dims.
        distribute_plus.
        repeat rewrite <- kron_assoc by auto with wf_db.
        restore_dims.
        repeat rewrite kron_mixed_product; Msimpl_light.
        distribute_plus.
        repeat rewrite <- Mmult_assoc.
        repeat rewrite kron_mixed_product; Qsimpl.
        replace (hadamard × σx × hadamard) with σz by solve_matrix.
        subst ψBob.
        reflexivity.
      }
      subst ψBob. rewrite EBob in Bob1_2. clear EBob.
      repeat match goal with
      | H : _ / _ ⇩ _ |- _ => dependent destruction H
      end.
      all: unfold proj; simpl; autorewrite with eval_db; simpl.
      all: replace 4%nat with (2 * 2)%nat by reflexivity;
           rewrite <- id_kron;
           repeat rewrite <- kron_assoc by auto with wf_db;
           Msimpl_light;
           restore_dims.
      all: repeat rewrite <- Mmult_assoc;
           repeat rewrite kron_mixed_product;
           Qsimpl.
      all: distribute_plus; distribute_scale.
      all: repeat rewrite kron_mixed_product.
      all: Qsimpl.
      all: replace (∣0⟩⟨0∣ × ∣ 0 ⟩) with (∣ 0 ⟩) by solve_matrix;
           replace (∣1⟩⟨1∣ × ∣ 0 ⟩) with (@Zero 2 1) by solve_matrix;
           Qsimpl.
      all: replace (∣0⟩⟨0∣ × ∣ 0 ⟩) with (∣ 0 ⟩) by solve_matrix;
           replace (∣0⟩⟨1∣ × ∣ 0 ⟩) with (@Zero 2 1) by solve_matrix;
           Qsimpl.
      1,2,3: exists 0; solve_matrix.
      rewrite (ket_decomposition ψ WF).
      exists (/ 2).
      solve_matrix.
Qed.

End NDTeleport.


Definition NatE : forall (p:nat -> Prop),
    p 0 -> (forall (n:nat), p n -> p (S n)) -> forall (n:nat), p n :=
        fun (p:nat -> Prop) (H0:p 0) (IH:forall(m:nat),p m -> p (S m)) =>
            fix f (n:nat):p n :=
                match n with
                | 0     => H0
                | S m   => IH m (f m)
                end.

Definition NatRec : forall (c:nat -> Type),
    c 0 -> (forall (n:nat), c n -> c (S n)) -> forall (n:nat), c n :=
        fun (c:nat -> Type) (H0:c 0) (IH:forall(m:nat),c m -> c (S m)) =>
            fix f(n:nat):c n :=
                match n with
                | 0     => H0
                | S m   => IH m (f m)
                end.

Lemma NatRec0 : forall (c:nat -> Type) (a:c 0) (s:forall (n:nat), c n -> c (S n)),
    NatRec c a s 0 = a.
Proof. intros c a s. reflexivity. Qed.

Lemma NatRecn : forall (c:nat -> Type) (a:c 0) (s:forall (n:nat), c n -> c (S n)),
    forall (n:nat), NatRec c a s (S n) = s n (NatRec c a s n).
Proof. intros c a s n. reflexivity. Qed.

Definition F1 : nat -> nat := NatRec (fun _ => nat) 0 (fun _ n => S (S n)).
Definition F2 : nat -> nat := fix f (n:nat) : nat :=
    match n with
    | 0     => 0
    | S n   => S (S (f n))
    end.

Definition F3 : F1 = F2.
Proof. reflexivity. Qed.

Definition F4 : nat -> nat -> nat := fun (n:nat) => NatRec (fun _ => nat) n (fun _ => S).
Definition F5 : nat -> nat -> nat := fun (n:nat) => fix f(m:nat):nat :=
    match m with
    | 0     => n
    | S m   => S (f m)
    end.

Definition F6 : F4 = F5.
Proof. reflexivity. Qed.

Fixpoint sub (m n:nat) : nat :=
    match m with
    | 0     => 0
    | S m   =>
        match n with
        | 0     => S m
        | S n   => sub m n
        end
    end.

Definition F7 : nat -> nat -> nat.
Proof.
refine( NatRec (fun _ => nat -> nat)
    (fun _ => 0)
    (fun (m:nat) (f:nat -> nat) => NatRec (fun _ => nat)
        (S m)
        (fun n _ => f n)
)).
Defined.

Definition subst (a:Type) (p:a -> Prop) (x y:a) : x = y -> p x -> p y :=
    fun (e:x = y) (px:p x) =>
        match e with
        | eq_refl _ => px
        end.

Definition cong (a b:Type) (f:a -> b) (x y:a) : x = y -> f x = f y :=
    fun (e:x = y) =>
        subst a (fun (z:a) => f x = f z) x y e (eq_refl (f x)).

Definition L1 : forall (n:nat), n + 0 = n.
Proof.
refine ( fun(n:nat) =>
    NatE (fun (n:nat) => n + 0 = n)
    (eq_refl 0)
    (fun (m:nat) (H:m + 0 = m) => cong nat nat S (m + 0) m H)
    n
).
Qed.

Definition z_not_s : forall (n:nat), 0 = S n -> False :=
    fun (n:nat) (e:0 = S n) =>
        subst nat (fun (m:nat) =>
            match m with
            | 0     => True
            | S _   => False
            end) 0 (S n) e I.

Definition sinj : forall (m n:nat), S m = S n -> m = n :=
    fun (m n:nat) (e:S m = S n) =>
        subst nat (fun (k:nat) =>
            match k with
            | 0     => True
            | S k   => m = k
            end) (S m) (S n) e (eq_refl m).

Definition L2 : forall (n:nat), S n = n -> False.
Proof.
refine ( NatE (fun (n:nat) => S n = n -> False)
    (fun (e:1 = 0) => z_not_s 0 (eq_sym e))
    (fun (n:nat) (IH:S n = n -> False) (e:S (S n) = S n) =>
        IH (sinj (S n) n e)
)).
Qed.

Definition L3 : forall (n k:nat), n + S k = n -> False.
Proof.
refine ( NatE (fun (n:nat) => forall (k:nat), n + S k = n -> False)
    (fun (k:nat) (e:0 + S k = 0) => z_not_s k (eq_sym e))
    (fun (n:nat) (IH:forall (k:nat), n + S k = n -> False) =>
        fun (k:nat) (e:S n + S k = S n) => IH k (sinj (n + S k) n e)
)).
Qed.

Definition L4 : forall (m n p:nat), m + n = m + p -> n = p.
Proof.
refine ( NatE (fun (m:nat) => forall (n p:nat), m + n = m + p -> n = p)
    (fun(n p:nat) (e:0 + n = 0 + p) => e)
    (fun(m:nat) (IH:forall (n p:nat), m + n = m + p -> n = p) =>
        fun (n p:nat) (e:S m + n = S m + p) => IH n p (sinj (m + n) (m + p) e)
)).
Qed.

Definition L5 : forall (m n:nat), m = n \/ ~ m = n.
refine (NatE (fun (m:nat) => forall (n:nat), m = n \/ ~ m = n)
       (fun (n:nat) =>
        match n with
        | 0     => or_introl (eq_refl 0)
        | S n   => or_intror (z_not_s _)
        end)
        (fun (m:nat) (IH:forall (n:nat), m = n \/ ~ m = n) =>
            fun (n:nat) =>
                match n with
                | 0     => or_intror (fun (p:S m = 0) => z_not_s m (eq_sym p))
                | S n   =>
                    match (IH n) with
                    | or_introl e   => or_introl (cong nat nat S m n e)
                    | or_intror ne  => or_intror (fun (se:S m = S n) => ne (sinj m n se))
                    end
            end
)).
Qed.


Set Warnings "-notation-overridden,-parsing".
From LF Require Export indprop.
Definition relation (X: Type) := X -> X -> Prop.
Check le : nat -> nat -> Prop.
Check le : relation nat.

(*部分関数*)
Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Print next_nat.
Check next_nat : relation nat.

Theorem next_nat_partial_function :
   partial_function next_nat.
Proof.
  unfold partial_function.
  intros x y1 y2 H1 H2.
  inversion H1. inversion H2.
  reflexivity. Qed.

Theorem le_not_a_partial_function :
  ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense. {
    apply Hc with (x := 0).
    - apply le_n.
    - apply le_S. apply le_n. }
  discriminate Nonsense. Qed.

Inductive total_relation : nat -> nat -> Prop :=
  tot : forall n m : nat, total_relation n m.

Check total_relation : relation nat.

Theorem not_partial_total_relation :
  ~(partial_function total_relation).
Proof.
  unfold not. unfold partial_function. intros.
  assert (0 = 1) as Nonsense. {
    apply H with (x:= 0) (y1:= 0) (y2:= 1).
    - apply tot. - apply tot. }
  discriminate Nonsense.
Qed.

Inductive empty_relation : nat -> nat -> Prop := .

Theorem not_partial_empty_relation :
  partial_function empty_relation.
Proof.
  unfold partial_function. intros x y1 y2 H1 H2.
  inversion H1. Qed.

(*反射的関係*)
Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.

Theorem le_reflexive :
  reflexive le.
Proof.
  unfold reflexive. intros n. apply le_n. Qed.

(*推移的関係*)
Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans :
  transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  - apply Hnm.
  - apply le_S. apply IHHmo. apply Hnm. Qed.

Theorem lt_trans:
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  apply le_S in Hnm.
  apply le_trans with (a := (S n)) (b := (S m)) (c := o).
  apply Hnm.
  apply Hmo. Qed.

Theorem lt_trans' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hnm.
  - apply le_leftS in Hmo. apply Hmo.
  - apply IHHnm. apply le_leftS. apply Hmo.
Qed.

Theorem lt_trans'' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  - inversion Hmo.
  - apply le_S. apply IHo'.
    Abort.

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof.
  intros n m H. apply le_trans with (S n).
  - apply le_S. apply le_n.
  - apply H.
Qed.

Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  intros. inversion H.
  - apply le_n.
  - apply le_Sn_le in H2. apply H2.
Qed.

Theorem not_le_Sn_n : forall n, ~(S n <= n).
Proof.
  unfold not. intros. induction n.
  - inversion H.
  - apply IHn. apply le_S_n in H. apply H.
Qed.

(*対称的関係*)
Definition symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

Theorem le_not_symmetric :
  ~ (symmetric le).
Proof.
  unfold not. unfold symmetric. intros.
  assert (1 <= 0) as Nonsense. {
    apply H with (a:= 0) (b:= 1). apply le_S. apply le_n. }
  inversion Nonsense.
Qed.

(*反対称的関係*)
Definition antisymmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

Theorem le_antisymmetric :
  antisymmetric le.
Proof.
  intros a b.
  generalize dependent a.
  induction b.
  intros a.
  intros H.
  intros H1.
  inversion H.
  reflexivity.

  intros a H1 H2.
  destruct a.
  inversion H2.

  apply Sn_le_Sm__n_le_m in H1.
  apply Sn_le_Sm__n_le_m in H2.
  apply IHb in H1.
  rewrite H1.
  reflexivity.

  apply H2.
Qed.

Theorem le_step : forall n m p,
  n < m ->
  m <= S p ->
  n <= p.
Proof.
  unfold lt. intros. apply Sn_le_Sm__n_le_m. apply le_trans with m. apply H. apply H0.
Qed.

(*同値関係*)
Definition equivalence {X:Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

(*半順序関係*)
Definition order {X:Type} (R: relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).

(*全順序関係*)
Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order :
  order le.
Proof.
  unfold order. split.
    - apply le_reflexive.
    - split.
      + apply le_antisymmetric.
      + apply le_trans. Qed.

(*反射推移閉包
Rを含み反射性と推移性の両者を満たす最小の関係 *)
Inductive clos_refl_trans {A: Type} (R: relation A) : relation A :=
    | rt_step x y (H : R x y) : clos_refl_trans R x y
    | rt_refl x : clos_refl_trans R x x
    | rt_trans x y z
          (Hxy : clos_refl_trans R x y)
          (Hyz : clos_refl_trans R y z) :
          clos_refl_trans R x z.

Theorem next_nat_closure_is_le : forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
  intros n m. split.
  -
    intro H. induction H.
    + apply rt_refl.
    +
      apply rt_trans with m. apply IHle. apply rt_step.
      apply nn.
  -
    intro H. induction H.
    + inversion H. apply le_S. apply le_n.
    + apply le_n.
    +
      apply le_trans with y.
      apply IHclos_refl_trans1.
      apply IHclos_refl_trans2. Qed.

(*より使いやすい定義*)
Inductive clos_refl_trans_1n {A : Type}
                             (R : relation A) (x : A)
                             : A -> Prop :=
  | rt1n_refl : clos_refl_trans_1n R x x
  | rt1n_trans (y z : A)
      (Hxy : R x y) (Hrest : clos_refl_trans_1n R y z) :
      clos_refl_trans_1n R x z.

Lemma rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> clos_refl_trans_1n R x y.
Proof.
  intros X R x y H.
  apply rt1n_trans with y. apply H. apply rt1n_refl. Qed.

Lemma rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      clos_refl_trans_1n R x y ->
      clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.
Proof.
  intros. induction H. apply H0. apply rt1n_trans with (y0:= y). apply Hxy. apply IHclos_refl_trans_1n.
  apply H0.
Qed.

Theorem rtc_rsc_coincide :
         forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
Proof.

  intros. split.
  - intros. induction H. apply rt1n_trans with (y0 := y). apply H. apply rt1n_refl. apply rt1n_refl.
    apply rsc_trans with (y:= y).  apply IHclos_refl_trans1. apply IHclos_refl_trans2.
  - intros. induction H. apply rt_refl. apply rt_trans with (y0:= y).
    apply rt_step in Hxy. apply Hxy. apply IHclos_refl_trans_1n.
Qed.


(* Toy language of expressions https://www-verimag.imag.fr/~monin/Proof/Small_inversions/2021/eval_exp.v  *)
Inductive te : Type :=
  | Te_const : nat -> te
  | Te_plus : te -> te -> te
  | Te_div0 : te -> te.

Inductive val : Type :=
  | Nval  : nat -> val
  | Bval  : bool -> val.

(* Evaluation *)
Inductive eval : te -> val -> Prop :=
  | E_Const : forall n,
      eval (Te_const n) (Nval n)
  | E_Plus : forall t1 t2 n1 n2,
      eval t1 (Nval n1) ->
      eval t2 (Nval n2) ->
      eval (Te_plus t1 t2) (Nval (n1 + n2)).

(* Auxiliary inductive definitions when the 1st arg is constructed *)
Inductive eval_Const_1 n : val -> Prop :=
  | E_Const_1 : eval_Const_1 n (Nval n).
Inductive eval_Plus_1 t1 t2 : val -> Prop :=
  | E_Plus_1 : forall n1 n2,
      eval t1 (Nval n1) ->
      eval t2 (Nval n2) ->
      eval_Plus_1 t1 t2 (Nval (n1 + n2)).
Inductive eval_Div0_1 (t1: te) : val -> Prop :=.

Definition eval_1 : te -> val -> Prop :=
  fun t =>
    match t with
    | Te_const n => eval_Const_1 n
    | Te_plus t1 t2 => eval_Plus_1 t1 t2
    | Te_div0 t1 => eval_Div0_1 t1
    end.

Definition eval_eval_1 {t v} : eval t v -> eval_1 t v :=
  fun e =>
    match e with
    | E_Const n => E_Const_1 n
    | E_Plus t1 t2 n1 n2 e1 e2 => E_Plus_1 t1 t2 n1 n2 e1 e2
    end.

(* Interactive version *)
Definition eval_eval_1_inter {t v} : eval t v -> eval_1 t v.
Proof. intro e; destruct e; constructor; assumption. Qed.

(* Explicit version *)
Definition eval_eval_1_bavard {t v} : eval t v -> eval_1 t v :=
  fun e =>
    match e in eval t v return eval_1 t v with
    | E_Const n (*t := Te_const n, v := Nval n*) => E_Const_1 n : (eval_Const_1 n) (Nval n)
    | E_Plus t1 t2 n1 n2 e1 e2 (*t := Te_plus t1 t2, v := Nval (n1 + n2)*)
      => E_Plus_1 t1 t2 n1 n2 e1 e2 : (eval_Plus_1 t1 t2) (Nval (n1 + n2))
    end.

(* Auxiliary inductive definitions when the 2nd arg is constructed *)
(* Moderately useful, because the contents of 2nd argument is not
   constructed itself.
   No cases for Bval, and 2 cases for Nval.
   For the second, an auxiliary equality is introduced. *)

Inductive eval_Nat_2 (n: nat) : te -> Prop :=
  | E_Const_2 : eval_Nat_2 n (Te_const n)
  | E_Plus_2 : forall t1 t2 n1 n2,
      eval t1 (Nval n1) ->
      eval t2 (Nval n2) ->
      n = n1 + n2 ->
      eval_Nat_2 n (Te_plus t1 t2).

Inductive eval_Bool_2 (b: bool) : te -> Prop :=.

Definition eval_2 : te -> val -> Prop :=
  fun t v =>
    match v with
    | Nval n => eval_Nat_2 n
    | Bval b => eval_Bool_2 b
    end t.

Definition eval_eval_2 {t v} : eval t v -> eval_2 t v :=
  fun e =>
    match e with
    | E_Const n => E_Const_2 n
    | E_Plus t1 t2 n1 n2 e1 e2 => E_Plus_2 (n1 + n2) t1 t2 n1 n2 e1 e2 eq_refl
    end.

(* Auxiliary inductive definitions when args 1 and 2 are constructed *)

(* Symmetrical version, with 2 indices.
   Combines _1 and _2, with cumbersome additional equalities *)
Module S.
Inductive eval_Const_Nval_1_2 (c n : nat) : Prop :=
  | E_Const_Nval_1_2 : c = n -> eval_Const_Nval_1_2 c n.
Inductive eval_Plus_Nval_1_2 t1 t2 n : Prop :=
  | E_Plus_Nval_1_2 : forall n1 n2,
      eval t1 (Nval n1) ->
      eval t2 (Nval n2) ->
      n = n1 + n2 ->
      eval_Plus_Nval_1_2 t1 t2 n.
Inductive eval_other_Nval_1_2 : Prop :=.

Definition eval_1_2 : te -> val -> Prop :=
  fun t v =>
    match t, v with
    | Te_const c, Nval n => eval_Const_Nval_1_2 c n
    | Te_plus t1 t2, Nval n => eval_Plus_Nval_1_2 t1 t2 n
    | _, _ => eval_other_Nval_1_2
    end.

Definition eval_eval_1_2 {t v} : eval t v -> eval_1_2 t v :=
  fun e =>
    match e with
    | E_Const n => E_Const_Nval_1_2 n n eq_refl
    | E_Plus t1 t2 n1 n2 e1 e2 => E_Plus_Nval_1_2 t1 t2 (n1 + n2) n1 n2 e1 e2 eq_refl
    end.
End S.

(* Asymmetrical version, with 1 param and 1 indice:
   the first has precedence over the second, because it is
   "more constructed". Then the cumbersome equalities can be removed *)
Module A.
Inductive eval_Const_Nval_1_2 n : nat -> Prop :=
  | E_Const_Nval_1_2 : eval_Const_Nval_1_2 n n.
Inductive eval_Plus_Nval_1_2 t1 t2 : nat -> Prop :=
  | E_Plus_Nval_1_2 : forall n1 n2,
      eval t1 (Nval n1) ->
      eval t2 (Nval n2) ->
      eval_Plus_Nval_1_2 t1 t2 (n1 + n2).
Inductive eval_other_Nval_1_2 : Prop :=.

Definition eval_1_2 : te -> val -> Prop :=
  fun t v =>
    match t, v with
    | Te_const c, Nval n => eval_Const_Nval_1_2 c n
    | Te_plus t1 t2, Nval n => eval_Plus_Nval_1_2 t1 t2 n
    | _, _ => eval_other_Nval_1_2
    end.

Definition eval_eval_1_2 {t v} : eval t v -> eval_1_2 t v :=
  fun e =>
    match e with
    | E_Const n => E_Const_Nval_1_2 n
    | E_Plus t1 t2 n1 n2 e1 e2 => E_Plus_Nval_1_2 t1 t2 n1 n2 e1 e2
    end.
End A.

Notation eval_eval_1_2 := A.eval_eval_1_2.

Section varP.

Variable P : val -> Prop.

Lemma test_ev1 :
  forall v , P v -> eval (Te_plus (Te_const 1) (Te_const 0)) v -> v = Nval 1.
Proof.
  intros v p e.
  destruct (eval_eval_1 e) as [n1 n2 e1 e2].
  destruct (eval_eval_1_2 e1).
  destruct (eval_eval_1_2 e2).
  reflexivity.
Qed.

Lemma test_ev1_S :
  forall v , P v -> eval (Te_plus (Te_const 1) (Te_const 0)) v -> v = Nval 1.
Proof.
  intros v p e.
  destruct (eval_eval_1 e) as [n1 n2 e1 e2].
  generalize (S.eval_eval_1_2 e1). simpl. intro e1'.
  destruct (S.eval_eval_1_2 e1) as [eq1].
  destruct (S.eval_eval_1_2 e2) as [eq2].
  subst. reflexivity.
Qed.

Lemma test_ev2:
  eval (Te_plus (Te_const 1) (Te_const 0)) (Bval true) -> False.
Proof.
intro e. destruct (S.eval_eval_1_2 e).
Qed.

Lemma test_ev2':
  eval (Te_plus (Te_const 1) (Te_const 0)) (Nval 0) -> False.
Proof.
  intro e.
  cut (0=1). discriminate.
  pattern 0 at 1.
  destruct (eval_eval_1_2 e) as [n1 n2 e1 e2].
  destruct (eval_eval_1_2 e1).
  destruct (eval_eval_1_2 e2).
  reflexivity.
Qed.

Lemma test_ev3:
  forall n, n < 5 -> eval (Te_plus (Te_const 1) (Te_const 0)) (Nval n) -> n = 1.
Proof.
  intros n l e.
  destruct (eval_eval_1_2 e) as [n1 n2 e1 e2].
  destruct (eval_eval_1_2 e1).
  destruct (eval_eval_1_2 e2).
  reflexivity.
Qed.

Lemma test_ev3_S:
  forall n, n < 5 -> eval (Te_plus (Te_const 1) (Te_const 0)) (Nval n) -> n = 1.
Proof.
  intros n l e.
  destruct (S.eval_eval_1_2 e) as [n1 n2 e1 e2 eq].
  destruct (S.eval_eval_1_2 e1) as [eq1].
  destruct (S.eval_eval_1_2 e2) as [eq2].
  subst. reflexivity.
Qed.

End varP.

(* ------------------------------------------------------------ *)

(* Non-deterministic evaluation, in order to illustrate
   several cases matching an "input"
*)

Section varQ.

Variable Q : te -> Prop.

Inductive eval_nd: te -> val -> Prop :=
  | E_Const_nd : forall n,
      eval_nd (Te_const n) (Nval n)
  | E_Plus_nd1 : forall t1 t2 n1 n2,
      eval_nd t1 (Nval n1) ->
      eval_nd t2 (Nval n2) ->
      eval_nd (Te_plus t1 t2) (Nval (n1 + n2))
  | E_Plus_nd2 : forall t1 t2 n2,
      Q t1 ->
      eval_nd t2 (Nval n2) ->
      eval_nd (Te_plus t1 t2) (Nval n2).

(* Auxiliary inductive definitions *)
Inductive eval_nd_Const_1 n : val -> Prop :=
  | E_Const_nd_1 : eval_nd_Const_1 n (Nval n).
Inductive eval_nd_Plus_1 t1 t2 : val -> Prop :=
  | E_Plus_nd1_1 : forall n1 n2,
      eval_nd t1 (Nval n1) ->
      eval_nd t2 (Nval n2) ->
      eval_nd_Plus_1 t1 t2 (Nval (n1 + n2))
  | E_Plus_nd2_1 : forall n2,
      Q t1 ->
      eval_nd t2 (Nval n2) ->
      eval_nd_Plus_1 t1 t2 (Nval n2).
Inductive eval_Div0_1_2 (t1 : te) : val -> Prop :=.

Definition eval_nd_1 : te -> val -> Prop :=
  fun t =>
    match t with
    | Te_const n => eval_nd_Const_1 n
    | Te_plus t1 t2 => eval_nd_Plus_1 t1 t2
    | Te_div0 t1 => eval_Div0_1_2 t1
    end.

Definition eval_nd_eval_nd_1 {t v} : eval_nd t v -> eval_nd_1 t v :=
  fun e =>
    match e with
    | E_Const_nd n => E_Const_nd_1 n
    | E_Plus_nd1 t1 t2 n1 n2 e1 e2 => E_Plus_nd1_1 t1 t2 n1 n2 e1 e2
    | E_Plus_nd2 t1 t2 n2 q e2 => E_Plus_nd2_1 t1 t2 n2 q e2
    end.

Inductive eval_nd_Const_Nval_1_2 n : nat -> Prop :=
  | E_Const_nd_Nval_1_2 : eval_nd_Const_Nval_1_2 n n.
Inductive eval_nd_Plus_Nval_1_2 t1 t2 : nat -> Prop :=
  | E_Plus_nd_Nval1_1_2 : forall n1 n2,
      eval_nd t1 (Nval n1) ->
      eval_nd t2 (Nval n2) ->
      eval_nd_Plus_Nval_1_2 t1 t2 (n1 + n2)
  | E_Plus_nd_Nval2_1_2 : forall n2,
      Q t1 ->
      eval_nd t2 (Nval n2) ->
      eval_nd_Plus_Nval_1_2 t1 t2 n2.

Definition eval_nd_1_2 : te -> val -> Prop :=
  fun t v =>
    match t, v with
    | Te_const c, Nval n => eval_nd_Const_Nval_1_2 c n
    | Te_plus t1 t2, Nval n => eval_nd_Plus_Nval_1_2 t1 t2 n
    | _, _ => False
    end.

Definition eval_nd_eval_nd_1_2 {t v} : eval_nd t v -> eval_nd_1_2 t v :=
  fun e =>
    match e with
    | E_Const_nd n => E_Const_nd_Nval_1_2 n
    | E_Plus_nd1 t1 t2 n1 n2 e1 e2 => E_Plus_nd_Nval1_1_2 t1 t2 n1 n2 e1 e2
    | E_Plus_nd2 t1 t2 n2 q e2 => E_Plus_nd_Nval2_1_2 t1 t2 n2 q e2
    end.

Lemma test_ev_nd2:
  forall t, eval_nd (Te_plus (Te_const 0) (Te_const 1)) t-> t = Nval 1.
Proof.
  intros t e.
  destruct (eval_nd_eval_nd_1 e) as [n1 n2 e1 e2 | n2 q e2].
  - destruct (eval_nd_eval_nd_1_2 e1). destruct (eval_nd_eval_nd_1_2 e2). reflexivity.
  - destruct (eval_nd_eval_nd_1_2 e2). reflexivity.
Qed.

Lemma test_ev_nd3:
  forall n, eval_nd (Te_plus (Te_const 0) (Te_const 1)) (Nval n) -> n = 1.
Proof.
  intros n e.
  destruct (eval_nd_eval_nd_1_2 e) as [n1 n2 e1 e2 | n2 q e2].
  - destruct (eval_nd_eval_nd_1_2 e1). destruct (eval_nd_eval_nd_1_2 e2). reflexivity.
  - destruct (eval_nd_eval_nd_1_2 e2). reflexivity.
Qed.

End varQ.


Require Import Omega Init.Nat Arith.EqNat.
Require Import Coq.Arith.PeanoNat Coq.Structures.Equalities.

Lemma obvio_1: forall (N:nat) , (2< N) %nat -> (0 < N) %nat.
Proof.
intros. omega.
Qed.

Lemma obvio_2: forall (n m:nat) , (n < m)%nat -> (n-m)%nat = zero.
Proof.
intros.
induction n.
induction m. reflexivity. simpl. reflexivity.
cut ( (S n- m)%nat = pred (n-m)).
+ intros. rewrite H0. rewrite IHn. simpl. reflexivity. omega.
+ omega.
Qed.

Lemma obvio_3: forall (n:nat) , (n-n)%nat =zero.
Proof.
intros.
induction n.
auto.
simpl. rewrite IHn. reflexivity.
Qed.


(* Ejercicio 6.3 *)
Section ej63.

Definition Value := bool.
Inductive BoolExpr : Set :=
  | bbool : bool -> BoolExpr
  | band : BoolExpr -> BoolExpr -> BoolExpr
  | bnot : BoolExpr -> BoolExpr.
Inductive BEval : BoolExpr -> Value -> Prop :=
  | ebool : forall b : bool, BEval (bbool b) (b:Value)
  | eandl : forall e1 e2 : BoolExpr, BEval e1 false -> BEval (band e1 e2) false
  | eandr : forall e1 e2 : BoolExpr, BEval e2 false -> BEval (band e1 e2) false
  | eandrl : forall e1 e2 : BoolExpr, BEval e1 true -> BEval e2 true -> BEval (band e1 e2) true
  | enott : forall e : BoolExpr, BEval e true -> BEval (bnot e) false
  | enotf : forall e : BoolExpr, BEval e false -> BEval (bnot e) true.

Fixpoint beval1 (e : BoolExpr) : Value :=
  match e with
  | bbool b => b
  | band e1 e2 =>
    match beval1 e1, beval1 e2 with
    | true, true => true
    | _, _ => false
    end
  | bnot e1 => if beval1 e1 then false else true
end.

Fixpoint beval2 (e : BoolExpr) : Value :=
  match e with
  | bbool b => b
  | band e1 e2 =>
    match beval2 e1 with
    | false => false
    | _ => beval2 e2
    end
  | bnot e1 => if beval2 e1 then false else true
  end.

(* Ejercicio 6.3.1 - sin hints *)

Lemma beval1C : forall e:BoolExpr, {b:Value |(BEval e b)}.
Proof.
intros.
exists (beval1 e).
induction e; simpl.
  - constructor.
  - destruct (beval1 e1); try constructor; auto.
    destruct (beval1 e2); try apply eandr; try constructor; auto.
  - destruct (beval1 e); constructor; auto.
Qed.

Lemma beval2C : forall e:BoolExpr, {b:Value |(BEval e b)}.
Proof.
intros.
exists (beval2 e).
induction e; simpl.
  - constructor.
  - destruct (beval2 e1); try constructor; auto.
    destruct (beval2 e2); try apply eandr; try constructor; auto.
  - destruct (beval2 e); constructor; auto.
Qed.

(* Ejercicio 6.3.2 - con hints *)

Hint Constructors BEval.

Lemma beval1CH : forall e:BoolExpr, {b:Value |(BEval e b)}.
Proof.
intros.
exists (beval1 e).
induction e; simpl; auto.
  - destruct (beval1 e1), (beval1 e2); auto.
  - destruct (beval1 e); auto.
Qed.

Lemma beval2CH : forall e:BoolExpr, {b:Value |(BEval e b)}.
Proof.
intros.
exists (beval2 e).
induction e; simpl; auto.
  - destruct (beval2 e1), (beval2 e2); auto.
  - destruct (beval2 e); auto.
Qed.

End ej63.

(* Ejercicio 6.3.3/4 - extracción *)
Require Extraction.
Extraction Language Haskell.
(* Ejercicio 6.3.4 - usar tipo bool de Haskell *)
Extract Inductive bool => "Prelude.Bool" [ "Prelude.True" "Prelude.False" ].

Extraction "beval1C.hs" beval1C.
Extraction "beval2C.hs" beval2C.
Extraction "beval1CH.hs" beval1CH.
Extraction "beval2CH.hs" beval2CH.

(* Ejercicio 6.5 *)
Section ej65.

(* Ejercicio 6.5.1 *)
Inductive Le : nat -> nat -> Prop :=
  | Le_0  : forall n: nat, Le 0 n
  | Le_Sn : forall n m: nat, Le n m -> Le (S n) (S m).

Inductive Gt : nat -> nat -> Prop :=
  | Gt_n  : forall n: nat, Gt (S n) 0
  | Gt_Sn : forall n m: nat, Gt n m -> Gt (S n) (S m).

(* Ejercicio 6.5.2 *)
Fixpoint leBool (n m: nat) :=
  match n, m with
    | 0, _           => true
    | _, 0           => false
    | (S ni), (S mi) => leBool ni mi
  end.

Require Import FunInd.
Functional Scheme leBool_ind := Induction for leBool Sort Set.

Hint Constructors Le.
Hint Constructors Gt.

Lemma Le_Gt_dec: forall n m:nat, {(Le n m)}+{(Gt n m)}.
Proof.
intros.
functional induction (leBool n m) using leBool_ind; simpl; auto.
destruct IHb; [ left | right ]; auto.
Qed.

(* Ejercicio 6.5.3 *)
Require Import Omega.

Lemma le_gt_dec: forall n m:nat, {(le n m)}+{(gt n m)}.
Proof.
intros.
functional induction (leBool n m) using leBool_ind; simpl; auto with arith.
destruct IHb; [ left | right ]; omega. (* sirve auto with arith *)
Qed.

End ej65.

(* Ejercicio 6.6 *)
Section ej66.

Require Import Omega.
Require Import DecBool.
Require Import Compare_dec.
Require Import Plus.
Require Import Mult.

Definition spec_res_nat_div_mod (a b:nat) (qr:nat*nat) :=
  match qr with
    (q,r) => (a = b*q + r) /\ r < b
  end.

Definition nat_div_mod : forall a b:nat, not(b=0) -> {qr:nat*nat | spec_res_nat_div_mod a b qr}.
Proof.
intros.
induction a.
  * exists (0,0); simpl; omega.
  * destruct IHa.
    destruct x.
    induction s.
    case_eq (le_lt_eq_dec (S n0) b); auto.
      + exists (n, (S n0)).
        simpl.
        split; auto with arith; omega.
      + exists ((S n), 0).
        simpl.
        rewrite -> H0.
        rewrite <- e.
        simpl.
        replace (n0 * S n) with (n0 * n + n0); auto with arith.
        split; omega.
Qed.

End ej66.

(* Ejercicio 6.7 *)
Section ej67.

Inductive tree (A:Set) : Set :=
  | leaf : tree A
  | node : A -> tree A -> tree A -> tree A.

Inductive tree_sub (A:Set) (t:tree A) : tree A -> Prop :=
  | tree_sub1 : forall (t':tree A) (x:A), tree_sub A t (node A x t t')
  | tree_sub2 : forall (t':tree A) (x:A), tree_sub A t (node A x t' t).

Theorem well_founded_tree_sub : forall A:Set, well_founded (tree_sub A).
Proof.
unfold well_founded.
intros.
induction a;
constructor;
intros;
inversion H;
auto.
Qed.

End ej67.

(* Ejercicio 6.8 *)
Section ej68.

(* Ejercicio 6.8.1 *)
Fixpoint size (x: BoolExpr) :=
  match x with
  | bbool _  => 1
  | band x y => size x + size y + 1
  | bnot x   => size x + 1
  end.

Definition elt (e1 e2 : BoolExpr) := size e1 < size e2.

(* Ejercicio 6.8.2 *)
Require Import Wf_nat.
Require Import Inverse_Image.

Theorem well_founded_elt : well_founded (elt).
Proof.
apply (wf_inverse_image BoolExpr nat).
exact lt_wf.
Qed.

End ej68.


(* Copied and modified from Xavier Leroy's lectures. *)

(** A library of relation operators defining sequences of transitions
  and useful properties about them. *)

Set Implicit Arguments.

Section SEQUENCES.

Variable A: Type.                 (**r the type of states *)
Variable R: A -> A -> Prop.       (**r the transition relation, from one state to the next *)

(** ** Finite sequences of transitions *)

(** Zero, one or several transitions: reflexive, transitive closure of [R]. *)

Inductive star: A -> A -> Prop :=
  | star_refl: forall a,
      star a a
  | star_step: forall a b c,
      R a b -> star b c -> star a c.

Lemma star_one:
  forall (a b: A), R a b -> star a b.
Proof.
  eauto using star.
Qed.

Lemma star_trans:
  forall (a b: A), star a b -> forall c, star b c -> star a c.
Proof.
  induction 1; eauto using star.
Qed.

(** One or several transitions: transitive closure of [R]. *)

Inductive plus: A -> A -> Prop :=
  | plus_left: forall a b c,
      R a b -> star b c -> plus a c.

Lemma plus_one:
  forall a b, R a b -> plus a b.
Proof.
  eauto using star, plus.
Qed.

Lemma plus_star:
  forall a b,
  plus a b -> star a b.
Proof.
  intros. inversion H. eauto using star.
Qed.

Lemma plus_star_trans:
  forall a b c, plus a b -> star b c -> plus a c.
Proof.
  intros. inversion H. eauto using plus, star_trans.
Qed.

Lemma star_plus_trans:
  forall a b c, star a b -> plus b c -> plus a c.
Proof.
  intros. inversion H0. inversion H; eauto using plus, star, star_trans.
Qed.

Lemma plus_right:
  forall a b c, star a b -> R b c -> plus a c.
Proof.
  eauto using star_plus_trans, plus_one.
Qed.

(** ** Infinite sequences of transitions *)

(** It is easy to characterize the fact that all transition sequences starting
  from a state [a] are infinite: it suffices to say that any finite sequence
  starting from [a] can always be extended by one more transition. *)

Definition all_seq_inf (a: A) : Prop :=
  forall b, star a b -> exists c, R b c.

(** However, this is not the notion we are trying to characterize: that, starting
  from [a], there exists one infinite sequence of transitions
  [a --> a1 --> a2 --> ... -> aN -> ...].

  Indeed, consider [A = nat] and [R] such that [R 0 0] and [R 0 1].
  [all_seq_inf 0] does not hold, because a sequence [0 -->* 1] cannot be extended.
  Yet, [R] admits an infinite sequence, namely [0 --> 0 --> ...].

  Another attempt would be to represent the sequence of states
  [a0 --> a1 --> a2 --> ... -> aN -> ...] explicitly, as a function
  [f: nat -> A] such that [f i] is the [i]-th state [ai] of the sequence. *)

Definition infseq_with_function (a: A) : Prop :=
  exists f: nat -> A, f 0 = a /\ forall i, R (f i) (f (1 + i)).

(** This is a correct characterization of the existence of an infinite sequence
  of reductions.  However, it is very inconvenient to work with this definition
  in Coq's constructive logic: in most use cases, the function [f] is not
  computable and therefore cannot be defined in Coq.  *)

(** To obtain a practical definition of infinite sequences, we use the following
  coinductive definition of the predicate [infseq a]. *)

CoInductive infseq: A -> Prop :=
  | infseq_step: forall a b,
      R a b -> infseq b -> infseq a.

(** An inductive predicate such as [star a b] holds iff there exists a finite
  derivation of the conclusion [star a b] that uses the constructors
  [star_refl] and [star_step] a finite number of times.

  A coinductive predicate is similar, but holds iff there exists a finite
  OR INFINITE derivation of the conclusion that uses the constructors
  of the predicate a finite OR INFINITE number of times.

  In other words, an inductive predicate is a smallest fixpoint: the smallest predicate
  that satisfies its constructors; a coinductive predicate is a greatest fixpoint:
  the largest predicate that satisfies its constructors.

  The [infseq] predicate above must be defined coinductively.  Indeed, if
  we define it inductively, the predicate would be empty (always false),
  since there are no base cases!

  Coq provides some primitive support for constructing infinite derivations
  of facts such as [infseq a].  Such constructions are proofs by coinduction.
  For example, we can prove the following: *)

Remark cycle_infseq:
  forall a, R a a -> infseq a.
Proof.
  intros. cofix COINDHYP. apply infseq_step with a. auto. apply COINDHYP.
Qed.

(** This style of proof by coinduction, using the [cofix] tactic, is effective
  but can run into limitations of Coq's proof engine (the so-called
  "guard condition").  However, we can derive more conventional
  coinduction principles that are often easier to use. *)

(** Consider a set [X] of states [A], that is, a predicate [X: A -> Prop].
  Assume that for every [a] in [X], we can make one [R] transition to a [b]
  that is still in [X].  Then, starting from [a] in [X], we can transition
  to some [a1] in [X], then to some [a2] still in [X], then... It is clear
  that we are just building an infinite sequence of transitions starting from
  [a]. Therefore [infseq a] should hold.  Let's prove this! *)

Lemma infseq_coinduction_principle:
  forall (X: A -> Prop),
  (forall a, X a -> exists b, R a b /\ X b) ->
  forall a, X a -> infseq a.
Proof.
  intros X P. cofix COINDHYP; intros.
  destruct (P a H) as [b [U V]]. apply infseq_step with b; auto.
Qed.

(** An even more useful variant of this coinduction principle considers a
  set [X] where for every [a] in [X], we can make one *or several* transitions
  to reach a [b] in [X].  *)

Lemma infseq_coinduction_principle_2:
  forall (X: A -> Prop),
  (forall a, X a -> exists b, plus a b /\ X b) ->
  forall a, X a -> infseq a.
Proof.
  intros.
  apply infseq_coinduction_principle with
    (X := fun a => exists b, star a b /\ X b).
- intros.
  destruct H1 as [b [STAR Xb]]. inversion STAR; subst.
+ destruct (H b Xb) as [c [PLUS Xc]]. inversion PLUS; subst.
  exists b0; split. auto. exists c; auto.
+ exists b0; split. auto. exists b; auto.
- exists a; split. apply star_refl. auto.
Qed.

(** Here is an example of use of [infseq_coinduction_principle]:
  if all finite transition sequences starting at [a] can be extended,
  [infseq a] holds. *)

Lemma infseq_if_all_seq_inf:
  forall a, all_seq_inf a -> infseq a.
Proof.
  apply infseq_coinduction_principle.
  intros. destruct (H a) as [b Rb]. constructor.
  exists b; split; auto.
  unfold all_seq_inf; intros. apply H. apply star_step with b; auto.
Qed.

(** Likewise, the function-based characterization [infseq_with_function]
  implies [infseq]. *)

Lemma infseq_from_function:
  forall a, infseq_with_function a -> infseq a.
Proof.
  apply infseq_coinduction_principle.
  intros. destruct H as [f [P Q]].
  exists (f 1); split.
  subst a. apply Q.
  exists (fun n => f (1 + n)); split. auto. intros. apply Q.
Qed.

(** Consider the transition sequences starting at state [a].
  They can be infinite, or they can be finite: after a number of transitions,
  we reach a state from with no transition is possible.  It is intuitively
  obvious that at least one of the two cases must hold.

  It is however impossible to prove this fact in Coq's constructive logic.
  Indeed, a constructive proof would be isomorphic (by the Curry-Howard isomorphism)
  to a terminating function that solves Turing's halting problem!

  To prove this fact, we must enrich Coq with axioms from classical logic,
  namely the axiom of excluded middle: for all propositions [P],
  either [P] or [~P] hold.  The Coq standard library provides such axioms
  in the module named [Classical], which we now import. *)

Require Import Classical.

Definition irred (a: A) : Prop := forall b, ~(R a b).

Lemma infseq_or_finseq:
  forall a, infseq a \/ exists b, star a b /\ irred b.
Proof.
  intros.
  destruct (classic (forall b, star a b -> exists c, R b c)).
- left. apply infseq_if_all_seq_inf; auto.
- right.
  apply not_all_ex_not in H. destruct H as [b P].
  apply imply_to_and in P. destruct P as [U V].
  exists b; split. auto.
  red; intros; red; intros. elim V. exists b0; auto.
Qed.

(** ** Determinism properties for functional transition relations. *)

(** A transition relation is functional if every state can transition to at most
  one other state. *)

Hypothesis R_functional:
  forall a b c, R a b -> R a c -> b = c.

(** Uniqueness of finite transition sequences. *)

Lemma star_star_inv:
  forall a b, star a b -> forall c, star a c -> star b c \/ star c b.
Proof.
  induction 1; intros.
- auto.
- inversion H1; subst.
+ right. eauto using star.
+ assert (b = b0) by (eapply R_functional; eauto). subst b0.
  apply IHstar; auto.
Qed.

Lemma finseq_unique:
  forall a b b',
  star a b -> irred b ->
  star a b' -> irred b' ->
  b = b'.
Proof.
  intros. destruct (star_star_inv H H1).
- inversion H3; subst. auto. elim (H0 _ H4).
- inversion H3; subst. auto. elim (H2 _ H4).
Qed.

(** A state cannot both diverge and terminate on an irreducible state. *)

Lemma infseq_star_inv:
  forall a b, star a b -> infseq a -> infseq b.
Proof.
  induction 1; intros.
- auto.
- inversion H1; subst.
  assert (b = b0) by (eapply R_functional; eauto). subst b0.
  apply IHstar; auto.
Qed.

Lemma infseq_finseq_excl:
  forall a b,
  star a b -> irred b -> infseq a -> False.
Proof.
  intros.
  assert (infseq b) by (eapply infseq_star_inv; eauto).
  inversion H2. elim (H0 b0); auto.
Qed.

(** If there exists an infinite sequence of transitions from [a],
  all sequences of transitions arising from [a] are infinite. *)

Lemma infseq_all_seq_inf:
  forall a, infseq a -> all_seq_inf a.
Proof.
  intros. unfold all_seq_inf. intros.
  assert (infseq b) by (eapply infseq_star_inv; eauto).
  inversion H1. subst. exists b0; auto.
Qed.

End SEQUENCES.


Section LPPO_1.
Variable A : Set.
Variables P Q : A -> Prop.
Lemma lppo_exrc_1 :
(exists x : A, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
split.
intro.
destruct H.
destruct H.
left.
exists x.
assumption.
right.
exists x.
assumption.
intro.
destruct H.
destruct H.
exists x.
left.
assumption.
destruct H.
exists x.
right.
assumption.
Qed.
Lemma lppo_exrc_2 : ~(exists x : A, P x) <-> forall x : A, ~P x.
Proof.
split.
intro.
intro x0.
intro.
apply H.
exists x0.
assumption.
intro.
intro.
destruct H0.
assert (H1 := H x).
apply H1.
assumption.
Qed.
End LPPO_1.

Section natProofs.
Variable a b c d: nat. (*variables de tipo nat*)

(*B) a*)
Theorem identity : forall a, a + 0 = a.
intro.
induction a0.
simpl.
reflexivity.
simpl.
rewrite IHa0.
reflexivity.
Qed.

(*B) b*)
Theorem associative : forall a b c, a + (b + c) = (a + b) + c.
intros.
induction a0.
simpl.
reflexivity.
simpl.
rewrite IHa0.
reflexivity.
Qed.

Theorem subCommutative : forall a b, S (b + a) = b + S (a).
Proof.
intros.
induction b0.
simpl.
reflexivity.
simpl.
rewrite IHb0.
reflexivity.
Qed.

(*B) c*)
Theorem commutative : forall a b, a + b = b + a.
intros.
induction a0.
simpl.
rewrite identity.
reflexivity.
simpl.
rewrite IHa0.
rewrite subCommutative.
reflexivity.
Qed.

(*B) d*)
Theorem equality: forall a b c, b = c -> b + a = c + a.
Proof.
intros.
induction a0.
rewrite identity.
rewrite -> identity.
rewrite H.
reflexivity.
rewrite commutative.
simpl.
rewrite commutative.
rewrite IHa0.
rewrite subCommutative.
reflexivity.
Qed.

(*C) a*)
Theorem multIdentity: forall a, a * 1 = a.
Proof.
intros.
induction a0.
simpl.
reflexivity.
simpl.
rewrite IHa0.
reflexivity.
Qed.

(*C) b*)
Theorem zeroProduct: forall a, a * 0 = 0.
Proof.
intros.
induction a0.
simpl.
reflexivity.
simpl.
rewrite IHa0.
reflexivity.
Qed.

Theorem auxSubCommutative: forall a b, a * b + b = b + a * b.
Proof.
intros.
induction b0.
simpl.
rewrite identity.
rewrite zeroProduct.
reflexivity.
rewrite commutative.
simpl.
reflexivity.
Qed.

(*C) c*)
Theorem auxCommutative: forall a b, a * S b = a + a * b.
Proof.
intros.
induction a0.
simpl.
reflexivity.
simpl.
rewrite commutative.
rewrite IHa0.
rewrite commutative.
rewrite associative.
rewrite commutative.
rewrite associative.
rewrite commutative.
rewrite auxSubCommutative.
reflexivity.
Qed.

(*C) d*)
Theorem multCommutative: forall a b, a * b = b * a.
Proof.
intros.
induction b0.
simpl.
rewrite zeroProduct.
reflexivity.
simpl.
rewrite auxCommutative.
rewrite IHb0.
reflexivity.
Qed.

(*C) e*)
Theorem multDistributive: forall a b c, a * (b + c) = (a * b) + (a * c).
Proof.
intros.
induction a0.
simpl.
reflexivity.
simpl.
rewrite IHa0.
rewrite associative.
rewrite commutative.
assert (H: b0 + c0 = c0 + b0).
rewrite commutative.
reflexivity.
rewrite H.
rewrite commutative.
assert (H1: c0 + b0 + a0 * b0 = c0 + (b0 + a0 * b0)).
rewrite associative.
reflexivity.
assert (H2: c0 + (b0 + a0 * b0) = (b0 + a0 * b0) + c0).
rewrite commutative.
simpl.
reflexivity.
rewrite H1.
rewrite H2.
rewrite associative.
reflexivity.
Qed.

(*C) f*)
Theorem multAssociative: forall a b c, a * (b * c) = (a * b) * c.
Proof.
intros.
induction a0.
simpl.
reflexivity.
simpl.
rewrite IHa0.
rewrite commutative.
simpl.
rewrite multCommutative.
rewrite commutative.
rewrite multCommutative.
rewrite <- multDistributive.
rewrite multCommutative.
reflexivity.
Qed.

End natProofs.


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

(*i $Id: Gt.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

(** Theorems about [gt] in [nat]. [gt] is defined in [Init/Peano.v] as:
<<
Definition gt (n m:nat) := m < n.
>>
*)

Require Import Le.
Require Import Lt.
Require Import Plus.
Open Local Scope nat_scope.

Implicit Types m n p : nat.

(** * Order and successor *)

Theorem gt_Sn_O : forall n, S n > 0.
Proof.
  auto with arith.
Qed.
Hint Resolve gt_Sn_O: arith v62.

Theorem gt_Sn_n : forall n, S n > n.
Proof.
  auto with arith.
Qed.
Hint Resolve gt_Sn_n: arith v62.

Theorem gt_n_S : forall n m, n > m -> S n > S m.
Proof.
  auto with arith.
Qed.
Hint Resolve gt_n_S: arith v62.

Lemma gt_S_n : forall n m, S m > S n -> m > n.
Proof.
  auto with arith.
Qed.
Hint Immediate gt_S_n: arith v62.

Theorem gt_S : forall n m, S n > m -> n > m \/ m = n.
Proof.
  intros n m H; unfold gt in |- *; apply le_lt_or_eq; auto with arith.
Qed.

Lemma gt_pred : forall n m, m > S n -> pred m > n.
Proof.
  auto with arith.
Qed.
Hint Immediate gt_pred: arith v62.

(** * Irreflexivity *)

Lemma gt_irrefl : forall n, ~ n > n.
Proof lt_irrefl.
Hint Resolve gt_irrefl: arith v62.

(** * Asymmetry *)

Lemma gt_asym : forall n m, n > m -> ~ m > n.
Proof fun n m => lt_asym m n.

Hint Resolve gt_asym: arith v62.

(** * Relating strict and large orders *)

Lemma le_not_gt : forall n m, n <= m -> ~ n > m.
Proof le_not_lt.
Hint Resolve le_not_gt: arith v62.

Lemma gt_not_le : forall n m, n > m -> ~ n <= m.
Proof.
auto with arith.
Qed.

Hint Resolve gt_not_le: arith v62.

Theorem le_S_gt : forall n m, S n <= m -> m > n.
Proof.
  auto with arith.
Qed.
Hint Immediate le_S_gt: arith v62.

Lemma gt_S_le : forall n m, S m > n -> n <= m.
Proof.
  intros n p; exact (lt_n_Sm_le n p).
Qed.
Hint Immediate gt_S_le: arith v62.

Lemma gt_le_S : forall n m, m > n -> S n <= m.
Proof.
  auto with arith.
Qed.
Hint Resolve gt_le_S: arith v62.

Lemma le_gt_S : forall n m, n <= m -> S m > n.
Proof.
  auto with arith.
Qed.
Hint Resolve le_gt_S: arith v62.

(** * Transitivity *)

Theorem le_gt_trans : forall n m p, m <= n -> m > p -> n > p.
Proof.
  red in |- *; intros; apply lt_le_trans with m; auto with arith.
Qed.

Theorem gt_le_trans : forall n m p, n > m -> p <= m -> n > p.
Proof.
  red in |- *; intros; apply le_lt_trans with m; auto with arith.
Qed.

Lemma gt_trans : forall n m p, n > m -> m > p -> n > p.
Proof.
  red in |- *; intros n m p H1 H2.
  apply lt_trans with m; auto with arith.
Qed.

Theorem gt_trans_S : forall n m p, S n > m -> m > p -> n > p.
Proof.
  red in |- *; intros; apply lt_le_trans with m; auto with arith.
Qed.

Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith v62.

(** * Comparison to 0 *)

Theorem gt_0_eq : forall n, n > 0 \/ 0 = n.
Proof.
  intro n; apply gt_S; auto with arith.
Qed.

(** * Simplification and compatibility *)

Lemma plus_gt_reg_l : forall n m p, p + n > p + m -> n > m.
Proof.
  red in |- *; intros n m p H; apply plus_lt_reg_l with p; auto with arith.
Qed.

Lemma plus_gt_compat_l : forall n m p, n > m -> p + n > p + m.
Proof.
  auto with arith.
Qed.
Hint Resolve plus_gt_compat_l: arith v62.

(* begin hide *)
Notation gt_O_eq := gt_0_eq (only parsing).
(* end hide *)


Require Import HoTT.Basics.

Section Definitions.
	Variable A:Set.
	Definition prod A := A->A->A.
	Definition associative {A} (m : prod A) :=
		forall a b c : A, m (m a b) c = m a (m b c).
	Definition commutative {A} (m : prod A) :=
		forall a b : A, m a b = m b a.
	Definition neutral {A} (e:A) (m:prod A) :=
		forall a:A, (m e a = a) /\ (m a e = a).
	Definition exists_inverse {A} (m:prod A) (e:A) :=
		forall a:A, exists a', m a a' = e /\ m a' a = e.

	Definition isMonoid A (m : prod A) (e:A) :=
		associative m /\ neutral e m.
	Definition isCommutative_Monoid A (m : prod A) (e:A) :=
		associative m /\ neutral e m /\ commutative m.
	Definition isGroup A (m:prod A) (e:A) :=
		associative m /\ neutral e m /\ exists_inverse m e.
	Definition isAbelian_Group A (m:prod A) (e:A) :=
		associative m /\ neutral e m /\ exists_inverse m e /\ commutative m.
End Definitions.

Section Nat.
	Fixpoint add (m:nat) : nat->nat :=
		match m with
			| O => (fun n:nat => n)
			| S m => (fun n:nat => S (add m n) )
		end.

	(*Addition is defined recursively on the first variable.
	It also decreases on second variable: *)
	Lemma pred_second : forall m n : nat, add m (S n) = S (add m n).
	Proof.
		intros m n.
		induction m.
		(*Base case*) * reflexivity.
		(*Induction step*) *
			simpl.
			rewrite IHm. reflexivity.
	Defined.

	Lemma addzero : forall n : nat, add n 0 = n.
	Proof.
	induction n. reflexivity. (*Base case done*)
	(*Induction step:*)
	simpl. rewrite IHn. reflexivity.
	Defined.

	Lemma zeroadd : forall n : nat, add 0 n = n.
	Proof. reflexivity. Defined.

	Lemma add_associative : forall l m n:nat, add (add l m) n = add l (add m n).
		induction l.
			induction m.
				induction n.
					(*l m n = 0*) * reflexivity.
					(*l = m = 0, Step n*)* reflexivity.
					(*l = 0, Step m *)* reflexivity.
					(*Step l*)*
						intros m n.
						simpl.
						apply (ap S).
						apply IHl.
	Defined.

	Lemma add_commutative : forall n m:nat, add n m = add m n.
		induction n.
		(*Base case*) *
			intro m.
			rewrite addzero. reflexivity.
		(*Induction step*) *
			intro m.
			simpl.
			rewrite IHn.
			symmetry.
			apply pred_second.
	Defined.

	Proposition nat_comm_monoid : isCommutative_Monoid nat add O.
		unfold isCommutative_Monoid.
		split.
			(*Associativity*) *
					unfold associative.
					apply add_associative.
				* split.
				(*Neutral element*) **
					unfold neutral.
					intro n.
					split.
							***apply zeroadd. ***apply addzero.
			(*Commutativity*) **
				unfold commutative.
				apply add_commutative.
	Defined.

	(*Define addition by recursion on the second variable.*)
	Fixpoint add' (m n : nat) : nat :=
		match n with
		|O => m
		|S n1 => S (add' m n1)
	end.

	Proposition equaladditions : forall m n:nat, add m n = add' m n.
		induction n.
		(*Base case*) * simpl. rewrite addzero. reflexivity.
		(*Induction step*) *
			simpl.
			rewrite pred_second.
			rewrite IHn.
			reflexivity.
	Defined.

	(*Slightly different proof showing that the two additions are equal (doesn't use lemmas)*)
	Proposition equaladditions2 : forall m n:nat, add m n = add' m n.
		induction m.
		(*Base case m*) *
			induction n.
				(*Base case n*) ** reflexivity.
				(*Induction step n*) **
					simpl.
					rewrite <- IHn.
					reflexivity.
		(*Induction step m*) *
 			intro n.
			simpl.
			rewrite IHm.
				induction n.
					(*Base case n*) ** reflexivity.
					(*Induction step n*) **
						simpl.
						rewrite IHn. reflexivity.
	Defined.

End Nat.

Section Bad_Idea.
	Inductive Z' : Set :=
		|minus (n0 n1:nat) : Z'
	.

	Axiom eq_Z : forall m1 m2 n1 n2 : nat,
		add m1 n2 = add n1 m2 <-> minus m1 m2 = minus n1 n2.

	Definition f (n : Z') : nat :=
		match n with
			minus n1 n2 => n1
		end.

	Lemma eq1 : minus 1 1 = minus 0 0.
		apply eq_Z. reflexivity.
	Qed.

	Theorem wrong : 1=0.
		apply ((ap f) eq1).
	Qed.

End Bad_Idea.

Section Integers.

	Inductive Z : Set :=
		|subt (n0 n1:nat) : Z
	.

	Definition EqZ (m n : Z) : Type :=
		match m,n with
			| subt m1 m2, subt n1 n2 =>
				add m1 n2 = add m2 n1
		end.

	Lemma refl_Z : Reflexive EqZ.
		unfold Reflexive. Abort.

	(*TODO: This is equiv relation*)

	Definition WellDefined_Z {A:Type} (f:Z->A) : Type.
		(*TODO*) exact A. Defined.
(* 	Axiom eq_Z_1 : forall m1 m2 n1 n2 : nat,
		add m1 n2 = add n1 m2 -> subt m1 m2 = subt n1 n2.

	Axiom eq_Z_2 : forall m1 m2 n1 n2 : nat,
		subt m1 m2 = subt n1 n2 -> add m1 n2 = add n1 m2. *)

	Definition inj (n: nat) : Z := subt n O.

	Definition neg (m:Z) :=
		match m with
		|subt m1 m2 => subt m2 m1
	end.

(* 	Definition add_Z (m n : Z) : Z :=
		match m with
		| subt m1 m2 => match n with
			|subt n1 n2 => subt (add m1 n1) (add m2 n2)
		end
	end.
 *)
	Definition add_Z (m n : Z) : Z :=
		match m,n with
		|subt m1 m2, subt n1 n2 => subt (add m1 n1) (add m2 n2)
	end.

	Definition subt_Z (m n: Z) : Z :=
		add_Z m (neg n).

	Proposition injection : forall m n:nat, inj m = inj n -> m = n.
	Proof.
		unfold inj.
		intros m n p.
 		rewrite <- (addzero m). rewrite <- (addzero n).
		apply eq_Z_2.
		assumption.
	Defined.

	(*Abelian group axioms*)
	Lemma add_Z_associative : forall l m n : Z,
		add_Z (add_Z l m) n = add_Z l (add_Z m n).
	Proof.
		induction l.
		induction m.
		induction n.
		unfold add_Z.
		rewrite add_associative. rewrite add_associative. reflexivity.
	Defined.

	Lemma add_Z_commutative : forall m n : Z,
		add_Z m n = add_Z n m.
		induction m.
		induction n.
		simpl.
		rewrite (add_commutative n2 n0). rewrite (add_commutative n3 n1). reflexivity.
	Defined.

	Definition O_Z := subt O O.

	Lemma addzero_Z : forall n : Z, add_Z n O_Z = n.
	Proof.
		induction n.
		unfold O_Z.
		unfold add_Z.
		rewrite addzero. rewrite addzero. reflexivity.
	Defined.
	Lemma zeroadd_Z : forall n : Z, add_Z O_Z n = n.
		induction n.
		unfold O_Z.
		unfold add_Z.
		rewrite zeroadd. rewrite zeroadd. reflexivity.
	Defined.

	Lemma inverse_neg : forall n : Z, add_Z n (neg n) = O_Z /\ add_Z (neg n) n = O_Z.
	Proof.
		induction n.
		unfold neg.
		unfold add_Z.
		unfold O_Z.
		split.
		*apply eq_Z_1.
		rewrite addzero. rewrite zeroadd.
		apply add_commutative.
		*apply eq_Z_1.
		rewrite addzero. rewrite zeroadd.
		apply add_commutative.
	Defined.

	Proposition Z_abelian : isAbelian_Group Z add_Z O_Z.
		unfold isAbelian_Group.

		split.
		(*Associativity*) *
			unfold associative. apply add_Z_associative.
		* split.
		(*Neutral element*) **
			unfold neutral. intro n. split.
				***apply zeroadd_Z. ***apply addzero_Z.
		** split.
		(*Exists inverse*) ***
			unfold exists_inverse.
				intro n.
				exists (neg n). apply inverse_neg.
		(*Commutativity*) ***
			unfold commutative.
			apply add_Z_commutative.
	Defined.

End Integers.

Section Problem.
	Definition f (n : Z) : nat :=
		match n with
			subt n1 n2 => n1
		end.

	Lemma eq1 : subt 1 1 = subt 0 0.
		apply eq_Z_1. reflexivity.
	Qed.

	Theorem wrong : 1=0.
		apply ((ap f) eq1).
	Qed.


Require Import Unicode.Utf8.
Require Import Game.Mynat.Definition.
Require Import Game.Mynat.Add.

(* Level 1 *)
(* `induction a`: induction on term `a` *)

Lemma zero_add (a : mynat) : 0 + a = a.
Proof.
  induction a.
  rewrite add_zero.
  reflexivity.
  rewrite add_succ.
  rewrite IHa.
  reflexivity.
Qed.

(* Level 2 *)

Lemma add_assoc (a b c : mynat) : (a + b) + c = a + (b + c).
Proof.
  induction c.
  rewrite add_zero.
  rewrite add_zero.
  reflexivity.
  rewrite add_succ.
  rewrite IHc.
  rewrite add_succ.
  rewrite add_succ.
  reflexivity.
Qed.

(* Level 3 *)

Lemma succ_add (a b : mynat) : succ a + b = succ (a + b).
Proof.
  induction b.
  rewrite add_zero.
  rewrite add_zero.
  reflexivity.
  rewrite add_succ.
  rewrite IHb.
  rewrite add_succ.
  reflexivity.
Qed.

(* Level 4 *)

Lemma add_comm (a b : mynat) : a + b = b + a.
Proof.
  induction b.
  rewrite add_zero.
  rewrite zero_add.
  reflexivity.
  rewrite add_succ.
  rewrite IHb.
  rewrite succ_add.
  reflexivity.
Qed.

(* Level 5 *)

Theorem succ_eq_add_one (n : mynat) : succ n = n + 1.
Proof.
  rewrite one_eq_succ_zero.
  rewrite add_succ.
  rewrite add_zero.
  reflexivity.
Qed.

(* Level 6 *)
(* `rewrite (f x)`: Substitute `f` with bindings `x` *)

Lemma add_right_comm (a b c : mynat) : a + b + c = a + c + b.
Proof.
  rewrite add_assoc.
  rewrite (add_comm b c).
  rewrite add_assoc.
  reflexivity.
Qed.


From Coq Require Import List. Import ListNotations.
From Coq Require Import ZArith.

Inductive even : nat -> Prop :=
  | even_0 : even 0
  | even_SS (n : nat) (H : even n) : even (S (S n)).

Theorem plus_2_even_inv : forall n: nat,
  even (S (S n)) -> even n.
Proof.
  intros n H. inversion H as [ | ns IHn Eq ]. apply IHn.
Qed.

Open Scope Z_scope.

Inductive sorted : list Z -> Prop :=
  | sorted0 : sorted nil
  | sorted1 : forall z : Z, sorted (z :: nil)
  | sorted2 :
      forall (z1 z2: Z) (l: list Z),
        z1 <= z2 ->
        sorted (z2 :: l) -> sorted (z1 :: z2 :: l).

Theorem sorted_inv: forall (z : Z) (l : list Z),
  sorted (z :: l) -> sorted l.
Proof.
  intros.
  inversion H as [ | | z1 z2 L Cond Heq ].
  - apply sorted0.
  - apply Heq.
Qed.


Require Export P01.

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p. induction n.
  - reflexivity.
  - simpl. rewrite -> IHn. reflexivity.
Qed.


Record Category5 : Type := category5
    { Obj5          : Type
    ; Hom5          : Obj5 -> Obj5 -> Type
    ; compose5      : forall (a b c:Obj5), Hom5 a b -> Hom5 b c -> Hom5 a c
    ; id5           : forall (a:Obj5), Hom5 a a
    ; proof_idl5    : forall (a b:Obj5)(f:Hom5 a b), compose5 _ _ _ (id5 a) f = f
    ; proof_idr5    : forall (a b:Obj5)(f:Hom5 a b), compose5 _ _ _ f (id5 b) = f
    ; proof_asc5    : forall (a b c d:Obj5)(f:Hom5 a b)(g:Hom5 b c)(h:Hom5 c d),
        compose5 _ _ _ (compose5 _ _ _ f g) h =
        compose5 _ _ _ f (compose5 _ _ _ g h)
    }
    .

Definition Obj (C:Category5) : Type := Obj5 C.
Definition Hom (C:Category5)(a b:Obj C) : Type := Hom5 C a b.

Arguments Hom {C} _ _.

Definition compose(C:Category5)(a b c:Obj C)(f:Hom a b)(g:Hom b c) : Hom a c :=
    compose5 C _ _ _ f g.

Arguments compose {C} {a} {b} {c} _ _.

Definition id (C:Category5) (a:Obj C) : Hom a a := id5 C a.

Arguments id {C} _.

Notation "f ; g" := (compose f g) (at level 40, left associativity).

Theorem id_left : forall (C:Category5) (a b:Obj C) (f: Hom a b), id a ; f = f.
Proof. intros C a b f. apply proof_idl5. Qed.

Theorem id_right : forall (C:Category5) (a b:Obj C) (f: Hom a b), f ; id b = f.
Proof. intros C a b f. apply proof_idr5. Qed.

Theorem compose_assoc : forall (C:Category5) (a b c d:Obj C),
    forall (f:Hom a b) (g:Hom b c) (h: Hom c d),
        (f ; g) ; h = f ; (g ; h).
Proof. intros C a b c d f g h. apply proof_asc5. Qed.


Require Import List. Import ListNotations.
Require Import Coq.ZArith.BinInt. (* Z *)
Require Import XorCorrespondence. (* Blist *)
Require Import Integers.          (* byte *)
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import HMAC_functional_prog_Z.

Require Import Coq.Strings.Ascii.
Require Import Coq.Program.Tactics.
Require Import Bruteforce.

Open Scope Z_scope.

(* ----- Inductive *)

(* In XorCorrespondence *)
(* Definition asZ (x : bool) : Z := if x then 1 else 0. *)

(*
Definition convertByteBits (bits : Blist) (byte : Z) : Prop :=
  exists (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
   bits = [b0; b1; b2; b3; b4; b5; b6; b7] /\
   byte =  (1 * (asZ b0) + 2 * (asZ b1) + 4 * (asZ b2) + 8 * (asZ b3)
         + 16 * (asZ b4) + 32 * (asZ b5) + 64 * (asZ b6) + 128 * (asZ b7)).
*)

Inductive bytes_bits_lists : Blist -> list Z -> Prop :=
  | eq_empty : bytes_bits_lists nil nil
  | eq_cons : forall (bits : Blist) (bytes : list Z)
                     (b0 b1 b2 b3 b4 b5 b6 b7 : bool) (byte : Z),
                bytes_bits_lists bits bytes ->
                convertByteBits [b0; b1; b2; b3; b4; b5; b6; b7] byte ->
                bytes_bits_lists (b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: bits)
                                 (byte :: bytes).

(* ----- Computational *)

(* TODO: assumes Z is positive and in range, does not use Z.positive *)

Definition div_mod (num : Z) (denom : Z) : bool * Z :=
  (Z.gtb (num / denom) 0, num mod denom).

Eval compute in div_mod 129 128.
Eval compute in div_mod 1 64.

Definition byteToBits (byte : Z) : Blist :=
  let (b7, rem7) := div_mod byte 128 in
  let (b6, rem6) := div_mod rem7 64 in
  let (b5, rem5) := div_mod rem6 32 in
  let (b4, rem4) := div_mod rem5 16 in
  let (b3, rem3) := div_mod rem4 8 in
  let (b2, rem2) := div_mod rem3 4 in
  let (b1, rem1) := div_mod rem2 2 in
  let (b0, rem0) := div_mod rem1 1 in
  [b0; b1; b2; b3; b4; b5; b6; b7].

Fixpoint bytesToBits (bytes : list Z) : Blist :=
  match bytes with
    | [] => []
    | byte :: xs => byteToBits byte ++ bytesToBits xs
  end.

Definition bitsToByte (bits : Blist) : Z :=
  match bits with
    | b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: nil =>
      1 * (asZ b0) + 2 * (asZ b1) + 4 * (asZ b2) + 8 * (asZ b3)
      + 16 * (asZ b4) + 32 * (asZ b5) + 64 * (asZ b6) + 128 * (asZ b7)
    | _ => -1                   (* should not happen *)
  end.

Fixpoint bitsToBytes (bits : Blist) : list Z :=
  match bits with
    | b0 :: b1 :: b2 :: b3 :: b4 :: b5 :: b6 :: b7 :: xs =>
      bitsToByte [b0; b1; b2; b3; b4; b5; b6; b7] :: bitsToBytes xs
    | _ => []
  end.

(* -------------------- Various theorems and lemmas *)

Lemma bytes_bits_length : forall (bits : Blist) (bytes : list Z),
  bytes_bits_lists bits bytes -> length bits = (length bytes * 8)%nat.
Proof.
  intros bits bytes corr.
  induction corr.
  - reflexivity.
  - simpl. repeat f_equal. apply IHcorr.
Qed.

Lemma bytesToBits_app : forall (l1 l2 : list Z),
                          bytesToBits (l1 ++ l2) = bytesToBits l1 ++ bytesToBits l2.
Proof.
  induction l1; intros.
  * reflexivity.
  *
    simpl. rewrite -> IHl1. reflexivity.
Qed.

Lemma bytesToBits_len : forall (l : list Z),
                          length (bytesToBits l) = (length l * 8)%nat.
Proof.
  induction l; intros; try reflexivity.
  -
    simpl.
    rewrite -> IHl.
    reflexivity.
Qed.

(* Prove by brute force (test all Z in range) *)
Theorem byte_bit_byte_id : forall (byte : Z),
                             0 <= byte < 256 ->
                                bitsToByte (byteToBits byte) = byte.
Proof.
  intros byte range.
  do_range range reflexivity.
Qed.

Theorem bits_byte_bits_id : forall (b0 b1 b2 b3 b4 b5 b6 b7 : bool),
                              [b0; b1; b2; b3; b4; b5; b6; b7] =
                              byteToBits (bitsToByte [b0; b1; b2; b3; b4; b5; b6; b7]).
Proof.
  intros.
  destruct b0; destruct b1; destruct b2; destruct b3;
  destruct b4; destruct b5; destruct b6; destruct b7;
  reflexivity.
Qed.

Theorem bytes_bits_bytes_id : forall (bytes : list Z),
                                Forall (fun b => 0 <= b < 256) bytes ->
                                bitsToBytes (bytesToBits bytes) = bytes.
Proof.
  intros range bytes.
  induction bytes as [ | byte bytes].
  - reflexivity.
  -
    unfold bytesToBits.
    fold bytesToBits.
    unfold byteToBits.
    unfold bitsToBytes.
    Opaque bitsToByte. Opaque bitsToBytes. Opaque bytesToBits.
    simpl.
    Transparent bitsToBytes. fold bitsToBytes.
    rewrite -> IHbytes.

    Transparent bitsToByte.
    unfold bitsToByte. f_equal.
    apply byte_bit_byte_id.

    apply H. Transparent bytesToBits.
Qed.

Close Scope string_scope.

(* ------------------ Theorems relating inductive and computational definitions *)

Theorem bytes_bits_def_eq : forall (bytes : list Z),
                              Forall (fun b => 0 <= b < 256) bytes ->
                              bytes_bits_lists (bytesToBits bytes) bytes.
Proof.
  intros range bytes.
  induction bytes as [ | byte bytes ].
  -
    simpl. apply eq_empty.
  -
    apply eq_cons.

    *
      apply IHbytes.
    *
      unfold convertByteBits.
      do 8 eexists.
      split.
      +
        reflexivity.
      +
        do_range H reflexivity.
Qed.

Theorem bytes_bits_comp_ind : forall (bits : Blist) (bytes : list Z),
                               Forall (fun b => 0 <= b < 256) bytes ->
                               bits = bytesToBits bytes ->
                               bytes_bits_lists bits bytes.
Proof.
  intros bits bytes range corr.
  rewrite -> corr.
  apply bytes_bits_def_eq.
  assumption.
Qed.

Theorem bytes_bits_ind_comp : forall (bits : Blist) (bytes : list Z),
                                 Forall (fun b => 0 <= b < 256) bytes ->
                                 bytes_bits_lists bits bytes ->
                                 bytes = bitsToBytes bits.
Proof.
  intros bits bytes range corr.
  induction corr.
  - reflexivity.
  -
    rewrite -> IHcorr.
    *
      unfold convertByteBits in H.
      unfold bitsToBytes.
      fold bitsToBytes.
      f_equal.

      assert (range' : 0 <= byte < 256). admit.

      unfold bitsToByte.
      Print convertByteBits.
      destruct_exists. destruct H7. inversion H7.
      subst. reflexivity.

      * admit.                  (* bytes in range *)
Qed.

Theorem bits_bytes_ind_comp : forall (bits : Blist) (bytes : list Z),
                                 Forall (fun b => 0 <= b < 256) bytes ->
                                 bytes_bits_lists bits bytes ->
                                 bits = bytesToBits bytes.
Proof.
  intros bits bytes range corr.
  induction corr.
  - reflexivity.
  -
    unfold convertByteBits in H.
    destruct_exists.
    destruct H7.
    inversion H7.
    subst.
    clear H7.
    rewrite -> IHcorr.
    unfold bytesToBits.
    fold bytesToBits.
    assert (list_8 : forall {A : Type} (e0 e1 e2 e3 e4 e5 e6 e7 : A) (l : list A),
                       e0 :: e1 :: e2 :: e3 :: e4 :: e5 :: e6 :: e7 :: l =
                       [e0; e1; e2; e3; e4; e5; e6; e7] ++ l).
    reflexivity.
    rewrite -> list_8.
    f_equal.
    apply bits_byte_bits_id.

    admit.                      (* in range *)
Qed.


Variables P Q R : Prop.

Theorem one : (P /\ ~ P) -> Q.

Proof.
  intro pnpH.
  destruct pnpH as [pH npH].
  cut False.                        (* assume a contradiction *)
  intro fH.
  case fH.
  apply npH.                    (* ~p <-> p -> False *)
  exact pH.
Qed.

Theorem C : (P -> Q -> R) -> (Q -> P -> R).

Proof.
  intro pqrH.
  intro qH.
  intro pH.
  apply pqrH.
  exact pH.
  exact qH.
Qed.

(* simply use auto *)

Theorem C1 : (P -> Q -> R) -> (Q -> P -> R).

Proof.
  auto.
Qed.

Section auto.
  Variables P1 P2 P3 P4 P5 P6 : Prop.

  Theorem had : (P1 -> P2) -> (P2 -> P3) -> (P3 -> P4) -> (P4 -> P5) -> (P5 -> P6) -> (P1 -> P6).
  Proof.
    auto 6.
  Qed.

  (* suger *)
  Goal (P1 \/ P1) -> P1.
  tauto.
  Save p1.

  Print p1.
End auto.

Require Import Coq.Logic.Classical.

Print classic. (* Axiom tnd : P \/ ~ P. *)

Theorem nnpp : ~~ P -> P.

Proof.
  cut (P \/ ~P).
  intro pnpH.
  case pnpH.
  intros pH nnpH.
  exact pH.
  intros npH nnpH.
  unfold not in npH.
  unfold not in nnpH.
  contradict nnpH.              (* a small trick *)
  exact npH.
  apply classic.
Qed.


From mathcomp
  Require Import ssreflect ssrnat.

Hypothesis ExMidLaw : forall P : Prop, P \/ ~P.

Lemma notnotEq (P : Prop) : ~ ~ P -> P.
Proof.
  move=> HnotnotP.
  - case: (ExMidLaw (~ P)).
    + by move /HnotnotP.
    + by case: (ExMidLaw P).
Qed.

(* 問2.2 *)
Lemma ex2_2 : forall A B C : Prop, (A -> B) /\ (B -> C) -> (A -> C).
Proof.
  move=> A B C; case.
  move=> Hyp1 Hyp2 Hyp3.
  by apply: (Hyp2 (Hyp1 Hyp3)).
Qed.

(* 問2.7 *)
Lemma ex2_7 (A B : Prop) : ~(A /\ B) <-> (~A) \/ (~B).
Proof.
  apply: conj.
  + move=> HnotAandB.
    case: (ExMidLaw ((~A) \/ (~B))).
    + by [].
    + case: (ExMidLaw A).
      + move=> HA HnotnotAornotB.
        case: (ExMidLaw B).
        + move=> HB.
          case: HnotAandB.
          apply: conj.
          by [].
          by [].
        + move=> HnotB.
          right.
          by [].
      + move=> HnotA HnotnotAornotB.
        left.
        by [].
  + move=> HnotAornotB HAandB.
    case: HnotAornotB.
    + case: HAandB.
      by [].
    + case: HAandB.
      by [].
Qed.

(* 問2.8 *)
Lemma ex2_8 (T : Type) (P : T -> Prop) : ~(forall x : T, P x) <-> (exists x : T, ~P x).
Proof.
  apply: conj.
  + move=> HnotforallPx.
    apply: notnotEq.
    move=> HnotexistsnotPx.
    apply: HnotforallPx.
    move=> x.
    apply: notnotEq.
    move=> HnotforallPx.
    apply HnotexistsnotPx.
    exists x.
    by [].
  + case.
    move=> x HnotPx HnotforallPx.
    apply: HnotPx.
    move: x.
    by [].
Qed.


Require Export BinPos.

Fixpoint Pshift (n:nat) (x:positive) {struct n} : positive :=
match n with
| O => x
| (S m) => xO (Pshift m x)
end.

Definition Pow2 (n:nat) := Pshift n 1.

Local Open Scope positive_scope.

Lemma Pshift1 : forall x y n, (Pshift n x)*y=(Pshift n (x*y)).
Proof.
induction n;
simpl;
congruence.
Qed.

Lemma Pshift2 : forall x n m, (Pshift n (Pshift m x))=(Pshift (n+m) x).
Proof.
induction n;
simpl;
intros;
try rewrite IHn;
reflexivity.
Qed.

Lemma Pshift3 : forall x y n, (Pshift n x)+(Pshift n y)=(Pshift n (x+y)).
Proof.
induction n;
simpl;
congruence.
Qed.

Lemma PshiftExpand : forall x n, (Pshift n x)= (Pow2 n)*x.
Proof.
intros.
unfold Pow2.
rewrite Pshift1.
reflexivity.
Qed.

Hint Rewrite PshiftExpand : PshiftExpand.
Hint Rewrite <- Pshift2 : PshiftExpand.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := cons : Nat -> Lst -> Lst |  nil : Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint plus (plus_arg0 : Nat) (plus_arg1 : Nat) : Nat
           := match plus_arg0, plus_arg1 with
              | zero, n => n
              | succ n, m => succ (plus n m)
              end.

Fixpoint half (half_arg0 : Nat) : Nat
           := match half_arg0 with
              | zero => zero
              | succ zero => zero
              | succ (succ n) => succ (half n)
              end.

Lemma lem: forall m n, plus (succ m) n = plus m (succ n).
Proof.
intros. simpl. induction m.
  - simpl. rewrite IHm. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : Nat), eq (half (plus x x)) x.
Proof.
induction x.
  - simpl. destruct x.
    * simpl. rewrite <- lem. rewrite IHx. reflexivity.
    * reflexivity.
  - reflexivity.
Qed.


Require Import Arith.
Require Import List.
Require Import Ascii.
Import ListNotations.
Require Import Omega.

Require Import StructTact.StructTactics.
Require Import oeuf.StuartTact.
Require Import Recdef.

(* "String to nat" conversion, for use as a spec.

   The "strings" throughout this module are actually lists of nats, where each
   nat is a single digit 0-9.  They're stored little-endian, so `123` is
   represented as the list `[3; 2; 1]`.
 *)
Fixpoint s2n' (s : list nat) (pow : nat) : nat :=
    match s with
    | [] => 0
    | n :: s' => pow * n + s2n' s' (pow * 10)
    end.

Definition s2n s := s2n' s 1.

(* Implementation *)

(* `inc` uses a modified little-endian representation, where each digit `n` is
   instead represented by `9 - n`.  This lets us use normal pattern matching
   instead of `eq_nat_dec` inside `inc`.

   Examples:

   "0" = [9]
   "1" = [8]
   "9" = [0]
   "10" = [9, 8]
   "19" = [0, 8]
   "20" = [9, 7]
   "123" = [6, 7, 8]
*)

Fixpoint inc s :=
    match s with
    | [] => [8]
    | 0 :: s' => 9 :: inc s'
    | S n' :: s' => n' :: s'
    end.

(* `fixup` converts a modified little-endian digit string to a normal one. *)
Definition fixup' n := 9 - n.
Definition fixup s := map fixup' s.

Fixpoint n2s' n s :=
    match n with
    | 0 => s
    | S n' => n2s' n' (inc s)
    end.

Definition n2s n := fixup (n2s' n []).

(* Main correctness proofs:
    (1) `s2n (n2s n) = n`
    (2) Forall (fun n => n <= 9) (n2s n)
 *)

Lemma s2n'_pow : forall s pow,
    s2n' s pow = pow * s2n s.
induction s; intros; unfold s2n in *; simpl in *.
{ omega. }
rewrite IHs. rewrite IHs with (pow := 10).
ring.
Qed.

(* We need this property for some of the proofs. *)
Definition digits_ok s := Forall (fun n => n <= 9) s.

Lemma inc_digits_ok : forall s,
    digits_ok s -> digits_ok (inc s).
induction s; intros0 Hok.
{ simpl. constructor; [ omega | constructor ]. }

simpl. break_match.
- invc Hok. constructor; eauto. eapply IHs; eauto.
- invc Hok. constructor; eauto. omega.
Qed.

(* fixup + s2n = fs2n *)
Definition fs2n s := s2n (fixup s).

Lemma inc_s2n : forall s, digits_ok s -> fs2n (inc s) = S (fs2n s).
induction s; intros0 Hok; simpl.
{ reflexivity. }

break_match.

- unfold fs2n, fixup, s2n in *. simpl in *.
  do 2 rewrite s2n'_pow.
  unfold s2n. rewrite IHs by (invc Hok; auto).
  ring.

- unfold fs2n, fixup, s2n in *. simpl in *.
  cut (fixup' n = S (fixup' (S n))). { intro. omega. }
  unfold fixup'. invc Hok. omega.
Qed.

Lemma n2s'_fs2n : forall n s, digits_ok s -> fs2n (n2s' n s) = n + fs2n s.
induction n; intros; simpl.
- reflexivity.
- rewrite IHn, inc_s2n; eauto.
  eapply inc_digits_ok; eauto.
Qed.

(* Main proof #1 *)
Lemma n2s_s2n : forall n, s2n (n2s n) = n.
intros.
unfold n2s. change (s2n (fixup ?x)) with (fs2n x).
rewrite n2s'_fs2n; eauto.
constructor.
Qed.

Lemma n2s'_digits_ok : forall n s, digits_ok s -> digits_ok (n2s' n s).
induction n; intros; simpl; auto using inc_digits_ok.
Qed.

Lemma fixup_digits_ok : forall s, digits_ok s -> digits_ok (fixup s).
induction s; intros0 Hok; simpl.
- constructor.
- invc Hok. constructor; eauto.
  + unfold fixup'. omega.
  + eapply IHs. eauto.
Qed.

(* Main proof #2 *)
Lemma n2s_digits_ok : forall n, digits_ok (n2s n).
intros. eapply fixup_digits_ok. eapply n2s'_digits_ok. constructor.
Qed.

(* Elim version *)

Definition inc_elim s :=
    list_rect (fun _ => list nat)
        [8]
        (fun n s' IHs =>
            nat_rect (fun _ => list nat)
                (9 :: IHs)
                (fun n' IHn => n' :: s')
                n)
        s.

Definition n2s_elim' n :=
    nat_rect (fun _ => list nat -> list nat)
        (fun s => s)
        (fun n' IHn s => IHn (inc_elim s))
        n.

Definition nat_sub_elim x y :=
    nat_rect (fun _ => nat -> nat)
        (fun y => 0)
        (fun x' IHx y =>
            nat_rect (fun _ => nat)
                (S x')
                (fun y' IHy => IHx y')
                y)
        x y.

Definition fixup'_elim n := nat_sub_elim 9 n.

Definition list_map_elim {A B} (f : A -> B) xs :=
    list_rect (fun _ => list B)
        []
        (fun x xs IHxs => f x :: IHxs)
        xs.

Definition fixup_elim s := list_map_elim fixup'_elim s.

Definition n2s_elim n :=
    fixup_elim (n2s_elim' n []).

(* Elim version equivalence proofs *)

Lemma inc_elim_eq : forall s, inc_elim s = inc s.
induction s; simpl.
{ reflexivity. }
break_match; simpl.
- congruence.
- reflexivity.
Qed.

Lemma n2s_elim'_eq : forall n s, n2s_elim' n s = n2s' n s.
induction n; intros; simpl.
- reflexivity.
- rewrite inc_elim_eq. eapply IHn.
Qed.

Lemma nat_sub_elim_eq : forall x y, nat_sub_elim x y = Nat.sub x y.
induction x; destruct y; simpl; try reflexivity.
rewrite <- IHx. reflexivity.
Qed.

Lemma fixup'_elim_eq : forall n, fixup'_elim n = fixup' n.
intros. unfold fixup'_elim, fixup'. eapply nat_sub_elim_eq.
Qed.

Lemma list_map_elim_eq : forall A B (f f' : A -> B) xs,
    (forall x, f x = f' x) ->
    list_map_elim f xs = List.map f' xs.
induction xs; intros; simpl.
- reflexivity.
- f_equal; eauto.
Qed.

Lemma fixup_elim_eq : forall s, fixup_elim s = fixup s.
intros. eapply list_map_elim_eq.
intros. eapply fixup'_elim_eq.
Qed.

Lemma n2s_elim_eq : forall n, n2s_elim n = n2s n.
intros. unfold n2s_elim, n2s.
rewrite n2s_elim'_eq, fixup_elim_eq.
reflexivity.
Qed.

(* Digit to string conversion *)

Definition digit_char n :=
    match n with
    | 0 => "0"%char
    | 1 => "1"%char
    | 2 => "2"%char
    | 3 => "3"%char
    | 4 => "4"%char
    | 5 => "5"%char
    | 6 => "6"%char
    | 7 => "7"%char
    | 8 => "8"%char
    | 9 => "9"%char
    | _ => "?"%char
    end.

Definition string_of_nat n := map digit_char (rev (n2s n)).
Eval compute in string_of_nat 123.

(* Digit to string with eliminators *)

Definition digit_char_elim n :=
    nat_rect (fun _ => ascii) "0"%char (fun n _ =>
    nat_rect (fun _ => ascii) "1"%char (fun n _ =>
    nat_rect (fun _ => ascii) "2"%char (fun n _ =>
    nat_rect (fun _ => ascii) "3"%char (fun n _ =>
    nat_rect (fun _ => ascii) "4"%char (fun n _ =>
    nat_rect (fun _ => ascii) "5"%char (fun n _ =>
    nat_rect (fun _ => ascii) "6"%char (fun n _ =>
    nat_rect (fun _ => ascii) "7"%char (fun n _ =>
    nat_rect (fun _ => ascii) "8"%char (fun n _ =>
    nat_rect (fun _ => ascii) "9"%char (fun n _ =>
        "?"%char) n) n) n) n) n) n) n) n) n) n.

(* Reimplementations of List.rev in a more Oeuf-friendly style *)
Fixpoint list_rev' {A} xs acc : list A :=
    match xs with
    | [] => acc
    | x :: xs => list_rev' xs (x :: acc)
    end.

Definition list_rev {A} xs : list A := list_rev' xs [].

(* Eliminator implementations of list_rev *)
Definition list_rev'_elim {A} xs acc :=
    list_rect (fun _ => list A -> list A)
        (fun acc => acc)
        (fun x xs IHxs acc => IHxs (x :: acc))
        xs acc.

Definition list_rev_elim {A} xs : list A := list_rev'_elim xs [].

Definition string_of_nat_elim n :=
    list_map_elim digit_char_elim (list_rev_elim (n2s_elim n)).

(* Proofs *)

Lemma digit_char_elim_eq : forall n, digit_char_elim n = digit_char n.
do 10 (destruct n; simpl; [reflexivity|]).
reflexivity.
Qed.

Lemma list_rev'_eq : forall A (xs acc : list A),
    list_rev' xs acc = List.rev xs ++ acc.
induction xs; intros; simpl.
- reflexivity.
- rewrite IHxs. rewrite <- app_assoc. reflexivity.
Qed.

Lemma list_rev_eq : forall A (xs : list A), list_rev xs = List.rev xs.
intros. unfold list_rev. rewrite list_rev'_eq. rewrite app_nil_r. reflexivity.
Qed.

Lemma list_rev'_elim_eq : forall A (xs acc : list A),
    list_rev'_elim xs acc = list_rev' xs acc.
induction xs; intros; simpl.
- reflexivity.
- rewrite IHxs. reflexivity.
Qed.

Lemma list_rev_elim_eq : forall A (xs : list A),
    list_rev_elim xs = list_rev xs.
intros. eapply list_rev'_elim_eq.
Qed.

Lemma string_of_nat_elim_eq : forall n, string_of_nat_elim n = string_of_nat n.
intros. unfold string_of_nat_elim, string_of_nat.
rewrite n2s_elim_eq. rewrite list_rev_elim_eq.  rewrite list_rev_eq.
eapply list_map_elim_eq. eapply digit_char_elim_eq.
Qed.