(* week-04_exercises.v *)
(* FPP 2020 - YSC3236 2020-2011, Sem1 *)

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

(*
Your name:
Bernard Boey
Tristan Koh

Your e-mail address:
bernard@u.yale-nus.edu.sg
tristan.koh@u.yale-nus.edu.sg

Your student number:
A0191234L
A0191222R

*)

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

(* Exercise 9 *)

Proposition foo :
  forall P Q R1 R2 : Prop,
    P -> (P -> Q) -> (Q -> R1) /\ (Q -> R2) -> R1 /\ R2.
Proof.
  (* Backwards proof *)
  intros P Q R1 R2.
  intros H_P H_P_implies_Q [H_Q_implies_R1 H_Q_implies_R2].
  split.
  - apply H_Q_implies_R1.
    apply H_P_implies_Q.
    apply H_P.
  - apply H_Q_implies_R2.
    apply H_P_implies_Q.
    apply H_P.

    Restart.

  (* Forwards proof *)
  intros P Q R1 R2.
  intros H_P H_P_implies_Q [H_Q_implies_R1 H_Q_implies_R2].
  assert (H_Q := H_P_implies_Q H_P).
  assert (H_R1 := H_Q_implies_R1 H_Q).
  assert (H_R2 := H_Q_implies_R2 H_Q).
  Check (conj H_R1 H_R2).
  exact (conj H_R1 H_R2).
Qed.

(* Exercise 10 *)

Proposition bar :
  forall P1 P2 Q R1 R2 T1 T2 : Prop,
    P1 -> (P1 -> P2) -> (P2 -> Q) -> (Q -> R1) -> (R1 -> T1) -> (Q -> R2) -> (R2 -> T2) -> T1 /\ T2.
Proof.

  (* Split as early as possible *)
  intros P1 P2 Q R1 T1 R2 T2.
  intros H_P1 H_P1_implies_P2 H_P2_implies_Q H_Q_implies_R1 H_R1_implies_R2 H_Q_implies_T1 H_T1_implies_T2.
  split.
  - apply H_R1_implies_R2.
    apply H_Q_implies_R1.
    apply H_P2_implies_Q.
    apply H_P1_implies_P2.
    apply H_P1.
  - apply H_T1_implies_T2.
    apply H_Q_implies_T1.
    apply H_P2_implies_Q.
    apply H_P1_implies_P2.
    apply H_P1.

  Restart.

  (* Split as late as possible *)
  intros P1 P2 Q R1 T1 R2 T2.
  intros H_P1 H_P1_implies_P2 H_P2_implies_Q H_Q_implies_R1 H_R1_implies_R2 H_Q_implies_T1 H_T1_implies_T2.
  assert (H_P2 := H_P1_implies_P2 H_P1).
  assert (H_Q := H_P2_implies_Q H_P2).
  assert (H_R1 := H_Q_implies_R1 H_Q).
  assert (H_R2 := H_R1_implies_R2 H_R1).
  assert (H_T1 := H_Q_implies_T1 H_Q).
  assert (H_T2 := H_T1_implies_T2 H_T1).
  split.
  - exact H_R2.
  - exact H_T2.

  Restart.

  (* Without splitting at all *)
  intros P1 P2 Q R1 T1 R2 T2.
  intros H_P1 H_P1_implies_P2 H_P2_implies_Q H_Q_implies_R1 H_R1_implies_R2 H_Q_implies_T1 H_T1_implies_T2.
  assert (H_P2 := H_P1_implies_P2 H_P1).
  assert (H_Q := H_P2_implies_Q H_P2).
  assert (H_R1 := H_Q_implies_R1 H_Q).
  assert (H_R2 := H_R1_implies_R2 H_R1).
  assert (H_T1 := H_Q_implies_T1 H_Q).
  assert (H_T2 := H_T1_implies_T2 H_T1).
  exact (conj H_R2 H_T2).
Qed.

(* Exercise 11 *)

Proposition baz :
  forall P Q R T U1 U2 : Prop,
    P -> (P -> Q) -> (Q -> R) -> (R -> T) -> (T -> U1) -> (T -> U2) -> U1 /\ U2.
Proof.

  (* Using split as early as possible *)

  intros P Q R T U1 U2.
  intros H_P H_P_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U1 H_T_implies_U2.
  split.
  - apply H_T_implies_U1.
    apply H_R_implies_T.
    apply H_Q_implies_R.
    apply H_P_implies_Q.
    apply H_P.
  - apply H_T_implies_U2.
    apply H_R_implies_T.
    apply H_Q_implies_R.
    apply H_P_implies_Q.
    apply H_P.

  Restart.

  (* Using split as late as possible *)

  intros P Q R T U1 U2.
  intros H_P H_P_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U1 H_T_implies_U2.
  assert (H_Q := H_P_implies_Q H_P).
  assert (H_R := H_Q_implies_R H_Q).
  assert (H_T := H_R_implies_T H_R).
  assert (H_U1 := H_T_implies_U1 H_T).
  assert (H_U2 := H_T_implies_U2 H_T).
  split.
  - exact H_U1.
  - exact H_U2.
Qed.

(* Exercise 12 *)

(* Part a *)
Proposition baz_dual_early :
  forall P1 P2 Q R T U : Prop,
    (P1 \/ P2) -> (P1 -> Q) -> (P2 -> Q) -> (Q -> R) -> (R -> T) -> (T -> U) -> U.
Proof.
  intros P1 P2 Q R T U.
  intros H_P1_or_P2 H_P1_implies_Q H_P2_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U.
  destruct H_P1_or_P2 as [H_P1 | H_P2].
  - assert (H_Q := H_P1_implies_Q H_P1).
    assert (H_R := H_Q_implies_R H_Q).
    assert (H_T := H_R_implies_T H_R).
    assert (H_U := H_T_implies_U H_T).
    exact H_U.
  - assert (H_Q := H_P2_implies_Q H_P2).
    assert (H_R := H_Q_implies_R H_Q).
    assert (H_T := H_R_implies_T H_R).
    assert (H_U := H_T_implies_U H_T).
    exact H_U.
Qed.

(* Part b *)

Proposition baz_dual_late :
  forall P1 P2 Q R T U : Prop,
    (P1 \/ P2) -> (P1 -> Q) -> (P2 -> Q) -> (Q -> R) -> (R -> T) -> (T -> U) -> U.
Proof.
  intros P1 P2 Q R T U.
  intros H_P1_or_P2 H_P1_implies_Q H_P2_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U.
  apply H_T_implies_U.
  apply H_R_implies_T.
  apply H_Q_implies_R.
  destruct H_P1_or_P2 as [H_P1 | H_P2].
  - apply (H_P1_implies_Q).
    apply H_P1.
  - apply (H_P2_implies_Q).
    apply H_P2.
Qed.

(* Part d *)
Proposition baz_dual_early_or_late :
  forall P1 P2 Q R T U : Prop,
    (P1 \/ P2) -> (P1 -> Q) -> (P2 -> Q) -> (Q -> R) -> (R -> T) -> (T -> U) -> U.
Proof.
  intros P1 P2 Q R T U.
  intros [H_P1 | H_P2] H_P1_implies_Q H_P2_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U.
  - assert (H_Q := H_P1_implies_Q H_P1).
    assert (H_R := H_Q_implies_R H_Q).
    assert (H_T := H_R_implies_T H_R).
    assert (H_U := H_T_implies_U H_T).
    exact H_U.
  - assert (H_Q := H_P2_implies_Q H_P2).
    assert (H_R := H_Q_implies_R H_Q).
    assert (H_T := H_R_implies_T H_R).
    assert (H_U := H_T_implies_U H_T).
    exact H_U.
Qed.

