(* week-05_mystery-functions.v *)
(* FPP 2019 - YSC3236 2019-2020, Sem1 *)
(* Olivier Danvy <danvy@yale-nus.edu.sg> *)
(* Version of 10 Sep 2019 *)

(* ********** *)

Require Import Arith Bool.

Notation "A =n= B" :=
  (beq_nat A B) (at level 70, right associativity).

Notation "A =b= B" :=
  (eqb A B) (at level 70, right associativity).

Definition beq_nat_nat (p1 p2 : nat * nat) : bool :=
  match p1 with
  | (n11, n12) =>
    match p2 with
    | (n21, n22) =>
      (n11 =n= n21) && (n12 =n= n22)
    end
  end.

Notation "A =nn= B" :=
  (beq_nat_nat A B) (at level 70, right associativity).

(* ********** *)

Definition specification_of_mystery_function_00 (mf : nat -> nat) :=
  mf 0 = 1 /\ forall i j : nat, mf (S (i + j)) = mf i + mf j.

Proposition there_is_at_most_one_mystery_function_00 :
  forall f g : nat -> nat,
    specification_of_mystery_function_00 f ->
    specification_of_mystery_function_00 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_00.
  intros [H_f_O H_f_S] [H_g_O H_g_S].
  intro n.
  induction n as [ | n' IHn'].

  - rewrite -> H_g_O.
    exact H_f_O.

  - rewrite <- (Nat.add_0_l n').
    rewrite -> (H_f_S 0 n').
    rewrite -> (H_g_S 0 n').
    rewrite -> H_f_O.
    rewrite -> H_g_O.
    rewrite -> IHn'.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_00a (mf : nat -> nat) :=
  (mf 0 =n= 1) (* etc. *).

Definition unit_test_for_mystery_function_00b (mf : nat -> nat) :=
  (mf 0 =n= 1) && (mf 1 =n= 2) (* etc. *).

Definition unit_test_for_mystery_function_00c (mf : nat -> nat) :=
  (mf 0 =n= 1) && (mf 1 =n= 2) && (mf 2 =n= 3) (* etc. *).

Definition unit_test_for_mystery_function_00d (mf : nat -> nat) :=
  (mf 0 =n= 1) && (mf 1 =n= 2) && (mf 2 =n= 3) && (mf 3 =n= 4)
  (* etc. *).

Definition mystery_function_00 := S.

Definition less_succinct_mystery_function_00 (n : nat) : nat :=
  S n.

Compute (unit_test_for_mystery_function_00d mystery_function_00).

Theorem there_is_at_least_one_mystery_function_00 :
  specification_of_mystery_function_00 mystery_function_00.
Proof.
  unfold specification_of_mystery_function_00, mystery_function_00.
  split.
  - reflexivity.
  - intros i j.
    rewrite -> plus_Sn_m.
    rewrite <- plus_n_Sm.
    reflexivity.
Qed.

Definition mystery_function_00_alt := fun (n : nat) => n + 1.

Theorem there_is_at_least_one_mystery_function_00_alt :
  specification_of_mystery_function_00 mystery_function_00_alt.
Proof.
Abort.

Theorem soundness_of_the_unit_test_function_for_mystery_function_00 :
  forall mf : nat -> nat,
    specification_of_mystery_function_00 mf ->
    unit_test_for_mystery_function_00c mf = true.
Proof.
  unfold specification_of_mystery_function_00.
  unfold unit_test_for_mystery_function_00c.
  intros mf [H_O H_S].
  (* Goal: (mf 0 =n= 1) && (mf 1 =n= 2) && (mf 2 =n= 3) = true *)
  rewrite -> H_O.
  (* Goal: (1 =n= 1) && (mf 1 =n= 2) && (mf 2 =n= 3) = true *)
  rewrite -> (Nat.eqb_refl 1).
  (* Goal: true && (mf 1 =n= 2) && (mf 2 =n= 3) = true *)
  rewrite -> (andb_true_l (mf 1 =n= 2)).
  (* Goal: (mf 1 =n= 2) && (mf 2 =n= 3) = true *)
  (* etc. *)
  Check (Nat.add_1_l 0).
  rewrite <- (Nat.add_1_l 0) at 1.
  Check (plus_Sn_m 0 0).
  rewrite -> (plus_Sn_m 0 0).
  rewrite -> (H_S 0 0).
  rewrite -> H_O.
  rewrite -> (Nat.add_1_l 1).
  Check (Nat.eqb_refl 2).
  rewrite -> (Nat.eqb_refl 2).
  rewrite -> (andb_true_l (mf 2 =n= 3)).
  Check (Nat.add_1_l 1).
  rewrite <- (Nat.add_1_l 1) at 1.
  Check (plus_Sn_m 0 1).
  rewrite -> (plus_Sn_m 0 1).
  rewrite -> (H_S 0 1).
  rewrite -> H_O.
  rewrite <- (Nat.add_1_l 0) at 2.
  Check (plus_Sn_m 0 0).
  rewrite -> (plus_Sn_m 0 0).
  rewrite -> (H_S 0 0).
  rewrite -> H_O.
  rewrite -> (Nat.add_1_l 1).
  rewrite -> (Nat.add_1_l 2).
  exact (Nat.eqb_refl 3).
Qed.

Theorem soundness_of_the_unit_test_function_for_mystery_function_00b :
  forall mf : nat -> nat,
    specification_of_mystery_function_00 mf ->
    unit_test_for_mystery_function_00b mf = true.
Proof.
  unfold specification_of_mystery_function_00,
         unit_test_for_mystery_function_00b.
  intros mf [H_O H_S].
  (* Goal: (mf 0 =n= 1) && (mf 1 =n= 2) = true *)
  rewrite -> H_O.
  (* Goal: (1 =n= 1) && (mf 1 =n= 2) = true *)
  rewrite -> (Nat.eqb_refl 1).
  (* Goal: true && (mf 1 =n= 2) = true *)
  rewrite -> (andb_true_l (mf 1 =n= 2)).
  (* Goal: (mf 1 =n= 2) = true *)
  (* etc. *)
  Check (Nat.add_1_l 0).
  rewrite <- (Nat.add_1_l 0) at 1.
  Check (plus_Sn_m 0 0).
  rewrite -> (plus_Sn_m 0 0).
  rewrite -> (H_S 0 0).
  rewrite -> H_O.
  Check (plus_Sn_m 0 1).
  rewrite -> (plus_Sn_m 0 1).
  Check (Nat.add_1_r 0).
  rewrite -> (Nat.add_1_r 0).
  Check (Nat.eqb_refl 2).
  exact (Nat.eqb_refl 2).
Qed.

Theorem soundness_of_the_unit_test_function_for_mystery_function_00_with_Search :
  forall mf : nat -> nat,
    specification_of_mystery_function_00 mf ->
    unit_test_for_mystery_function_00b mf = true.
Proof.
  unfold specification_of_mystery_function_00,
         unit_test_for_mystery_function_00b.
  intros mf [H_O H_S].

  rewrite -> H_O.
  Search (beq_nat _  _ = true).
  Check (Nat.eqb_refl 1).
  rewrite -> (Nat.eqb_refl 1).
  Search (true && _ = _).
  Check (andb_true_l (mf 1 =n= 2)).
  rewrite -> (andb_true_l (mf 1 =n= 2)).

  Check (Nat.add_1_l 0).
  rewrite <- (Nat.add_1_l 0) at 1.
  Check (plus_Sn_m 0 0).
  rewrite -> (plus_Sn_m 0 0).
  rewrite -> (H_S 0 0).
  rewrite -> H_O.
  Check (plus_Sn_m 0 1).
  rewrite -> (plus_Sn_m 0 1).
  Check (Nat.add_1_r 0).
  rewrite -> (Nat.add_1_r 0).
  Check (Nat.eqb_refl 2).
  exact (Nat.eqb_refl 2).
Qed.

(* ********** *)

(* {SPECIFICATION_OF_MYSTERY_FUNCTION_11} *)
Definition specification_of_mystery_function_11 (mf : nat -> nat) :=
  mf 1 = 1
  /\
  forall i j : nat,
    mf (i + j) = mf i + 2 * i * j + mf j.

Theorem there_is_at_most_one_mystery_function_11:
  forall f g : nat -> nat,
    specification_of_mystery_function_11 f ->
    specification_of_mystery_function_11 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_11.
  intros [H_f_1 H_f_S] [H_g_1 H_g_S].
  intro n.
  induction n as [ | n' IHn'].

  - assert (H_tmp := H_f_S 0 0).
    rewrite -> (Nat.add_0_r 0) in H_tmp.
    rewrite -> (Nat.mul_0_r (2 * 0)) in H_tmp.
    rewrite -> (Nat.add_0_r (f 0)) in H_tmp.
    rewrite <- (Nat.add_0_r (f 0)) in H_tmp at 1.
    (* apply plus_reg_l in H_tmp. *)
    (* Yikes: *)
    Check plus_reg_l.
    Check (plus_reg_l 0 (f 0) (f 0)).
    apply (plus_reg_l 0 (f 0) (f 0)) in H_tmp.
    (* *)
    rewrite <- H_tmp.
    clear H_tmp.
    assert (H_tmp := H_g_S 0 0).
    rewrite -> (Nat.add_0_r 0) in H_tmp.
    rewrite -> (Nat.mul_0_r (2 * 0)) in H_tmp.
    rewrite -> (Nat.add_0_r (g 0)) in H_tmp.
    rewrite <- (Nat.add_0_r (g 0)) in H_tmp at 1.
    apply plus_reg_l in H_tmp.
    rewrite <- H_tmp.
    clear H_tmp.
    reflexivity.

  - Search (S _ = _).
    assert (H_tmp := plus_n_Sm n' 0).
    rewrite -> (Nat.add_0_r n') in H_tmp.
    rewrite -> H_tmp.
    rewrite -> (H_f_S n' 1).
    rewrite -> (H_g_S n' 1).
    rewrite -> IHn'.
    rewrite -> H_f_1.
    rewrite -> H_g_1.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_11 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 1) && (mf 2 =n= 4) && (mf 3 =n= 9)
(* etc. *).

Definition mystery_function_11 (n : nat) : nat :=
  n * n.

Compute (unit_test_for_mystery_function_11 mystery_function_11).

Theorem there_is_at_least_one_mystery_function_11 :
  specification_of_mystery_function_11 mystery_function_11.
Proof.
  unfold specification_of_mystery_function_11, mystery_function_11.
  split.
  - rewrite -> (Nat.mul_1_r 1).
    reflexivity.

  - intros i j.
    rewrite -> (Nat.mul_add_distr_r i j (i + j)).
    rewrite -> (Nat.mul_add_distr_l i i j).
    rewrite -> (Nat.mul_add_distr_l j i j).
    rewrite -> BinInt.ZL0.
    rewrite -> (Nat.mul_add_distr_r 1 1 i).
    rewrite -> Nat.mul_1_l.
    rewrite -> (Nat.mul_add_distr_r i i j).
    rewrite -> (Nat.mul_comm j i).
    rewrite -> (Nat.add_assoc (i * i + i * j) (i * j) (j * j)).
    rewrite -> (Nat.add_assoc (i * i) (i * j) (i * j)).
    reflexivity.
Qed.

(* ***** *)

Definition specification_of_mystery_function_04 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  forall n' : nat,
    mf (S n') = mf n' + S (2 * n').

Lemma equivalence_of_successor_and_add_one : (* Ahem, Check Nat.add_1_r. *)
  forall n : nat,
    S n = n + 1.
Proof.
  intro n.
  rewrite <- (Nat.add_0_r n) at 1.
  rewrite -> (plus_n_Sm n 0).
  reflexivity.
Qed.

Lemma equivalence_of_times_two_and_add_itself :
  forall n : nat,
    2 * n = n + n.
Proof.
  intro n.
  rewrite -> BinInt.ZL0.
  rewrite -> (Nat.mul_add_distr_r 1 1 n).
  rewrite -> (Nat.mul_1_l n).
  reflexivity.
Qed.

Lemma distributive_law_l_r :
  forall a b c d : nat,
    (a + b) * (c + d) = a * c + a * d + b * c + b * d.
Proof.
  intros a b c d.
  rewrite -> Nat.mul_add_distr_r.
  rewrite -> Nat.mul_add_distr_l.
  rewrite -> (Nat.mul_add_distr_l b c d).
  rewrite -> (Nat.add_assoc (a * c + a * d) (b * c) (b * d)).
  reflexivity.
Qed.

Theorem there_is_at_most_one_mystery_function_04:
  forall f g : nat -> nat,
    specification_of_mystery_function_04 f ->
    specification_of_mystery_function_04 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_04.
  intros [H_f_O H_f_S] [H_g_O H_g_S].
  intro n.
  induction n as [ | n' IHn'].

  - rewrite -> H_g_O.
    exact (H_f_O).

  - rewrite -> (H_f_S n').
    rewrite -> (H_g_S n').
    rewrite -> IHn'.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_04 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 1) && (mf 2 =n= 4) && (mf 3 =n= 9)
(* etc. *).

Definition mystery_function_04 (n : nat) : nat :=
  n * n.

Compute (unit_test_for_mystery_function_04 mystery_function_04).

Theorem there_is_at_least_one_mystery_function_04 :
  specification_of_mystery_function_04 mystery_function_04.
Proof.
  unfold specification_of_mystery_function_04, mystery_function_04.
  split.
  - rewrite -> (Nat.mul_0_r 0).
    reflexivity.

  - intros n'.
    rewrite -> (equivalence_of_times_two_and_add_itself n').
    rewrite -> equivalence_of_successor_and_add_one.
    rewrite -> (equivalence_of_successor_and_add_one (n' + n')).
    rewrite -> distributive_law_l_r.
    rewrite -> (Nat.mul_1_r n').
    rewrite -> (Nat.mul_1_l n').
    rewrite -> (Nat.mul_1_l 1).
    rewrite -> (Nat.add_assoc (n' * n') (n' + n')  1).
    rewrite -> (Nat.add_assoc (n' * n') n' n').
    reflexivity.
Qed.

(* ***** *)

Definition specification_of_mystery_function_15 (mf : nat -> nat * nat) :=
  mf 0 = (0, 1)
  /\
  forall n' : nat,
    mf (S n') = let (x, y) := mf n'
                in (S x, y * S x).

Theorem there_is_at_most_one_mystery_function_15:
  forall f g : nat -> nat * nat,
    specification_of_mystery_function_15 f ->
    specification_of_mystery_function_15 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_15.
  intros [H_f_O H_f_S] [H_g_O H_g_S].
  intro n.
  induction n as [ | n' IHn'].

  - rewrite -> H_g_O.
    exact (H_f_O).

  - rewrite -> H_f_S.
    rewrite -> H_g_S.
    rewrite -> IHn'.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_15 (mf : nat -> nat * nat) :=
  (mf 0 =nn= (0, 1)) && (mf 1 =nn= (1, 1)) && (mf 2 =nn= (2, 2)) && (mf 3 =nn= (3, 6)).

(* etc. *)

Fixpoint fac (n : nat) : nat :=
  match n with
  | 0 => 1
  | S n' => (fac n') * n
  end.

Definition mystery_function_15 (n : nat) : nat * nat :=
  (n, fac n).

Compute (unit_test_for_mystery_function_15 mystery_function_15).

Theorem there_is_at_least_one_mystery_function_15:
  specification_of_mystery_function_15 mystery_function_15.
Proof.
  unfold specification_of_mystery_function_15, mystery_function_15.
  split.
  - unfold fac.
    reflexivity.

  - intro n'.
    unfold fac.
    fold fac.
    reflexivity.
Qed.
    (* ***** *)

Definition specification_of_mystery_function_16 (mf : nat -> nat * nat) :=
  mf 0 = (0, 1)
  /\
  forall n' : nat,
    mf (S n') = let (x, y) := mf n'
                in (y, x + y).

Theorem there_is_at_most_one_mystery_function_16:
  forall f g : nat -> nat * nat,
    specification_of_mystery_function_16 f ->
    specification_of_mystery_function_16 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_16.
  intros [H_f_O H_f_S] [H_g_O H_g_S].
  intro n.
  induction n as [ | n' IHn'].

  - rewrite -> H_g_O.
    exact (H_f_O).

  - rewrite -> H_f_S.
    rewrite -> H_g_S.
    rewrite -> IHn'.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_16 (mf : nat -> nat * nat) :=
  (mf 0 =nn= (0, 1)) && (mf 1 =nn= (1, 1)) && (mf 2 =nn= (1, 2)) && (mf 3 =nn= (2, 3)).

Fixpoint fib (n : nat) : nat :=
  match n with
  | O => 0
  | (S n') =>
    match n' with
    | O => 1
    | (S n'') => (fib n'') + (fib n')
    end
  end.

Definition mystery_function_16 (n : nat) : nat * nat :=
  (fib n, fib (S n)).

Compute (unit_test_for_mystery_function_16 mystery_function_16).

Theorem there_is_at_least_one_mystery_function_16:
  specification_of_mystery_function_16 mystery_function_16.
Proof.
  unfold specification_of_mystery_function_16, mystery_function_16.
  split.
  - unfold fib.
    reflexivity.

  - intro n'.
    unfold fib.
    fold fib.
    reflexivity.
Qed.

(* ***** *)

Lemma triple_induction (P : nat -> Prop) :
  P 0 ->
  P 1 ->
  P 2 ->
  (forall n, P n -> P (S n) -> P (S (S n)) -> P (S (S (S n)))) ->
  forall n, P n.
Proof.
  intros H0 H1 H2 Hstep n.
  enough (P n /\ P (S n) /\ P (S (S n))) as [H [H_S H_SS]].
  - exact H.
  - induction n as [ | n [IH IH_S]].
    * exact (conj H0 (conj H1 H2)).
    * destruct IH_S as [IH_S_1 IH_S_2].
      + split.
        ++ exact IH_S_1.
        ++ split.
           +++ exact IH_S_2.
           +++ exact ((Hstep n) IH IH_S_1 IH_S_2).
Qed.

Definition specification_of_mystery_function_17 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  mf 1 = 1
  /\
  mf 2 = 1
  /\
  forall p q : nat,
    mf (S (p + q)) = mf (S p) * mf (S q) + mf p * mf q.

Theorem there_is_at_most_one_mystery_function_17:
  forall f g : nat -> nat,
    specification_of_mystery_function_17 f ->
    specification_of_mystery_function_17 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_17.
  intros [H_f_O [H_f_1 [H_f_2 H_f_S]]] [H_g_O [H_g_1 [H_g_2 H_g_S]]].
  intro n.
  induction n using triple_induction.

  - rewrite -> H_g_O.
    exact (H_f_O).

  - rewrite -> H_g_1.
    exact (H_f_1).

  - rewrite -> H_g_2.
    exact (H_f_2).

  - assert (H_tmp := H_f_S (n + 1) 1).
    Search (2 = 1 + 1).
    rewrite -> (Nat.add_1_r n) in H_tmp.
    rewrite -> (Nat.add_1_r (S n)) in H_tmp.
    rewrite -> H_tmp.
    rewrite -> H_f_2.
    rewrite -> H_f_1.
    clear H_tmp.
    assert (H_tmp := H_g_S (n + 1) 1).
    Search (2 = 1 + 1).
    rewrite -> (Nat.add_1_r n) in H_tmp.
    rewrite -> (Nat.add_1_r (S n)) in H_tmp.
    rewrite -> H_tmp.
    rewrite -> H_g_2.
    rewrite -> H_g_1.
    rewrite -> IHn1.
    rewrite -> IHn0.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_17 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 1) && (mf 2 =n= 1) && (mf 3 =n= 2)
(* etc. *).

Definition mystery_function_17 (n : nat) : nat :=
  fib n.

Compute (unit_test_for_mystery_function_17 mystery_function_17).

Theorem there_is_at_least_one_mystery_function_17 :
  specification_of_mystery_function_17 mystery_function_17.
Proof.
  unfold specification_of_mystery_function_17, mystery_function_17.
  split.
  { unfold fib.
    reflexivity.
  }
  split.
  { unfold fib.
    reflexivity.
  }
  split.
  { unfold fib.
    exact (Nat.add_0_l 1).
  }
  intros p q.
  induction p as [ | p' IHp'].

  - (* an induction proof *)
Abort.

(* ***** *)

Definition specification_of_mystery_function_18 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  mf 1 = 1
  /\
  mf 2 = 1
  /\
  forall n''' : nat,
    mf n''' + mf (S (S (S n'''))) = 2 * mf (S (S n''')).

Theorem there_is_at_most_one_mystery_function_18:
  forall f g : nat -> nat,
    specification_of_mystery_function_18 f ->
    specification_of_mystery_function_18 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_18.
  intros [H_f_O [H_f_1 [H_f_2 H_f_S]]] [H_g_O [H_g_1 [H_g_2 H_g_S]]].
  intro n.
  induction n using triple_induction.

  - rewrite -> H_g_O.
    exact (H_f_O).

  - rewrite -> H_g_1.
    exact (H_f_1).

  - rewrite -> H_g_2.
    exact (H_f_2).

  - assert (H_tmp := H_f_S n).
    assert (H_tmp2 := H_g_S n).
    rewrite -> IHn1 in H_tmp.
    rewrite <- H_tmp2 in H_tmp.
    rewrite -> IHn in H_tmp.
    Search (_ + _ = _ + _ -> _).
    exact ((plus_reg_l (f (S (S (S n)))) (g (S (S (S n)))) (g n) ) H_tmp).
Qed.

Definition unit_test_for_mystery_function_18 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 1) && (mf 2 =n= 1) && (mf 3 =n= 2)
(* etc. *).

Definition mystery_function_18 (n : nat) : nat :=
  fib n.

Compute (unit_test_for_mystery_function_18 mystery_function_18).

Theorem there_is_at_least_one_mystery_function_18 :
  specification_of_mystery_function_18 mystery_function_18.
Proof.
  unfold specification_of_mystery_function_18, mystery_function_18.
  split.
  { unfold fib.
    reflexivity.
  }
  split.
  { unfold fib.
    reflexivity.
  }
  split.
  { unfold fib.
    exact (Nat.add_0_l 1).
  }
  intro n.
  induction n as [ | n' IHn'].

  - unfold fib. fold fib.
    rewrite -> Nat.add_0_l.
    rewrite -> Nat.add_0_l.
    rewrite -> (Nat.mul_1_r 2).
    symmetry.
    exact BinInt.ZL0.

  - (* an induction proof *)
Abort.

(* ***** *)

Definition specification_of_mystery_function_03 (mf : nat -> nat -> nat) :=
  mf 0 0 = 0
  /\
  (forall i j: nat, mf (S i) j = S (mf i j))
  /\
  (forall i j: nat, S (mf i j) = mf i (S j)).

Theorem there_is_at_most_one_mystery_function_03:
  forall f g : nat -> nat -> nat,
    specification_of_mystery_function_03 f ->
    specification_of_mystery_function_03 g ->
    forall i j : nat,
      f i j = g i j.
Proof.
  intros f g.
  unfold specification_of_mystery_function_03.
  intros [H_f_O [H_f_S  H_f_S']] [H_g_O [H_g_S H_g_S']].
  intro i.
  induction i as [ | i' IHi'].

  - intro j.
    induction j as [ | j' IHj'].

    -- rewrite -> H_g_O.
       exact (H_f_O).
    -- rewrite <- (H_g_S' 0 j').
       rewrite <- (H_f_S' 0 j').
       rewrite <- IHj'.
       reflexivity.
  - intro j.
    rewrite -> (H_f_S i' j).
    rewrite -> (H_g_S i' j).
    rewrite -> IHi'.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_03 (mf : nat -> nat -> nat) :=
  (mf 0 0 =n= 0) && (mf 0 1 =n= 1) && (mf 1 0 =n= 1) && (mf 1 1 =n= 2) && (mf 1 2 =n= 3) && (mf 2 1 =n= 3) && (mf 2 2 =n= 4).

Fixpoint mystery_function_03 (i j : nat) : nat :=
  match i with
    | O => j
    | S i' => mystery_function_03 i' (S j)
  end.

Compute (unit_test_for_mystery_function_03 mystery_function_03).

Ltac fold_unfold_tactic name := intros; unfold name; fold name; reflexivity.

Lemma fold_unfold_mystery_function_03_O :
  forall j : nat,
   mystery_function_03 O j =
    j.
Proof.
  fold_unfold_tactic mystery_function_03.
Qed.

Lemma fold_unfold_mystery_function_03_S :
  forall i' j : nat,
    mystery_function_03 (S i') j =
    mystery_function_03 i' (S j).
Proof.
  fold_unfold_tactic mystery_function_03.
Qed.

Lemma about_mystery_function_03 :
  forall i j : nat,
    mystery_function_03 i (S j) = S (mystery_function_03 i j).
Proof.
  intro i.
  induction i as [ | i' IHi'].

  - intro j.
    rewrite -> (fold_unfold_mystery_function_03_O j).
    exact (fold_unfold_mystery_function_03_O (S j)).

  - intro j.
    rewrite -> (fold_unfold_mystery_function_03_S i' (S j)).
    rewrite -> (fold_unfold_mystery_function_03_S i' j).
    Check (IHi' (S j)).
    exact (IHi' (S j)).
Qed.

Theorem there_is_at_least_one_mystery_function_03:
  specification_of_mystery_function_03 mystery_function_03.
Proof.
  unfold specification_of_mystery_function_03, mystery_function_03.
  split.
  - reflexivity.

  - split.
    -- unfold mystery_function_03.
       fold mystery_function_03.
       exact (about_mystery_function_03).

    -- unfold mystery_function_03.
       fold mystery_function_03.
       symmetry.
       apply (about_mystery_function_03 i j).
Qed.

(* ***** *)

Definition specification_of_mystery_function_42 (mf : nat -> nat) :=
  mf 1 = 42
  /\
  forall i j : nat,
    mf (i + j) = mf i + mf j.

Theorem there_is_at_most_one_mystery_function_42:
  forall f g : nat -> nat,
    specification_of_mystery_function_42 f ->
    specification_of_mystery_function_42 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_42.
  intros [H_f_1 H_f_S] [H_g_1 H_g_S].
  intro n.
  induction n as [ | n' IHn'].
  - assert (H_tmp := H_f_S 0 1).
    Search (0 + _ = _).
    rewrite -> (Nat.add_0_l 1) in H_tmp.
    rewrite -> H_f_1 in H_tmp.
    Search (_ + _ = _).
    rewrite <- (Nat.add_0_l 42) in H_tmp at 1.
    Search (_ + _ = _ + _).
    rewrite -> (Nat.add_cancel_r 0 (f 0) 42) in H_tmp.
    rewrite <- H_tmp.
    clear H_tmp.
    assert (H_tmp := H_g_S 0 1).
    rewrite -> (Nat.add_0_l 1) in H_tmp.
    rewrite -> H_g_1 in H_tmp.
    rewrite <- (Nat.add_0_l 42) in H_tmp at 1.
    rewrite -> (Nat.add_cancel_r 0 (g 0) 42) in H_tmp.
    rewrite <- H_tmp.
    reflexivity.
  - rewrite -> (equivalence_of_successor_and_add_one n').
    rewrite -> (H_f_S n' 1).
    rewrite -> H_f_1.
    rewrite -> (H_g_S n' 1).
    rewrite -> H_g_1.
    rewrite -> IHn'.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_42 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 42) && (mf 2 =n= 84) && (mf 3 =n= 126).

Definition mystery_function_42 (n : nat) : nat :=
  n * 42.

Compute (unit_test_for_mystery_function_42 mystery_function_42).

Theorem there_is_at_least_one_mystery_function_42:
  specification_of_mystery_function_42 mystery_function_42.
Proof.
  unfold specification_of_mystery_function_42, mystery_function_42.
  split.
  - exact (Nat.mul_1_l 42).

  - intros i j.
    Search ((_ + _) * _ = _ * _ + _ * _).
    exact (Nat.mul_add_distr_r i j 42).
Qed.

(* ***** *)

Definition specification_of_mystery_function_07 (mf : nat -> nat -> nat) :=
  (forall j : nat, mf 0 j = j)
  /\
  (forall i : nat, mf i 0 = i)
  /\
  (forall i j k : nat, mf (i + k) (j + k) = (mf i j) + k).

Theorem there_is_at_most_one_mystery_function_07:
  forall f g : nat -> nat -> nat,
    specification_of_mystery_function_07 f ->
    specification_of_mystery_function_07 g ->
    forall i j : nat,
      f i j = g i j.
Proof.
  intros f g.
  unfold specification_of_mystery_function_07.
  intros [H_f_O_l [H_f_O_r H_f_S]] [H_g_O_l [H_g_O_r H_g_S]].
  intros i.
  induction i as [ | i' IHi'].
  - intro j.
    induction j as [ | j' IHj'].
    -- rewrite -> (H_g_O_l 0).
       exact (H_f_O_l 0).
    -- rewrite -> (H_g_O_l (S j')).
       exact (H_f_O_l (S j')).
  - intro j.
    induction j as [ | j' IHj'].
    -- rewrite -> (H_g_O_r (S i')).
       exact (H_f_O_r (S i')).
    -- rewrite -> (equivalence_of_successor_and_add_one i').
       rewrite -> (equivalence_of_successor_and_add_one j').
       rewrite -> (H_f_S i' j' 1).
       rewrite -> (H_g_S i' j' 1).
       rewrite -> IHi'.
       reflexivity.
  (*
  Restart.

  intros f g.
  unfold specification_of_mystery_function_07.
  intros [H_f_O_l [H_f_O_r H_f_S]] [H_g_O_l [H_g_O_r H_g_S]].
  intros i.
  induction i as [ | i' IHi'].
  - intro j.
    rewrite -> (H_g_O_l).
    exact (H_f_O_l j).
  - intro j.
    assert (H_tmp := H_f_S i' (j-1) 1).
    rewrite <- (equivalence_of_successor_and_add_one i') in H_tmp.
    Search (_ = _ - 1).
    rewrite <- (equivalence_of_successor_and_add_one j) in H_tmp.
    assert (H_tmp' := (IHi' (j - 1))).
    rewrite -> Nat.add_0_r in H_tmp.
    rewrite -> Nat.add_0_r in H_tmp.
    rewrite -> Nat.add_0_r in H_tmp. *)
Qed.

Definition unit_test_for_mystery_function_07 (mf : nat -> nat -> nat) :=
  (mf 0 1 =n= 1) && (mf 1 0 =n= 1) && (mf 2 2 =n= 2) && (mf 2 6 =n= 6).

Definition mystery_function_07 (i j : nat) : nat :=
  Nat.max i j.

Compute (unit_test_for_mystery_function_07 mystery_function_07).

Theorem there_is_at_least_one_mystery_function_07:
  specification_of_mystery_function_07 mystery_function_07.
Proof.
  unfold specification_of_mystery_function_07, mystery_function_07.
  split.
  - intro j.
    exact (Nat.max_0_l j).

  - split.
    -- intro i.
       exact (Nat.max_0_r i).
    -- intros i j k.
       exact (Nat.add_max_distr_r i j k).
Qed.

(* ***** *)

Definition specification_of_mystery_function_08 (mf : nat -> nat -> bool) :=
  (forall j : nat, mf 0 j = true)
  /\
  (forall i : nat, mf (S i) 0 = false)
  /\
  (forall i j : nat, mf (S i) (S j) = mf i j).

Theorem there_is_at_most_one_mystery_function_08:
  forall f g : nat -> nat -> bool,
    specification_of_mystery_function_08 f ->
    specification_of_mystery_function_08 g ->
    forall i j : nat,
      f i j = g i j.
Proof.
  intros f g.
  unfold specification_of_mystery_function_08.
  intros [H_f_O_l [H_f_O_r H_f_S]] [H_g_O_l [H_g_O_r H_g_S]].
  intros i.
  induction i as [ | i' IHi'].
  - intro j.
    induction j as [ | j' IHj'].
    -- rewrite -> (H_g_O_l 0).
       exact (H_f_O_l 0).
    -- rewrite -> (H_g_O_l (S j')).
       exact (H_f_O_l (S j')).
  - intro j.
    induction j as [ | j' IHj'].
    -- rewrite -> (H_g_O_r i').
       exact (H_f_O_r i').
    -- rewrite -> (H_g_S i' j').
       rewrite -> (H_f_S i' j').
       rewrite -> (IHi' j').
       reflexivity.
Qed.

Definition unit_test_for_mystery_function_08 (mf : nat -> nat -> bool) :=
  (mf 0 0 =b= true) && (mf 1 0 =b= false) && (mf 0 1 =b= true) && (mf 2 6 =b= true) && (mf 6 6 =b= true).

Definition mystery_function_08 (i j : nat) : bool :=
  (Nat.min i j) =n= i.

Compute (unit_test_for_mystery_function_08 mystery_function_08).

Theorem there_is_at_least_one_mystery_function_08:
  specification_of_mystery_function_08 mystery_function_08.
Proof.
  unfold specification_of_mystery_function_08, mystery_function_08.
  split.
  - intro j.
    Search (Nat.min 0 _).
    rewrite -> (Nat.min_0_l j).
    Search (beq_nat _ _).
    exact (Nat.eqb_refl 0).

  - split.
    -- intro i.
    rewrite -> (equivalence_of_successor_and_add_one i) at 1.
    rewrite -> (Nat.min_0_r (i + 1)).
    Search (beq_nat _ _).
    assert (H_tmp := (Nat.neq_succ_0 i)).
    Search (_ <> _ -> _).
    apply (Nat.neq_sym (S i) 0) in H_tmp.
    Search (_ =n= _).
    apply (Nat.eqb_neq 0 (S i)).
    exact H_tmp.

    -- intros i j.
       Search(Nat.min).
       Search (beq_nat).
       rewrite <- (Nat.succ_min_distr i j).
       rewrite <- (Nat.add_1_l (Nat.min i j)).
       rewrite <- (Nat.add_1_l i).
       destruct (Nat.lt_ge_cases j i) as [ H_i_greater_j | H_i_smaller_eq_j ].
    * assert (H_tmp := Nat.lt_neq j i).
      assert (H_neq := H_tmp H_i_greater_j).
      clear H_tmp.
      apply Nat.lt_le_incl in H_i_greater_j.
      rewrite -> (Nat.min_r i j).
      ** assert (H_tmp := Nat.lt_neq i j).
         assert (H_tmp2 := (not_eq_S j i)).
         assert (H_neq_S := H_tmp2 H_neq).
         rewrite <- (Nat.add_1_l j) in H_neq_S.
         rewrite <- (Nat.add_1_l i) in H_neq_S.
         assert (H_tmp3 := Nat.eqb_neq (1 + j) (1 + i)).
         destruct H_tmp3 as [_ H_tmp3_right].
         rewrite -> (H_tmp3_right H_neq_S).
         symmetry.
         clear H_tmp2 H_neq_S H_tmp3_right.
         assert (H_tmp2 := Nat.eqb_neq j i).
         destruct H_tmp2 as [_ H_tmp2_right].
         exact (H_tmp2_right H_neq).
      ** exact H_i_greater_j.
    * rewrite -> ((Nat.min_l i j) H_i_smaller_eq_j).
      rewrite -> (Nat.eqb_refl i).
      exact (Nat.eqb_refl (1 + i)).
Qed.

(* ***** *)

Definition specification_of_mystery_function_23 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  mf 1 = 0
  /\
  forall n'' : nat,
    mf (S (S n'')) = S (mf n'').

Lemma zero_or_nonzero :
  forall n : nat,
  (n = 0) \/ (n <> 0).
Proof.
  intro n.
  induction n as [ | n' IHn'].

  - left.
    reflexivity.

  - right.
    exact (Nat.neq_succ_0 n').
Qed.

(* Master Lemma *)

Lemma pair_induction (P : nat -> Prop) :
  P 0 ->
  P 1 ->
  (forall n, P n -> P (S n) -> P (S (S n))) ->
  forall n, P n.
Proof.
  intros H0 H1 Hstep n.
  enough (P n /\ P (S n)) as [H H_S].
  + exact H.
  +  induction n as [ | n' [IHn' IHn'2]].

  * split.
    - exact H0.
    - exact H1.
  * split.
    - exact IHn'2.
    - exact (Hstep n' IHn' IHn'2).
Qed.

Theorem there_is_at_most_one_mystery_function_23:
  forall f g : nat -> nat,
    specification_of_mystery_function_23 f ->
    specification_of_mystery_function_23 g ->
    forall n : nat,
      f n = g n.
Proof.
intros f g.
  unfold specification_of_mystery_function_23.
  intros [H_f_O [H_f_1 H_f_S]] [H_g_O [H_g_1 H_g_S]].
  intro n.
  induction n using pair_induction.

  - rewrite -> H_g_O.
    exact (H_f_O).
  - rewrite -> H_g_1.
    exact H_f_1.
  - rewrite -> (H_f_S n).
    rewrite -> (H_g_S n).
    rewrite -> IHn.
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_23 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 0) && (mf 2 =n= 1) && (mf 3 =n= 1)
(* etc. *).

Definition mystery_function_23 (n : nat) : nat :=
  n / 2.

Compute (unit_test_for_mystery_function_23 mystery_function_23).

Theorem there_is_at_least_one_mystery_function_23:
  specification_of_mystery_function_23 mystery_function_23.
Proof.
  unfold specification_of_mystery_function_23, mystery_function_23.
  split.

 - apply (Nat.div_0_l 2).
   exact (Nat.neq_succ_0 1).
 - split.
   apply (Nat.div_1_l 2).
   * exact Nat.lt_1_2.
   * intro n.
     rewrite <- (Nat.add_1_l n).
     rewrite <- (Nat.add_1_l (1 + n)).
     rewrite -> (Nat.add_assoc 1 1 n).
     rewrite <- BinInt.ZL0.
     rewrite <- (Nat.add_1_l (n / 2)).
     rewrite <- (Nat.mul_1_l 2) at 1.
     rewrite -> (Nat.div_add_l 1 2 n).
     ** reflexivity.
     ** exact (Nat.neq_succ_0 1).
Qed.

(* ***** *)

Definition specification_of_mystery_function_24 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  mf 1 = 1
  /\ forall n'' : nat,
      mf (S (S n'')) = S (mf n'').
(* (n + 1) / 2 *)
(* ***** *)

Theorem there_is_at_most_one_mystery_function_24:
  forall f g : nat -> nat,
    specification_of_mystery_function_24 f ->
    specification_of_mystery_function_24 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_24.
  intros [H_f_O [H_f_1 H_f_S]] [H_g_O [H_g_1 H_g_S]].

  assert (H_n : forall n : nat, f n = g n /\ f (S n) = g (S n)).
  { intro n.
    induction n as [ | n' [IHn' IHSn']].

    - split.

      -- rewrite -> H_f_O.
         rewrite -> H_g_O.
         reflexivity.

      -- rewrite -> H_f_1.
         rewrite -> H_g_1.
         reflexivity.

    - split.

      -- exact IHSn'.

      -- rewrite -> H_f_S.
         rewrite -> H_g_S.
         rewrite -> IHn'.
         reflexivity.
  }
  intro n.
  destruct (H_n n) as [ly _].
  exact ly.
Qed.
(*
  intros f g.
  unfold specification_of_mystery_function_24.
  intros [H_f_O [H_f_1 H_f_S]] [H_g_O [H_g_1 H_g_S]].
  intro n.
  induction n using pair_induction.

  - rewrite -> H_g_O.
    exact (H_f_O).
  - rewrite -> H_g_1.
    exact H_f_1.
  - rewrite -> (H_f_S n).
    rewrite -> (H_g_S n).
    rewrite -> IHn.
    reflexivity.
Qed.
*)

Definition unit_test_for_mystery_function_24 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 1) && (mf 2 =n= 1) && (mf 3 =n= 2)
(* etc. *).

Definition mystery_function_24 (n : nat) : nat :=
  (n + 1) / 2.

Compute (unit_test_for_mystery_function_24 mystery_function_24).

Theorem there_is_at_least_one_mystery_function_24:
  specification_of_mystery_function_24 mystery_function_24.
Proof.
  unfold specification_of_mystery_function_24, mystery_function_24.
  split.

 - apply (Nat.div_0_l 2).
   exact (Nat.neq_succ_0 1).
 - split.
   * rewrite <- BinInt.ZL0.
     exact ((Nat.div_same 2) (Nat.neq_succ_0 1)).
   * intro n.
     rewrite <- (Nat.add_1_l n).
     rewrite <- (Nat.add_1_l (1 + n)).
     rewrite -> (Nat.add_assoc 1 1 n).
     rewrite <- BinInt.ZL0.
     rewrite <- (Nat.add_1_l ((n + 1) / 2)).
     rewrite <- (Nat.mul_1_l 2) at 1.
     rewrite <- (Nat.add_assoc (1 * 2) n 1).
     rewrite -> (Nat.div_add_l 1 2 (n + 1)).
     ** reflexivity.
     ** exact (Nat.neq_succ_0 1).
Qed.

(* ***** *)

Lemma even_or_odd :
  forall m : nat,
  (exists q : nat, m = 2 * q) \/ (exists q : nat, m = S (2 * q)).
Proof.
  intro n.
  induction n as [ | n' [[q H_q] | [q H_q]]].
  - left.
    exists 0.
    rewrite -> (Nat.mul_0_r 2).
    reflexivity.

  - (* left.
    rewrite -> H_q. *)
    (*  exists q0 : nat, S (2 * q) = 2 * q0 we found out that if we choose the left disjunct, we run into an impossibility. *)
    right.
    rewrite -> H_q.
    exists q.
    reflexivity.

  - (* right.
    rewrite -> H_q. *)
    left.
    rewrite -> H_q.
    Search ( 1 + _  = S _).
    exists (S q).
    Search (S _ * _ = _).
    Check (Nat.mul_succ_l 1 q).
    rewrite -> (Nat.mul_succ_l 1 q).
    rewrite -> (Nat.mul_1_l q).
    rewrite -> (Nat.mul_succ_l 1 (S q)).
    rewrite -> (Nat.mul_1_l (S q)).
    Check (plus_Sn_m).
    rewrite <- (plus_Sn_m q q).
    Check (plus_n_Sm).
    rewrite -> (plus_n_Sm (S q) q).
    reflexivity.
Qed.

Definition specification_of_mystery_function_13 (mf : nat -> nat) :=
  (forall q : nat, mf (2 * q) = q)
  /\
  (forall q : nat, mf (S (2 * q)) = q).
(* n / 2  *)

Theorem there_is_at_most_one_mystery_function_13:
  forall f g : nat -> nat,
    specification_of_mystery_function_13 f ->
    specification_of_mystery_function_13 g ->
    forall n : nat,
      f n = g n.
Proof.
  intros f g.
  unfold specification_of_mystery_function_13.
  intros [H_f_O H_f_S] [H_g_O H_g_S].
  intro n.
  Check (even_or_odd n).
  destruct (even_or_odd n) as [[q H_q] | [q H_q]].

  - rewrite -> H_q.
    rewrite -> (H_g_O q).
    exact (H_f_O q).

  - rewrite -> H_q.
    rewrite -> (H_g_S q).
    exact (H_f_S q).
Qed.

Definition unit_test_for_mystery_function_13 (mf : nat -> nat) :=
  (mf 0 =n= 0) && (mf 1 =n= 0) && (mf 2 =n= 1) && (mf 3 =n= 1)
(* etc. *).

Definition mystery_function_13 (n : nat) : nat :=
  n / 2.

Compute (unit_test_for_mystery_function_13 mystery_function_13).

Theorem there_is_at_least_one_mystery_function_13:
  specification_of_mystery_function_13 mystery_function_13.
Proof.
  unfold specification_of_mystery_function_13, mystery_function_13.
  split.

  - intro q.
    rewrite -> (Nat.mul_comm 2 q).
    rewrite -> (Nat.div_mul q 2).
    * reflexivity.
    * exact (Nat.neq_succ_0 1).

  - intro q.
    rewrite <- (Nat.add_1_l (2 * q)).
    rewrite <- (Nat.mul_comm q 2).
    rewrite -> (Nat.div_add 1 q 2).
    assert (H_tmp := Nat.div_1_l 2).
    rewrite -> H_tmp.
    * exact (Nat.add_0_l q).
    * exact (Nat.lt_1_2).
    * exact (Nat.neq_succ_0 1).
Qed.

Definition specification_of_mystery_function_25 (mf : nat -> nat) :=
  mf 0 = 0
  /\
  (forall q : nat,
      mf (2 * (S q)) = S (mf (S q)))
  /\
  mf 1 = 0
  /\
  (forall q : nat,
      mf (S (2 * (S q))) = S (mf (S q))).

(* log *)
(* ****** *)

Theorem there_is_at_most_one_mystery_function_25:
  forall f g : nat -> nat,
    specification_of_mystery_function_25 f ->
    specification_of_mystery_function_25 g ->
    forall n : nat,
      f n = g n.
Proof.
(*
intros f g.
  unfold specification_of_mystery_function_25.
  intros [H_f_O [H_f_S [H_f_1 H_f_SS]]] [H_g_O [H_g_S [H_g_1 H_g_SS]]].
  intro n.
  induction n using pair_induction.
  - rewrite -> H_g_O.
    exact H_f_O.
  - rewrite -> H_g_1.
    exact H_f_1.
  - destruct (even_or_odd n) as [[q H_q] | [q H_q]].
      * rewrite -> H_q.
      assert (H_tmp := H_f_S q).
      rewrite <- (Nat.add_1_l (2 * q)) at 1.
      rewrite <- (Nat.add_1_l (1 + (2 * q))) at 1.
      rewrite -> (Nat.add_assoc 1 1 (2 * q)).
      rewrite <- BinInt.ZL0.
      rewrite <- (Nat.add_1_l q) in H_tmp.
      rewrite -> (Nat.mul_add_distr_l 2 1 q) in H_tmp.
      rewrite -> (Nat.mul_1_r 2) in H_tmp.
      rewrite -> H_tmp.
      rewrite -> (Nat.add_1_l q).
      clear H_tmp.
      assert (H_tmp := H_g_S q).
      rewrite <- (Nat.add_1_l (2 * q)) at 1.
      rewrite <- (Nat.add_1_l (1 + (2 * q))) at 1.
      rewrite -> (Nat.add_assoc 1 1 (2 * q)).
      rewrite <- BinInt.ZL0.
      rewrite <- (Nat.add_1_l q) in H_tmp.
      rewrite -> (Nat.mul_add_distr_l 2 1 q) in H_tmp.
      rewrite -> (Nat.mul_1_r 2) in H_tmp.
      rewrite -> H_tmp.
      rewrite -> (Nat.add_1_l q).
      Search (log _).

  induction n using pair_induction.

  - rewrite -> H_g_O.
    exact (H_f_O).
  - rewrite -> H_g_1.
    exact H_f_1.
  - destruct (even_or_odd n) as [[q H_q] | [q H_q]].
    + rewrite -> H_q.
      assert (H_tmp := H_f_S q).
      rewrite <- (Nat.add_1_l (2 * q)) at 1.
      rewrite <- (Nat.add_1_l (1 + (2 * q))) at 1.
      rewrite -> (Nat.add_assoc 1 1 (2 * q)).
      rewrite <- BinInt.ZL0.
      rewrite <- (Nat.add_1_l q) in H_tmp.
      rewrite -> (Nat.mul_add_distr_l 2 1 q) in H_tmp.
      rewrite -> (Nat.mul_1_r 2) in H_tmp.
      rewrite -> H_tmp.
      rewrite -> (Nat.add_1_l q).
      clear H_tmp.
      assert (H_tmp := H_g_S q).
      rewrite <- (Nat.add_1_l (2 * q)) at 1.
      rewrite <- (Nat.add_1_l (1 + (2 * q))) at 1.
      rewrite -> (Nat.add_assoc 1 1 (2 * q)).
      rewrite <- BinInt.ZL0.
      rewrite <- (Nat.add_1_l q) in H_tmp.
      rewrite -> (Nat.mul_add_distr_l 2 1 q) in H_tmp.
      rewrite -> (Nat.mul_1_r 2) in H_tmp.
      rewrite -> H_tmp.
      rewrite -> (Nat.add_1_l q).

      Search (
      rewrite -> (H_g_O).
      exact (H_f_O q).

    + rewrite -> H_q.
      rewrite -> (H_g_S q).
      exact (H_f_S q).

rewrite -> (H_f_S n).
    rewrite -> (H_g_S n).
    rewrite -> IHn.
    reflexivity.
Qed.
*)
Abort.

Definition specification_of_mystery_function_20 (mf : nat -> nat -> nat) :=
  (forall j : nat, mf O j = j)
  /\
  (forall i j : nat, mf (S i) j = S (mf i j)).
(* add  *)
(* ****** *)

Theorem there_is_at_most_one_mystery_function_20:
  forall f g : nat -> nat -> nat,
    specification_of_mystery_function_20 f ->
    specification_of_mystery_function_20 g ->
    forall n m: nat,
      f n m = g n m.
Proof.
  intros f g.
  unfold specification_of_mystery_function_20.
  intros [H_f_O H_f_S] [H_g_O H_g_S].
  intro n.
  induction n as [ | n' IHn'].

  - intro m.
    rewrite -> (H_g_O m).
    exact (H_f_O m).

  - intro m.
    rewrite -> (H_f_S n' m).
    rewrite -> (H_g_S n' m).
    rewrite -> (IHn' m).
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_20 (mf : nat -> nat -> nat) :=
  (mf 0 0 =n= 0) && (mf 1 0 =n= 1) && (mf 0 1 =n= 1) && (mf 1 1 =n= 2)
(* etc. *).

Definition mystery_function_20 (n m : nat) : nat :=
  n + m.

Compute (unit_test_for_mystery_function_20 mystery_function_20).

Theorem there_is_at_least_one_mystery_function_20 :
  specification_of_mystery_function_20 mystery_function_20.
Proof.
  unfold specification_of_mystery_function_20, mystery_function_20.
  split.
  - intro j.
    exact (Nat.add_0_l j).

  - intros i j.
    exact (Nat.add_succ_l i j).
Qed.

Definition specification_of_mystery_function_21 (mf : nat -> nat -> nat) :=
  (forall j : nat, mf O j = j)
  /\
  (forall i j : nat, mf (S i) j = mf i (S j)).
(* add *)

Theorem there_is_at_most_one_mystery_function_21:
  forall f g : nat -> nat -> nat,
    specification_of_mystery_function_21 f ->
    specification_of_mystery_function_21 g ->
    forall n m: nat,
      f n m = g n m.
Proof.
  intros f g.
  unfold specification_of_mystery_function_21.
  intros [H_f_O H_f_S] [H_g_O H_g_S].
  intro n.
  induction n as [ | n' IHn'].

  - intro m.
    rewrite -> (H_g_O m).
    exact (H_f_O m).

  - intro m.
    rewrite -> (H_f_S n' m).
    rewrite -> (H_g_S n' m).
    rewrite -> (IHn' (S m)).
    reflexivity.
Qed.

Definition unit_test_for_mystery_function_21 (mf : nat -> nat -> nat) :=
  (mf 0 0 =n= 0) && (mf 1 0 =n= 1) && (mf 0 1 =n= 1) && (mf 1 1 =n= 2)
(* etc. *).

Definition mystery_function_21 (n m : nat) : nat :=
  n + m.

Compute (unit_test_for_mystery_function_21 mystery_function_21).

Theorem there_is_at_least_one_mystery_function_21 :
  specification_of_mystery_function_21 mystery_function_21.
Proof.
  unfold specification_of_mystery_function_21, mystery_function_21.
  split.
  - intro j.
    exact (Nat.add_0_l j).

  - intros i j.
    exact (Nat.add_succ_comm i j).
Qed.

(* ****** *)

Definition specification_of_mystery_function_22 (mf : nat -> nat -> nat) :=
  forall i j : nat,
    mf O j = j
    /\
    mf (S i) j = mf i (S j).
(* add  *)

Theorem there_is_at_most_one_mystery_function_22:
  forall f g : nat -> nat -> nat,
    specification_of_mystery_function_22 f ->
    specification_of_mystery_function_22 g ->
    forall n m: nat,
      f n m = g n m.
Proof.
  intros f g.
  unfold specification_of_mystery_function_22.
  intros H_f H_g.
  intro n.
  induction n as [ | n' IHn'].

  - intro m.
    assert (H_tmp := H_g 0 m).
    destruct H_tmp as [H_g_O _].
    rewrite -> H_g_O.
    assert (H_tmp := H_f 0 m).
    destruct H_tmp as [H_f_O _].
    exact H_f_O.

  - intro m.
    assert (H_tmp := H_g n' m).
    destruct H_tmp as [_ H_g_S].
    rewrite -> H_g_S.
    rewrite <- (IHn' (S m)).
    assert (H_tmp := H_f n' m).
    destruct H_tmp as [_ H_g_f].
    exact H_g_f.
Qed.

Definition unit_test_for_mystery_function_22 (mf : nat -> nat -> nat) :=
  (mf 0 0 =n= 0) && (mf 1 0 =n= 1) && (mf 0 1 =n= 1) && (mf 1 1 =n= 2)
(* etc. *).

Definition mystery_function_22 (n m : nat) : nat :=
  n + m.

Compute (unit_test_for_mystery_function_22 mystery_function_22).

Theorem there_is_at_least_one_mystery_function_22 :
  specification_of_mystery_function_22 mystery_function_22.
Proof.
  unfold specification_of_mystery_function_22, mystery_function_22.
  split.
  - exact (Nat.add_0_l j).

  - exact (Nat.add_succ_comm i j).
Qed.

(* ********** *)

(* Binary trees of natural numbers: *)

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

Definition specification_of_mystery_function_19 (mf : tree -> tree) :=
  (forall n : nat,
     mf (Leaf n) = Leaf n)
  /\
  (forall (n : nat) (t : tree),
     mf (Node (Leaf n) t) = Node (Leaf n) (mf t))
  /\
  (forall t11 t12 t2 : tree,
     mf (Node (Node t11 t12) t2) = mf (Node t11 (Node t12 t2))).

(* You might not manage to prove
   that at most one function satisfies this specification (why?),
   but consider whether the following function does.
   Assuming it does, what does this function do?
   And what is the issue here?
*)

Theorem there_is_at_most_one_mystery_function_19:
  forall f g : tree -> tree,
    specification_of_mystery_function_19 f ->
    specification_of_mystery_function_19 g ->
    forall t: tree,
      f t = g t.
Proof.
  intros f g.
  unfold specification_of_mystery_function_21.
  intros [H_f_O [H_f_S H_f_SS]] [H_g_O [H_g_S H_g_SS]].
  intro t.
  induction t as [ | t' IHt'].

  - rewrite (H_g_O n).
    exact (H_f_O n).

  - (* difficult to proceed *)
Abort.

Fixpoint mystery_function_19_aux (t a : tree) : tree :=
  match t with
  | Leaf n =>
     Node (Leaf n) a
  | Node t1 t2 =>
     mystery_function_19_aux t1 (mystery_function_19_aux t2 a)
  end.

Fixpoint mystery_function_19 (t : tree) : tree :=
  match t with
  | Leaf n =>
     Leaf n
  | Node t1 t2 =>
     mystery_function_19_aux t1 (mystery_function_19 t2)
  end.

Theorem there_is_at_least_one_mystery_function_19 :
  specification_of_mystery_function_19 mystery_function_19.
Proof.
  unfold specification_of_mystery_function_19, mystery_function_19.
  unfold mystery_function_19_aux.
  split.
  - intro n.
    reflexivity.

  - split.
    * reflexivity.
    * reflexivity.
Qed.

(* ********** *)

(* Extra mystery functions: *)

(* ***** *)

Definition specification_of_mystery_function_05 (mf : nat -> nat) :=
  mf 0 = 1
  /\
  forall i j : nat,
    mf (S (i + j)) = 2 * mf i * mf j.

(* ***** *)

Definition specification_of_mystery_function_06 (mf : nat -> nat) :=
  mf 0 = 2
  /\
  forall i j : nat,
    mf (S (i + j)) = mf i * mf j.

(* ***** *)

Definition specification_of_mystery_function_09 (mf : nat -> bool) :=
  mf 0 = false
  /\
  mf 1 = true
  /\
  forall i j : nat,
    mf (i + j) = xorb (mf i) (mf j).

(* ***** *)

Definition specification_of_mystery_function_10 (mf : nat -> bool) :=
  mf 0 = false
  /\
  mf 1 = true
  /\
  forall i j : nat,
    mf (i + j) = (mf i =b= mf j).

(* ***** *)

Definition specification_of_mystery_function_12 (mf : nat -> nat) :=
  mf 1 = 1
  /\
  forall i : nat,
    mf (S (S i)) = (S (S i)) * mf (S i).

(* ***** *)

Definition specification_of_mystery_function_14 (mf : nat -> bool) :=
  (forall q : nat, mf (2 * q) = true)
  /\
  (forall q : nat, mf (S (2 * q)) = false).

(* ********** *)

(* Simple examples of specifications: *)

(* ***** *)

Definition specification_of_the_factorial_function (fac : nat -> nat) :=
  fac 0 = 1
  /\
  forall n' : nat, fac (S n') = S n' * fac n'.

(* ***** *)

Definition specification_of_the_fibonacci_function (fib : nat -> nat) :=
  fib 0 = 0
  /\
  fib 1 = 1
  /\
  forall n'' : nat,
    fib (S (S n'')) = fib n'' + fib (S n'').

(* ********** *)

(* end of week-05_mystery-functions.v *)


(**************************************************************************
* TLC: A library for Coq                                                  *
* Order relations                                                         *
**************************************************************************)

Set Implicit Arguments.
From TLC Require Import LibTactics LibLogic LibReflect LibOperation LibRelation.
Generalizable Variables A.

(**************************************************************************)
(* * Preorder *)

(** Definition *)

Record preorder A (R:binary A) : Prop := {
   preorder_refl : refl R;
   preorder_trans : trans R }.

Arguments preorder_trans [A] [R] [p] y [x] [z].

(** Transformations *)

Lemma preorder_inverse : forall A (R:binary A),
  preorder R ->
  preorder (inverse R).
Proof using. hint trans_inverse. introv [Re Tr]. constructor~. Qed.

Lemma preorder_rclosure : forall A (R:binary A),
  preorder R ->
  preorder (rclosure R).
Proof using. hint refl_rclosure, trans_rclosure. introv [Re Tr]. constructor~. Qed.

(**************************************************************************)
(* * Total preorder *)

(** Definition of total preorder relations *)

Record total_preorder A (R:binary A) : Prop := {
   total_preorder_trans : trans R;
   total_preorder_total : total R }.

Arguments total_preorder_trans [A] [R] t y [x] [z].

(** Conversion to preorder *)

Lemma total_preorder_refl : forall A (le:binary A),
  total_preorder le ->
  refl le.
Proof using. introv [Tr To]. intros x. destruct~ (To x x). Qed.

#[global]
Hint Resolve total_preorder_refl.

Coercion total_preorder_to_preorder A (R:binary A)
  (O:total_preorder R) : preorder R.
Proof using. lets [M _]: O. constructor~. Qed.

#[global]
Hint Resolve total_preorder_to_preorder.

(** Transformations *)

Lemma total_preorder_inverse : forall A (R:binary A),
  total_preorder R ->
  total_preorder (inverse R).
Proof using. hint trans_inverse, total_inverse. introv [Tr To]. constructor~. Qed.

Lemma total_preorder_rclosure : forall A (R:binary A),
  total_preorder R ->
  total_preorder (rclosure R).
Proof using. hint trans_rclosure, total_rclosure. introv [Re Tr]. constructor~. Qed.

(** Properties *)

Lemma inverse_of_not : forall A (R:binary A) x y,
  total R ->
  ~ R x y ->
  inverse R x y.
Proof using. introv T H. destruct (T x y); auto_false~. Qed.

Lemma inverse_strict_of_not : forall A (R:binary A) x y,
  total R ->
  ~ R x y ->
  inverse (strict R) x y.
Proof using.
  introv T H. destruct (T x y). auto_false~.
  hnf. split~. intro_subst~.
Qed.

(**************************************************************************)
(* * Order *)

(** Definition *)

Record order A (R:binary A) : Prop := {
   order_refl : refl R;
   order_trans : trans R;
   order_antisym : antisym R }.

Arguments order_trans [A] [R] [o] y [x] [z].
Arguments order_antisym [A] [R] [o] [x] [y].

(** Conversion to preorder *)

Coercion order_to_preorder A (R:binary A)
  (O:order R) : preorder R.
Proof using. destruct* O. constructors*. Qed.

#[global]
Hint Resolve order_to_preorder.

(** Transformations *)

Lemma order_inverse : forall A (R:binary A),
  order R ->
  order (inverse R).
Proof using.
  hint trans_inverse, antisym_inverse.
  introv [Re Tr An]. constructor~.
Qed.

Lemma order_rclosure : forall A (R:binary A),
  order R ->
  order (rclosure R).
Proof using.
  hint refl_rclosure, trans_rclosure, antisym_rclosure.
  introv [Re Tr An]. constructor~.
Qed.

(** Properties *)

(* ********************************************************************** *)
(** * Order relation upto an equivalence relation *)

(** Note: this is used in LibFix *)

Record order_wrt (A:Type) (E:binary A) (R:binary A) : Prop := {
   order_wrt_refl : refl R;
   order_wrt_trans : trans R;
   order_wrt_antisym : antisym_wrt E R }.

Arguments order_wrt_trans [A] [E] [R] [o] y [x] [z].
Arguments order_wrt_antisym [A] [E] [R] [o] [x] [y].

(** Conversion to preorder *)

Coercion order_wrt_to_preorder A (E:binary A) (R:binary A)
  (O:order_wrt E R) : preorder R.
Proof using. destruct* O. constructors*. Qed.

#[global]
Hint Resolve order_wrt_to_preorder.

(** Transformations *)

Lemma order_wrt_inverse : forall A (E:binary A) (R:binary A),
  order_wrt E R ->
  order_wrt E (inverse R).
Proof using.
  hint trans_inverse, antisym_wrt_inverse.
  introv [Re Tr An]. constructor~.
Qed.

Lemma order_wrt_rclosure : forall A (E:binary A) (R:binary A),
  order_wrt E R ->
  order_wrt (rclosure E) (rclosure R).
Proof using.
  hint refl_rclosure, trans_rclosure, antisym_wrt_rclosure.
  introv [Re Tr An]. constructor~.
Qed.

(** Properties *)

(**************************************************************************)
(* * Total Order *)

(** Definition *)

Record total_order A (R:binary A) : Prop := {
   total_order_order : order R;
   total_order_total : total R }.

(** Projections *)

Definition total_order_refl := order_refl.
Definition total_order_trans := order_trans.
Definition total_order_antisym := order_antisym.

Arguments total_order_trans [A] [R] [o] y [x] [z].
Arguments total_order_antisym [A] [R] [o] [x] [y].

(** Construction *)

Lemma total_order_intro : forall A (R:binary A),
   trans R ->
   antisym R ->
   total R ->
   total_order R.
Proof using.
  introv Tra Ant Tot. constructor~. constructor~.
  intros_all. destruct~ (Tot x x).
Qed.

(** Conversion to order *)

Coercion total_order_to_total_preorder A (R:binary A)
  (O:total_order R) : total_preorder R.
Proof using. destruct* O. constructors*. applys* order_trans. Qed.

Definition total_order_to_order := total_order_order.

#[global]
Hint Resolve total_order_to_order total_order_to_total_preorder.

(** Transformations *)

Lemma total_order_inverse : forall A (R:binary A),
  total_order R ->
  total_order (inverse R).
Proof using.
  hint total_inverse, order_inverse.
  introv [Or To]. constructor~.
Qed.

Lemma total_order_rclosure : forall A (R:binary A),
  total_order R ->
  total_order (rclosure R).
Proof using.
  hint total_rclosure, order_rclosure.
  introv [Or To]. constructor~.
Qed.

(** Properties *)

Section TotalOrderProp.
Variables (A:Type) (R : binary A).

(** WARNING: notations here are not typeclass operators
    -- TODO: is this really what we want?
    perhaps it would be clearer to inline these notations. *)

Notation "'le'" := (R).
Notation "'ge'" := (inverse R).
Notation "'lt'" := (strict R).
Notation "'gt'" := (inverse lt).

Ltac total_order_normalize :=
  repeat rewrite rclosure_eq_fun;
  repeat rewrite inverse_eq_fun;
  repeat rewrite strict_eq_fun.

Lemma total_order_le_is_rclosure_lt : forall (To:total_order R),
  le = rclosure lt.
Proof using.
  extens. intros. total_order_normalize. iff M.
  tests~: (x = y).
  destruct M. autos*. subst*. dintuition eauto.
Qed.

Lemma total_order_lt_is_strict_le : forall (To:total_order R),
  lt = strict le.
Proof using.
  auto.
Qed.

Lemma total_order_ge_is_rclosure_gt : forall (To:total_order R),
  ge = rclosure gt.
Proof using.
  extens. intros. total_order_normalize. iff M.
  tests~: (x = y).
  destruct M. autos*. subst*. dintuition eauto.
Qed.

Lemma total_order_gt_is_strict_ge : forall (To:total_order R),
  gt = strict ge.
Proof using.
  extens. intros. total_order_normalize. iff M.
  tests~: (x = y).
  destruct M. autos*.
  destruct M. autos*.
Qed.

Lemma total_order_lt_or_eq_or_gt : forall (To:total_order R) x y,
  lt x y \/ x = y \/ gt x y.
Proof using.
  introv H. intros. total_order_normalize. tests: (x = y).
    branch~ 2.
    destruct (total_order_total H x y).
     branch~ 1.
     branch~ 3.
Qed.

Lemma total_order_lt_or_ge : forall (To:total_order R) x y,
  lt x y \/ ge x y.
Proof using.
  intros. branches (total_order_lt_or_eq_or_gt To x y).
  left~.
  right~. subst. hnf. apply~ total_order_refl.
  right~. rewrite~ total_order_ge_is_rclosure_gt.
   total_order_normalize. hnfs~.
Qed.

Lemma total_order_le_or_gt : forall (To:total_order R) x y,
  le x y \/ gt x y.
Proof using.
  intros. branches~ (total_order_lt_or_eq_or_gt To x y).
  left~. rewrite~ total_order_le_is_rclosure_lt. total_order_normalize. hnfs~.
  left~. subst. apply~ total_order_refl.
Qed.

End TotalOrderProp.

(**************************************************************************)
(* * Strict order *)

(** Definition *)

Record strict_order A (R:binary A) : Prop := {
   strict_order_irrefl : irrefl R;
   strict_order_asym : asym R;
   strict_order_trans : trans R }.

Arguments strict_order_trans [A] [R] [s] y [x] [z].

(** Transformations *)

Lemma strict_order_inverse : forall A (R:binary A),
  strict_order R ->
  strict_order (inverse R).
Proof using.
  hint antisym_inverse, trans_inverse, asym_inverse.
  introv [Ir As Tr]. constructor~.
Qed.

Lemma strict_order_strict : forall A (R:binary A),
  order R ->
  strict_order (strict R).
Proof using.
  introv [Re As Tr]. unfold strict. constructor; intros_all; simpls.
  destruct* H.
  applys* antisym_inv x y.
  split. applys* As. intros E. subst. applys* antisym_inv y z.
Qed.

Lemma order_rclosure_of_strict_order : forall A (R:binary A),
  strict_order R ->
  order (rclosure R).
Proof using.
  introv [Re As Tr]. rewrite rclosure_eq_fun. constructor; simpl.
  intros_all~.
  introv [H1|E1] [H2|E2]; subst; auto.
    left. apply* trans_inv.
  introv [H1|E1] [H2|E2]; try subst; auto.
    false. apply* As.
Qed.

(**************************************************************************)
(* * Total strict order *)

(** Definition *)

Record strict_total_order A (R:binary A) : Prop := {
   strict_total_order_trans : trans R;
   strict_total_order_trichotomous : trichotomous R }.

Arguments strict_total_order_trans [A] [R] [s] y [x] [z].

(** Conversion to strict order and back *)

Lemma strict_total_order_irrefl : forall A (R:binary A),
  strict_total_order R ->
  irrefl R.
Proof using. introv [Tr Tk]. intros x. lets: (Tk x x). inverts~ H. Qed.

Lemma strict_total_order_asym : forall A (R:binary A),
  strict_total_order R ->
  asym R.
Proof using. introv [Tr Tk]. intros x y. lets: (Tk x y). inverts~ H. Qed.

Coercion strict_total_order_to_strict_order A (R:binary A)
  (O:strict_total_order R) : strict_order R.
Proof using.
  lets [M _]: O. constructor;
  autos~ strict_total_order_irrefl strict_total_order_asym.
Qed.

#[global]
Hint Resolve strict_total_order_to_strict_order.

(** Transformation *)

Lemma strict_total_order_inverse : forall A (R:binary A),
  strict_total_order R ->
  strict_total_order (inverse R).
Proof using.
  introv [Tr Tk]. constructor. apply~ trans_inverse.
  apply~ trichotomous_inverse.
Qed.
(** From total order *)

Lemma strict_total_order_of_total_order : forall A (R:binary A),
  total_order R ->
  strict_total_order (strict R).
Proof using.
  introv [[Re Tr As] To]. constructor.
  apply~ trans_strict.
  intros x y. tests: (x = y).
    subst. apply trichotomy_eq. unfolds* strict.
    unfold strict. destruct (To x y).
      apply* trichotomy_left.
      apply* trichotomy_right.
Qed.

(* ********************************************************************** *)
(** * Definition of order operators *)

(* ---------------------------------------------------------------------- *)
(** ** Classes and notation for comparison operators *)

(** Operators *)

Class Le (A : Type) := { le : binary A }.
Class Ge (A : Type) := { ge : binary A }.
Class Lt (A : Type) := { lt : binary A }.
Class Gt (A : Type) := { gt : binary A }.

Global Opaque le lt ge gt.

(** Structures *)

Class Le_preorder `{Le A} : Prop :=
  { le_preorder : preorder le }.

Class Le_total_preorder `{Le A} : Prop :=
  { le_total_preorder : total_preorder le }.

Class Le_order `{Le A} : Prop :=
  { le_order : order le }.

Class Le_total_order `{Le A} : Prop :=
  { le_total_order : total_order le }.

Class Lt_strict_order `{Lt A} : Prop :=
  { lt_strict_order : strict_order lt }.

Class Lt_strict_total_order `{Lt A} : Prop :=
  { lt_strict_total_order : strict_total_order lt }.

(** Notation *)

Declare Scope comp_scope.

Notation "x <= y" := (le x y)
  (at level 70, no associativity) : comp_scope.
Notation "x >= y" := (ge x y)
  (at level 70, no associativity) : comp_scope.
Notation "x < y" := (lt x y)
  (at level 70, no associativity) : comp_scope.
Notation "x > y" := (gt x y)
  (at level 70, no associativity) : comp_scope.

Open Scope comp_scope.

Notation "x <= y <= z" := (x <= y /\ y <= z)
  (at level 70, y at next level) : comp_scope.
Notation "x <= y < z" := (x <= y /\ y < z)
  (at level 70, y at next level) : comp_scope.
Notation "x < y <= z" := (x < y /\ y <= z)
  (at level 70, y at next level) : comp_scope.
Notation "x < y < z" := (x < y /\ y < z)
  (at level 70, y at next level) : comp_scope.

(* ---------------------------------------------------------------------- *)
(** ** The operators [ge], [lt] and [gt] are deduced from [le] *)

#[global]
Instance ge_of_le : forall `{Le A}, Ge A.
  constructor. apply (inverse le). Defined.
#[global]
Instance lt_of_le : forall `{Le A}, Lt A.
  constructor. apply (strict le). Defined.
#[global]
Instance gt_of_le : forall `{Le A}, Gt A.
  constructor. apply (inverse lt). Defined.

Lemma ge_is_inverse_le : forall `{Le A}, ge = inverse le.
Proof using. extens*. Qed.

Lemma lt_is_strict_le : forall `{Le A}, lt = strict le.
Proof using. extens*. Qed.

Lemma gt_is_inverse_lt : forall `{Le A}, gt = inverse lt.
Proof using. extens*. Qed.

Lemma gt_is_inverse_strict_le : forall `{Le A}, gt = inverse (strict le).
Proof using. extens. intros. rewrite gt_is_inverse_lt. rewrite* lt_is_strict_le. Qed.

Global Opaque ge_of_le lt_of_le gt_of_le.

(** Local tactic [rew_to_le] *)

#[global]
Hint Rewrite @gt_is_inverse_strict_le @ge_is_inverse_le @lt_is_strict_le : rew_to_le.

Tactic Notation "rew_to_le" :=
  autorewrite with rew_to_le in *.

#[global]
Hint Rewrite @ge_is_inverse_le @gt_is_inverse_lt : rew_to_le_lt.

Tactic Notation "rew_to_le_lt" :=
  autorewrite with rew_to_le_lt in *.

Lemma gt_is_strict_inverse_le : forall `{Le A},
  gt = strict (inverse le).
Proof using. intros. rew_to_le. apply inverse_strict. Qed.

Lemma le_is_rclosure_lt : forall `{Le A},
  refl le ->
  le = rclosure lt.
Proof using. intros. rew_to_le. rewrite~ rclosure_strict. Qed.

Lemma le_is_inverse_ge : forall `{Le A},
  le = inverse ge.
Proof using. intros. rew_to_le. rewrite~ inverse_inverse. Qed.

Lemma lt_is_inverse_gt : forall `{Le A},
  lt = inverse gt.
Proof using. intros. rew_to_le. rewrite~ inverse_inverse. Qed.

Lemma gt_is_strict_ge : forall `{Le A},
  gt = strict ge.
Proof using. intros. rew_to_le. apply inverse_strict. Qed.

Lemma ge_is_rclosure_gt : forall `{Le A},
  refl le ->
  ge = rclosure gt.
Proof using. intros. rewrite gt_is_strict_ge. rewrite~ rclosure_strict. Qed.

(* ********************************************************************** *)
(** * Classes for comparison properties *)

(* ---------------------------------------------------------------------- *)
(** ** Definition of classes *)

(** symmetric structure *)

Class Ge_preorder `{Le A} : Prop :=
  { ge_preorder : preorder ge }.
Class Ge_total_preorder `{Le A} : Prop :=
  { ge_total_preorder : total_preorder ge }.
Class Ge_order `{Le A} : Prop :=
  { ge_order : order ge }.
Class Ge_total_order `{Le A} : Prop :=
  { ge_total_order : total_order le }.
Class Gt_strict_order `{Le A} : Prop :=
  { gt_strict_order : strict_order gt }.
Class Gt_strict_total_order `{Le A} : Prop :=
  { gt_strict_total_order : strict_total_order gt }.

(** properties of le *)

Class Le_refl `{Le A} :=
  { le_refl : refl le }.
Class Le_trans `{Le A} :=
  { le_trans : trans le }.
Class Le_antisym `{Le A} :=
  { le_antisym : antisym le }.
Class Le_total `{Le A} :=
  { le_total : total le }.

(** properties of ge *)

Class Ge_refl `{Ge A} :=
  { ge_refl : refl ge }.
Class Ge_trans `{Ge A} :=
  { ge_trans : trans ge }.
Class Ge_antisym `{Ge A} :=
  { ge_antisym : antisym ge }.
Class Ge_total `{Ge A} :=
  { ge_total : total ge }.

(** properties of lt *)

Class Lt_irrefl `{Lt A} :=
  { lt_irrefl : irrefl lt }.
Class Lt_trans `{Lt A} :=
  { lt_trans : trans lt }.

(** properties of gt *)

Class Gt_irrefl `{Gt A} :=
  { gt_irrefl : irrefl gt }.
Class Gt_trans `{Gt A} :=
  { gt_trans : trans gt }.

(** mixed transitivity results *)

Class Lt_le_trans `{Le A} :=
  { lt_le_trans : forall y x z, x < y -> y <= z -> x < z }.
Class Le_lt_trans `{Le A} :=
  { le_lt_trans : forall y x z, x <= y -> y < z -> x < z }.
Class Gt_ge_trans `{Le A} :=
  { gt_ge_trans : forall y x z, x > y -> y >= z -> x > z }.
Class Ge_gt_trans `{Le A} :=
  { ge_gt_trans : forall y x z, x >= y -> y > z -> x > z }.

Arguments lt_irrefl [A] [H] [Lt_irrefl].
Arguments le_trans {A} {H} {Le_trans} y [x] [z].
Arguments ge_trans {A} {H} {Ge_trans} y [x] [z].
Arguments lt_trans {A} {H} {Lt_trans} y [x] [z].
Arguments gt_trans {A} {H} {Gt_trans} y [x] [z].

(** conversion between operators *)

Class Ge_as_sle `{Le A} : Prop :=
  { ge_as_sle : forall x y : A, (x >= y) = (y <= x) }.

Class Gt_as_slt `{Le A} : Prop :=
  { gt_as_slt : forall x y : A, (x > y) = (y < x) }.

Class Ngt_as_sle `{Le A} : Prop :=
  { ngt_as_sle : forall x y : A, (~ x < y) = (y <= x) }.

Class Nlt_as_ge `{Le A} : Prop :=
  { nlt_as_ge : forall x y : A, (~ x < y) = (x >= y) }.

Class Ngt_as_le `{Le A} : Prop :=
  { ngt_as_le : forall x y : A, (~ x > y) = (x <= y) }.

Class Nle_as_gt `{Le A} : Prop :=
  { nle_as_gt : forall x y : A, (~ x <= y) = (x > y) }.

Class Nge_as_lt `{Le A} : Prop :=
  { nge_as_lt : forall x y : A, (~ x >= y) = (x < y) }.

(** inclusion between operators *)

Class Lt_to_le `{Le A} : Prop :=
  { lt_to_le : forall x y : A, (x < y) -> (x <= y) }.

Class Gt_to_ge `{Le A} : Prop :=
  { gt_to_ge : forall x y : A, (x > y) -> (x >= y) }.

Class Nle_to_sle `{Le A} : Prop :=
  { nle_to_sle : forall x y : A, (~ x <= y) -> (y <= x) }.

Class Nle_to_slt `{Le A} : Prop :=
  { nle_to_slt : forall x y : A, (~ x <= y) -> (y < x) }.

(** case analysis *)

Class Case_eq_lt_gt `{Le A} : Prop :=
  { case_eq_lt_gt : forall x y : A, x = y \/ x < y \/ x > y }.

Class Case_eq_lt_slt `{Le A} : Prop :=
  { case_eq_lt_slt : forall x y : A, x = y \/ x < y \/ y < x }.

Class Case_le_gt `{Le A} : Prop :=
  { case_le_gt : forall x y : A, x <= y \/ x > y }.

Class Case_le_slt `{Le A} : Prop :=
  { case_le_slt : forall x y : A, x <= y \/ y < x }.

Class Case_lt_ge `{Le A} : Prop :=
  { case_lt_ge : forall x y : A, x < y \/ x >= y }.

Class Case_lt_sle `{Le A} : Prop :=
  { case_lt_sle : forall x y : A, x < y \/ y <= x }.

(** case analysis under one assumption *)

Class Neq_case_lt_gt `{Le A} : Prop :=
  { neq_case_lt_gt : forall x y : A, x <> y -> x < y \/ x > y }.

Class Neq_case_lt_slt `{Le A} : Prop :=
  { neq_case_lt_slt : forall x y : A, x <> y -> x < y \/ y < x }.

Class Le_case_eq_lt `{Le A} : Prop :=
  { le_case_eq_lt : forall x y : A, x <= y -> x = y \/ x < y }.

Class Ge_case_eq_gt `{Le A} : Prop :=
  { ge_case_eq_gt : forall x y : A, x >= y -> x = y \/ x > y }.

(** case analysis under two assumptions *)

Class Le_neq_to_lt `{Le A} : Prop :=
  { le_neq_to_lt : forall x y : A, x <= y -> x <> y -> x < y }.

Class Ge_neq_to_gt `{Le A} : Prop :=
  { ge_neq_to_gt : forall x y : A, x >= y -> x <> y -> x > y }.

Class Nlt_nslt_to_eq `{Le A} : Prop :=
  { nlt_nslt_to_eq : forall x y : A, ~ (lt x y) -> ~ (lt y x) -> x = y }.

(** contradiction from case analysis *)

Class Lt_ge_false `{Le A} : Prop :=
  { lt_ge_false : forall x y : A, x < y -> x >= y -> False }.

Class Lt_gt_false `{Le A} : Prop :=
  { lt_gt_false : forall x y : A, x < y -> x > y -> False }.

Class Lt_slt_false `{Le A} : Prop :=
  { lt_slt_false : forall x y : A, x < y -> y < x -> False }.

(* ********************************************************************** *)
(* * Instances for comparison structures *)

Section Instances.
Context `{Le A}.

Ltac auto_star ::= try solve [ dauto ].

(** derived structures *)

Global Instance Le_preorder_of_Le_order :
  Le_order ->
  Le_preorder.
Proof using. constructor. intros. apply* order_to_preorder. Qed.

Global Instance Le_total_preorder_of_Le_total_order :
  Le_total_order ->
  Le_total_preorder.
Proof using. constructor. intros. apply* total_order_to_total_preorder. Qed.

Global Instance Le_preorder_of_Total_preorder :
  Le_total_preorder ->
  Le_preorder.
Proof using. constructor. intros. apply* total_preorder_to_preorder. Qed.

Global Instance Le_order_of_Le_total_order :
  Le_total_order ->
  Le_order.
Proof using. constructor. intros. apply* total_order_to_order. Qed.

Global Instance lt_strict_order_of_lt_strict_total_order :
  Lt_strict_total_order ->
  Lt_strict_order.
Proof using. constructor. intros. apply* strict_total_order_to_strict_order. Qed.

Global Instance Lt_strict_order_of_Le_order :
  Le_order ->
  Lt_strict_order.
Proof using. constructor. intros. rew_to_le. apply* strict_order_strict. Qed.

Global Instance Lt_strict_total_order_of_Le_total_order :
  Le_total_order ->
  Lt_strict_total_order.
Proof using. constructor. intros. rew_to_le. apply* strict_total_order_of_total_order. Qed.

(** symmetric structures *)

Global Instance Ge_preorder_of_Le_order :
  Le_order ->
  Ge_preorder.
Proof using. constructor. rew_to_le. apply preorder_inverse. apply le_preorder. Qed.

Global Instance Ge_total_preorder_of_Le_total_order :
  Le_total_order ->
  Ge_total_preorder.
Proof using. constructor. rew_to_le. apply total_preorder_inverse. apply le_total_preorder. Qed.

Global Instance Ge_preorder_of_Total_preorder :
  Le_total_preorder ->
  Ge_preorder.
Proof using. constructor. rew_to_le. apply preorder_inverse. apply le_preorder. Qed.

Global Instance Ge_order_of_Le_total_order :
  Le_total_order ->
  Ge_order.
Proof using. constructor. rew_to_le. apply order_inverse. apply le_order. Qed.

Global Instance Gt_strict_order_of_lt_strict_total_order :
  Lt_strict_total_order ->
  Gt_strict_order.
Proof using. constructor. rewrite gt_is_inverse_lt. apply strict_order_inverse. apply lt_strict_order. Qed.

Global Instance Gt_strict_order_of_Le_order :
  Le_order ->
  Gt_strict_order.
Proof using. constructor. rewrite gt_is_inverse_lt. apply strict_order_inverse. apply lt_strict_order. Qed.

Global Instance Gt_strict_total_order_of_Le_total_order :
  Le_total_order ->
  Gt_strict_total_order.
Proof using. constructor. rewrite gt_is_inverse_lt. apply strict_total_order_inverse. apply lt_strict_total_order. Qed.

(** properties of le *)

Global Instance Le_refl_of_Le_preorder :
  Le_preorder ->
  Le_refl.
Proof using. intros [[Re Tr]]. constructor~. Qed.

Global Instance Le_trans_of_Le_preorder :
  Le_preorder ->
  Le_trans.
Proof using. intros [[Re Tr]]. constructor~. Qed.

Global Instance Le_antisym_of_Le_order :
  Le_order ->
  Le_antisym.
Proof using. constructor. intros. apply* order_antisym. Qed.

Global Instance Le_total_of_Le_total_order :
  Le_total_order ->
  Le_total.
Proof using. constructor. intros. apply* total_order_total. Qed.

(** properties of ge *)

Global Instance Ge_refl_of_Le_preorder :
  Le_preorder ->
  Ge_refl.
Proof using. constructor. rew_to_le. apply refl_inverse. apply le_refl. Qed.

Global Instance Ge_trans_of_Le_preorder :
  Le_preorder ->
  Ge_trans.
Proof using. constructor. rew_to_le. apply trans_inverse. apply le_trans. Qed.

Global Instance Ge_antisym_of_Le_order :
  Le_order ->
  Ge_antisym.
Proof using. constructor. rew_to_le. apply antisym_inverse. apply le_antisym. Qed.

Global Instance Ge_total_of_Le_total_order :
  Le_total_order ->
  Ge_total.
Proof using. constructor. rew_to_le. apply total_inverse. apply le_total. Qed.

(** properties of lt *)

Global Instance Lt_irrefl_of_Le_order :
  Le_order ->
  Lt_irrefl.
Proof using. constructor. apply strict_order_irrefl. apply lt_strict_order. Qed.

Global Instance Lt_trans_of_Le_order :
  Le_order ->
  Lt_trans.
Proof using. constructor. apply strict_order_trans. apply lt_strict_order. Qed.

(** properties of gt *)

Global Instance Gt_irrefl_of_Le_order :
  Le_order ->
  Gt_irrefl.
Proof using. constructor. apply strict_order_irrefl. apply gt_strict_order. Qed.

Global Instance Gt_trans_of_Le_order :
  Le_order ->
  Gt_trans.
Proof using. constructor. apply strict_order_trans. apply gt_strict_order. Qed.

(** mixed transitivity results *)

Global Instance Lt_le_trans_of_Le_order :
  Le_order ->
  Lt_le_trans.
Proof using.
  constructor. introv K L. rew_to_le. destruct K as [U V].
  split~. apply* le_trans. intro_subst. apply V. apply* le_antisym.
Qed.

Global Instance Le_lt_trans_of_Le_order :
  Le_order ->
  Le_lt_trans.
Proof using.
  constructor. introv K L. rew_to_le. destruct L as [U V].
  split~. apply* le_trans. intro_subst. apply V. apply* le_antisym.
Qed.

Global Instance gt_ge_trans_of_Le_order :
  Le_order ->
  Gt_ge_trans.
Proof using.
  constructor. introv K L. rew_to_le_lt. hnf in *. apply* le_lt_trans.
Qed.

Global Instance ge_gt_trans_of_Le_order :
  Le_order ->
  Ge_gt_trans.
Proof using.
  constructor. introv K L. rew_to_le_lt. hnf in *. apply* lt_le_trans.
Qed.
(** conversion between operators *)

Global Instance Ge_as_sle_of :
  Ge_as_sle.
Proof using. constructor. intros. rew_to_le. auto. Qed.

Global Instance Gt_as_slt_of :
  Gt_as_slt.
Proof using. constructor. intros. rew_to_le. auto. Qed.

Global Instance Ngt_as_sle_of_Le_total_order :
  Le_total_order ->
  Ngt_as_sle.
Proof using.
  constructor. intros. rew_to_le. unfold strict. rew_logic. iff M.
  destruct M.
    forwards K:(inverse_strict_of_not (R:=le)); eauto.
      apply le_total. apply (proj1 K).
    subst. apply le_refl.
  apply or_classic_l. intros P Q. apply P. apply* le_antisym.
Qed.

Global Instance Nlt_as_ge_of_Le_total_order :
  Le_total_order ->
  Nlt_as_ge.
Proof using. constructor. intros. rew_to_le_lt. unfold inverse. apply ngt_as_sle. Qed.

Global Instance Ngt_as_le_of_Le_total_order :
  Le_total_order ->
  Ngt_as_le.
Proof using. constructor. intros. rew_to_le_lt. unfold inverse. apply ngt_as_sle. Qed.

Global Instance Nle_as_gt_of_Le_total_order :
  Le_total_order ->
  Nle_as_gt.
Proof using.
  constructor. intros. rew_to_le_lt. unfold inverse.
  rewrite <- ngt_as_sle. rewrite~ not_not_eq.
Qed.

Global Instance Nge_as_lt_of_Le_total_order :
  Le_total_order ->
  Nge_as_lt.
Proof using.
  constructor. intros. rew_to_le_lt. unfold inverse.
  rewrite nle_as_gt. rewrite~ gt_is_inverse_lt.
Qed.

(** inclusion between operators *)

Global Instance Lt_to_le_of :
  Lt_to_le.
Proof using. constructor. intros. rew_to_le. unfolds* strict. Qed.

Global Instance Gt_to_ge_of :
  Gt_to_ge.
Proof using. constructor. intros. rew_to_le. unfolds* inverse, strict. Qed.

Global Instance Nle_to_sle_of_Le_total_order :
  Le_total_order ->
  Nle_to_sle.
Proof using.
  constructor. introv K. rewrite nle_as_gt in K.
  rew_to_le. unfolds* inverse, strict.
Qed.

Global Instance Nle_to_slt_of_Le_total_order :
  Le_total_order ->
  Nle_to_slt.
Proof using.
  constructor. introv K. rewrite nle_as_gt in K.
  rew_to_le. unfolds* inverse, strict.
Qed.

(** case analysis under no assumption *)

Global Instance Case_eq_lt_gt_of_Le_total_order :
  Le_total_order ->
  Case_eq_lt_gt.
Proof using.
  introv K. constructor. intros.
  lets [(M1&M2)|[M|(M1&M2)]]: (total_order_lt_or_eq_or_gt le_total_order x y).
    rewrite le_is_rclosure_lt in M1 by applys* total_order_refl. destruct* M1.
    autos*.
    rewrite le_is_rclosure_lt in M1 by applys* total_order_refl. destruct* M1.
Qed.

Global Instance Case_eq_lt_slt_of_Le_total_order :
  Le_total_order ->
  Case_eq_lt_slt.
Proof using.
  constructor. intros. pattern lt at 2. rewrite lt_is_inverse_gt.
  apply case_eq_lt_gt.
Qed.

Global Instance Case_le_gt_of_Le_total_order :
  Le_total_order ->
  Case_le_gt.
Proof using.
  constructor. intros.
  rewrite le_is_rclosure_lt by applys* total_order_refl. rewrite rclosure_eq.
  branches (total_order_lt_or_eq_or_gt le_total_order x y); eauto.
Qed.

Global Instance Case_eq_lt_ge_of_Le_total_order :
  Le_total_order ->
  Case_lt_ge.
Proof using.
  constructor. intros.
  rewrite ge_is_rclosure_gt by applys* total_order_refl. rewrite rclosure_eq.
  branches (total_order_lt_or_eq_or_gt le_total_order x y); eauto.
Qed.

Global Instance Case_le_slt_of_Le_total_order :
  Le_total_order ->
  Case_le_slt.
Proof using. constructor. intros. rewrite lt_is_inverse_gt. apply case_le_gt. Qed.

Global Instance Case_eq_lt_sle_of_Le_total_order :
  Le_total_order ->
  Case_lt_sle.
Proof using. constructor. intros. rewrite le_is_inverse_ge. apply case_lt_ge. Qed.

(** case analysis under one assumption *)

Global Instance Neq_case_lt_gt_of_Le_total_order :
  Le_total_order ->
  Neq_case_lt_gt.
Proof using. constructor. intros. destruct* (case_eq_lt_gt x y). Qed.

Global Instance Neq_case_lt_slt_of_Le_total_order :
  Le_total_order ->
  Neq_case_lt_slt.
Proof using. constructor. intros. destruct* (case_eq_lt_gt x y). Qed.

Global Instance Le_case_eq_lt_of_Le_total_order :
  Le_total_order ->
  Le_case_eq_lt.
Proof using. constructor. intros. rew_to_le. unfold strict. tests*: (x = y). Qed.

Global Instance Ge_case_eq_gt_of_Le_total_order :
  Le_total_order ->
  Ge_case_eq_gt.
Proof using. constructor. intros. rew_to_le. unfold inverse, strict. tests*: (x = y). Qed.

(** case analysis under two assumptions *)

Global Instance Le_neq_to_lt_of_Le_total_order :
  Le_total_order ->
  Le_neq_to_lt.
Proof using. constructor. intros. rew_to_le. hnfs*. Qed.

Global Instance Ge_neq_to_gt_of_Le_total_order :
  Le_total_order ->
  Ge_neq_to_gt.
Proof using. constructor. intros. rew_to_le. hnfs*. Qed.

Global Instance Nlt_nslt_to_eq_of_Le_total_order :
  Le_total_order ->
  Nlt_nslt_to_eq.
Proof using. constructor. intros. branches* (case_eq_lt_gt x y). Qed.

(** contradiction from case analysis *)

Global Instance Lt_ge_false_of_Le_total_order :
  Le_total_order ->
  Lt_ge_false.
Proof using. constructor. introv H1 H2. rewrite~ <- nlt_as_ge in H2. Qed.

Global Instance Lt_gt_false_of_Le_total_order :
  Le_total_order ->
  Lt_gt_false.
Proof using.
  constructor. introv H1 H2. rewrite~ <- nle_as_gt in H2.
  apply H2. apply* lt_to_le.
Qed.

Global Instance Lt_slt_false_of_Le_total_order :
  Le_total_order ->
  Lt_slt_false.
Proof using.
  constructor. introv H1 H2. rewrite <- gt_as_slt in H2.
  apply* lt_gt_false.
Qed.

End Instances.

(** -- Other lemmas needs arguments to be implicit? *)

(* ********************************************************************** *)
(** * Boolean comparison *)

Module BooleanComparison.

Open Scope comp_scope.

(** Additional notation for reflected boolean comparison.
    Use [Open Scope comp_scope_reflect] to use them. *)

Declare Scope comp_scope_reflect.

Notation "x ''<=' y" := (isTrue (@le _ _ x y))
  (at level 70, no associativity) : comp_scope_reflect.
Notation "x ''>=' y" := (isTrue (@ge _ _ x y))
  (at level 70, no associativity) : comp_scope_reflect.
Notation "x ''<' y" := (isTrue (@lt _ _ x y))
  (at level 70, no associativity) : comp_scope_reflect.
Notation "x ''>' y" := (isTrue (@gt _ _ x y))
  (at level 70, no associativity) : comp_scope_reflect.

End BooleanComparison.

(* ********************************************************************** *)
(** * Order on relations and on predicates *)

Lemma order_rel_incl : forall A B,
  order (@rel_incl A B).
Proof using.
  hint refl_rel_incl, antisym_rel_incl, trans_rel_incl.
  constructors*.
Qed.

Lemma order_pred_incl : forall A B,
  order (@rel_incl A B).
Proof using.
  hint refl_rel_incl, antisym_rel_incl, trans_rel_incl.
  constructors*.
Qed.

(* ********************************************************************** *)
(* * Min and max *)

Definition min `{Le A} (n m:A) : A :=
  If n <= m then n else m.

Lemma min_l : forall `{Le A} (n m:A),
  antisym le ->
  n <= m ->
  min n m = n.
Proof using. introv T M. unfold min. case_if*. Qed.

Lemma min_r : forall `{Le A} (n m:A),
  antisym le ->
  m <= n ->
  min n m = m.
Proof using. introv T M. unfold min. case_if*. Qed.

Definition max `{Le A} (n m:A) : A :=
  If n <= m then m else n.

Lemma max_l : forall `{Le A} (n m:A),
  antisym le ->
  n >= m ->
  max n m = n.
Proof using. introv T M. unfold max. case_if*. Qed.

Lemma max_r : forall `{Le A} (n m:A),
  antisym le ->
  n <= m ->
  max n m = m.
Proof using. introv T M. unfold max. case_if*. Qed.


From Hammer Require Import Hammer Reconstr.

Require Import String.
Require Import Arith.PeanoNat.
Require Import Bool.Bool.

Inductive aexpr :=
| Nval : nat -> aexpr
| Vval : string -> aexpr
| Aplus : aexpr -> aexpr -> aexpr.

Definition state := string -> nat.

Fixpoint aval (s : state) (e : aexpr) :=
  match e with
  | Nval n => n
  | Vval x => s x
  | Aplus x y => aval s x + aval s y
  end.

Fixpoint plus (e1 e2 : aexpr) :=
  match e1, e2 with
  | Nval n1, Nval n2 => Nval (n1 + n2)
  | Nval 0, _ => e2
  | _, Nval 0 => e1
  | _, _ => Aplus e1 e2
  end.

Lemma lem_aval_plus : forall s e1 e2, aval s (plus e1 e2) = aval s e1 + aval s e2.
Proof.
  induction e1; sauto.
Qed.

Fixpoint asimp (e : aexpr) :=
  match e with
  | Aplus x y => plus (asimp x) (asimp y)
  | _ => e
  end.

Lemma lem_aval_asimp : forall s e, aval s (asimp e) = aval s e.
Proof.
  induction e; sauto.
  hammer_hook "imp" "imp.lem_aval_asimp.subgoal_1".
  Reconstr.reasy (@lem_aval_plus) Reconstr.Empty.
Qed.

Inductive bexpr :=
| Bval : bool -> bexpr
| Bnot : bexpr -> bexpr
| Band : bexpr -> bexpr -> bexpr
| Bless : aexpr -> aexpr -> bexpr.

Fixpoint bval (s : state) (e : bexpr) :=
  match e with
  | Bval b => b
  | Bnot e1 => negb (bval s e1)
  | Band e1 e2 => bval s e1 && bval s e2
  | Bless a1 a2 => aval s a1 <? aval s a2
  end.

Fixpoint not (e : bexpr) :=
  match e with
  | Bval true => Bval false
  | Bval false => Bval true
  | _ => Bnot e
  end.

Fixpoint and (e1 e2 : bexpr) :=
  match e1, e2 with
  | Bval true, _ => e2
  | _, Bval true => e1
  | Bval false, _ => Bval false
  | _, Bval false => Bval false
  | _, _ => Band e1 e2
  end.

Definition less (a1 a2 : aexpr) :=
  match a1, a2 with
  | Nval n1, Nval n2 => Bval (n1 <? n2)
  | _, _ => Bless a1 a2
  end.

Fixpoint bsimp (e : bexpr) :=
  match e with
  | Bnot e1 => not (bsimp e1)
  | Band e1 e2 => and (bsimp e1) (bsimp e2)
  | Bless a1 a2 => less a1 a2
  | _ => e
  end.

Lemma lem_bval_not : forall s e, bval s (not e) = negb (bval s e).
Proof.
  induction e; sauto.
Qed.

Lemma lem_bval_and : forall s e1 e2, bval s (and e1 e2) = bval s e1 && bval s e2.
Proof.
  induction e1; sauto.
Qed.

Lemma lem_bval_less : forall s a1 a2, bval s (less a1 a2) = (aval s a1 <? aval s a2).
Proof.
  induction a1; sauto.
Qed.

Lemma lem_bval_bsimp : forall s e, bval s (bsimp e) = bval s e.
Proof.
  induction e; sauto.
  - hammer_hook "imp" "imp.lem_bval_bsimp.subgoal_1". Reconstr.reasy (@lem_bval_not) Reconstr.Empty.
  - hammer_hook "imp" "imp.lem_bval_bsimp.subgoal_2". Reconstr.reasy (@lem_bval_and) Reconstr.Empty.
  - hammer_hook "imp" "imp.lem_bval_bsimp.subgoal_3". ycrush.
  - hammer_hook "imp" "imp.lem_bval_bsimp.subgoal_4". ycrush.
Qed.

Inductive cmd :=
| Skip : cmd
| Assign : string -> aexpr -> cmd
| Seq : cmd -> cmd -> cmd
| If : bexpr -> cmd -> cmd -> cmd
| While : bexpr -> cmd -> cmd.

Definition update (s : state) x v y := if string_dec x y then v else s y.

Inductive big_step : cmd * state -> state -> Prop :=
| SkipSem : forall s, big_step (Skip, s) s
| AssignSem : forall s x a, big_step (Assign x a, s) (update s x (aval s a))
| SeqSem : forall c1 c2 s1 s2 s3, big_step (c1, s1) s2 -> big_step (c2, s2) s3 ->
                                  big_step (Seq c1 c2, s1) s3
| IfTrue : forall b c1 c2 s s', bval s b = true -> big_step (c1, s) s' ->
                                big_step (If b c1 c2, s) s'
| IfFalse : forall b c1 c2 s s', bval s b = false -> big_step (c2, s) s' ->
                                 big_step (If b c1 c2, s) s'
| WhileFalse : forall b c s, bval s b = false ->
                             big_step (While b c, s) s
| WhileTrue : forall b c s1 s2 s3,
    bval s1 b = true -> big_step (c, s1) s2 -> big_step (While b c, s2) s3 ->
    big_step (While b c, s1) s3.

Notation "A ==> B" := (big_step A B) (at level 80, no associativity).

Lemma lem_seq_assoc : forall c1 c2 c3 s s', (Seq c1 (Seq c2 c3), s) ==> s' <->
                                            (Seq (Seq c1 c2) c3, s) ==> s'.
Proof.
  hammer_hook "imp" "imp.lem_seq_assoc".
  scrush. (* > 2s *)
Qed.

Definition equiv_cmd (c1 c2 : cmd) := forall s s', (c1, s) ==> s' <-> (c2, s) ==> s'.

Notation "A ~~ B" := (equiv_cmd A B) (at level 70, no associativity).

Lemma lem_unfold_loop : forall b c, While b c ~~ If b (Seq c (While b c)) Skip.
Proof.
  hammer_hook "imp" "imp.lem_unfold_loop".
  unfold equiv_cmd; intros; split; intro H; inversion H; ycrush.
Qed.

Lemma lem_while_cong_aux : forall b c c' s s', (While b c, s) ==> s' -> c ~~ c' ->
                                               (While b c', s) ==> s'.
Proof.
  hammer_hook "imp" "imp.lem_while_cong_aux".
  assert (forall p s', p ==> s' -> forall b c c' s, p = (While b c, s) -> c ~~ c' -> (While b c', s) ==> s').
  intros p s' H.
  induction H; sauto.
  - ycrush.
  - unfold equiv_cmd in *; ycrush.
  - eauto.
Qed.

Lemma lem_while_cong : forall b c c', c ~~ c' -> While b c ~~ While b c'.
Proof.
  hammer_hook "imp" "imp.lem_while_cong".
  Reconstr.reasy (@lem_while_cong_aux) (@equiv_cmd).
Qed.

Lemma lem_big_step_deterministic :
  forall c s s1 s2, (c, s) ==> s1 -> (c, s) ==> s2 -> s1 = s2.
Proof.
  hammer_hook "imp" "imp.lem_big_step_deterministic".
  intros c s s1 s2 H.
  revert s2.
  induction H; try yelles 1.
  scrush.
  intros s0 H2; inversion H2; scrush.
Qed.

Inductive small_step : cmd * state -> cmd * state -> Prop :=
| AssignSemS : forall x a s, small_step (Assign x a, s) (Skip, update s x (aval s a))
| SeqSemS1 : forall c s, small_step (Seq Skip c, s) (c, s)
| SeqSemS2 : forall c1 c2 s c1' s', small_step (c1, s) (c1', s') ->
                                    small_step (Seq c1 c2, s) (Seq c1' c2, s')
| IfTrueS : forall b c1 c2 s, bval s b = true ->
                              small_step (If b c1 c2, s) (c1, s)
| IfFalseS : forall b c1 c2 s, bval s b = false ->
                               small_step (If b c1 c2, s) (c2, s)
| WhileS : forall b c s, small_step (While b c, s) (If b (Seq c (While b c)) Skip, s).

Notation "A --> B" := (small_step A B) (at level 80, no associativity).

Require Import Relations.

Ltac pose_rt := pose @rt_step; pose @rt_refl; pose @rt_trans.

Definition small_step_star := clos_refl_trans (cmd * state) small_step.

Hint Unfold small_step_star : yhints.

Notation "A -->* B" := (small_step_star A B) (at level 80, no associativity).

Lemma lem_small_step_deterministic :
  forall c s s1 s2, (c, s) --> s1 -> (c, s) --> s2 -> s1 = s2.
Proof.
  hammer_hook "imp" "imp.lem_small_step_deterministic".
  intros c s s1 s2 H.
  revert s2.
  induction H; try yelles 1.
  scrush.
  intros s2 H2; inversion H2; scrush.
Qed.

Lemma lem_star_seq2 : forall c1 c2 s c1' s', (c1, s) -->* (c1', s') ->
                                             (Seq c1 c2, s) -->* (Seq c1' c2, s').
Proof.
  hammer_hook "imp" "imp.lem_star_seq2".
  assert (forall p1 p2, p1 -->* p2 ->
                        forall c1 c2 s c1' s', p1 = (c1, s) -> p2 = (c1', s') ->
                                               (Seq c1 c2, s) -->* (Seq c1' c2, s')).
  intros p1 p2 H.
  induction H as [ | | ? y ]; try yelles 1.
  pose_rt; pose SeqSemS2; scrush.
  intros c1 c2 s c1' s' H1 H2; subst.
  destruct y as [ c0 s0 ].
  assert ((Seq c1 c2, s) -->* (Seq c0 c2, s0)) by scrush.
  assert ((Seq c0 c2, s0) -->* (Seq c1' c2, s')) by scrush.
  pose_rt; scrush.
  scrush.
Qed.

Lemma lem_seq_comp : forall c1 c2 s1 s2 s3, (c1, s1) -->* (Skip, s2) -> (c2, s2) -->* (Skip, s3) ->
                                            (Seq c1 c2, s1) -->* (Skip, s3).
Proof.
  hammer_hook "imp" "imp.lem_seq_comp".
  intros c1 c2 s1 s2 s3 H1 H2.
  assert ((Seq c1 c2, s1) -->* (Seq Skip c2, s2)).
  pose lem_star_seq2; scrush.
  assert ((Seq Skip c2, s2) -->* (c2, s2)).
  pose_rt; scrush.
  pose_rt; scrush.
Qed.

Lemma lem_big_to_small : forall p s', p ==> s' -> p -->* (Skip, s').
Proof.
  intros p s' H.
  induction H as [ | | | | | | b c s1 s2 ]; try yelles 1.
  - hammer_hook "imp" "imp.lem_big_to_small.subgoal_1". Reconstr.reasy (@lem_seq_comp) Reconstr.Empty.
  - hammer_hook "imp" "imp.lem_big_to_small.subgoal_2". pose_rt; pose IfTrueS; scrush.
  - hammer_hook "imp" "imp.lem_big_to_small.subgoal_3". pose_rt; pose IfFalseS; scrush.
  - hammer_hook "imp" "imp.lem_big_to_small.subgoal_4". pose_rt; pose WhileS; pose IfFalseS; ycrush.
  - hammer_hook "imp" "imp.lem_big_to_small.subgoal_5".
    assert ((While b c, s1) -->* (Seq c (While b c), s1)) by
        (pose_rt; pose WhileS; pose IfTrueS; ycrush).
    assert ((Seq c (While b c), s1) -->* (Seq Skip (While b c), s2)) by
        Reconstr.reasy (@lem_star_seq2) Reconstr.Empty.
    pose_rt; pose SeqSemS1; ycrush.
Qed.

Lemma lem_small_to_big_aux : forall p p', p --> p' -> forall s, p' ==> s -> p ==> s.
Proof.
  intros p p' H.
  induction H; sauto; try yelles 1.
  hammer_hook "imp" "imp.lem_big_to_small_aux.subgoal_1".
  Reconstr.reasy (@lem_unfold_loop) (@equiv_cmd).
Qed.

Lemma lem_small_to_big_aux_2 : forall p p', p -->* p' -> forall s, p' ==> s -> p ==> s.
Proof.
  intros p p' H.
  induction H; sauto.
  hammer_hook "imp" "imp.lem_big_to_small_aux_2.subgoal_1".
  Reconstr.reasy (@lem_small_to_big_aux) Reconstr.Empty.
Qed.

Lemma lem_small_to_big : forall p s, p -->* (Skip, s) -> p ==> s.
Proof.
  assert (forall p p', p -->* p' -> forall s, p' = (Skip, s) -> p ==> s).
  intros p p' H.
  induction H; sauto.
  - hammer_hook "imp" "imp.lem_small_to_big.subgoal_1". ycrush.
  - hammer_hook "imp" "imp.lem_small_to_big.subgoal_2".
    Reconstr.rsimple (@lem_small_to_big_aux_2) (@small_step_star).
  - hammer_hook "imp" "imp.lem_small_to_big.subgoal_3". ycrush.
Qed.

Corollary cor_big_iff_small : forall p s, p ==> s <-> p -->* (Skip, s).
Proof.
  hammer_hook "imp" "imp.cor_big_iff_small".
  Reconstr.reasy (@lem_small_to_big, @lem_big_to_small) Reconstr.Empty.
Qed.


Require Import Arith.
Require Import Omega.
Require Import Recdef.
Require Import List.
Require Import Program.Tactics.
Require Import Program.Equality.
Require Import Sorting.Permutation.
Import ListNotations.

Variable A:Type.
Implicit Types l : list A.

(* This Ltac performs inversion on `Add` terms where the result list
   is a cons. *)
Ltac InvAdd := repeat (match goal with
 | H: Add ?x _ (_ :: _) |- _ => inversion H; clear H; subst
 end).

(* Let’s try to prove Permutation_Add_inv without a new induction
   principle! Look where we get stuck. *)

Theorem Permutation_Add_inv' a l1 l2 :
  Permutation l1 l2 ->
  forall l1' l2', Add a l1' l1 ->
                  Add a l2' l2 ->
                  Permutation l1' l2'.
Proof.
  revert l1 l2.
  refine (Permutation_ind _ _ _ _ _).
  - (* nil *)
    intros.
    inversion H.
  - (* skip *)
    intros x l1 l2 PE IH. intros.
    InvAdd.
    + auto.
    + rewrite <- PE. now apply Permutation_Add.
    + rewrite PE. symmetry. now apply Permutation_Add.
    + apply perm_skip. now apply IH.
  - (* swap *)
    intros x y l l1 l2 A1 A2. intros.
    Check Permutation_ind.
    (* DAMN *)
    admit.
  - (* trans *)
    intros l1 l l2 PE IH PE' IH' l1' l2' AD1 AD2.
    assert (Ha : In a l).
    { rewrite <- PE. rewrite (Add_in AD1). simpl; auto. }
    destruct (Add_inv _ _ Ha) as (l',AD).
    transitivity l'.
    now apply IH.
    now apply IH'.
Abort.

(* This new induction principle is inspired by the place we got stuck. *)

Lemma Permutation_ind_bis:
  forall P: list A -> list A -> Prop,
    (* nil: *)
    P [] [] ->
    (* skip/cons: *)
    (forall a l l', Permutation l l' -> P l l' ->
                    P (a :: l) (a :: l')) ->
    (* generalized swap: *)
    (forall x y l l', Permutation l l' -> P l l' ->
                      P (x :: y :: l) (y :: x :: l')) ->
    (* trans: *)
    (forall l l' l'', Permutation l l' -> P l l' ->
                      Permutation l' l'' -> P l' l'' ->
                      P l l'') ->
    (* ...imply true for all *)
    forall l l', Permutation l l' -> P l l'.
  intros P Hnil Hcons Hswap Htrans l l' PE.
  induction PE.
  auto.
  apply Hcons; auto.
  apply Hswap.
  apply Permutation_refl.
  induction l; auto.
  apply Htrans with (l':=l'); auto.
Qed.

(* Now we can prove Add_inv! *)

Theorem Permutation_Add_inv a l1 l2 :
  Permutation l1 l2 ->
  forall l1' l2', Add a l1' l1 ->
                  Add a l2' l2 ->
                  Permutation l1' l2'.
Proof.
  revert l1 l2.
  refine (Permutation_ind_bis _ _ _ _ _).
  - (* nil *)
    inversion_clear 1.
  - (* skip *)
    intros x l1 l2 PE IH. intros.
    InvAdd.
    + auto.
    + rewrite <- PE. now apply Permutation_Add.
    + rewrite PE. symmetry. now apply Permutation_Add.
    + apply perm_skip. now apply IH.
  - (* swap *)
    intros x y l1 l2 PE IH. intros.
    InvAdd.
    + now constructor.
    + now constructor.
    + constructor. rewrite <- PE. now apply Permutation_Add.
    + now constructor.
    + now constructor.
    + rewrite perm_swap. constructor. rewrite <- PE.
      now apply Permutation_Add.
    + constructor. rewrite PE. symmetry.
      now apply Permutation_Add.
    + rewrite perm_swap. constructor. rewrite PE. symmetry.
      now apply Permutation_Add.
    + (* The case that needs the inductive hypothesis! *)
      rewrite perm_swap. constructor. constructor.
      now apply IH.
  - (* trans *)
    intros l1 l l2 PE IH PE' IH' l1' l2' AD1 AD2.
    assert (Ha : In a l).
    { rewrite <- PE. rewrite (Add_in AD1). simpl; auto. }
    destruct (Add_inv _ _ Ha) as (l',AD).
    transitivity l'.
    now apply IH.
    now apply IH'.
Qed.

(* A little more Ltac makes this easier to prove, but harder to
   investigate the proof. This is basically the library’s proof
   (the library uses `auto` here and there). *)

Ltac finish_basic_perms H :=
  try constructor; try rewrite perm_swap; try constructor; trivial;
  (rewrite <- H; now apply Permutation_Add) ||
  (rewrite H; symmetry; now apply Permutation_Add).

Theorem Permutation_Add_inv' a l1 l2 :
  Permutation l1 l2 ->
  forall l1' l2', Add a l1' l1 ->
                  Add a l2' l2 ->
                  Permutation l1' l2'.
Proof.
  revert l1 l2.
  refine (Permutation_ind_bis _ _ _ _ _).
  - (* nil *)
    inversion_clear 1.
  - (* skip *)
    intros x l1 l2 PE IH. intros.
    InvAdd; try finish_basic_perms PE.
    apply perm_skip. now apply IH.
  - (* swap *)
    intros x y l1 l2 PE IH. intros.
    InvAdd; try finish_basic_perms PE.
    (* The case that needs the inductive hypothesis! *)
    rewrite perm_swap. do 2 constructor. now apply IH.
  - (* trans *)
    intros l1 l l2 PE IH PE' IH' l1' l2' AD1 AD2.
    assert (Ha : In a l).
    { rewrite <- PE. rewrite (Add_in AD1). simpl; auto. }
    destruct (Add_inv _ _ Ha) as (l',AD).
    transitivity l'.
    now apply IH.
    now apply IH'.
Qed.