(* Exercise 13 *)
Proposition ladidah :
  forall P1 P2 P3 P4 Q R T U : Prop,
    (P1 \/ P2) \/ (P3 \/ P4) -> (P1 -> Q) -> (P2 -> Q) -> (P3 -> Q) -> (P4 -> Q) -> (Q -> R) -> (R -> T) -> (T -> U) -> U.

  (* Backward proof *)
  intros P1 P2 P3 P4 Q R T U.
  intros H_P1_or_P2_or_P3_or_P4 H_P1_implies_Q H_P2_implies_Q H_P3_implies_Q H_P4_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U.
  apply H_T_implies_U.
  apply H_R_implies_T.
  apply H_Q_implies_R.
  destruct H_P1_or_P2_or_P3_or_P4 as [[H_P1 | H_P2] | [H_P3 | H_P4]].
  - exact (H_P1_implies_Q H_P1).
  - exact (H_P2_implies_Q H_P2).
  - exact (H_P3_implies_Q H_P3).
  - exact (H_P4_implies_Q H_P4).

    Restart.

    (* Forward proof *)
    intros P1 P2 P3 P4 Q R T U.
    intros H_P1_or_P2_or_P3_or_P4 H_P1_implies_Q H_P2_implies_Q H_P3_implies_Q H_P4_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U.
    destruct H_P1_or_P2_or_P3_or_P4 as [[H_P1 | H_P2] | [H_P3 | H_P4]].
  - assert (H_Q := H_P1_implies_Q H_P1).
    assert (H_R := H_Q_implies_R H_Q).
    assert (H_T := H_R_implies_T H_R).
    assert (H_U := H_T_implies_U H_T).
    exact H_U.
  -  assert (H_Q := H_P2_implies_Q H_P2).
     assert (H_R := H_Q_implies_R H_Q).
     assert (H_T := H_R_implies_T H_R).
     assert (H_U := H_T_implies_U H_T).
     exact H_U.
  -  assert (H_Q := H_P3_implies_Q H_P3).
     assert (H_R := H_Q_implies_R H_Q).
     assert (H_T := H_R_implies_T H_R).
     assert (H_U := H_T_implies_U H_T).
     exact H_U.
  -  assert (H_Q := H_P4_implies_Q H_P4).
     assert (H_R := H_Q_implies_R H_Q).
     assert (H_T := H_R_implies_T H_R).
     assert (H_U := H_T_implies_U H_T).
     exact H_U.
Qed.

Proposition toodeloo :
  forall P Q R T U1 U2 U3 U4: Prop,
    P -> (P -> Q) -> (Q -> R) -> (R -> T) -> (T -> U1) -> (T -> U2) -> (T -> U3) -> (T -> U4) -> (U1 /\ U2) /\ (U3 /\ U4).
Proof.

  (* Forward proof *)
  intros P Q R T U1 U2 U3 U4.
  intros H_P H_P_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U1 H_T_implies_U2 H_T_implies_U3 H_T_implies_U4.
  assert (H_Q := H_P_implies_Q H_P).
  assert (H_R := H_Q_implies_R H_Q).
  assert (H_T := H_R_implies_T H_R).
  assert (H_U1 := H_T_implies_U1 H_T).
  assert (H_U2 := H_T_implies_U2 H_T).
  assert (H_U3 := H_T_implies_U3 H_T).
  assert (H_U4 := H_T_implies_U4 H_T).
  split.
  - exact (conj H_U1 H_U2).
  - exact (conj H_U3 H_U4).

    Restart.

    (* Backwards proof *)
    intros P Q R T U1 U2 U3 U4.
    intros H_P H_P_implies_Q H_Q_implies_R H_R_implies_T H_T_implies_U1 H_T_implies_U2 H_T_implies_U3 H_T_implies_U4.
    split.
  - split.
    -- apply H_T_implies_U1.
       apply H_R_implies_T.
       apply H_Q_implies_R.
       apply H_P_implies_Q.
       apply H_P.
    -- apply H_T_implies_U2.
       apply H_R_implies_T.
       apply H_Q_implies_R.
       apply H_P_implies_Q.
       apply H_P.
  - split.
    -- apply H_T_implies_U3.
       apply H_R_implies_T.
       apply H_Q_implies_R.
       apply H_P_implies_Q.
       apply H_P.
    -- apply H_T_implies_U4.
       apply H_R_implies_T.
       apply H_Q_implies_R.
       apply H_P_implies_Q.
       apply H_P.
Qed.

(* Equational reasoning about arithmetic functions *)

(* Paraphernalia: *)

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

Require Import Arith Bool.

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

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

(* Two implementations of the addition function *)

(* ***** *)

(* Unit tests *)

Definition test_add (candidate: nat -> nat -> nat) : bool :=
  (candidate 0 0 =n= 0)
  &&
  (candidate 0 1 =n= 1)
  &&
  (candidate 1 0 =n= 1)
  &&
  (candidate 1 1 =n= 2)
  &&
  (candidate 1 2 =n= 3)
  &&
  (candidate 2 1 =n= 3)
  &&
  (candidate 2 2 =n= 4)
  (* etc. *)
  .

(* ***** *)

(* Recursive implementation of the addition function *)

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

Compute (test_add add_v1).

Lemma fold_unfold_add_v1_O :
  forall j : nat,
    add_v1 O j =
    j.
Proof.
  fold_unfold_tactic add_v1.
Qed.

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

(* ***** *)

(* Tail-recursive implementation of the addition function *)

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

Compute (test_add add_v2).

Lemma fold_unfold_add_v2_O :
  forall j : nat,
    add_v2 O j =
    j.
Proof.
  fold_unfold_tactic add_v2.
Qed.

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

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

(* Equivalence of add_v1 and add_v2 *)

(* ***** *)

(* The master lemma: *)

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

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

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

(* ***** *)

(* The main theorem: *)

Theorem equivalence_of_add_v1_and_add_v2 :
  forall i j : nat,
    add_v1 i j = add_v2 i j.
Proof.
  intro i.
  induction i as [ | i' IHi'].

  - intro j.
    rewrite -> (fold_unfold_add_v2_O j).
    exact (fold_unfold_add_v1_O j).

  - intro j.
    rewrite -> (fold_unfold_add_v1_S i' j).
    rewrite -> (fold_unfold_add_v2_S i' j).
    rewrite -> (IHi' j).
    symmetry.
    exact (about_add_v2 i' j).
Qed.

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

(* Neutral (identity) element for addition *)

(* Exercise 17 *)

Property O_is_left_neutral_wrt_add_v1 :
  forall y : nat,
    add_v1 0 y = y.
Proof.
  exact (fold_unfold_add_v1_O).
Qed.

(* Exercise 18 *)

Property O_is_left_neutral_wrt_add_v2 :
  forall y : nat,
    add_v2 0 y = y.
Proof.
  exact (fold_unfold_add_v2_O).
Qed.

(* Exercise 19 *)

Property O_is_right_neutral_wrt_add_v1 :
  forall x : nat,
    add_v1 x 0 = x.
Proof.
  intro x.
  induction x as [ | x' IHx'].
  - exact (fold_unfold_add_v1_O 0).
  - rewrite -> (fold_unfold_add_v1_S x' 0).
    rewrite -> IHx'.
    reflexivity.
Qed.

(* Exercise 20 *)

Property O_is_right_neutral_wrt_add_v2 :
  forall x : nat,
    add_v2 x 0 = x.
Proof.
  intro x.
  induction x as [ | x' IHx'].
  - exact (fold_unfold_add_v2_O 0).
  - rewrite -> (fold_unfold_add_v2_S x' 0).
    rewrite -> (about_add_v2 x' 0).
    rewrite -> IHx'.
    reflexivity.
Qed.

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

(* Associativity of addition *)

(* Exercise 21 *)

Property add_v1_is_associative :
  forall x y z : nat,
    add_v1 x (add_v1 y z) = add_v1 (add_v1 x y) z.
Proof.
  intros x y z.
  induction x as [ | x' IHx'].
  - rewrite -> (fold_unfold_add_v1_O (add_v1 y z)).
    rewrite -> (fold_unfold_add_v1_O y).
    reflexivity.
  - rewrite -> (fold_unfold_add_v1_S x' (add_v1 y z)).
    rewrite -> (fold_unfold_add_v1_S x' y).
    rewrite -> (fold_unfold_add_v1_S (add_v1 x' y) z).
    rewrite -> IHx'.
    reflexivity.
Qed.

(* Exercise 22 *)

Property add_v2_is_associative :
  forall x y z : nat,
    add_v2 x (add_v2 y z) = add_v2 (add_v2 x y) z.
Proof.
  intros x y z.
  induction x as [ | x' IHx'].
  - rewrite -> (fold_unfold_add_v2_O (add_v2 y z)).
    rewrite -> (fold_unfold_add_v2_O y).
    reflexivity.
  - rewrite -> (fold_unfold_add_v2_S x' (add_v2 y z)).
    rewrite -> (fold_unfold_add_v2_S x' y).
    rewrite -> (about_add_v2 x' (add_v2 y z)).
    rewrite -> (about_add_v2 x' y).
    rewrite -> (fold_unfold_add_v2_S (add_v2 x' y) z).
    rewrite -> (about_add_v2 (add_v2 x' y) z).
    rewrite -> IHx'.
    reflexivity.
Qed.

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

(* Commutativity of addition *)

(* Exercise 23 *)

Lemma about_add_v1 :
  forall x y : nat,
    add_v1 x (S y) = S (add_v1 x y).
Proof.
  intros x y.
  induction x as [ | x' IHx'].
  - rewrite -> (fold_unfold_add_v1_O y).
    exact (fold_unfold_add_v1_O (S y)).
  - rewrite -> (fold_unfold_add_v1_S x' (S y)).
    rewrite -> (fold_unfold_add_v1_S x' y).
    rewrite -> IHx'.
    reflexivity.
Qed.

Property add_v1_is_commutative :
  forall x y : nat,
    add_v1 x y = add_v1 y x.
Proof.
  intros x y.
  induction x as [ | x' IHx'].
  - rewrite -> (O_is_right_neutral_wrt_add_v1 y).
    exact (fold_unfold_add_v1_O y).
  - rewrite -> (fold_unfold_add_v1_S x' y).
    rewrite -> (about_add_v1 y x').
    rewrite -> IHx'.
    reflexivity.
Qed.

(* Exercise 24 *)

Property add_v2_is_commutative :
  forall x y : nat,
    add_v2 x y = add_v2 y x.
Proof.
  intro x.
  induction x as [ | x' IHx'].
  - intro y.
    rewrite -> (O_is_right_neutral_wrt_add_v2 y).
    exact (fold_unfold_add_v2_O y).
  - intro y.
    rewrite -> (fold_unfold_add_v2_S x' y).
    rewrite -> (IHx' (S y)).
    rewrite -> (fold_unfold_add_v2_S y x').
    reflexivity.
Qed.

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

(* Four implementations of the multiplication function *)

(* ***** *)

(* Unit tests *)

Definition test_mul (candidate: nat -> nat -> nat) : bool :=
  (candidate 0 0 =n= 0)
  &&
  (candidate 0 1 =n= 0)
  &&
  (candidate 1 0 =n= 0)
  &&
  (candidate 1 1 =n= 1)
  &&
  (candidate 1 2 =n= 2)
  &&
  (candidate 2 1 =n= 2)
  &&
  (candidate 2 2 =n= 4)
  &&
  (candidate 2 3 =n= 6)
  &&
  (candidate 3 2 =n= 6)
  &&
  (candidate 6 4 =n= 24)
  &&
  (candidate 4 6 =n= 24)
  (* etc. *)
  .

(* ***** *)

(* Recursive implementation of the multiplication function, using add_v1 *)

Fixpoint mul_v11 (x y : nat) : nat :=
  match x with
  | O =>
    O
  | S x' =>
    add_v1 (mul_v11 x' y) y
  end.

Compute (test_mul mul_v11).

Lemma fold_unfold_mul_v11_O :
  forall y : nat,
    mul_v11 O y =
    O.
Proof.
  fold_unfold_tactic mul_v11.
Qed.

Lemma fold_unfold_mul_v11_S :
  forall x' y : nat,
    mul_v11 (S x') y =
    add_v1 (mul_v11 x' y) y.
Proof.
  fold_unfold_tactic mul_v11.
Qed.

(* ***** *)

(* Recursive implementation of the multiplication function, using add_v2 *)

Fixpoint mul_v12 (x y : nat) : nat :=
  match x with
  | O =>
    O
  | S x' =>
    add_v2 (mul_v12 x' y) y
  end.

Compute (test_mul mul_v11).

Lemma fold_unfold_mul_v12_O :
  forall y : nat,
    mul_v12 O y =
    O.
Proof.
  fold_unfold_tactic mul_v12.
Qed.

Lemma fold_unfold_mul_v12_S :
  forall x' y : nat,
    mul_v12 (S x') y =
    add_v2 (mul_v12 x' y) y.
Proof.
  fold_unfold_tactic mul_v12.
Qed.

(* ***** *)

(* Exercise 27 *)

(* Tail-recursive implementation of the multiplication function, using add_v1 *)

Fixpoint mul_v21_aux (x y a : nat) : nat :=
  match x with
  | O =>
    a
  | S x' =>
    mul_v21_aux x' y (add_v1 y a)
  end.

Definition mul_v21 (x y : nat) : nat :=
  mul_v21_aux x y 0.

Compute (test_mul mul_v21).

Lemma fold_unfold_mul_v21_aux_O :
  forall y a : nat,
    mul_v21_aux 0 y a =
    a.
Proof.
  fold_unfold_tactic mul_v21_aux.
Qed.

Lemma fold_unfold_mul_v21_aux_S :
  forall x' y a : nat,
    mul_v21_aux (S x') y a =
    mul_v21_aux x' y (add_v1 y a).
Proof.
  fold_unfold_tactic mul_v21_aux.
Qed.

(* ***** *)

(* Exercise 28 *)

(* Tail-recursive implementation of the multiplication function, using add_v2 *)

Fixpoint mul_v22_aux (x y a : nat) : nat :=
  match x with
  | O =>
    a
  | S x' =>
    mul_v22_aux x' y (add_v2 y a)
  end.

Definition mul_v22 (x y : nat) : nat :=
  mul_v22_aux x y 0.

Compute (test_mul mul_v22).

Lemma fold_unfold_mul_v22_aux_O :
  forall y a : nat,
    mul_v22_aux 0 y a =
    a.
Proof.
  fold_unfold_tactic mul_v22_aux.
Qed.

Lemma fold_unfold_mul_v22_aux_S :
  forall x' y a : nat,
    mul_v22_aux (S x') y a =
    mul_v22_aux x' y (add_v2 y a).
Proof.
  fold_unfold_tactic mul_v22_aux.
Qed.

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

(* Exercise 29 *)

(* Equivalence of mul_v11, mul_v12, mul_v21, and mul_v22 *)

(* ***** *)

Theorem equivalence_of_mul_v11_and_mul_v12 :
  forall i j : nat,
    mul_v11 i j = mul_v12 i j.
Proof.
  intros i j.
  induction i as [ | i' IHi'].
  - rewrite -> (fold_unfold_mul_v12_O j).
    exact (fold_unfold_mul_v11_O j).
  - rewrite -> (fold_unfold_mul_v11_S i' j).
    rewrite -> (fold_unfold_mul_v12_S i' j).
    rewrite -> IHi'.
    rewrite -> (equivalence_of_add_v1_and_add_v2 (mul_v12 i' j) j).
    reflexivity.
Qed.

(* ***** *)

Lemma about_mul_v21_and_add_v1 :
  forall x y a n : nat,
    add_v1 (mul_v21_aux x y a) n = mul_v21_aux x y (add_v1 n a).
Proof.
  intros x.
  induction x as [ | x' IHx'].
  - intros y a n.
    rewrite -> (fold_unfold_mul_v21_aux_O y a).
    rewrite -> (fold_unfold_mul_v21_aux_O y (add_v1 n a)).
    exact (add_v1_is_commutative a n).
  - intros y a n.
    rewrite -> (fold_unfold_mul_v21_aux_S x' y a).
    rewrite -> (fold_unfold_mul_v21_aux_S x' y (add_v1 n a)).
    rewrite -> (IHx' y (add_v1 y a) n).
    rewrite -> (add_v1_is_associative n y a).
    rewrite -> (add_v1_is_associative y n a).
    rewrite -> (add_v1_is_commutative n y).
    reflexivity.
Qed.

Theorem equivalence_of_mul_v11_and_mul_v21 :
  forall i j : nat,
    mul_v11 i j = mul_v21 i j.
Proof.
  intros i j.
  unfold mul_v21.
  induction i as [ | i' IHi'].
  - rewrite -> (fold_unfold_mul_v21_aux_O j 0).
    exact (fold_unfold_mul_v11_O j).
  - rewrite -> (fold_unfold_mul_v11_S i' j).
    rewrite -> (fold_unfold_mul_v21_aux_S i' j).
    rewrite -> IHi'.
    Check (about_mul_v21_and_add_v1 i' j 0 j).
    exact (about_mul_v21_and_add_v1 i' j 0 j).
Qed.

(* ***** *)

Lemma equivalence_of_mul_v21_aux_and_mul_v22_aux :
  forall i j a : nat,
    mul_v21_aux i j a = mul_v22_aux i j a.
Proof.
  intros i j.
  induction i as [ | i' IHi'].
  - intro a.
    rewrite -> (fold_unfold_mul_v22_aux_O j a).
    exact (fold_unfold_mul_v21_aux_O j a).
  - intro a.
    rewrite -> (fold_unfold_mul_v22_aux_S i' j a).
    rewrite -> (fold_unfold_mul_v21_aux_S i' j a).
    rewrite -> (equivalence_of_add_v1_and_add_v2 j a).
    exact (IHi' (add_v2 j a)).
Qed.

Theorem equivalence_of_mul_v21_and_mul_v22 :
  forall i j : nat,
    mul_v21 i j = mul_v22 i j.
Proof.
  intros i j.
  unfold mul_v21.
  unfold mul_v22.
  exact (equivalence_of_mul_v21_aux_and_mul_v22_aux i j 0).
Qed.

(* ***** *)

Lemma about_mul_v22_and_add_v2 :
  forall x y a n : nat,
    add_v2 (mul_v22_aux x y a) n = mul_v22_aux x y (add_v2 n a).
Proof.
  intros x.
  induction x as [ | x' IHx'].
  - intros y a n.
    rewrite -> (fold_unfold_mul_v22_aux_O y a).
    rewrite -> (fold_unfold_mul_v22_aux_O y (add_v2 n a)).
    exact (add_v2_is_commutative a n).
  - intros y a n.
    rewrite -> (fold_unfold_mul_v22_aux_S x' y a).
    rewrite -> (fold_unfold_mul_v22_aux_S x' y (add_v2 n a)).
    rewrite -> (IHx' y (add_v2 y a) n).
    rewrite -> (add_v2_is_associative n y a).
    rewrite -> (add_v2_is_associative y n a).
    rewrite -> (add_v2_is_commutative n y).
    reflexivity.
Qed.

Theorem equivalence_of_mul_v11_and_mul_v22 :
  forall i j : nat,
    mul_v11 i j = mul_v22 i j.
Proof.
  intros i j.
  unfold mul_v22.
  induction i as [ | i' IHi'].
  - rewrite -> (fold_unfold_mul_v22_aux_O j 0).
    exact (fold_unfold_mul_v11_O j).
  - rewrite -> (fold_unfold_mul_v11_S i' j).
    rewrite -> (fold_unfold_mul_v22_aux_S i' j).
    rewrite -> IHi'.
    rewrite -> (equivalence_of_add_v1_and_add_v2 (mul_v22_aux i' j 0) j).
    exact (about_mul_v22_and_add_v2 i' j 0 j).

  Restart.

  intros i j.
  rewrite -> (equivalence_of_mul_v11_and_mul_v21 i j).
  exact (equivalence_of_mul_v21_and_mul_v22 i j).
Qed.

(* ***** *)

Theorem equivalence_of_mul_v12_and_mul_v21 :
  forall i j : nat,
    mul_v12 i j = mul_v21 i j.
Proof.
  intros i j.
  unfold mul_v21.
  induction i as [ | i' IHi'].
  - rewrite -> (fold_unfold_mul_v21_aux_O j 0).
    exact (fold_unfold_mul_v12_O j).
  - rewrite -> (fold_unfold_mul_v12_S i' j).
    rewrite -> (fold_unfold_mul_v21_aux_S i' j).
    rewrite -> IHi'.
    rewrite <- (equivalence_of_add_v1_and_add_v2 (mul_v21_aux i' j 0) j).
    exact (about_mul_v21_and_add_v1 i' j 0 j).

  Restart.

  intros i j.
  rewrite <- (equivalence_of_mul_v11_and_mul_v12 i j).
  exact (equivalence_of_mul_v11_and_mul_v21 i j).
Qed.

(* ***** *)

Theorem equivalence_of_mul_v12_and_mul_v22 :
  forall i j : nat,
    mul_v12 i j = mul_v22 i j.
Proof.
  intros i j.
  unfold mul_v22.
  induction i as [ | i' IHi'].
  - rewrite -> (fold_unfold_mul_v12_O j).
    rewrite -> (fold_unfold_mul_v22_aux_O j 0).
    reflexivity.
  - rewrite -> (fold_unfold_mul_v12_S i' j).
    rewrite -> (fold_unfold_mul_v22_aux_S i' j).
    rewrite -> IHi'.
    exact (about_mul_v22_and_add_v2 i' j 0 j).

  Restart.

  intros i j.
  rewrite <- (equivalence_of_mul_v11_and_mul_v12 i j).
  rewrite -> (equivalence_of_mul_v11_and_mul_v21 i j).
  exact (equivalence_of_mul_v21_and_mul_v22 i j).
Qed.

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

(* 1 is left neutral with respect to multiplication *)

Lemma mul_v12_aux :
  forall x y': nat,
  mul_v12 x (S y') = add_v2 (mul_v12 x y') x.
Proof.
  intros x y'.
  induction x as [ | x' IHx'].
  - rewrite -> (fold_unfold_mul_v12_O (S y')).
    rewrite -> (fold_unfold_mul_v12_O y').
    rewrite -> (fold_unfold_add_v2_O 0).
    reflexivity.
  - rewrite -> (fold_unfold_mul_v12_S x' (S y')).
    rewrite -> (fold_unfold_mul_v12_S x' y').
    rewrite -> IHx'.
    rewrite -> (about_add_v2 (add_v2 (mul_v12 x' y') x') y').
    rewrite -> (about_add_v2 (add_v2 (mul_v12 x' y') y') x').
    rewrite <- (add_v2_is_associative (mul_v12 x' y') x' y').
    rewrite <- (add_v2_is_associative (mul_v12 x' y') y' x').
    rewrite <- (add_v2_is_commutative x' y').
    reflexivity.
Qed.

Property SO_is_left_neutral_wrt_mul_v12 :
  forall y : nat,
    mul_v12 1 y = y.
Proof.
  intro y.
  induction y as [ | y' IHy'].
  - exact (fold_unfold_mul_v12_O 1).
  - rewrite -> (mul_v12_aux 1 y').
    rewrite -> IHy'.
    rewrite -> (about_add_v2 y' 0).
    rewrite -> (O_is_right_neutral_wrt_add_v2 y').
    reflexivity.
Qed.

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

(* Multiplication is right-distributive over addition *)

(* Exercise 34 *)

Property mul_v11_is_right_distributive_over_add_v1 :
  forall x y z : nat,
    mul_v11 (add_v1 x y) z = add_v1 (mul_v11 x z) (mul_v11 y z).
Proof.
  intros x y z.
  induction x as [ | x' IHx'].
  - rewrite -> (fold_unfold_add_v1_O y).
    rewrite -> (fold_unfold_mul_v11_O z).
    rewrite -> (fold_unfold_add_v1_O (mul_v11 y z)).
    reflexivity.
  - rewrite -> (fold_unfold_add_v1_S x' y).
    rewrite -> (fold_unfold_mul_v11_S x' z).
    rewrite -> (fold_unfold_mul_v11_S (add_v1 x' y) z).
    rewrite -> IHx'.
    rewrite <- (add_v1_is_associative (mul_v11 x' z) (mul_v11 y z) z).
    rewrite -> (add_v1_is_commutative (mul_v11 y z) z).
    Check (add_v1_is_associative (mul_v11 x' z) z (mul_v11 y z)).
    exact (add_v1_is_associative (mul_v11 x' z) z (mul_v11 y z)).
Qed.

(* ***** *)

Lemma about_mul_v12 :
  forall x y : nat,
    mul_v12 (S x) y = add_v2 (mul_v12 x y) y.
Proof.
  intro x.
  induction x as [ | x' IHx'].
  - intro y.
    rewrite -> (fold_unfold_mul_v12_O y).
    rewrite -> (fold_unfold_add_v2_O y).
    exact (SO_is_left_neutral_wrt_mul_v12 y).
  - intro y.
    rewrite -> (fold_unfold_mul_v12_S (S x') y).
    reflexivity.
Qed.

Property mul_v12_is_right_distributive_over_add_v2 :
  forall x y z : nat,
    mul_v12 (add_v2 x y) z = add_v2 (mul_v12 x z) (mul_v12 y z).
Proof.
  intros x.
  induction x as [ | x' IHx'].
  - intros y z.
    rewrite -> (fold_unfold_add_v2_O y).
    rewrite -> (fold_unfold_mul_v12_O z).
    rewrite -> (fold_unfold_add_v2_O (mul_v12 y z)).
    reflexivity.
  - intros y z.
    rewrite -> (fold_unfold_add_v2_S x' y).
    rewrite -> (IHx' (S y) z).
    rewrite -> (about_mul_v12 y z).
    rewrite -> (about_mul_v12 x' z).
    rewrite -> (add_v2_is_commutative (mul_v12 y z) z).
    Check (add_v2_is_associative (mul_v12 x' z) z (mul_v12 y z)).
    exact (add_v2_is_associative (mul_v12 x' z) z (mul_v12 y z)).

  Restart.

  intros x y z.
  rewrite <- (equivalence_of_add_v1_and_add_v2).
  rewrite <- (equivalence_of_add_v1_and_add_v2).
  rewrite <- (equivalence_of_mul_v11_and_mul_v12).
  rewrite <- (equivalence_of_mul_v11_and_mul_v12).
  rewrite <- (equivalence_of_mul_v11_and_mul_v12).
  exact (mul_v11_is_right_distributive_over_add_v1 x y z).
Qed.

Property mul_v21_is_right_distributive_over_add_v1 :
  forall x y z : nat,
    mul_v21 (add_v1 x y) z = add_v1 (mul_v21 x z) (mul_v21 y z).
Proof.
  intros x y z.
  unfold mul_v21.
  induction x as [ | x' IHx'].
  - rewrite -> (fold_unfold_add_v1_O y).
    rewrite -> (fold_unfold_mul_v21_aux_O z 0).
    rewrite -> (fold_unfold_add_v1_O (mul_v21_aux y z 0)).
    reflexivity.
  - rewrite -> (fold_unfold_add_v1_S x' y).
    rewrite -> (fold_unfold_mul_v21_aux_S x' z).
    rewrite -> (fold_unfold_mul_v21_aux_S (add_v1 x' y) z).
    rewrite <- (about_mul_v21_and_add_v1 (add_v1 x' y) z 0 z).
    rewrite <- (about_mul_v21_and_add_v1 x' z 0 z).
    rewrite -> IHx'.
    rewrite <- (add_v1_is_associative (mul_v21_aux x' z 0) (mul_v21_aux y z 0) z).
    rewrite <- (add_v1_is_associative (mul_v21_aux x' z 0) z (mul_v21_aux y z 0)).
    rewrite -> (add_v1_is_commutative (mul_v21_aux y z 0) z).
    reflexivity.

  Restart.

  intros x y z.
  rewrite <- (equivalence_of_mul_v11_and_mul_v21).
  rewrite <- (equivalence_of_mul_v11_and_mul_v21).
  rewrite <- (equivalence_of_mul_v11_and_mul_v21).
  exact (mul_v11_is_right_distributive_over_add_v1 x y z).
Qed.

Property mul_v22_is_right_distributive_over_add_v2 :
  forall x y z : nat,
    mul_v22 (add_v2 x y) z = add_v2 (mul_v22 x z) (mul_v22 y z).
Proof.
  intros x y z.
  unfold mul_v22.
  induction x as [ | x' IHx'].
  - rewrite -> (fold_unfold_add_v2_O y).
    rewrite -> (fold_unfold_mul_v22_aux_O z 0).
    rewrite -> (fold_unfold_add_v2_O (mul_v22_aux y z 0)).
    reflexivity.
  - rewrite -> (fold_unfold_add_v2_S x' y).
    rewrite -> (fold_unfold_mul_v22_aux_S x' z).
    rewrite -> (about_add_v2 x' y).
    rewrite -> (fold_unfold_mul_v22_aux_S (add_v2 x' y) z).
    rewrite <- (about_mul_v22_and_add_v2 (add_v2 x' y) z 0 z).
    rewrite <- (about_mul_v22_and_add_v2 x' z 0 z).
    rewrite -> IHx'.
    rewrite <- (add_v2_is_associative (mul_v22_aux x' z 0) (mul_v22_aux y z 0) z).
    rewrite <- (add_v2_is_associative (mul_v22_aux x' z 0) z (mul_v22_aux y z 0)).
    rewrite -> (add_v2_is_commutative (mul_v22_aux y z 0) z).
    reflexivity.

  Restart.

  intros x y z.
  rewrite <- (equivalence_of_add_v1_and_add_v2).
  rewrite <- (equivalence_of_add_v1_and_add_v2).
  rewrite <- (equivalence_of_mul_v11_and_mul_v22).
  rewrite <- (equivalence_of_mul_v11_and_mul_v22).
  rewrite <- (equivalence_of_mul_v11_and_mul_v22).
  exact (mul_v11_is_right_distributive_over_add_v1 x y z).
Qed.

(* end of week-04_exercises.v *)


Require Import init.

Require Import list_perm.

Require Import equivalence.

Local Instance list_perm_reflexive U : Reflexive _ := {
    refl := @list_perm_refl U
}.
Local Instance list_perm_symmetric U : Symmetric _ := {
    sym := @list_perm_sym U
}.
Local Instance list_perm_transitive U : Transitive _ := {
    trans := @list_perm_trans U
}.

Definition ulist_equiv U := make_equiv _
    (list_perm_reflexive U) (list_perm_symmetric U) (list_perm_transitive U).
Notation "'ulist' U" := (equiv_type (ulist_equiv U)) (at level 1).

Definition ulist_end {U} := to_equiv (ulist_equiv U) list_end.

Lemma uadd_wd U : ∀ (a : U) l1 l2,
    list_permutation l1 l2 → list_permutation (a ꞉ l1) (a ꞉ l2).
Proof.
    intros a l1 l2 l_perm.
    apply list_perm_skip.
    exact l_perm.
Qed.
Definition ulist_add {U} (a : U)
    := unary_op (unary_self_wd (E := ulist_equiv U) (uadd_wd U a)).
(** Like with list_add, this is NOT a colon!  It is actually U+02D0,
modifier letter triangular colon.  I have it mapped to \uadd in ibus. *)
Infix "ː" := ulist_add (at level 49, right associativity) : list_scope.
(** These are \llbracket and \rrbracket, U+27E6 and U+27E7. *)
Notation "⟦⟧" := ulist_end : list_scope.
Notation "⟦ a ⟧" := (a ː ⟦⟧) : list_scope.
Notation "⟦ x ; y ; .. ; z ⟧" :=
    (x ː (y ː .. (z ː ⟦⟧) ..))
    (format "⟦ '[' x ; '/' y ; '/' .. ; '/' z ']' ⟧") : list_scope.

Theorem ulist_induction {U} : ∀ S : ulist U → Prop,
    S ⟦⟧ → (∀ a l, S l → S (a ː l)) → ∀ l, S l.
Proof.
    intros S S_end S_add l.
    equiv_get_value l.
    induction l.
    -   exact S_end.
    -   assert (to_equiv (ulist_equiv U) (a ꞉ l) =
            a ː (to_equiv (ulist_equiv U) l)) as eq.
        {
            unfold ulist_add; equiv_simpl.
            apply list_perm_refl.
        }
        rewrite eq.
        apply S_add.
        exact IHl.
Qed.

Theorem ulist_destruct {U} : ∀ S : ulist U → Prop,
    S ⟦⟧ → (∀ a l, S (a ː l)) → ∀ l, S l.
Proof.
    intros S S_end S_ind l.
    induction l using ulist_induction.
    -   exact S_end.
    -   apply S_ind.
Qed.

Theorem ulist_end_neq {U} : ∀ (a : U) l, a ː l ≠ ⟦⟧.
Proof.
    intros a l contr.
    equiv_get_value l.
    unfold ulist_add, ulist_end in contr; equiv_simpl in contr.
    apply list_perm_sym in contr.
    apply list_perm_nil_eq in contr.
    inversion contr.
Qed.

Theorem ulist_single_eq {U} : ∀ (a b : U), ⟦a⟧ = ⟦b⟧ → a = b.
Proof.
    intros a b eq.
    unfold ulist_add, ulist_end in eq; equiv_simpl in eq.
    pose proof (list_perm_single eq) as eq2.
    inversion eq2.
    reflexivity.
Qed.

Lemma uconc_wd U : ∀ al1 al2 bl1 bl2 : list U,
    list_permutation al1 al2 → list_permutation bl1 bl2 →
    list_permutation (al1 + bl1) (al2 + bl2).
Proof.
    intros al1 al2 bl1 bl2 eq1 eq2.
    pose proof (list_perm_rpart al1 eq2).
    pose proof (list_perm_lpart bl2 eq1).
    exact (list_perm_trans H H0).
Qed.
Global Instance ulist_plus U : Plus (ulist U) := {
    plus := binary_op (binary_self_wd (E := ulist_equiv U) (uconc_wd U))
}.

Theorem ulist_add_conc_add {U} : ∀ (a : U) l1 l2,
    a ː (l1 + l2) = (a ː l1) + l2.
Proof.
    intros a l1 l2.
    equiv_get_value l1 l2.
    unfold plus, ulist_add; equiv_simpl.
    apply list_perm_refl.
Qed.

Theorem ulist_add_conc {U} : ∀ (a : U) l, a ː l = (⟦a⟧) + l.
Proof.
    intros a l.
    equiv_get_value l.
    unfold ulist_end, ulist_add, plus; equiv_simpl.
    apply list_perm_refl.
Qed.

Global Instance ulist_zero U : Zero (ulist U) := {
    zero := ⟦⟧
}.

Global Instance ulist_plus_comm U : PlusComm (ulist U).
Proof.
    split.
    intros a b.
    equiv_get_value a b.
    unfold plus; equiv_simpl.
    apply list_perm_conc.
Qed.

Global Instance ulist_plus_lid U : PlusLid (ulist U).
Proof.
    split.
    intros l.
    equiv_get_value l.
    unfold ulist_end, plus, zero; equiv_simpl.
    apply list_perm_refl.
Qed.

Theorem ulist_conc_lid {U} : ∀ l : ulist U, ⟦⟧ + l = l.
Proof.
    exact plus_lid.
Qed.

Theorem ulist_conc_rid {U} : ∀ l : ulist U, l + ⟦⟧ = l.
Proof.
    exact plus_rid.
Qed.

Global Instance ulist_plus_assoc U : PlusAssoc (ulist U).
Proof.
    split.
    intros a b c.
    equiv_get_value a b c.
    unfold plus; equiv_simpl.
    rewrite plus_assoc.
    apply list_perm_refl.
Qed.

Theorem ulist_swap {U} : ∀ (a b : U) l, a ː b ː l = b ː a ː l.
Proof.
    intros a b l.
    equiv_get_value l.
    unfold ulist_add; equiv_simpl.
    apply list_perm_swap.
Qed.

Theorem ulist_skip {U} : ∀ (a : U) l1 l2, a ː l1 = a ː l2 → l1 = l2.
Proof.
    intros a l1 l2.
    equiv_get_value l1 l2.
    unfold ulist_add; equiv_simpl.
    apply list_perm_add_eq.
Qed.

Global Instance ulist_plus_lcancel U : PlusLcancel (ulist U).
Proof.
    split.
    intros l1 l2 l3.
    equiv_get_value l1 l2 l3.
    unfold plus; equiv_simpl.
    apply list_perm_conc_lcancel.
Qed.

Unset Keyed Unification.

Theorem list_image_perm {U V} : ∀ al bl (f : U → V),
    list_permutation al bl →
    list_permutation (list_image f al) (list_image f bl).
Proof.
    intros al bl f albli x.
    revert bl albli.
    induction al as [|a al]; intros.
    -   apply list_perm_nil_eq in albli.
        subst bl.
        rewrite list_image_end.
        cbn.
        reflexivity.
    -   assert (in_list (a ꞉ al) a) as a_in by (left; reflexivity).
        apply (list_perm_in albli) in a_in.
        apply in_list_split in a_in as [l1 [l2 eq]]; subst bl.
        pose proof (list_perm_split l1 l2 a) as eq.
        pose proof (list_perm_trans albli eq) as eq2.
        apply list_perm_add_eq in eq2.
        specialize (IHal _ eq2).
        rewrite list_image_conc.
        do 2 rewrite list_image_add.
        rewrite list_count_conc.
        do 2 rewrite list_count_add.
        rewrite IHal.
        rewrite list_image_conc, list_count_conc.
        do 2 rewrite plus_assoc.
        apply rplus.
        apply plus_comm.
Qed.

Lemma ulist_image_wd A B : ∀ (f : A → B) a b, list_permutation a b →
    to_equiv (ulist_equiv B) (list_image f a) =
    to_equiv (ulist_equiv B) (list_image f b).
Proof.
    intros a b f ab.
    equiv_simpl.
    apply list_image_perm.
    exact ab.
Qed.
Definition ulist_image {A B} (f : A → B) :=
    unary_op (E := ulist_equiv A) (ulist_image_wd A B f).

Theorem ulist_image_end {A B : Type} : ∀ f : A → B,
    ulist_image f ⟦⟧ = ⟦⟧.
Proof.
    intros f.
    unfold ulist_end, ulist_image; equiv_simpl.
    apply list_perm_refl.
Qed.

Theorem ulist_image_add {A B : Type} : ∀ a l (f : A → B),
    ulist_image f (a ː l) = f a ː ulist_image f l.
Proof.
    intros a l f.
    equiv_get_value l.
    unfold ulist_image, ulist_add; equiv_simpl.
    apply list_perm_refl.
Qed.

Theorem ulist_image_conc {A B : Type} : ∀ a b (f : A → B),
    ulist_image f (a + b) = ulist_image f a + ulist_image f b.
Proof.
    intros a b f.
    equiv_get_value a b.
    unfold ulist_image, plus; equiv_simpl.
    rewrite list_image_conc.
    apply list_perm_refl.
Qed.

Theorem ulist_image_comp {A B C : Type} :
    ∀ (l : ulist A) (f : A → B) (g : B → C),
    ulist_image g (ulist_image f l) = ulist_image (λ x, g (f x)) l.
Proof.
    intros l f g.
    equiv_get_value l.
    unfold ulist_image; equiv_simpl.
    rewrite list_image_comp.
    apply list_perm_refl.
Qed.


Inductive last (A: Set) (a : A) : list A -> Prop :=
| last_single : last A a (cons a nil)
| last_step : forall (y:A) (l:list A), last A a l -> last A a (cons y l).

Print option.
Print list.
Fixpoint last_fun {A: Set} (l : list A) : option A := match l with
        | nil => None
        | cons a nil => Some a
        | cons a b => last_fun b
end.

Fixpoint append {A : Set} (l1 l2 : list A): list A :=
        match l1 with
        | nil => l2
        | cons a b => cons a (append b l2)
        end.

Inductive palindrome (A:Set) : list A -> Prop :=
| palin_nil : palindrome A nil
| palin_single : forall x, palindrome A (cons x nil)
| palin_nnil : forall (x:A) (l:list A), palindrome A l -> palindrome A (cons x (append l (cons x nil))).

Theorem last_step_add:
        forall (A:Set) (a x y: A) (l:list A), last A a (x::y::l)%list -> last A a (y::l).
       Proof.
              intros A a x y l h1.
             inversion h1.  apply H0.
       Qed.

Theorem p2138p1:
        forall (A: Set)(a: A)(l: list A),last _ ((fun c => match c with Some b => b | None => a  end) (last_fun (cons a l))) (cons a l).
       Proof.
           intros A a l.
           change( last A (match (last_fun (a :: l)) with |Some b => b | None => a end) (a :: l)).
           elim l. simpl; apply last_single.
           intros a0 l0 h1. destruct l0. simpl. apply last_step. apply last_single. change (last A match last_fun (a :: (a1 :: l0)%list) with |Some b => b |None => a end (a :: (a0 :: a1 :: l0)%list)).
           apply last_step. apply last_step. eapply last_step_add. apply h1.
       Qed.

Definition relation (A: Type) := A -> A -> Prop.

Inductive sorted {A:Set} (R: A-> A -> Prop): list A -> Prop :=
| sorted0 : sorted R nil
| sorted1 : forall (x: A), sorted R (cons x nil)
| sorted2 : forall (x y:A) (l:list A),
                R x y -> sorted R (cons y l) -> sorted R (cons x (cons y l)).

Hint Resolve sorted0 sorted1 sorted2 : sorted_base.

Theorem sorted_nat_123 : sorted le ((1 :: 2 :: 3 :: nil)%list).
Proof.
        auto with sorted_base.
Qed.

Theorem xy_ord :
        forall x y:nat, le x y -> sorted le (x::y::nil)%list.
Proof.
        auto with sorted_base.
Qed.

Require Import Arith.

Theorem zero_cons_ord :
        forall l:list nat, sorted le l -> sorted le (cons 0 l).
Proof.
        induction l; auto with sorted_base arith.
Qed.

Theorem sorted1_inv :
        forall (A:Set) (le:A->A->Prop) (x:A) (l:list A),
                sorted le (cons x l) -> sorted le l.
Proof.
        intros A r x l h1; inversion h1; auto with sorted_base.
Qed.

Theorem sorted2_inv :
        forall (A:Set) (le:A -> A -> Prop) (x y :A) (l:list A),
                sorted le (cons x (cons y l)) -> le x y.
        Proof.
                inversion 1; auto with sorted_base.
        Qed.

Inductive cons_trans {A:Type} : nat -> list A -> list A -> Prop :=
| cont0 : forall (l:list A), cons_trans   0 l l
| cont1 :forall (n:nat) (x:A) (l1 l2:list A), cons_trans n l1 l2 -> cons_trans n (x::l1)%list (x::l2)%list
| cont2 : forall (n:nat) (x y:A) (l1 l2:list A), cons_trans n l1 l2 -> cons_trans (S n) (x::y::l1)%list (y::x::l2)%list
|cont3 : forall (n m:nat) (l1 l2 l3: list A), (cons_trans n l1 l2) -> (cons_trans m l2 l3) -> (cons_trans (n+m) l1 l3).

Definition permutation {A:Type} (x y: list A) : Prop := exists n : nat, cons_trans n x y.

Require Import Relations.

Hint Resolve cont0 cont1 cont2: perm_base.
Theorem perm_refl:
        forall (A:Type), reflexive (list A) permutation.
Proof.
        unfold reflexive; unfold permutation.
        intros A x. elim x. exists 0; auto with perm_base.
        intros a l h1; inversion h1. exists x0; auto with perm_base.
Qed.

Theorem perm_symm:
        forall (A:Type), symmetric (list A) permutation.
Proof.
        unfold symmetric; unfold permutation.
        intros A. induction 1. induction H. exists 0; auto with perm_base.
        inversion IHcons_trans. exists x0; auto with perm_base. inversion IHcons_trans. exists (S x0); auto with perm_base. inversion IHcons_trans1. inversion IHcons_trans2. exists (x0 + x); eapply cont3. apply H2. apply H1.
Qed.

Hint Resolve perm_refl perm_symm : perm_base.

Theorem perm_tran:
        forall (A:Type), transitive (list A) permutation.
Proof.
        unfold transitive; unfold permutation.
        intros A x y z h1 h2. inversion h1. inversion h2. exists (x0 + x1); eapply cont3; [apply H | trivial].
Qed.

Hint Resolve perm_tran : perm_base.
Theorem perm_equiv:
        forall (A:Type), equiv (list A) permutation.
        unfold equiv. intro A; auto with perm_base.
Qed.

Inductive par : Set := open | close.

Inductive wp : list par -> Prop:=
| wp0 : wp nil
| wp1 : forall (l1 l2 : list par), wp l1-> wp l2 -> wp (cons open (app l1 (cons close l2))).

Hint Resolve wp0 wp1 : wp_base.

Theorem wp_oc : wp (cons open (cons close nil)).
Proof.
        change (wp (open :: (app nil (close :: nil)%list))).
        auto with wp_base.
Qed.

Theorem wp_o_head_c :
        forall l1 l2 : list par, wp l1 -> wp l2 -> wp (cons open (app l1 (cons close l2))).
Proof.
        auto with wp_base.
Qed.

Require Import List.
SearchRewrite (_ ++ (_ ++ _))%list.

Hint Resolve app_assoc:wp_base.

Theorem wp_o_tail_c:
        forall l1 l2:list par, wp l1 -> wp l2 ->
                wp (app l1 (cons open (app l2 (cons close nil)))).
Proof.
        induction 1; simpl; auto with wp_base.
        intros. simpl. rewrite <- app_assoc.
        change (wp ((open :: l1 ++ (close :: (l0 ++ (open :: l2 ++ close :: nil))))%list)).
        auto with wp_base.
Qed.

Hint Resolve wp_o_tail_c : wp_base.

Inductive bin : Set := L : bin | N' : bin -> bin -> bin.

Fixpoint bin_to_string (t:bin) : list par :=
        match t with
        | L => nil
        | N' u v => cons open (app (bin_to_string u) (cons close (bin_to_string v)))
        end.

Theorem wp_bin_to_string :
        forall (t : bin), wp (bin_to_string t).
Proof.
        induction t; simpl ; auto with wp_base.
Qed.

Fixpoint bin_to_string'  (t:bin) : list par:=
        match t with
        | L => nil
        | N' u v => app (bin_to_string' u) (cons open (app (bin_to_string' v) (cons close nil)))
        end.

Theorem wp_bin_to_string' :
        forall (t:bin), wp (bin_to_string' t).
Proof.
        induction t; simpl; auto with wp_base.
Qed.

Require Import JMeq.

Theorem JMEQHELPER1:
        forall (x y : nat), JMeq x y -> JMeq (S x) (S y).
Proof.
        intros.
        elim H. trivial.
Qed.

Goal forall (x y z:nat), JMeq (x+(y+z)) ((x+y)+z).
Proof.
        induction x. simpl. auto. intros. simpl. apply JMEQHELPER1. trivial.
Qed.

Inductive even : nat -> Prop :=
| even0 : even 0
| even1 : forall (n:nat), even n -> even (S (S n)).

Theorem even_double :
        forall (x:nat), even x -> exists n:nat, x = 2*n.
Proof.
        intros. induction H. exists 0;trivial.
        inversion IHeven. exists (S x). rewrite -> H0. simpl; trivial. rewrite -> plus_assoc. rewrite -> plus_comm. simpl. pattern (x+0). rewrite -> plus_comm. simpl. pattern (x + S x). rewrite -> plus_comm. simpl. trivial.
Qed.

Theorem double_even:
        forall (x:nat), even (2 * x).
Proof.
        intros. induction x. simpl; apply even0. simpl. pattern (x+0). rewrite -> plus_comm. simpl. rewrite -> plus_comm. simpl. apply even1. assert (forall x, x + x = 2 * x). induction x0;simpl; auto. rewrite -> H; trivial.
Qed.

Require Import Omega.

Open Scope Z_scope.
Inductive Pfact : Z -> Z -> Prop :=
        pfact0 : Pfact 0 1
        | pfact1 : forall n v: Z, n <> 0 -> Pfact (n-1) v -> Pfact n (n*v).

Goal Pfact 3 6.
apply (pfact1 3 2).
discriminate.
apply (pfact1 2 1).
discriminate.
apply (pfact1 1 1).
discriminate.
apply pfact0.
Qed.

Theorem fact_dom : forall x y: Z, Pfact x y -> 0 <= x.
Proof.
        intros. elim H. omega.
        intros. omega.
Qed.

Require Import ZArith.
Require Import Zwf.
Check Zwf_well_founded.

Theorem dom_fact_ex :
        forall x: Z, 0<=x -> exists y : Z, Pfact x y.
Proof.
        intro x0.
        Check well_founded_ind.
        elim x0 using (well_founded_ind (Zwf_well_founded 0)).
        intros. elim (Zle_lt_or_eq _ _ H0). intros . elim (H (x-1)). intros. exists (x*x1). apply pfact1. omega. trivial. unfold Zwf. omega. omega. intros. exists 1. rewrite <- H1. apply pfact0.
Qed.

Print N.
Print bin.
Inductive parse_rel : list par -> list par -> bin -> Prop:=
| parse_node : forall (l1 l2 l3:list par) (t1 t2 : bin), parse_rel l1 (cons close l2) t1 -> parse_rel l2 l3 t2 -> parse_rel (cons open l1) l3 (N' t1 t2)
| parse_leaf_nil : parse_rel nil nil L
| parse_leaf_close :
                forall l:list par, parse_rel (cons close l) (cons close l) L.

SearchRewrite (_ ++_)%list.

Theorem parse_rel_sound_anx :
        forall (l1 l2:list par) (t:bin),
        parse_rel l1 l2 t -> l1 = app (bin_to_string t) l2.
Proof.
        induction 1. simpl. rewrite <- app_assoc. pattern ((close :: bin_to_string t2) ++ l3). rewrite <- app_comm_cons. rewrite <- IHparse_rel2. rewrite <- IHparse_rel1. trivial. simpl;trivial. simpl;trivial.
Qed.

Theorem parse_rel_sound :
        forall l: list par, (exists t:bin, parse_rel l nil t) -> wp l.
Proof.
        inversion 1. assert (l = app (bin_to_string x) nil). apply parse_rel_sound_anx. trivial. rewrite <- app_nil_end in H1. rewrite -> H1. apply wp_bin_to_string.
Qed.

Section little_semantics.
Variables Var aExp bExp : Set.
Inductive inst : Set :=
| Skip : inst
| Assign : Var -> aExp -> inst
| Sequence : inst -> inst -> inst
| WhileDo : bExp -> inst -> inst.

Variables
 (state : Set)
 (update : state -> Var-> Z -> option state)
 (evalA : state -> aExp -> option Z)
 (evalB : state -> bExp -> option bool).

Inductive exec : state -> inst -> state -> Prop :=
| execSkip : forall s:state, exec s Skip s
| execAssign :
    forall (s s1:state)(v:Var)(n:Z)(a:aExp),
    evalA s a = Some n -> update s v n = Some s1 -> exec s (Assign v a) s1
| execSequence :
    forall (s s1 s2:state)(i1 i2:inst),
    exec s i1 s1 -> exec s1 i2 s2 -> exec s (Sequence i1 i2) s2
| execWhileFalse :
    forall (s :state) (e: bExp)(i:inst),
    evalB s e = Some false -> exec s (WhileDo e i) s
| execWhileTrue :
    forall (s s1 s2 : state)(i:inst) (e:bExp),
    evalB s e = Some true -> exec s i s1 ->  exec s1 (WhileDo e i) s2 -> exec s (WhileDo e i) s2.

Theorem some_true:
        forall x:option bool, x = Some true \/ x = Some false \/ x = None.
Proof.
        intro x; destruct x; try tauto. destruct b; try tauto.
Qed.

Theorem HoareWhileRule_1:
        forall (P:state -> Prop) (b:bExp)(i:inst)(s s':state),
        (forall s1 s2:state, P s1 -> evalB s1 b = Some true -> exec s1 i s2 -> P s2) -> P s -> exec s (WhileDo b i) s' -> P s' /\ evalB s' b = Some false.
Proof.
        intros P b i s s' H.
        cut (forall i',exec s i' s' -> i' = WhileDo b i -> P s -> P s' /\ evalB s' b = Some false).
        eauto.
        intros i' h. elim h; try (intros; discriminate).
        intros. injection H1. intros. rewrite <- H4. split; trivial.
        intros. injection H5. intros. assert (h2 : P s1). rewrite -> H8 in H0; rewrite -> H7 in H1. apply (H s0 s1 H6 H0 H1). apply H4; trivial.
Qed.

Theorem NeverHalt:
        forall (s s': state) (b:bExp),
        exec s (WhileDo b Skip) s' -> evalB s b = Some true -> False.
Proof.
        cut (forall (s s':state) (b:bExp) (i:inst), exec s i s' -> i = WhileDo b Skip -> evalB s b = Some true -> False). intro. eauto.
        intros s s' b i h1. elim h1; try (intros; discriminate).
        intros. injection H0. intros. rewrite <-H3 in H1. rewrite -> H1 in H. discriminate.
        intros. injection H4; intros. rewrite -> H6 in H0; inversion H0. rewrite -> H10 in H5. apply H3; trivial.
Qed.

Theorem HoareSeqRule:
        forall (P: state -> Prop) (i1 i2:inst),
        (forall (s s':state), P s -> exec s i1 s' -> P s') -> (forall (s s':state),P s -> exec s i2 s' -> P s') -> (forall (s1 s2:state), P s1 -> exec s1 (Sequence i1 i2) s2 -> P s2).
Proof.
        intros. inversion H2.
        apply (H0 s0 s2);trivial.
        apply (H s1 s0);trivial.
Qed.

End little_semantics.

Close Scope Z_scope.

Goal ~sorted le ((1::3::2::nil)%list).
unfold not.
intros.
inversion H. inversion H4.
inversion H7. inversion H11. inversion H13.
Qed.

Goal ~(even 1).
unfold not; intros.
generalize (eq_refl 1). pattern 1 at -2.
elim H. intros; discriminate.
intros; discriminate.
Qed.

Inductive stampprice : nat -> Prop:=
| sp0 : stampprice 3
| sp1 : stampprice 5
| sp2 : forall (n m:nat), stampprice n -> stampprice m -> stampprice (n+m).

Hint Resolve sp0 sp1 sp2: sp_base.

Theorem StrongInd:
        forall (P:nat -> Prop),
        P 0 ->
        (forall m:nat, (forall n:nat, n < m -> P n) -> P m) -> (forall m:nat, P m).
Proof.
        intros.
        assert (forall n, (forall m, m < n -> P m)).
        intro. induction n. intros. inversion H1.
        intros. inversion H1. apply H0. apply IHn.
        apply IHn. omega.
        generalize m. clear m. intros m. induction m; trivial. apply H1 with (n:= S (S m)). omega.
Qed.

Goal forall n, n >= 8 -> stampprice n.
intro. pattern n. elim n using StrongInd. intros; omega.
intros.inversion H0. change (stampprice (3+5)). auto with sp_base arith. inversion H1. change (stampprice (3 + 3 + 3)). auto with sp_base arith. inversion H3. change (stampprice (5 + 5)). auto with sp_base arith. change (stampprice (3 + m2)). apply sp2. apply sp0. apply H; omega.
Qed.


Require Import Nijn.Prelude.
Require Import Nijn.Syntax.Signature.
Require Import Nijn.Syntax.Signature.RewriteLemmas.

Import AFSNotation.

(** * Strong normalization *)

(** An AFS is strongly normalizing if the rewriting relation is well-founded *)
Definition isSN
           {B F : Type}
           (X : afs B F)
  : Prop
  := forall (C : con B) (A : ty B), Wf (fun (t1 t2 : tm X C A) => t1 ∼> t2).

(** A type is said to be strongly normalizing if the rewrite relations of terms on that type is strongly normalizing *)
Definition Ty_isSN
           {B F : Type}
           (X : afs B F)
           (A : ty B)
  : Prop
  := forall (C : con B), Wf (fun (t1 t2 : tm X C A) => t1 ∼> t2).

(** We show that if one type is strongly normalizing, then all types are. Hence, it is sufficient to check for strong normalization in just one type. *)
Definition map_Tm
           {B F : Type}
           {X : afs B F}
           {C : con B}
           (A : ty B)
           {A' : ty B}
           (t : tm X C A')
  : tm X (A' ⟶ A ,, C) A
  := TmVar Vz · wkTm t (Drop _ (idWk C)).

Definition Rew_map_Tm
           {B F : Type}
           {X : afs B F}
           {C : con B}
           {A A' : ty B}
           {t1 t2 : tm X C A'}
           (p : t1 ∼> t2)
  : map_Tm A t1 ∼> map_Tm A t2.
Proof.
  unfold map_Tm.
  apply rew_App_r.
  apply Rew_Wk.
  exact p.
Qed.

Theorem SN_if_TySN
        {B F : Type}
        (X : afs B F)
        (A : ty B)
        (H : Ty_isSN X A)
  : isSN X.
Proof.
  intros C A'.
  simple refine (fiber_Wf (H ((A' ⟶ A) ,, C)) _ _).
  - exact (map_Tm _).
  - intros t1 t2.
    exact Rew_map_Tm.
Qed.