Inductive natlist : Type :=
  | nil
  | cons (n : nat) (l : natlist).

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
Definition bag := natlist.
Fixpoint eqb (n m : nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => eqb n' m'
            end
  end.

Fixpoint count (v : nat) (s : bag) : nat :=
    match s with
    | nil => O
    | h :: t => match eqb v h with
        | true => 1 + count v t
        | false => count v t
        end
    end.

Fixpoint leb (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => leb n' m'
      end
  end.
Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.
Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil => l2
  | h :: t => h :: (app t l2)
  end.
Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).

Fixpoint remove_one (v : nat) (s: bag) : bag :=
    match s with
    | nil => nil
    | h :: t => match eqb v h with
        | true => t
        | false => h :: remove_one v t
        end
    end.
Fixpoint rev (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => rev t ++ [h]
  end.

(* EXERCISE *)
Theorem count_member_nonzero : forall (s : bag),
  1 <=? (count 1 (1 :: s)) = true.
Proof.
    intros s. simpl. reflexivity. Qed.

(* The following lemma about leb might help you in the next exercise (it will also be useful in later chapters). *)
Theorem leb_n_Sn : forall n,
  n <=? (S n) = true.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* 0 *)
    simpl. reflexivity.
  - (* S n' *)
    simpl. rewrite IHn'. reflexivity. Qed.

(* EXERCISE *)
(* the previous lemma ended up helping! *)
Theorem remove_does_not_increase_count: forall (s : bag),
  (count 0 (remove_one 0 s)) <=? (count 0 s) = true.
Proof.
    intros s. induction s as [| n s' IHs'].
    - simpl. reflexivity.
    - destruct n.
     + simpl. rewrite -> leb_n_Sn. reflexivity.
     + simpl. rewrite -> IHs'. reflexivity.
    Qed.

(* EXERCISE *)
(*  An injective function is one-to-one: it maps distinct inputs to distinct outputs, without any collisions. *)
Theorem involution_injective : forall (f : nat -> nat),
    (forall n : nat, n = f (f n)) -> (forall n1 n2 : nat, f n1 = f n2 -> n1 = n2).
Proof.
    intros f H0 n1 n2 H1.
    rewrite -> H0.
    rewrite <- H1.
    rewrite <- H0.
    reflexivity.
    Qed.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof. Admitted.

(* EXERCISE *)
Theorem rev_injective : forall (l1 l2 : natlist),
  rev l1 = rev l2 -> l1 = l2.
Proof.
  intros l1 l2. intros H.
  rewrite <- rev_involutive.
  rewrite <- H.
  rewrite -> rev_involutive.
  reflexivity.
  Qed.


Inductive Nat : Type :=
  | Z : Nat
  | S : Nat -> Nat.

Fixpoint add (m n:Nat) : Nat :=
  match m with
    | Z => n
    | S m' => S (add m' n)
  end.

Notation "m + n" := (add m n).
Notation "0" := Z.
Notation "1" := (S Z).

Lemma s_equality : forall m n:Nat, m = n -> S m = S n.
  intros.
  induction m.
  rewrite H.
  auto.
  rewrite H.
  auto.
Qed.

Lemma add_identity : forall m:Nat, m + 0 = m.
  intros.
  elim m.
  simpl.
  auto.
  simpl.
  intros.
  apply s_equality.
  apply H.
Qed.

Lemma add_s_equality : forall m n:Nat, m + (S n) = S (m + n).
Proof.
  intros.
  induction m.
  simpl.
  reflexivity.
  simpl.
  rewrite IHm.
  reflexivity.
Qed.

Lemma add_s : forall m : Nat, S m = m + (S Z).
Proof.
  intros.
  induction m.
  simpl.
  reflexivity.
  simpl.
  rewrite <- IHm.
  reflexivity.
Qed.

Lemma add_commutative : forall m n:Nat, m + n = n + m.
Proof.
  intros.
  induction m as [ | m IHm ].
  simpl.
  rewrite add_identity.
  reflexivity.
  simpl.
  rewrite add_s_equality.
  rewrite IHm.
  reflexivity.
Qed.

Fixpoint mult (m n : Nat) :=
  match m with
    | Z => Z
    | S m' => n + (mult m' n)
  end.

Notation "m * n" := (mult m n).

Lemma mult_identity : forall m : Nat, m * 1 = m.
Proof.
  intros.
  induction m.
  simpl.
  reflexivity.
  simpl.
  rewrite IHm.
  reflexivity.
Qed.

Lemma mult_zero : forall m : Nat, m * 0 = 0.
Proof.
  intros.
  induction m.
  simpl.
  reflexivity.
  simpl.
  rewrite IHm.
  reflexivity.
Qed.

Lemma add_assoc : forall m n o : Nat, m + (n + o) = (m + n) + o.
Proof.
  intros.
  induction m.
  simpl.
  reflexivity.
  simpl.
  rewrite IHm.
  reflexivity.
Qed.

Lemma mult_distributive : forall m n o : Nat, m * (n + o) = (m * n) + (m * o).
Proof.
Admitted.

Lemma mult_associative : forall m n o : Nat, m * (n * o) = (m * n) * o.
Proof.
Admitted.

Lemma mult_s : forall m n : Nat, m * (S n) = (m * n) + m.
Proof.
Admitted.

Lemma mult_commutative : forall m n : Nat, m * n = n * m.
Proof.
  intros.
  induction m.
  simpl.
  rewrite mult_zero.
  reflexivity.
  simpl.
  rewrite add_s.
  rewrite mult_distributive.
  rewrite mult_identity.
  rewrite IHm.
  rewrite add_commutative.
  reflexivity.
Qed.


(* week_40a_binary_trees.v *)
(* dIFP 2014-2015, Q1, Week 40 *)
(* Olivier Danvy <danvy@cs.au.dk> *)

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

Require Import Arith Bool unfold_tactic.

Lemma plus_1_l :
  forall n : nat,
    1 + n = S n.
Proof.
  intro n.
  rewrite -> plus_Sn_m.
  rewrite -> plus_0_l.
  reflexivity.
Qed.

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

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

(* Data type of binary trees of natural numbers: *)

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

(* There is one base case: leaves.
   There is one induction case, with two subtrees.
*)

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

(* Sample of binary trees of natural numbers: *)

Definition bt_0 :=
  Leaf 42.

Definition bt_1 :=
  Node (Leaf 10)
       (Leaf 20).

Definition bt_2 :=
  Node (Node (Leaf 10)
             (Leaf 20))
       (Leaf 30).

(*
Print bt_2.
bt_2 = Node (Node (Leaf 10) (Leaf 20)) (Leaf 30)
     : binary_tree_nat
*)

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

(* How many leaves are there in a given binary tree? *)

(* A unit test: *)

Definition unit_test_for_number_of_leaves (candidate : binary_tree_nat -> nat) :=
  (candidate bt_0 =n= 1)
  &&
  (candidate bt_1 =n= 2)
  &&
  (candidate bt_2 =n= 3)
  &&
  (candidate (Node bt_1 bt_2) =n= 5)
  .

(* ***** *)

(* A specification: *)

Definition specification_of_number_of_leaves (number_of_leaves : binary_tree_nat -> nat) :=
  (forall n : nat,
     number_of_leaves (Leaf n) = 1)
  /\
  (forall t1 t2 : binary_tree_nat,
     number_of_leaves (Node t1 t2) = number_of_leaves t1 + number_of_leaves t2).

(* ***** *)

(* Uniqueness of the specification: *)

Theorem there_is_only_one_number_of_leaves :
  forall f g : binary_tree_nat -> nat,
    specification_of_number_of_leaves f ->
    specification_of_number_of_leaves g ->
    forall t : binary_tree_nat,
      f t = g t.
Proof.
  intros f g.
  unfold specification_of_number_of_leaves.
  intros [Hf_leaf Hf_node] [Hg_leaf Hg_node].
  intro t.
  induction t as [n | t1 IHt1 t2 IHt2].

  rewrite -> Hf_leaf.
  rewrite -> Hg_leaf.
  reflexivity.

  rewrite -> Hf_node.
  rewrite -> Hg_node.
  rewrite -> IHt1.
  rewrite -> IHt2.
  reflexivity.
Qed.

(* ***** *)

(* A first implementation, in direct style: *)

(* The auxiliary (recursive) function: *)

Fixpoint number_of_leaves_ds (t : binary_tree_nat) : nat :=
  match t with
    | Leaf n =>
      1
    | Node t1 t2 =>
      (number_of_leaves_ds t1) + (number_of_leaves_ds t2)
  end.

(* The canonical unfold lemmas: *)

Lemma unfold_number_of_leaves_ds_Leaf :
  forall n : nat,
    number_of_leaves_ds (Leaf n) = 1.
Proof.
  unfold_tactic number_of_leaves_ds.
Qed.

Lemma unfold_number_of_leaves_ds_Node :
  forall t1 t2 : binary_tree_nat,
    number_of_leaves_ds (Node t1 t2) =
    (number_of_leaves_ds t1) + (number_of_leaves_ds t2).
Proof.
  unfold_tactic number_of_leaves_ds.
Qed.

(* The main (non-recursive) function: *)

Definition number_of_leaves_v0 (t : binary_tree_nat) : nat :=
  number_of_leaves_ds t.

(* ***** *)

(* The standard sanity check: *)

Compute unit_test_for_number_of_leaves number_of_leaves_v0.
(*
     = true
     : bool
*)

(* ***** *)

(* The first implementation satisfies the specification: *)

Theorem number_of_leaves_v0_satisfies_the_specification_of_number_of_leaves :
  specification_of_number_of_leaves number_of_leaves_v0.
Proof.
  unfold specification_of_number_of_leaves.
  unfold number_of_leaves_v0.
  split.

  exact unfold_number_of_leaves_ds_Leaf.

  exact unfold_number_of_leaves_ds_Node.
Qed.

(* ***** *)

(* A second implementation, with an accumulator: *)

(* The auxiliary (recursive) function: *)

Fixpoint number_of_leaves_acc (t : binary_tree_nat) (a : nat) : nat :=
  match t with
    | Leaf n =>
      1 + a  (* or even better: S a *)
    | Node t1 t2 =>
      number_of_leaves_acc t1 (number_of_leaves_acc t2 a)
  end.

(* The canonical unfold lemmas: *)

Lemma unfold_number_of_leaves_acc_Leaf :
  forall n a : nat,
    number_of_leaves_acc (Leaf n) a = 1 + a.
Proof.
  unfold_tactic number_of_leaves_acc.
Qed.

Lemma unfold_number_of_leaves_acc_Node :
  forall (t1 t2 : binary_tree_nat)
         (a : nat),
    number_of_leaves_acc (Node t1 t2) a =
    number_of_leaves_acc t1 (number_of_leaves_acc t2 a).
Proof.
  unfold_tactic number_of_leaves_acc.
Qed.

(* The main (non-recursive) function: *)

Definition number_of_leaves_v1 (t : binary_tree_nat) : nat :=
  number_of_leaves_acc t 0.

(* ***** *)

(* The standard sanity check: *)

Compute unit_test_for_number_of_leaves number_of_leaves_v1.
(*
     = true
     : bool
*)

(* The second implementation satisfies the specification: *)

Theorem number_of_leaves_v1_satisfies_the_specification_of_number_of_leaves_first_attempt :
  specification_of_number_of_leaves number_of_leaves_v1.
Proof.
  unfold specification_of_number_of_leaves.
  unfold number_of_leaves_v1.
  split.

  intro n.
  apply (unfold_number_of_leaves_acc_Leaf n 0).

  intros t1 t2.
  rewrite -> unfold_number_of_leaves_acc_Node.
  (* Hum, we are stuck.  Let's venture a helpful lemma: *)
Abort.

Lemma about_number_of_leaves_acc_tentative :
  forall (t : binary_tree_nat)
         (a : nat),
    number_of_leaves_acc t a = (number_of_leaves_acc t 0) + a.
Proof.
Admitted.

Theorem number_of_leaves_v1_satisfies_the_specification_of_number_of_leaves_second_attempt :
  specification_of_number_of_leaves number_of_leaves_v1.
Proof.
  unfold specification_of_number_of_leaves.
  unfold number_of_leaves_v1.
  split.

  intro n.
  apply (unfold_number_of_leaves_acc_Leaf n 0).

  intros t1 t2.
  rewrite -> unfold_number_of_leaves_acc_Node.
  rewrite -> about_number_of_leaves_acc_tentative.
  reflexivity.
  (* Yay, the proof goes through.
     So let's prove the helpful lemma. *)
Abort.

Lemma about_number_of_leaves_acc :
  forall (t : binary_tree_nat)
         (a : nat),
    number_of_leaves_acc t a = (number_of_leaves_acc t 0) + a.
Proof.
  intro t.
  induction t as [n | t1 IHt1 t2 IHt2].

  (* Base case: *)
  intro a.
  (* left-hand side: *)
  rewrite -> unfold_number_of_leaves_acc_Leaf.
  (* right-hand side: *)
  rewrite -> unfold_number_of_leaves_acc_Leaf.
  rewrite -> plus_0_r.
  reflexivity.

  (* Induction case: *)
  intro a.
  (* left-hand side: *)
  rewrite -> unfold_number_of_leaves_acc_Node.
  rewrite -> IHt1.
  rewrite -> IHt2.
  (* right-hand side: *)
  rewrite -> unfold_number_of_leaves_acc_Node.
  rewrite -> (IHt1 (number_of_leaves_acc t2 0)).
  (* postlude: *)
  apply plus_assoc.
Qed.

Theorem number_of_leaves_v1_satisfies_the_specification_of_number_of_leaves :
  specification_of_number_of_leaves number_of_leaves_v1.
Proof.
  unfold specification_of_number_of_leaves.
  unfold number_of_leaves_v1.
  split.

  intro n.
  apply (unfold_number_of_leaves_acc_Leaf n 0).

  intros t1 t2.
  rewrite -> unfold_number_of_leaves_acc_Node.
  rewrite -> about_number_of_leaves_acc.
  reflexivity.
Qed.

(* ***** *)

(* The two implementations implement the same function: *)

Theorem number_of_leaves_v0_and_v1_implement_the_same_function :
  forall t : binary_tree_nat,
    number_of_leaves_v0 t = number_of_leaves_v1 t.
Proof.
  (* Pedestrian attempt: *)
  intro t.
  unfold number_of_leaves_v0.
  unfold number_of_leaves_v1.
  induction t as [n | t1 IHt1 t2 IHt2].

  rewrite -> unfold_number_of_leaves_ds_Leaf.
  rewrite -> unfold_number_of_leaves_acc_Leaf.
  rewrite -> plus_0_r.
  reflexivity.

  rewrite -> unfold_number_of_leaves_ds_Node.
  rewrite -> unfold_number_of_leaves_acc_Node.
  rewrite -> about_number_of_leaves_acc.
  rewrite -> IHt1.
  rewrite -> IHt2.
  reflexivity.

  Restart.

  (* Reusing what we did before: *)

  exact (there_is_only_one_number_of_leaves
           number_of_leaves_v0
           number_of_leaves_v1
           number_of_leaves_v0_satisfies_the_specification_of_number_of_leaves
           number_of_leaves_v1_satisfies_the_specification_of_number_of_leaves).

  Restart.

  (* Reusing what we did before, less concisely: *)

  intro t.
  exact (there_is_only_one_number_of_leaves
           number_of_leaves_v0
           number_of_leaves_v1
           number_of_leaves_v0_satisfies_the_specification_of_number_of_leaves
           number_of_leaves_v1_satisfies_the_specification_of_number_of_leaves
           t).
Qed.

(* ***** *)

(* A third implementation, with higher-order functions: *)

Definition compose_nat (f g : nat -> nat) (n : nat) :=
  f (g n).

Notation "F << G" := (compose_nat F G) (at level 70, right associativity).

Compute (S << S) 40.

Compute ((fun x => 2 + x) << (fun y => 10 * y)) 4.

Lemma unfold_compose_nat :
  forall (f g : nat -> nat)
          (n : nat),
    compose_nat f g n = f (g n).
Proof.
  unfold_tactic compose_nat.
Qed.

(* The auxiliary (recursive) function: *)

Fixpoint number_of_leaves_higher_order (t : binary_tree_nat) : nat -> nat :=
  match t with
    | Leaf n =>
      S
    | Node t1 t2 =>
      (number_of_leaves_higher_order t1) << (number_of_leaves_higher_order t2)
  end.

(* The canonical unfold lemmas: *)

Lemma unfold_number_of_leaves_higher_order_Leaf :
  forall n : nat,
    number_of_leaves_higher_order (Leaf n) = S.
Proof.
  unfold_tactic number_of_leaves_higher_order.
Qed.

Lemma unfold_number_of_leaves_higher_order_Node :
  forall (t1 t2 : binary_tree_nat),
    number_of_leaves_higher_order (Node t1 t2) =
    ((number_of_leaves_higher_order t1) << (number_of_leaves_higher_order t2)).
Proof.
  unfold_tactic number_of_leaves_higher_order.
Qed.

(* The main (non-recursive) function: *)

Definition number_of_leaves_v2 (t : binary_tree_nat) : nat :=
  number_of_leaves_higher_order t 0.

(* ***** *)

(* The standard sanity check: *)

Compute unit_test_for_number_of_leaves number_of_leaves_v2.
(*
     = true
     : bool
*)

(* The second implementation satisfies the specification: *)

Theorem number_of_leaves_v2_satisfies_the_specification_of_number_of_leaves_first_attempt :
  specification_of_number_of_leaves number_of_leaves_v2.
Proof.
  unfold specification_of_number_of_leaves.
  unfold number_of_leaves_v2.
  split.

  intro n.
  rewrite -> unfold_number_of_leaves_higher_order_Leaf.
  reflexivity.

  intros t1 t2.
  rewrite -> unfold_number_of_leaves_higher_order_Node.
  rewrite -> unfold_compose_nat.
(* Aha: number_of_leaves_v2 is the same as number_of_leaves_v1! *)
Abort.

Lemma about_number_of_leaves_higher_order :
  forall (t : binary_tree_nat)
         (a : nat),
    number_of_leaves_higher_order t a =
    number_of_leaves_acc t a.
Proof.
  intro t.
  induction t as [n | t1 IHt1 t2 IHt2].

  intro a.
  rewrite -> unfold_number_of_leaves_higher_order_Leaf.
  rewrite -> unfold_number_of_leaves_acc_Leaf.
  rewrite -> (plus_1_l a).
  reflexivity.

  intro a.
  rewrite -> unfold_number_of_leaves_higher_order_Node.
  rewrite -> unfold_compose_nat.
  rewrite -> IHt1.
  rewrite -> IHt2.
  rewrite -> unfold_number_of_leaves_acc_Node.
  reflexivity.
Qed.

Theorem number_of_leaves_v2_satisfies_the_specification_of_number_of_leaves :
  specification_of_number_of_leaves number_of_leaves_v2.
Proof.
  unfold specification_of_number_of_leaves.
  unfold number_of_leaves_v2.
  split.

  intro n.
  rewrite -> about_number_of_leaves_higher_order.
  exact (unfold_number_of_leaves_acc_Leaf n 0).

  intros t1 t2.
  rewrite -> about_number_of_leaves_higher_order.
  rewrite -> unfold_number_of_leaves_acc_Node.
  rewrite -> about_number_of_leaves_acc.
  rewrite -> about_number_of_leaves_higher_order.
  rewrite -> about_number_of_leaves_higher_order.
  reflexivity.
Qed.

(* ***** *)

(* A fourth implementation, in CPS: *)

(* The auxiliary (recursive) function: *)

Fixpoint number_of_leaves_cps (ans : Type) (t : binary_tree_nat) (k : nat -> ans) : ans :=
  match t with
    | Leaf n =>
      k 1
    | Node t1 t2 =>
      number_of_leaves_cps
        ans
        t1
        (fun n1 => number_of_leaves_cps
                     ans
                     t2
                     (fun n2 => k (n1 + n2)))
  end.

(* The canonical unfold lemmas: *)

Lemma unfold_number_of_leaves_cps_Leaf :
  forall (ans : Type)
         (n : nat)
         (k : nat -> ans),
    number_of_leaves_cps ans (Leaf n) k = k 1.
Proof.
  unfold_tactic number_of_leaves_cps.
Qed.

Lemma unfold_number_of_leaves_cps_Node :
  forall (ans : Type)
         (t1 t2 : binary_tree_nat)
         (k : nat -> ans),
    number_of_leaves_cps ans (Node t1 t2) k =
    number_of_leaves_cps
      ans
      t1
      (fun n1 => number_of_leaves_cps
                   ans
                   t2
                   (fun n2 => k (n1 + n2))).
Proof.
  unfold_tactic number_of_leaves_cps.
Qed.

(* The main (non-recursive) function: *)

Definition number_of_leaves_v3 (t : binary_tree_nat) : nat :=
  number_of_leaves_cps nat t (fun n => n).

(* ***** *)

(* The standard sanity check: *)

Compute unit_test_for_number_of_leaves number_of_leaves_v3.
(*
     = true
     : bool
*)

(* The fourth implementation satisfies the specification: *)

Theorem number_of_leaves_v3_satisfies_the_specification_of_number_of_leaves_first_attempt :
  specification_of_number_of_leaves number_of_leaves_v3.
Proof.
  unfold specification_of_number_of_leaves.
  unfold number_of_leaves_v3.
  split.

  intro n.
  rewrite -> unfold_number_of_leaves_cps_Leaf.
  reflexivity.

  intros t1 t2.
  rewrite -> unfold_number_of_leaves_cps_Node.
  (* Hum, we are stuck.  Let's venture a helpful lemma: *)
Abort.

Lemma about_number_of_leaves_cps_tentative :
  forall (ans : Type)
         (t : binary_tree_nat)
         (k : nat -> ans),
    number_of_leaves_cps ans t k =
    k (number_of_leaves_cps nat t (fun n => n)).
Proof.
Admitted.

Theorem number_of_leaves_v3_satisfies_the_specification_of_number_of_leaves_second_attempt :
  specification_of_number_of_leaves number_of_leaves_v3.
Proof.
  unfold specification_of_number_of_leaves.
  unfold number_of_leaves_v3.
  split.

  intro n.
  rewrite -> unfold_number_of_leaves_cps_Leaf.
  reflexivity.

  intros t1 t2.
  rewrite -> unfold_number_of_leaves_cps_Node.
  rewrite -> about_number_of_leaves_cps_tentative.
  rewrite -> about_number_of_leaves_cps_tentative.
  reflexivity.
  (* Yay, the proof goes through.
     So let's prove the helpful lemma. *)
Abort.

Lemma about_number_of_leaves_cps :
  forall (ans : Type)
         (t : binary_tree_nat)
         (k : nat -> ans),
    number_of_leaves_cps ans t k =
    k (number_of_leaves_cps nat t (fun n => n)).
Proof.
  intros ans t.
  induction t as [n | t1 IHt1 t2 IHt2].

  (* Base case: *)
  intro k.
  (* left-hand side: *)
  rewrite -> unfold_number_of_leaves_cps_Leaf.
  (* right-hand side: *)
  rewrite -> unfold_number_of_leaves_cps_Leaf.
  reflexivity.

  (* Induction case: *)
  intro k.
  (* left-hand side: *)
  rewrite -> unfold_number_of_leaves_cps_Node.
  rewrite -> IHt1.
  rewrite -> IHt2.
  (* right-hand side: *)
  symmetry.
  (* OK, left-hand side then: *)
  rewrite -> unfold_number_of_leaves_cps_Node.
  (* And we are stuck.
     Let's strengthen the induction hypothesis. *)

  Restart.

  intros ans t.
  revert ans.
  induction t as [n | t1 IHt1 t2 IHt2].

  (* Base case: *)
  intros ans k.
  (* left-hand side: *)
  rewrite -> unfold_number_of_leaves_cps_Leaf.
  (* right-hand side: *)
  rewrite -> unfold_number_of_leaves_cps_Leaf.
  reflexivity.

  (* Induction case: *)
  intros ans k.
  (* left-hand side: *)
  rewrite -> unfold_number_of_leaves_cps_Node.
  rewrite -> IHt1.
  rewrite -> IHt2.
  (* right-hand side: *)
  symmetry.
  (* OK, left-hand side then: *)
  rewrite -> unfold_number_of_leaves_cps_Node.
  rewrite -> IHt1.
  rewrite -> IHt2.
  reflexivity.
Qed.

Theorem number_of_leaves_v3_satisfies_the_specification_of_number_of_leaves :
  specification_of_number_of_leaves number_of_leaves_v3.
Proof.
  unfold specification_of_number_of_leaves.
  unfold number_of_leaves_v3.
  split.

  intro n.
  rewrite -> unfold_number_of_leaves_cps_Leaf.
  reflexivity.

  intros t1 t2.
  rewrite -> unfold_number_of_leaves_cps_Node.
  rewrite -> about_number_of_leaves_cps.
  rewrite -> about_number_of_leaves_cps.
  reflexivity.
Qed.

(* ***** *)

(* The four implementations implement the same function: *)

Theorem number_of_leaves_v0_and_v3_implement_the_same_function :
  forall t : binary_tree_nat,
    number_of_leaves_v0 t = number_of_leaves_v3 t.
Proof.
  exact (there_is_only_one_number_of_leaves
           number_of_leaves_v0
           number_of_leaves_v3
           number_of_leaves_v0_satisfies_the_specification_of_number_of_leaves
           number_of_leaves_v3_satisfies_the_specification_of_number_of_leaves).
Qed.

Theorem number_of_leaves_v1_and_v3_implement_the_same_function :
  forall t : binary_tree_nat,
    number_of_leaves_v1 t = number_of_leaves_v3 t.
Proof.
  exact (there_is_only_one_number_of_leaves
           number_of_leaves_v1
           number_of_leaves_v3
           number_of_leaves_v1_satisfies_the_specification_of_number_of_leaves
           number_of_leaves_v3_satisfies_the_specification_of_number_of_leaves).
Qed.

Theorem number_of_leaves_v2_and_v3_implement_the_same_function :
  forall t : binary_tree_nat,
    number_of_leaves_v2 t = number_of_leaves_v3 t.
Proof.
  exact (there_is_only_one_number_of_leaves
           number_of_leaves_v2
           number_of_leaves_v3
           number_of_leaves_v2_satisfies_the_specification_of_number_of_leaves
           number_of_leaves_v3_satisfies_the_specification_of_number_of_leaves).
Qed.

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

(* Exercise:
   Revisit how to compute the number of nodes
   of a binary tree.
*)
Definition unit_test_for_number_of_nodes (candidate : binary_tree_nat -> nat) :=
  (candidate bt_0 =n= 0)
    &&
    (candidate bt_1 =n= 1)
    &&
    (candidate bt_2 =n= 2).

Definition specification_of_number_of_nodes (number_of_nodes : binary_tree_nat -> nat) :=
  (forall n : nat,
     number_of_nodes (Leaf n) = 0)
  /\
  (forall t1 t2 : binary_tree_nat,
     number_of_nodes (Node t1 t2) = S (number_of_nodes t1 + number_of_nodes t2)).

Theorem there_is_only_one_number_of_nodes :
  forall f g : binary_tree_nat -> nat,
    specification_of_number_of_nodes f ->
    specification_of_number_of_nodes g ->
    forall t : binary_tree_nat,
      f t = g t.
Proof.
  intros f g.
  unfold specification_of_number_of_nodes.
  intros [S_f_leaf S_f_node] [S_g_leaf S_g_node].
  intro t.
  induction t as [n | t1 IHt1 t2 IHt2].

    rewrite S_g_leaf.
    exact (S_f_leaf n).

  rewrite S_f_node.
  rewrite S_g_node.
  rewrite IHt1.
  rewrite IHt2.
  reflexivity.
Qed.

Fixpoint number_of_nodes_ds (t : binary_tree_nat) : nat :=
  match t with
      | Leaf n =>
        0
      | Node t1 t2 =>
        S (number_of_nodes_ds t1 + number_of_nodes_ds t2)
  end.

Lemma unfold_number_of_nodes_ds_leaf :
  forall n : nat,
    number_of_nodes_ds (Leaf n) = 0.
Proof.
  unfold_tactic number_of_nodes_ds.
Qed.

Lemma unfold_number_of_nodes_ds_node :
  forall t1 t2 : binary_tree_nat,
    number_of_nodes_ds (Node t1 t2) = S (number_of_nodes_ds t1 + number_of_nodes_ds t2).
Proof.
  unfold_tactic number_of_nodes_ds.
Qed.

Definition number_of_nodes_v0 (t : binary_tree_nat) : nat :=
  number_of_nodes_ds t.

Compute unit_test_for_number_of_nodes number_of_nodes_v0.

(* MANGLER number_of_nodes_v0_fits_the_specification_of_number_of_nodes *)

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

(* Food for thought (with thanks to John Anker):
   For any binary tree,
   how would you compare its number of leaves and its number of nodes?
   Is there a relation?  If so, could you formalize it in Coq?
*)

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

(* end of week_40a_binary_trees.v *)


Require Import Arith.

Lemma fib_ind :
 forall P:nat -> Prop,
   P 0 ->
   P 1 ->
  (forall n:nat, P n -> P (S n) -> P (S (S n))) ->
  forall n:nat, P n.
Proof.
 intros P H0 H1 HSSn n.
 cut (P n /\ P (S n)).
 tauto.
 elim n.
 split; auto.
 intros n0 Hn0; case Hn0; auto.
Qed.

Fixpoint fib (n:nat) : nat :=
  match n with
  | O => 1
  | S O => 1
  | S (S p as q) => fib p + fib q
  end.

(* A geralisation of the fibonacci sequence, parameterized by
   its two first items *)

Fixpoint general_fib (a0 a1 n:nat) {struct n} : nat :=
  match n with
  | O => a0
  | S p => general_fib a1 (a0 + a1) p
  end.

Definition fib_tail (n:nat) := general_fib 1 1 n.

Eval compute in (fib_tail 10).

Lemma general_fib_1 : forall a b:nat, general_fib a b 1 = b.
Proof.
 simpl; auto.
Qed.

Lemma general_fib_S :
 forall a b n:nat, general_fib a b (S n) = general_fib b (a + b) n.
Proof.
 simpl; auto.
Qed.

Lemma general_fib_2 :
 forall a b n:nat,
   general_fib a b (S (S n)) = general_fib a b n + general_fib a b (S n).
Proof.
 intros a b n; generalize a b.
 elim n.
 simpl; auto.
 intros n0 H a0 b0.
 pattern (general_fib a0 b0 (S (S (S n0)))); rewrite general_fib_S.
 pattern (general_fib a0 b0 (S (S n0))); rewrite general_fib_S.
 pattern (general_fib a0 b0 (S n0)); rewrite general_fib_S.
 apply H.
Qed.

Lemma fib_SSn : forall n:nat, fib (S (S n)) = fib n + fib (S n).
Proof.
 simpl; auto.
Qed.

Lemma linear_fibo_equiv : forall n:nat, fib_tail n = fib n.
Proof.
 intro n; elim n using fib_ind.
 simpl; auto.
 simpl; auto.
 unfold fib_tail.
 intros n0 e0 e1; rewrite general_fib_2.
 rewrite e0; rewrite e1.
 rewrite fib_SSn; trivial.
Qed.


(*Zhiwei Wu, Wenrui Meng 1 hour for each *)
(** * MoreProp: More about Propositions and Evidence *)

Require Export "Prop".

(* ##################################################### *)
(** * Programming with Propositions *)

(** A _proposition_ is a statement expressing a factual claim,
    like "two plus two equals four."  In Coq, propositions are written
    as expressions of type [Prop].  Although we haven't mentioned it
    explicitly, we have already seen numerous examples. *)

Check (2 + 2 = 4).
(* ===> 2 + 2 = 4 : Prop *)

Check (ble_nat 3 2 = false).
(* ===> ble_nat 3 2 = false : Prop *)

Check (beautiful 8).
(* ===> beautiful 8 : Prop *)

(** Both provable and unprovable claims are perfectly good
    propositions.  Simply _being_ a proposition is one thing; being
    _provable_ is something else! *)

Check (2 + 2 = 5).
(* ===> 2 + 2 = 5 : Prop *)

Check (beautiful 4).
(* ===> beautiful 4 : Prop *)

(** Both [2 + 2 = 4] and [2 + 2 = 5] are legal expressions
    of type [Prop]. *)

(** We've seen one place that propositions can appear in Coq: in
    [Theorem] (and [Lemma] and [Example]) declarations. *)

Theorem plus_2_2_is_4 :
  2 + 2 = 4.
Proof. reflexivity.  Qed.

(** But they can be used in many other ways.  For example, we can give
    a name to a proposition using a [Definition], just as we have
    given names to expressions of other sorts. *)

Definition plus_fact : Prop  :=  2 + 2 = 4.
Check plus_fact.
(* ===> plus_fact : Prop *)

(** We can later use this name in any situation where a proposition is
    expected -- for example, as the claim in a [Theorem] declaration. *)

Theorem plus_fact_is_true :
  plus_fact.
Proof. reflexivity.  Qed.

(** We've seen several ways of constructing propositions.

       - We can define a new proposition primitively using [Inductive].

       - Given two expressions [e1] and [e2] of the same type, we can
         form the proposition [e1 = e2], which states that their
         values are equal.

       - We can combine propositions using implication and
         quantification. *)

(** We have also seen _parameterized propositions_, such as [even] and
    [beautiful]. *)

Check (even 4).
(* ===> even 4 : Prop *)
Check (even 3).
(* ===> even 3 : Prop *)
Check even.
(* ===> even : nat -> Prop *)

(** The type of [even], i.e., [nat->Prop], can be pronounced in
    three equivalent ways: (1) "[even] is a _function_ from numbers to
    propositions," (2) "[even] is a _family_ of propositions, indexed
    by a number [n]," or (3) "[even] is a _property_ of numbers."  *)

(** Propositions -- including parameterized propositions -- are
    first-class citizens in Coq.  For example, we can define functions
    from numbers to propositions... *)

Definition between (n m o: nat) : Prop :=
  andb (ble_nat n o) (ble_nat o m) = true.

(** ... and then partially apply them: *)

Definition teen : nat->Prop := between 13 19.

(** We can even pass propositions -- including parameterized
    propositions -- as arguments to functions: *)

Definition true_for_zero (P:nat->Prop) : Prop :=
  P 0.

(** Here are two more examples of passing parameterized propositions
    as arguments to a function.

    The first function, [true_for_all_numbers], takes a proposition
    [P] as argument and builds the proposition that [P] is true for
    all natural numbers. *)

Definition true_for_all_numbers (P:nat->Prop) : Prop :=
  forall n, P n.

(** The second, [preserved_by_S], takes [P] and builds the proposition
    that, if [P] is true for some natural number [n'], then it is also
    true by the successor of [n'] -- i.e. that [P] is _preserved by
    successor_: *)

Definition preserved_by_S (P:nat->Prop) : Prop :=
  forall n', P n' -> P (S n').

(** **** Exercise: 3 stars (combine_odd_even) *)
(** Complete the definition of the [combine_odd_even] function
    below. It takes as arguments two properties of numbers [Podd] and
    [Peven]. As its result, it should return a new property [P] such
    that [P n] is equivalent to [Podd n] when [n] is odd, and
    equivalent to [Peven n] otherwise. *)

Definition combine_odd_even (Podd Peven : nat -> Prop) : nat -> Prop :=
 fun (n : nat) => match (oddb n) with
                  | true => Podd n
                  | false => Peven n end.

(** To test your definition, see whether you can prove the following
    facts: *)

Theorem combine_odd_even_intro :
  forall (Podd Peven : nat -> Prop) (n : nat),
    (oddb n = true -> Podd n) ->
    (oddb n = false -> Peven n) ->
    combine_odd_even Podd Peven n.
Proof.
intros. unfold combine_odd_even. simpl. destruct (oddb n).
Case "true". apply H. reflexivity.
Case "false". apply H0. reflexivity.
Qed.
(*
intros. remember (oddb n) as b. destruct b.
Case "odd".
unfold combine_odd_even. rewrite <- Heqb. apply H. trivial.

Case "even".
unfold combine_odd_even. rewrite <- Heqb. apply  H0. trivial. Qed.
*)
Theorem combine_odd_even_elim_odd :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = true ->
    Podd n.
Proof.
intros. unfold combine_odd_even in H. rewrite H0 in H. apply H. Qed.

Theorem combine_odd_even_elim_even :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = false ->
    Peven n.
Proof.
intros. unfold combine_odd_even in H. rewrite -> H0 in H.
apply H. Qed.
(** [] *)

(* ##################################################### *)
(** One more quick digression, for adventurous souls: if we can define
    parameterized propositions using [Definition], then can we also
    define them using [Fixpoint]?  Of course we can!  However, this
    kind of "recursive parameterization" doesn't correspond to
    anything very familiar from everyday mathematics.  The following
    exercise gives a slightly contrived example. *)

(** **** Exercise: 4 stars, optional (true_upto_n__true_everywhere) *)
(** Define a recursive function
    [true_upto_n__true_everywhere] that makes
    [true_upto_n_example] work. *)

(*
Fixpoint true_upto_n__true_everywhere
(* FILL IN HERE *)

Example true_upto_n_example :
    (true_upto_n__true_everywhere 3 (fun n => even n))
  = (even 3 -> even 2 -> even 1 -> forall m : nat, even m).
Proof. reflexivity.  Qed.
*)
(** [] *)

(* $Date: 2013-02-06 20:56:12 -0500 (Wed, 06 Feb 2013) $ *)


Require Import primRec Arith ArithRing List.
Import extEqualNat.

(** ** Solution to an exercise  *)

Definition double n := n * 2.

Lemma doubleIsPR : isPR 1 double.
Proof.
  unfold double; apply compose1_2IsPR.
  - apply idIsPR.
  - apply const1_NIsPR.
  - apply multIsPR.
Qed.

(* begin snippet expDef *)

Fixpoint exp n p :=
  match p with
    0 => 1
  | S m =>  exp n m * n
  end.

(* end snippet expDef *)

Definition exp_alt := fun a b => nat_rec (fun _ => nat)
                                     1
                                     (fun _ y =>  y * a)
                                     b.

Remark  exp_alt_ok : extEqual 2 exp_alt exp.
Proof.
  intros x y; induction y; cbn; auto.
Qed.

Lemma exp_alt_PR : isPR 2 exp_alt.
Proof.
  unfold exp_alt.
    apply swapIsPR.
    apply ind1ParamIsPR.
    + apply filter011IsPR.
      apply multIsPR.
    + apply const1_NIsPR.
Qed.

Lemma expIsPR : isPR 2 exp.
Proof.
  destruct exp_alt_PR as [x Hx].
  exists x.
  apply extEqualTrans with exp_alt; auto.
  apply exp_alt_ok.
Qed.

(* begin snippet tower2Def *)

Fixpoint tower2 n :=
  match n with
    0 => 1
  | S p => exp 2 (tower2 p)
  end.

(* end snippet tower2Def *)

Definition tower2_alt h : nat :=  nat_rec (fun n => nat)
                                1
                                (fun _  y =>  exp 2 y)
                                h.

Remark tower2_alt_ok  : extEqual 1 tower2_alt tower2.
Proof. intro x; induction x; cbn; auto. Qed.

Lemma tower2_alt_PR : isPR 1 tower2_alt.
Proof.
unfold tower2_alt;  apply indIsPR.
    +  apply filter01IsPR.
       eapply compose1_2IsPR.
       * apply const1_NIsPR.
       * apply idIsPR.
       * apply expIsPR.
         Qed.

Lemma tower2IsPR : isPR 1 tower2.
Proof.
 destruct tower2_alt_PR as [x Hx].
 exists x.
 apply extEqualTrans with tower2_alt; [auto | apply tower2_alt_ok].
Qed.

(* begin snippet factDef *)
Fixpoint fact n :=
  match n with 0 => 1
          |   S p  => n * fact p
  end.
(* end snippet factDef *)

Definition fact_alt
  : nat -> nat :=
  fun a => nat_rec _ 1 (fun x y =>  S x * y) a.

Remark fact_alt_ok : extEqual 1 fact_alt fact.
Proof.
  intro x;induction x; cbn; auto.
Qed.

Lemma fact_altIsPR : isPR 1 fact_alt.
Proof.
  unfold fact_alt; apply indIsPR.
  apply compose2_2IsPR.
  +  apply filter10IsPR; apply succIsPR.
  +  apply filter01IsPR; apply idIsPR.
  +  apply multIsPR.
Qed.

Lemma factIsPR : isPR 1 fact.
Proof.
  destruct fact_altIsPR as [x Hx].
  exists x; apply extEqualTrans with fact_alt; [trivial | ].
  apply fact_alt_ok.
Qed.


(** **** KE DING 8318 *)

(** * MoreProp: More about Propositions and Evidence *)

Require Export "Prop".

(* ##################################################### *)
(** * Programming with Propositions *)

(** A _proposition_ is a statement expressing a factual claim,
    like "two plus two equals four."  In Coq, propositions are written
    as expressions of type [Prop].  Although we haven't mentioned it
    explicitly, we have already seen numerous examples. *)

Check (2 + 2 = 4).
(* ===> 2 + 2 = 4 : Prop *)

Check (ble_nat 3 2 = false).
(* ===> ble_nat 3 2 = false : Prop *)

Check (beautiful 8).
(* ===> beautiful 8 : Prop *)

(** Both provable and unprovable claims are perfectly good
    propositions.  Simply _being_ a proposition is one thing; being
    _provable_ is something else! *)

Check (2 + 2 = 5).
(* ===> 2 + 2 = 5 : Prop *)

Check (beautiful 4).
(* ===> beautiful 4 : Prop *)

(** Both [2 + 2 = 4] and [2 + 2 = 5] are legal expressions
    of type [Prop]. *)

(** We've seen one place that propositions can appear in Coq: in
    [Theorem] (and [Lemma] and [Example]) declarations. *)

Theorem plus_2_2_is_4 :
  2 + 2 = 4.
Proof. reflexivity.  Qed.

(** But they can be used in many other ways.  For example, we can give
    a name to a proposition using a [Definition], just as we have
    given names to expressions of other sorts. *)

Definition plus_fact : Prop  :=  2 + 2 = 4.
Check plus_fact.
(* ===> plus_fact : Prop *)

(** We can later use this name in any situation where a proposition is
    expected -- for example, as the claim in a [Theorem] declaration. *)

Theorem plus_fact_is_true :
  plus_fact.
Proof. reflexivity.  Qed.

(** We've seen several ways of constructing propositions.

       - We can define a new proposition primitively using [Inductive].

       - Given two expressions [e1] and [e2] of the same type, we can
         form the proposition [e1 = e2], which states that their
         values are equal.

       - We can combine propositions using implication and
         quantification. *)

(** We have also seen _parameterized propositions_, such as [even] and
    [beautiful]. *)

Check (even 4).
(* ===> even 4 : Prop *)
Check (even 3).
(* ===> even 3 : Prop *)
Check even.
(* ===> even : nat -> Prop *)

(** The type of [even], i.e., [nat->Prop], can be pronounced in
    three equivalent ways: (1) "[even] is a _function_ from numbers to
    propositions," (2) "[even] is a _family_ of propositions, indexed
    by a number [n]," or (3) "[even] is a _property_ of numbers."  *)

(** Propositions -- including parameterized propositions -- are
    first-class citizens in Coq.  For example, we can define functions
    from numbers to propositions... *)

Definition between (n m o: nat) : Prop :=
  andb (ble_nat n o) (ble_nat o m) = true.

(** ... and then partially apply them: *)

Definition teen : nat->Prop := between 13 19.

(** We can even pass propositions -- including parameterized
    propositions -- as arguments to functions: *)

Definition true_for_zero (P:nat->Prop) : Prop :=
  P 0.

(** Here are two more examples of passing parameterized propositions
    as arguments to a function.

    The first function, [true_for_all_numbers], takes a proposition
    [P] as argument and builds the proposition that [P] is true for
    all natural numbers. *)

Definition true_for_all_numbers (P:nat->Prop) : Prop :=
  forall n, P n.

(** The second, [preserved_by_S], takes [P] and builds the proposition
    that, if [P] is true for some natural number [n'], then it is also
    true by the successor of [n'] -- i.e. that [P] is _preserved by
    successor_: *)

Definition preserved_by_S (P:nat->Prop) : Prop :=
  forall n', P n' -> P (S n').

(** **** Exercise: 3 stars (combine_odd_even) *)
(** Complete the definition of the [combine_odd_even] function
    below. It takes as arguments two properties of numbers [Podd] and
    [Peven]. As its result, it should return a new property [P] such
    that [P n] is equivalent to [Podd n] when [n] is odd, and
    equivalent to [Peven n] otherwise. *)

Definition combine_odd_even (Podd Peven : nat -> Prop) : nat -> Prop :=
  fun n : nat => if (oddb n) then Podd n
                             else Peven n.

(** To test your definition, see whether you can prove the following
    facts: *)

Theorem combine_odd_even_intro :
  forall (Podd Peven : nat -> Prop) (n : nat),
    (oddb n = true -> Podd n) ->
    (oddb n = false -> Peven n) ->
    combine_odd_even Podd Peven n.
Proof.
  intros Podd Peven n Hodd Heven.
  unfold combine_odd_even.
  destruct (oddb n).
  Case "oddb n = true".
    apply Hodd.
    reflexivity.
  Case "oddb n = false".
    apply Heven.
    reflexivity.

Theorem combine_odd_even_elim_odd :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = true ->
    Podd n.
Proof.
  intros Podd Peven n Hc Hb.
  unfold combine_odd_even in Hc.
  rewrite -> Hb in Hc.
  apply Hc.

Theorem combine_odd_even_elim_even :
  forall (Podd Peven : nat -> Prop) (n : nat),
    combine_odd_even Podd Peven n ->
    oddb n = false ->
    Peven n.
Proof.
  intros Podd Peven n Hc Hb.
  unfold combine_odd_even in Hc.
  rewrite -> Hb in Hc.
  apply Hc.

(** [] *)

(* ##################################################### *)
(** One more quick digression, for adventurous souls: if we can define
    parameterized propositions using [Definition], then can we also
    define them using [Fixpoint]?  Of course we can!  However, this
    kind of "recursive parameterization" doesn't correspond to
    anything very familiar from everyday mathematics.  The following
    exercise gives a slightly contrived example. *)

(** **** Exercise: 4 stars, optional (true_upto_n__true_everywhere) *)
(** Define a recursive function
    [true_upto_n__true_everywhere] that makes
    [true_upto_n_example] work. *)

Fixpoint true_upto_n__true_everywhere (n : nat)(P : nat -> Prop) : Prop :=
  match n with
    | O => forall m, P m
    | S n' => even (S n') -> true_upto_n__true_everywhere n' P
  end.

Example true_upto_n_example :
    (true_upto_n__true_everywhere 3 (fun n => even n))
  = (even 3 -> even 2 -> even 1 -> forall m : nat, even m).
Proof. reflexivity.  Qed.

(** [] *)

(* $Date: 2013-02-06 21:18:41 -0500 (Wed, 06 Feb 2013) $ *)

(** **** KE DING 8318 *)


Set Warnings "-notation-overridden,-parsing".
From LF Require Export Logic.
Require Coq.omega.Omega.

Inductive even : nat -> Prop :=
  | ev_0 : even 0
  | ev_SS (n : nat) (H : even n) : even (S (S n)).
(* equavlent
Inductive even' : nat -> Prop :=
  | ev_0' : even' 0
  | ev_SS' : forall n, even' n -> even' (S (S n)).
*)

Theorem ev_4 : even 4.
Proof. apply ev_SS. apply ev_SS. apply ev_0. Qed.

Theorem ev_4' : even 4.
Proof. apply (ev_SS 2 (ev_SS 0 ev_0)). Qed.

Check (ev_SS 2 (ev_SS 0 ev_0)).

Theorem ev_plus4 : forall n, even n -> even (4 + n).
Proof.
  intros n. simpl. intros Hn.
  apply ev_SS. apply ev_SS. apply Hn.
Qed.

Theorem double_axiom1 : forall n,
  double (S n) = S (S (double n)).
Proof.
  intros. unfold double. simpl.
  rewrite plus_comm. simpl. reflexivity.
Qed.

Theorem ev_double : forall n,
  even (double n).
Proof.
  unfold double. intros.
  induction n as [|n' IHn'].
  - simpl. apply ev_0.
  - simpl. rewrite -> plus_comm. simpl.
    apply ev_SS. apply IHn'.
Qed.

Theorem ev_inversion :
  forall (n : nat), even n ->
    (n = 0) \/ (exists n', n = S (S n') /\ even n').
Proof.
  intros n E.
  destruct E as [|n' E'].
  - left. reflexivity.
  - right. exists n'. split.
    reflexivity. apply E'.
Qed.

Theorem ev_minus2 : forall n,
  even n -> even (pred (pred n)).
Proof.
  intros n E.
  destruct E as [| n' E'].
  - (* E = ev_0 *) simpl. apply ev_0.
  - (* E = ev_SS n' E' *) simpl. apply E'.
Qed.

Theorem evSS_ev : forall n,
  even (S (S n)) -> even n.
Proof.
 intros n H. apply ev_inversion in H. destruct H.
 - discriminate H.
 - destruct H as [n' [Hnm Hev]]. injection Hnm.
   intro Heq. rewrite Heq. apply Hev.
Qed.

Theorem evSS_ev' : forall n,
  even (S (S n)) -> even n.
Proof.
  intros n E.
  inversion E as [| n' E'].
  (* We are in the E = ev_SS n' E' case now. *)
  apply E'.
Qed.

Theorem one_not_even : ~ even 1.
Proof.
  intros H. apply ev_inversion in H.
  destruct H as [ | [m [Hm _]]].
  - discriminate H.
  - discriminate Hm.
Qed.

Theorem one_not_even' : ~ even 1.
  intros H. inversion H. Qed.

Theorem SSSSev__even : forall n,
  even (S (S (S (S n)))) -> even n.
Proof.
  intros n0 E0.
  inversion E0 as [|n1 E1].
  inversion E1 as [|n2 E2].
  apply E2.
Qed.

Theorem even5_nonsense :
  even 5 -> 2 + 2 = 9.
Proof.
  intros E.
  inversion E. inversion H0.
  inversion H2.
Qed.

Theorem inversion_ex1 : forall (n m o : nat),
  [n; m] = [o; o] ->
  [n] = [m].
Proof.
  intros n m o H. inversion H. reflexivity.
Qed.

Theorem inversion_ex2 : forall (n : nat),
  S n = O ->
  2 + 2 = 5.
Proof.
  intros n contra. inversion contra.
Qed.

Lemma ev_even_firsttry : forall n,
  even n -> exists k, n = double k.
Proof.
  intros n E. inversion E as [|n' E'].
  - exists 0. reflexivity.
  - assert (I : (exists k', n' = double k')
            ->  (exists k, S (S n') = double k)).
    { intros [k' Hk']. rewrite Hk'. exists (S k').
      rewrite <- double_axiom1. reflexivity. }
  apply I.
Abort.

Lemma ev_even : forall n,
  even n -> exists k, n = double k.
Proof.
  intros n E.
  induction E as [|n' E' IH].
  - exists 0. reflexivity.
  - destruct IH as [k' Hk'].
    rewrite Hk'. exists (S k').
    rewrite double_axiom1. reflexivity.
Qed.

Theorem ev_even_iff : forall n,
  even n <-> exists k, n = double k.
Proof.
  intros n. split.
  - (* -> *) apply ev_even.
  - (* <- *) intros [k Hk]. rewrite Hk. apply ev_double.
Qed.

Axiom plus_aux_axiom1 : forall n m,
  n + n + (m + m) = n + m + (n + m).

Theorem ev_sum : forall n m,
  even n -> even m -> even (n + m).
Proof.
  intros. apply ev_even_iff.
  apply ev_even_iff in H.
  apply ev_even_iff in H0.
  destruct H0 as [k0 H0].
  destruct H as [k1 H1].
  rewrite H0. rewrite H1. exists (k1 + k0).
  unfold double. rewrite plus_aux_axiom1.
  reflexivity.
Qed.

Inductive even' : nat -> Prop :=
| even'_0 : even' 0
| even'_2 : even' 2
| even'_sum n m (Hn : even' n) (Hm : even' m) : even' (n + m).

Theorem even'_ev : forall n,
  even' n <-> even n.
Proof.
  intros. split.
  - intros H. induction H.
    apply ev_0. apply ev_SS. apply ev_0.
    apply ev_sum. apply IHeven'1.
    apply IHeven'2.
  - intros E. induction E.
    apply even'_0.
    assert (I : n+ 2 = S (S n)).
    { rewrite plus_comm. simpl. reflexivity. }
    rewrite <- I. apply even'_sum.
    apply IHE. apply even'_2.
Qed.

Axiom plus_and_diff : forall n m k,
  n + m = k -> n = k - m.

Axiom plus_and_diff2 : forall n m,
  n + n - (m + m) = n - m + (n - m).

Theorem ev_ev__ev : forall n m,
  even (n+m) -> even n -> even m.
Proof.
  intros. apply ev_even_iff.
  apply ev_even_iff in H.
  apply ev_even_iff in H0.
  destruct H as [i Hi]. destruct H0 as [j Hj].
  rewrite Hj in Hi. rewrite plus_comm in Hi.
  apply plus_and_diff in Hi. rewrite Hi.
  unfold double. exists (i - j).
  apply plus_and_diff2.
Qed.

Axiom plus_n_assoc : forall n m k,
  n - k + (m - k) = n - k + m - k.

Axiom plus_n_aux : forall i j n,
  i + i - n + (j + j) - n =
    i + j - n + (i + j - n).

Theorem ev_plus_plus : forall n m p,
  even (n+m) -> even (n+p) -> even (m+p).
Proof.
  intros. apply ev_even_iff.
  apply ev_even_iff in H.
  apply ev_even_iff in H0.
  destruct H as [i Hi]. destruct H0 as [j Hj].
  exists (i + j - n). rewrite plus_comm in Hi.
  rewrite plus_comm in Hj.
  apply plus_and_diff in Hi.
  apply plus_and_diff in Hj.
  rewrite Hi. rewrite Hj.
  rewrite plus_n_assoc. unfold double.
  apply plus_n_aux.
Qed.

Module Playground.

Inductive le : nat -> nat -> Prop :=
  | le_n n : le n n
  | le_S n m (H : le n m) : le n (S m).

Notation "m <= n" := (le m n).

Theorem test_le1 :
  3 <= 3.
Proof.
  (* WORKED IN CLASS *)
  apply le_n. Qed.

Theorem test_le2 :
  3 <= 6.
Proof.
  (* WORKED IN CLASS *)
  apply le_S. apply le_S. apply le_S. apply le_n.
Qed.

Theorem test_le3 :
  (2 <= 1) -> 2 + 2 = 5.
Proof.
  intros H. inversion H. inversion H2.
Qed.

End Playground.

Definition lt (n m:nat) := le (S n) m.

Notation "m < n" := (lt m n).

Inductive square_of : nat -> nat -> Prop :=
  | sq n : square_of n (n * n).

Inductive next_nat : nat -> nat -> Prop :=
  | nn n : next_nat n (S n).

Inductive next_even : nat -> nat -> Prop :=
  | ne_1 n : even (S n) -> next_even n (S n)
  | ne_2 n (H : even (S (S n))) : next_even n (S (S n)).

Lemma le_trans : forall m n o,
  m <= n -> n <= o -> m <= o.
Proof.
  intros m n o H0 H1.
  destruct H0. apply H1.
  induction H1.
  + apply le_S. apply H0.
  + apply le_S. apply IHle.
Qed.

Theorem O_le_n : forall n,
  0 <= n.
Proof.
  intros. induction n as [|n' IHn'].
  apply le_n. apply le_S. apply IHn'.
Qed.

Theorem n_le_m__Sn_le_Sm : forall n m,
  n <= m -> S n <= S m.
Proof.
  intros. induction H.
  reflexivity. apply le_S. apply IHle.
Qed.

Theorem Sn_le_Sm__n_le_m : forall n m,
  S n <= S m -> n <= m.
Proof.
  intros. inversion H.
  - reflexivity.
  - apply (le_trans n (S n) m).
    apply le_S. apply le_n. apply H1.
Qed.

Theorem le_plus_l : forall a b,
  a <= a + b.
Proof.
  intros. rewrite plus_comm.
  induction b as [|b' IHb'].
  - simpl. reflexivity.
  - simpl. apply le_S. apply IHb'.
Qed.

Theorem plus_lt : forall n1 n2 m,
  n1 + n2 < m ->
  n1 < m /\ n2 < m.
Proof.
  unfold lt. intros.
  inversion H.
  - split. apply n_le_m__Sn_le_Sm.
    apply le_plus_l. apply n_le_m__Sn_le_Sm.
    rewrite plus_comm. apply le_plus_l.
  - split.
    + apply n_le_m__Sn_le_Sm.
      rewrite <- H1 in H.
      apply Sn_le_Sm__n_le_m in H.
      apply (le_trans n1 (n1 + n2) m0).
      apply le_plus_l. apply H.
    + apply n_le_m__Sn_le_Sm.
      rewrite <- H1 in H.
      apply Sn_le_Sm__n_le_m in H.
      apply (le_trans n2 (n1 + n2) m0).
      rewrite plus_comm. apply le_plus_l.
      apply H.
Qed.

Theorem lt_S : forall n m,
  n < m ->
  n < S m.
Proof.
  unfold lt. intros. apply n_le_m__Sn_le_Sm.
  apply (le_trans n (S n) m).
  apply le_S. apply le_n. apply H.
Qed.

Theorem leb_complete : forall n m,
  n <=? m = true -> n <= m.
Proof.
  intros. generalize dependent n.
  induction m as [|m' IHm'].
  - induction n as [|n' IHn'].
    + intros H. apply le_n.
    + intros H. simpl in H. discriminate H.
  - induction n as [|n' IHn'].
    + assert (I : S m' = 0 + S m').
      { reflexivity. } rewrite I. intros H.
      apply le_plus_l.
    + intros H. apply n_le_m__Sn_le_Sm.
      apply IHm'. simpl in H. apply H.
Qed.

Theorem leb_n_n : forall n,
  n <=? n = true.
Proof.
  intros. induction n as [|n' IHn'].
  - reflexivity.
  - simpl. apply IHn'.
Qed.

Theorem leb_correct : forall n m,
  n <= m ->
  n <=? m = true.
Proof.
  intros. generalize dependent n.
  induction m as [|m' IHm'].
  - intros n H. inversion H. reflexivity.
  - intros n H. inversion H.
    simpl. apply leb_n_n.
    induction n as [|n' IHn'].
    reflexivity. apply IHm'.
    apply (le_trans n' (S n') m').
    apply le_S. apply le_n. apply H1.
Qed.

Theorem leb_true_trans : forall n m o,
  n <=? m = true ->
    m <=? o = true ->
      n <=? o = true.
Proof.
  intros. apply leb_correct.
  apply leb_complete in H.
  apply leb_complete in H0.
  apply (le_trans n m o). apply H. apply H0.
Qed.

Theorem leb_iff : forall n m,
  n <=? m = true <-> n <= m.
Proof.
  split.
  apply leb_complete. apply leb_correct.
Qed.

Module R.

Inductive R : nat -> nat -> nat -> Prop :=
   | c1 : R 0 0 0
   | c2 m n o (H : R m n o) : R (S m) n (S o)
   | c3 m n o (H : R m n o) : R m (S n) (S o)
   | c4 m n o (H : R (S m) (S n) (S (S o))) : R m n o
   | c5 m n o (H : R m n o) : R n m o.

Theorem R_m_n_o : forall (m n o:nat),
  R m n o <-> m + n = o.
Proof.
  split.
  - intros. induction H.
    + reflexivity.
    + simpl. apply f_equal. apply IHR.
    + rewrite <- plus_n_Sm. simpl. apply f_equal. apply IHR.
    + rewrite <- plus_n_Sm in IHR. simpl in IHR. injection IHR.
      intros. apply H0.
    + rewrite plus_comm. apply IHR.
  -  generalize n o. induction m.
    + intros n0. induction n0.
      * simpl. intros. rewrite <- H. apply c1.
      * simpl. intros. rewrite <- H. apply c3.
        apply IHn0 with (o := n0). simpl. reflexivity.
    + intros n0. induction n0.
      * simpl. intros. rewrite plus_comm in H.
        simpl in H. rewrite <- H. apply c2.
        apply IHm. rewrite plus_comm. reflexivity.
      * simpl. rewrite plus_comm. simpl. intros.
        rewrite <- H. apply c3. apply IHn0.
        simpl. apply f_equal. rewrite plus_comm.
        reflexivity.
Qed.

End R.

Inductive subseq : list nat -> list nat -> Prop :=
  | sub_nil : forall l, subseq [] l
  | sub_one : forall n l1 l2,
      subseq l1 l2 -> subseq l1 (n :: l2)
  | sub_two : forall n l1 l2,
      subseq l1 l2 -> subseq (n :: l1) (n :: l2).

Theorem subseq_refl : forall (l : list nat),
  subseq l l.
Proof.
  intros. induction l as [|h t IHt].
  - apply sub_nil.
  - apply sub_two. apply IHt.
Qed.

Theorem subseq_app : forall (l1 l2 l3 : list nat),
  subseq l1 l2 ->
  subseq l1 (l2 ++ l3).
Proof.
  intros. induction H.
  - apply sub_nil.
  - apply sub_one. apply IHsubseq.
  - apply sub_two. apply IHsubseq.
Qed.

Theorem subseq_aux_0 : forall n (l1 l2:list nat),
  subseq (n :: l1) l2 -> subseq l1 l2.
Proof.
  intros.
  induction l2.
  - inversion H.
  - apply sub_one. inversion H.
    + apply IHl2. apply H2.
    + apply H1.
Qed.

Theorem subseq_aux_1 : forall n (l1 l2 : list nat),
  subseq (n :: l1) (n :: l2) -> subseq l1 l2.
Proof.
  intros. inversion H.
  apply subseq_aux_0 in H2. apply H2.
  apply H1.
Qed.

Theorem subseq_trans : forall (l1 l2 l3 : list nat),
  subseq l1 l2 ->
  subseq l2 l3 ->
  subseq l1 l3.
Proof.
  intros l1 l2 l3.
  generalize dependent l1.
  generalize dependent l2.
  generalize dependent l3.
  induction l3.
  - intros l2 l1 H0 H1. inversion H1.
    rewrite <- H in H0. apply H0.
  - intros l2 l1 H0 H1. inversion H1.
    + rewrite <- H in H0. inversion H0.
      apply sub_nil.
    + destruct H0 as [| h | h].
      * apply sub_nil.
      * apply sub_one.
        apply IHl3 with (l2 := h :: l2).
        apply sub_one. apply H0. apply H3.
      * apply sub_one.
        apply IHl3 with (l2 := h :: l2).
        apply sub_two. apply H0. apply H3.
    + destruct H0 as [| h | h].
      * apply sub_nil.
      * apply sub_one.
        apply IHl3 with (l2 := l2).
        apply H0. injection H2. intros.
        rewrite H in H6. rewrite H6 in H1.
        apply subseq_aux_1 in H1. apply H1.
      * injection H2. intros. rewrite <- H6.
        rewrite H. apply sub_two.
        apply IHl3 with (l2 := l2).
        apply H0. rewrite <- H in H1.
        rewrite H6 in H1.
        apply subseq_aux_1 in H1.
        apply H1.
Qed.

Inductive R : nat -> list nat -> Prop :=
  | c1 : R 0 []
  | c2 : forall n l, R n l -> R (S n) (n :: l)
  | c3 : forall n l, R (S n) l -> R n l.

(*
Provable:
   R 1 [1;2;1;0]
Not provable:
   R 2 [1;0]
   R 6 [3;2;1;0]
*)

Inductive reg_exp {T : Type} : Type :=
  | EmptySet
  | EmptyStr
  | Char (t : T)
  | App (r1 r2 : reg_exp)
  | Union (r1 r2 : reg_exp)
  | Star (r : reg_exp).

Inductive exp_match {T} :
  list T -> reg_exp -> Prop :=
  | MEmpty : exp_match [] EmptyStr
  | MChar x : exp_match [x] (Char x)
  | MApp s1 re1 s2 re2
             (H1 : exp_match s1 re1)
             (H2 : exp_match s2 re2) :
             exp_match (s1 ++ s2) (App re1 re2)
  | MUnionL s1 re1 re2
                (H1 : exp_match s1 re1) :
                exp_match s1 (Union re1 re2)
  | MUnionR re1 s2 re2
                (H2 : exp_match s2 re2) :
                exp_match s2 (Union re1 re2)
  | MStar0 re : exp_match [] (Star re)
  | MStarApp s1 s2 re
                 (H1 : exp_match s1 re)
                 (H2 : exp_match s2 (Star re)) :
                 exp_match (s1 ++ s2) (Star re).

Notation "s =~ re" := (exp_match s re) (at level 80).

Example reg_exp_ex1 : [1] =~ Char 1.
Proof.
  apply MChar.
Qed.

Example reg_exp_ex2 : [1; 2] =~ App (Char 1) (Char 2).
Proof.
  apply (MApp [1] _ [2]).
  - apply MChar.
  - apply MChar.
Qed.

Example reg_exp_ex3 : ~ ([1; 2] =~ Char 1).
Proof.
  intros H. inversion H.
Qed.

Fixpoint reg_exp_of_list {T} (l : list T) :=
  match l with
  | [] => EmptyStr
  | x :: l' => App (Char x) (reg_exp_of_list l')
  end.

Example reg_exp_ex4 : [1; 2; 3] =~ reg_exp_of_list [1; 2; 3].
Proof.
  simpl. apply (MApp [1]).
  { apply MChar. }
  apply (MApp [2]).
  { apply MChar. }
  apply (MApp [3]).
  { apply MChar. }
  apply MEmpty.
Qed.

Lemma MStar1 : forall T s (re : @reg_exp T) ,
  s =~ re ->
  s =~ Star re.
Proof.
  intros T s re H.
  rewrite <- (app_nil_r _ s).
  apply (MStarApp s [] re).
  apply H. apply MStar0.
Qed.

Lemma empty_is_empty : forall T (s : list T),
  ~ (s =~ EmptySet).
Proof.
  intros T s H. inversion H.
Qed.

Lemma MUnion' : forall T (s : list T)
                (re1 re2 : @reg_exp T),
  s =~ re1 \/ s =~ re2 ->
  s =~ Union re1 re2.
Proof.
  intros T s re1 re2 [H0 | H1].
  apply MUnionL. apply H0.
  apply MUnionR. apply H1.
Qed.

Lemma reg_exp_of_list_spec : forall T (s1 s2 : list T),
  s1 =~ reg_exp_of_list s2 <-> s1 = s2.
Proof.
  intros.
  generalize dependent s1.
  induction s2.
  - simpl. intros s1. split.
    + intros H. inversion H. reflexivity.
    + intros. rewrite H. apply MEmpty.
  - split.
    + intros H. inversion H.
      inversion H3. simpl.
      apply f_equal. apply IHs2.
      apply H4.
    + intros H. rewrite H. simpl.
      apply (MApp [x] (Char x) s2 _).
      apply MChar. apply IHs2.
      reflexivity.
Qed.

Lemma MStar' : forall T (ss : list (list T))
              (re : reg_exp),
  (forall s, In s ss -> s =~ re) ->
  fold app ss [] =~ Star re.
Proof.
  intros. induction ss as [|s' ss' IHss'].
  - simpl. apply MStar0.
  - simpl. apply MStarApp. apply H. simpl.
    left. reflexivity. apply IHss'.
    intros s H1. apply H. simpl. right.
    apply H1.
Qed.

Fixpoint re_chars {T} (re : reg_exp) : list T :=
  match re with
  | EmptySet => []
  | EmptyStr => []
  | Char x => [x]
  | App re1 re2 => re_chars re1 ++ re_chars re2
  | Union re1 re2 => re_chars re1 ++ re_chars re2
  | Star re => re_chars re
  end.

Theorem in_re_match : forall T (s : list T) (re : reg_exp) (x : T),
  s =~ re ->
  In x s ->
  In x (re_chars re).
Proof.
  intros T s re x Hmatch Hin.
  induction Hmatch as
  [| x'
   | s1 re1 s2 re2 Hmatch1 IH1 Hmatch2 IH2
   | s1 re1 re2 Hmatch IH
   | re1 s2 re2 Hmatch IH
   | re
   | s1 s2 re Hmatch1 IH1 Hmatch2 IH2].
  - apply Hin.
  - apply Hin.
  - simpl. rewrite In_app_iff in *.
    destruct Hin as [Hin | Hin].
    + left. apply (IH1 Hin).
    + right. apply (IH2 Hin).
  - simpl. rewrite In_app_iff.
    left. apply (IH Hin).
  - simpl. rewrite In_app_iff.
    right. apply (IH Hin).
  - destruct Hin.
  - simpl. rewrite In_app_iff in Hin.
    destruct Hin as [Hin | Hin].
    + apply (IH1 Hin).
    + apply (IH2 Hin).
Qed.

Theorem app_aux_1 : forall X (l1 l2 l3 : list X),
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof. Admitted.

Lemma star_app: forall T (s1 s2 : list T) (re : @reg_exp T),
  s1 =~ Star re ->
  s2 =~ Star re ->
  s1 ++ s2 =~ Star re.
Proof.
  intros T s1 s2 re H1.
  remember (Star re) as re'.
  generalize dependent s2.
  induction H1
  as [|x'|s1 re1 s2' re2 Hmatch1 IH1 Hmatch2 IH2
     |s1 re1 re2 Hmatch IH|re1 s2' re2 Hmatch IH
     |re''|s1 s2' re'' Hmatch1 IH1 Hmatch2 IH2].
  - (* MEmpty *) discriminate.
  - (* MChar *) discriminate.
  - (* MApp *) discriminate.
  - (* MUnionL *) discriminate.
  - (* MUnionR *) discriminate.
  - injection Heqre'.
    intros Heqre'' s H.
    apply H.
  - injection Heqre'. intros H0.
    intros s2 H1. rewrite app_aux_1.
    apply MStarApp.
    + apply Hmatch1.
    + apply IH2. rewrite H0.
      reflexivity. apply H1.
Qed.

Fixpoint re_not_empty {T : Type}
        (re : @reg_exp T) : bool :=
  match re with
  | EmptySet => false
  | EmptyStr => true
  | Char x => true
  | App re1 re2 => re_not_empty re1
                && re_not_empty re2
  | Union re1 re2 => re_not_empty re1
                || re_not_empty re2
  | Star re => true
  end.

Lemma re_not_empty_correct : forall T (re : @reg_exp T),
  (exists s, s =~ re)
      <-> re_not_empty re = true.
Proof.
  intros. split.
  - intros H. destruct H as [s].
    induction H. reflexivity.
    reflexivity. simpl.
    rewrite IHexp_match1.
    rewrite IHexp_match2.
    reflexivity. simpl.
    rewrite IHexp_match.
    reflexivity. simpl.
    rewrite IHexp_match.
    apply orb_true_iff.
    right. reflexivity.
    reflexivity. reflexivity.
  - intros H. induction re.
    + discriminate.
    + exists []. apply MEmpty.
    + exists [t]. apply MChar.
    + simpl in H. apply andb_true_iff in H.
      destruct H as [H0 H1].
      destruct IHre1. apply H0.
      destruct IHre2. apply H1.
      exists (x ++ x0). apply MApp.
      apply H. apply H2.
    + simpl in H. apply orb_true_iff in H.
      destruct H as [H0 | H1].
      * apply IHre1 in H0. destruct H0.
        exists x. apply MUnionL.
        apply H.
      * apply IHre2 in H1. destruct H1.
        exists x. apply MUnionR.
        apply H.
    + exists []. apply MStar0.
Qed.

(*
Lemma MStar' : forall T (ss : list (list T))
              (re : reg_exp),
  (forall s, In s ss -> s =~ re) ->
  fold app ss [] =~ Star re.
Lemma MStar'' : forall T (s : list T) (re : reg_exp),
  s =~ Star re ->
  exists ss : list (list T),
    s = fold app ss []
    /\ forall s', In s' ss -> s' =~ re.
Proof.
  intros. remember (Star re) as re'.
  induction H.
  - discriminate.
  - (* MChar *) discriminate.
  - (* MApp *) discriminate.
  - (* MUnionL *) discriminate.
  - (* MUnionR *) discriminate.
  - exists []. split. reflexivity.
    simpl. intros s.
    apply ex_falso_quodlibet.
  - exists [s1;s2]. split. simpl.
    rewrite app_nil_r. reflexivity.
    intros s' H1. unfold In in H1.
    injection Heqre'. intros H2.
    destruct H1 as [H1 | [H1 | H1]].
    + rewrite <- H1. rewrite <- H2.
      apply H.
    + rewrite <- H1.
*)


(* The file takes https://github.com/coq-community/topology as reference *)

Generalizable All Variables.

Require Export FormalMath.lib.Sets_ext.
Require Import FormalMath.lib.FiniteType.
Require Import Coq.Logic.ClassicalChoice.

Class OpenSet (A: Type) := open: Ensemble A -> Prop.
#[global] Typeclasses Transparent OpenSet.

Class TopologicalSpace (A: Type) {Ao: OpenSet A} : Prop :=
  {
    full_open: open Full_set;
    any_union_open: forall (f: Family A),
        (forall s, In f s -> open s) -> open (FamilyUnion f);
    intersection_open: forall (s1 s2: Ensemble A),
        open s1 -> open s2 -> open (Intersection s1 s2);
  }.

Definition topology_basis {A: Type} (B: Family A): Prop :=
  (forall (x: A), exists b, In B b /\ In b x) /\
  (forall (x: A) (b1 b2: Ensemble A),
      In B b1 -> In B b2 -> In (Intersection b1 b2) x ->
      exists b3, In B b3 /\ In b3 x /\ Included b3 (Intersection b1 b2)).

Definition basis_to_open {A} (B: Family A): OpenSet A :=
  fun u => forall x, In u x -> exists b, In B b /\ In b x /\ Included b u.

Lemma topology_basis_TopologicalSpace: forall A (B: Family A),
    topology_basis B -> @TopologicalSpace A (basis_to_open B).
Proof.
  intros. destruct H as [?B ?B]. split; unfold open, basis_to_open; intros.
  - destruct (B0 x) as [b [? ?]]. exists b. repeat split; auto.
  - destruct H0. destruct (H _ H0 _ H1) as [b [? [? ?]]]. exists b.
    repeat split; auto. repeat intro. exists S; auto.
  - destruct H1. destruct (H _ H1) as [b1 [? [? ?]]].
    destruct (H0 _ H2) as [b2 [? [? ?]]].
    assert (In (Intersection b1 b2) x) by (split; easy).
    specialize (B1 _ _ _ H3 H6 H9). destruct B1 as [b3 [? [? ?]]].
    exists b3. unfold Included in H12. repeat split; auto; destruct (H12 _ H13); auto.
Qed.

Lemma topology_basis_open_is_all_union: forall A (B: Family A),
    topology_basis B ->
    forall S, basis_to_open B S <->
              exists (F: Family A), Included F B /\ S = FamilyUnion F.
Proof.
  intros. destruct H as [?B ?B]. unfold basis_to_open. split; intros.
  - assert (forall m: {x | In S x},
               exists b, In B b /\ In b (proj1_sig m) /\ Included b S). {
      intros. destruct m. simpl. now apply H. } destruct (choice _ H0) as [f ?].
    exists (imageFamily f). split.
    + repeat intro. destruct H2. subst. now destruct (H1 x).
    + rewrite <- indexed_to_family_union. apply Extensionality_Ensembles.
      split; red; intros.
      * destruct (H1 (exist _ x H2)) as [? [? ?]]. simpl in *.
        exists (exist _ x H2); auto.
      * destruct H2. destruct (H1 i) as [? [? ?]]. auto.
  - destruct H as [F [? ?]]. destruct (B0 x) as [b [? ?]]. rewrite H1 in H0.
    inversion H0. subst. exists S0. repeat split; auto. repeat intro. exists S0; auto.
Qed.

Class HausdorffSpace (A: Type) {Ao: OpenSet A}: Type :=
  Hausdorff_prop: forall (x1 x2: A),
    x1 <> x2 ->
    { U1: Ensemble A & { U2: Ensemble A |
      open U1 /\ open U2 /\ In U1 x1 /\ In U2 x2 /\ Intersection U1 U2 = Empty_set } }.

Section TOPOLOGICAL_SPACE_PROP.

  Context `{T: TopologicalSpace A}.

  Lemma empty_open: open Empty_set.
  Proof. rewrite <- empty_family_union. apply any_union_open. intros. easy. Qed.

  Lemma union_open: forall (u v: Ensemble A), open u -> open v -> open (Union u v).
  Proof.
    intros.
    assert (Union u v = FamilyUnion (Couple u v)). {
      apply Extensionality_Ensembles. split; red; intros.
      - destruct H1; [exists u | exists v]; auto with sets.
      - destruct H1. destruct H1; [left | right]; easy.
    } rewrite H1. apply any_union_open. intros. now destruct H2.
  Qed.

  Definition closed (u: Ensemble A): Prop := open (Complement u).

  Lemma closed_compl_open: forall (S: Ensemble A), closed (Complement S) -> open S.
  Proof. intros. red in H. now rewrite Complement_Complement in H. Qed.

  Lemma full_closed: closed Full_set.
  Proof. red. rewrite Full_compl_empty. apply empty_open. Qed.

  Lemma empty_closed: closed Empty_set.
  Proof. red. rewrite Empty_compl_full. apply full_open. Qed.

  Lemma any_intersection_closed: forall (f: Family A),
      (forall s, In f s -> closed s) -> closed (FamilyIntersection f).
  Proof.
    intros. red. rewrite family_intersection_compl_union. apply any_union_open.
    intros. red in H0. specialize (H _ H0). now apply closed_compl_open.
  Qed.

  Lemma union_closed: forall (s1 s2: Ensemble A),
      closed s1 -> closed s2 -> closed (Union s1 s2).
  Proof. intros. red. rewrite De_Morgan_law1. apply intersection_open; auto. Qed.

  Definition interior (S: Ensemble A): Ensemble A :=
    FamilyUnion (fun U => open U /\ Included U S).

  Lemma interior_open: forall S, open (interior S).
  Proof. intro. apply any_union_open. intros. red in H. now destruct H. Qed.

  Lemma interior_Included: forall S, Included (interior S) S.
  Proof. repeat intro. destruct H. destruct H. auto with sets. Qed.

  Lemma open_interior_self: forall S, open S -> interior S = S.
  Proof.
    intros. apply Extensionality_Ensembles. split.
    - apply interior_Included.
    - repeat intro. exists S; auto with sets.
  Qed.

  Lemma interior_maximal: forall U S,
      open U -> Included U S -> Included U (interior S).
  Proof. repeat intro. exists U; auto with sets. Qed.

  Lemma Included_interior_open: forall S, Included S (interior S) -> open S.
  Proof.
    intros. replace S with (interior S). 1: apply interior_open.
    apply Extensionality_Ensembles. split; auto. apply interior_Included.
  Qed.

  Definition closure (S: Ensemble A): Ensemble A :=
    FamilyIntersection (fun U => closed U /\ Included S U).

  Lemma closure_closed: forall S, closed (closure S).
  Proof. intros. apply any_intersection_closed. intros. red in H. now destruct H. Qed.

  Lemma closure_Included: forall S, Included S (closure S).
  Proof. repeat intro. constructor. intros U ?. destruct H0. auto with sets. Qed.

  Lemma closed_closure_self: forall S, closed S -> closure S = S.
  Proof.
    intros. apply Extensionality_Ensembles. split.
    - repeat intro. destruct H0. apply H0. auto with sets.
    - apply closure_Included.
  Qed.

  Lemma closure_minimal: forall U S,
      closed U -> Included S U -> Included (closure S) U.
  Proof. repeat intro. destruct H1. apply H1. auto with sets. Qed.

  Definition isolated (x: A): Prop := open (Singleton x).

  Definition isolated_in_set (x: A) (S: Ensemble A): Prop :=
    In S x /\ exists U, open U /\ Intersection U S = Singleton x.

  Definition discrete (U: Ensemble A): Prop :=
    forall x, In U x -> isolated_in_set x U.

  Definition connected: Prop :=
    forall (S: Ensemble A), open S -> closed S -> S = Empty_set \/ S = Full_set.

  Definition compact: Prop :=
    forall (C: Family A),
      (forall U, In C U -> open U) -> FamilyUnion C = Full_set ->
      exists (fC: Family A), Finite fC /\ Included fC C /\ FamilyUnion fC = Full_set.

  Definition compact_set (S: Ensemble A): Prop :=
    forall (C: Family A),
      (forall U, In C U -> open U) -> Included S (FamilyUnion C) ->
      exists (fC: Family A), Finite fC /\ Included fC C /\
                             Included S (FamilyUnion fC).

  Lemma compact_set_on_indexed_covers:
    forall (S: Ensemble A) (Idx: Type) (C: IndexedFamily Idx A),
      compact_set S ->
      (forall idx: Idx, open (C idx)) -> Included S (IndexedUnion C) ->
      exists idxSet: Ensemble Idx,
        Finite idxSet /\
        Included S (IndexedUnion (fun i: {x: Idx | In idxSet x} => C (proj1_sig i))).
  Proof.
    intros. destruct (H (imageFamily C)) as [subcover].
    - intros. destruct H2. subst y. apply H0.
    - now rewrite indexed_to_family_union in H1.
    - destruct H2 as [? []]. apply Finite_FiniteT in H2.
      destruct (finite_choice _ _
                              (fun (U:{x:Ensemble A | In subcover x}) (a:Idx) =>
                                 proj1_sig U = C a)) as [choice_fun]; auto.
      + intros. destruct x as [x]. simpl. apply H3 in i. destruct i. exists x; auto.
      + exists (Im Full_set choice_fun). split.
        * apply FiniteT_img; auto. intros. apply classic.
        * repeat intro. apply H4 in H6. destruct H6.
          assert (In (Im Full_set choice_fun) (choice_fun (exist _ S0 H6))). {
            exists (exist _ S0 H6); constructor. }
          exists (exist _ (choice_fun (exist _ S0 H6)) H8). simpl. now rewrite <- H5.
  Qed.

  Lemma finite_intersection_open: forall {Idx: Type} (F:IndexedFamily Idx A),
      FiniteT Idx -> (forall i: Idx, open (F i)) -> open (IndexedIntersection F).
  Proof.
    intros. induction H.
    - rewrite empty_indexed_intersection. apply full_open.
    - assert (IndexedIntersection F =
              Intersection (IndexedIntersection (fun x => F (Some x))) (F None)). {
        apply Extensionality_Ensembles; split; red; intros.
        - destruct H1. constructor.
          + constructor. intros; apply H1.
          + apply H1.
        - destruct H1. destruct H1. constructor. intros.
          destruct i; [apply H1 | apply H2]. }
      rewrite H1. apply intersection_open.
      + apply IHFiniteT. intros; apply H0.
      + apply H0.
    - destruct H1.
      assert (IndexedIntersection F = IndexedIntersection (fun x => F (f x))). {
        apply Extensionality_Ensembles; split; red; intros.
        - constructor. destruct H3. intro; apply H3.
        - constructor. destruct H3. intro; rewrite <- H2 with i. apply H3. }
      rewrite H3. apply IHFiniteT. intro; apply H0.
  Qed.

  (* Theorem 26.3 of Topology *)
  Lemma compact_of_Hausdorff_closed:
    forall {Hau: HausdorffSpace A} (S: Ensemble A), compact_set S -> closed S.
  Proof.
    intros. red. apply Included_interior_open. repeat intro.
    assert (forall y, In S y -> y <> x). {
      intros. hnf in H0. intro. apply H0. now subst. }
    remember (fun yS: {z: A | In S z} =>
                let whole := Hausdorff_prop (proj1_sig yS) x (H1 _ (proj2_sig yS)) in
                (projT1 whole, proj1_sig (projT2 whole))).
    remember ((fun x: {z : A | In S z} => fst (p x)) :
                IndexedFamily {z : A | In S z} A) as V.
    assert (forall idx: {z: A | In S z}, open (V idx)). {
      intros. subst. simpl. destruct idx as [z]. simpl. unfold Hausdorff_prop.
      destruct Hau. destruct s. destruct a. simpl. easy. }
    assert (Included S (IndexedUnion V)). {
      repeat intro. exists (exist _ x0 H3). subst. simpl. unfold Hausdorff_prop.
      destruct Hau. destruct s. simpl. tauto. }
    destruct (compact_set_on_indexed_covers _ _ _ H H2 H3) as [idxSet []].
    remember ((fun x: {z : A | In S z} => snd (p x)) :
                IndexedFamily {z : A | In S z} A) as U.
    hnf. exists (IndexedIntersection
                   (fun i : {x : {z : A | In S z} | In idxSet x} => U (proj1_sig i))).
    - hnf. split.
      + apply finite_intersection_open.
        * now apply Finite_FiniteT.
        * intros. subst. simpl. unfold Hausdorff_prop. destruct Hau. simpl.
          destruct s as [? [? []]]. now simpl.
      + repeat intro. specialize (H5 _ H7). inversion H5. subst x1. clear H5.
        inversion H6. subst x1. clear H6. specialize (H5 i). subst. simpl in H5, H8.
        unfold Hausdorff_prop in H8, H5. destruct Hau. simpl in H8, H5.
        destruct s. simpl in H5. destruct a as [_ [_ [_ [_ ?]]]].
        assert (In (Intersection x1 x2) x0) by now constructor. rewrite H6 in H9.
        inversion H9.
    - hnf. constructor. intros. destruct i. simpl. subst. simpl. unfold Hausdorff_prop.
      destruct x0. simpl. destruct Hau. simpl. destruct s. simpl. tauto.
  Qed.

End TOPOLOGICAL_SPACE_PROP.


Require Export P02.

(** **** Exercise: 3 stars (optimize_0plus_b)  *)
(** Since the [optimize_0plus] transformation doesn't change the value
    of [aexp]s, we should be able to apply it to all the [aexp]s that
    appear in a [bexp] without changing the [bexp]'s value.  Write a
    function which performs that transformation on [bexp]s, and prove
    it is sound.  Use the tacticals we've just seen to make the proof
    as elegant as possible. *)

Fixpoint optimize_0plus (a:aexp) : aexp :=
  match a with
  | AId x              => AId x
  | ANum n             => ANum n
  | APlus (ANum 0) e2  => optimize_0plus e2
  | APlus e1 e2        => APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2       => AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2        => AMult (optimize_0plus e1) (optimize_0plus e2)
  end.

Theorem optimize_0plus_sound: forall st a,
  aeval st (optimize_0plus a) = aeval st a.
Proof.
  intros st a.
  induction a;
    try (simpl; rewrite IHa1; rewrite IHa2; reflexivity);
    try reflexivity.
  - (* APlus *)
    destruct a1;
      try (simpl; simpl in IHa1; rewrite IHa1;rewrite IHa2; reflexivity).
    + (* a1 = ANum n *) destruct n; simpl; rewrite IHa2; reflexivity.
    + (* a1 = AId i *) simpl. rewrite IHa2. reflexivity.
Qed.

Fixpoint optimize_0plus_b (b : bexp) : bexp :=
  match b with
  | BTrue       => BTrue
  | BFalse      => BFalse
  | BEq a1 a2   => BEq (optimize_0plus a1) (optimize_0plus a2)
  | BLe a1 a2   => BLe (optimize_0plus a1) (optimize_0plus a2)
  | BNot b1     => BNot (optimize_0plus_b b1)
  | BAnd b1 b2  => BAnd (optimize_0plus_b b1) (optimize_0plus_b b2)
  end.

Example optimize_0plus_b_example1:
  optimize_0plus_b (BEq
     (AMult (APlus (ANum 0) (APlus (ANum 0) (ANum 3)))
            (AMinus (ANum 5) (APlus (ANum 0) (ANum 1))))
     (APlus (ANum 2)
            (APlus (ANum 0)
                   (APlus (ANum 0) (ANum 1)))))
  = (BEq (AMult (ANum 3) (AMinus (ANum 5) (ANum 1)))
         (APlus (ANum 2) (ANum 1))).
Proof. reflexivity. Qed.

Theorem optimize_0plus_b_sound : forall st b,
  beval st (optimize_0plus_b b) = beval st b.
Proof.
  intros st b.
  induction b;
    try (simpl; repeat rewrite optimize_0plus_sound; reflexivity);
    try reflexivity.
  - (* BNot *) simpl. rewrite IHb. reflexivity.
  - (* BAnd *) simpl. rewrite IHb1. rewrite IHb2. reflexivity.
Qed.


(*|
#############################################################
Efficient Way of Defining Multiple Functions of the Same Type
#############################################################

:Link: https://stackoverflow.com/q/49600938
|*)

(*|
Question
********

I would like to avoid copying and pasting the parameters and return
type of functions of the same type that I am trying to define. Since,
in my opinion, that would be bad programming practice.

For example, I am defining the following functions:
|*)

Definition R := nat. (* .none *)
Definition metric_non_negative {X : Type} (d : X -> X -> R) :=
  forall x y : X, (d x y) >= 0.

Definition metric_identical_arguments {X : Type} (d : X -> X -> R) :=
  forall x y : X, (d x y) = 0 <-> x = y.

(*|
I would like to be able to define both functions without repeatedly
typing the redundancy:

.. code-block:: coq

    {X : Type} (d : X -> X -> R)

I would also like to potentially define a third function, in which
case the solution should generalize to the case where more than two
functions of the same type are being defined. Is this possible, and
how so?

----

**A (Anton Trunov):** Does ``Section`` mechanism not solve your
problem?
|*)

(*|
Answer
******

As Anton Trunov mentioned in his comment, it sounds exactly like you
want to use a section:
|*)

Reset metric_non_negative. (* .none *)
Section Metric.

  Context {X : Type}.
  Variable (d : X -> X -> R).

  Definition metric_non_negative :=
    forall x y : X, (d x y) >= 0.

  Definition metric_identical_arguments :=
    forall x y : X, (d x y) = 0 <-> x = y.

End Metric.

(*|
Note that I've used ``Context`` to make ``X`` an implicit argument;
you can also use ``Set Implicit Arguments.`` and make it a
``Variable`` to let Coq set its implicitness automatically.
|*)


From mathcomp Require Import all_ssreflect.

(** *** Exercise 1:
    - Prove this statement by induction.
      Relevant lemmas are
         doubleS odd_double addn0 addnn mulnn
         big_mkcond big_nat_recr
*)

Lemma sum_odd n : \sum_(0 <= i < n.*2 | odd i) i = n^2.
Proof.
(*D*)elim: n => [|n IHn]; first by rewrite unlock.
(*D*)rewrite doubleS big_mkcond 2?big_nat_recr // -big_mkcond /=.
(*D*)rewrite {}IHn odd_double /= addn0 -addnn -!mulnn.
(*D*)by rewrite mulSn mulnC mulSn addnA addSn addnC.
Qed.

(** *** Exercise 2:
    - Let's define the subtype of odd and even natural numbers
    - Intrument Coq to recognize odd/even number built out
      of product and successor
    - Inherit on [odd_nat] the [eqType] structure
*)

Structure odd_nat := Odd {
  oval :> nat;
  oprop : odd oval
}.
Lemma oddP (n : odd_nat) : odd n.
Proof. by case: n. Qed.

Structure even_nat := Even {
  eval :> nat;
  eprop : ~~ (odd eval)
}.
Lemma evenP (n : even_nat) : ~~ (odd n).
Proof. by case: n. Qed.

Example test_odd (n : odd_nat) : ~~ (odd 6) && odd (n * 3).
Proof. Fail by rewrite oddP evenP. Abort.

Canonical even_0 := Even 0 isT.

Lemma oddS n : ~~ (odd n) -> odd n.+1.
Proof.
(*D*)by rewrite /=; case: (odd n).
Qed.

Lemma evenS n : (odd n) -> ~~ (odd n.+1).
Proof.
(*D*)by rewrite /=; case: (odd n).
Qed.

Canonical odd_even (m : even_nat) :=
  Odd m.+1 (oddS m (eprop m)).
Canonical even_odd (m : odd_nat) :=
(*D*)Even m.+1 (evenS m (oprop m)).

Lemma odd_mulP (n m : odd_nat) : odd (n * m).
Proof.
(*D*)by rewrite odd_mul !oddP.
Qed.
Canonical odd_mul (n m : odd_nat) :=
(*D*)Odd (n * m) (odd_mulP n m).

Example test_odd (n : odd_nat) : ~~ (odd 6) && odd (n * 3).
Proof. by rewrite oddP evenP. Qed.

Fail Check forall n m : odd_nat, n == m.

Canonical odd_subType :=
(*D*)Eval hnf in [subType for oval].
Definition odd_eqMixin :=
(*D*)Eval hnf in [eqMixin of odd_nat by <:].
Canonical odd_eqType :=
(*D*)Eval hnf in EqType odd_nat odd_eqMixin.

Check forall n m : odd_nat, n == m.


(* Exercise 1 *)
(* Define an inductive type for the months in the gregorian calendar *)
(*(the French civil calendar) *)
Inductive month : Set :=
|January : month
|February : month
|March : month
|April : month
|May : month
|June : month
|July : month
|August : month
|September : month
|October : month
|November : month
|December : month.

(* Define an inductive type for the four seasons *)
Inductive season : Set :=
|Autumn : season
|Winter : season
|Spring : season
|Summer : season.

(* What is the inductive principle generated in each case ?*)
Check month_ind.
Check season_ind.

(* Define a function mapping each month to the season that contains *)
(* most of its days, using pattern matching *)
Definition season_of_month (m : month) :=
  match m with
    |January => Winter
    |February => Winter
    |March => Winter
    |April => Spring
    |May => Spring
    |June => Spring
    |July => Summer
    |August => Summer
    |September => Summer
    |October => Autumn
    |November => Autumn
    |December => Autumn
  end.

(* Exercise 2 *)
(* Define the boolean functions bool_xor, bool_and, bool_eq of type *)
(*bool -> bool -> bool, and the function bool_not of type bool -> bool *)
Definition bool_not (b:bool) : bool := if b then false else true.

Definition bool_xor (b b':bool) : bool := if b then bool_not b' else b'.

Definition bool_and (b b':bool) : bool := if b then b' else false.

Definition bool_or (b b':bool) := if b then true else b'.

Definition bool_eq (b b':bool) := if b then b' else bool_not b'.

(* prove the following theorems:*)
Lemma bool_xor_not_eq : forall b1 b2 : bool,
  bool_xor b1 b2 = bool_not (bool_eq b1 b2).
Proof.
  intros b1 b2; case b1; case b2; simpl; trivial.
Qed.

Lemma bool_not_and : forall b1 b2 : bool,
  bool_not (bool_and b1 b2) = bool_or (bool_not b1) (bool_not b2).
Proof.
  intros b1 b2; case b1; case b2; simpl; trivial.
Qed.

Lemma bool_not_not : forall b : bool, bool_not (bool_not b) = b.
Proof.
 intro b; case b; simpl; trivial.
Qed.

Lemma bool_or_not : forall b : bool,
  bool_or b (bool_not b) = true.
Proof.
  intro b; case b; simpl; trivial.
Qed.

Lemma bool_id_eq : forall b1 b2 : bool,
  b1 = b2 <-> bool_eq b1 b2 = true.
Proof.
  intros b1 b2 ;split.
 intro H;rewrite  H;  case b2; trivial.
 case b1; case b2; simpl; trivial.
  intro e;discriminate e.
Qed.

Lemma bool_not_or : forall b1 b2 : bool,
  bool_not (bool_or b1 b2) = bool_and (bool_not b1) (bool_not b2).
Proof.
  intros b1 b2; case b1; case b2; simpl; trivial.
Qed.

Lemma bool_or_and : forall b1 b2 b3 : bool,
  bool_or (bool_and b1 b3) (bool_and b2 b3) =
  bool_and (bool_or b1 b2) b3.
Proof.
  intros b1 b2 b3; case b1; case b2; case b3; simpl; trivial.
Qed.

(* Exercise 3 *)

(* Let us consider again the type color defined in the lecture :*)
Inductive color:Type :=
 | white | black | yellow | cyan | magenta | red | blue | green.

(* let us define the complement of a color *)

Definition compl (c : color) :=
 match c with
 | white => black
 | black => white
 | yellow => blue
 | cyan => red
 | magenta => green
 | red => cyan
 | blue => yellow
 | green => magenta
 end.

(*
Prove the following results:*)

Lemma compl_compl : forall c, compl (compl c)= c.
Proof.
 intro c;case c;simpl;trivial.
Qed.

Lemma compl_injective : forall c c', compl c = compl c' -> c = c'.
Proof.
 intro c;case c;intro c';case c';simpl;intro e;try discriminate;trivial.
Qed.

Lemma compl_surjective : forall c, exists c', c= compl  c'.
Proof.
 intro c; exists (compl c);rewrite compl_compl;trivial.
Qed.

(** Exercise 4 *)

(* Define an inductive type formula : Type that represents the *)
(*abstract language of propositional logic without variables:
L = L /\ L | L \/ L | ~L | L_true | L_false
*)
Inductive formula : Type :=
|L_true : formula
|L_false : formula
|L_and : formula -> formula -> formula
|L_or : formula -> formula -> formula
|L_neg : formula -> formula.

(* Define a function formula_holds of type (formula -> Prop computing the *)
(* Coq formula corresponding to an element of type formula *)
Fixpoint formula_holds (f : formula) : Prop :=
  match f with
    |L_true => True
    |L_false => False
    |L_and f1 f2 => (formula_holds f1) /\ (formula_holds f2)
    |L_or f1 f2 =>  (formula_holds f1) \/ (formula_holds f2)
    |L_neg f => ~(formula_holds f)
  end.

(* Define  a function isT_formula of type (formula -> bool) computing *)
(* the intended truth value of (f : formula) *)
Fixpoint isT_formula (f : formula) : bool :=
  match f with
    |L_true => true
    |L_false => false
    |L_and f1 f2 => andb (isT_formula f1) (isT_formula f2)
    |L_or f1 f2 =>  orb (isT_formula f1) (isT_formula f2)
    |L_neg f => negb (isT_formula f)
  end.

(* prove that is (idT_formula f) evaluates to true, then its *)
(*corresponding Coq formula holds ie.:*)
Require Import Bool.
Lemma isT_formula_correct : forall f : formula,
   isT_formula f = true <-> formula_holds f.
Proof.
induction f; simpl; split; trivial.
(* False *)
discriminate.
intro h; elim h.
(* And *)
case_eq (isT_formula f1); intro h1; case_eq (isT_formula f2); intro
   h2; try discriminate 1.
  split; [apply IHf1 | apply IHf2]; trivial.

  destruct IHf1 as [IHf1_1 IHf1_2].
  destruct IHf2 as [IHf2_1 IHf2_2].
  destruct 1.
  rewrite IHf1_2; trivial.
  rewrite IHf2_2; trivial.
(* Or *)
case_eq (isT_formula f1); intro h1; case_eq (isT_formula f2); intro
   h2; try discriminate 1.
  left; apply IHf1; trivial.
  left; apply IHf1; trivial.
  right; apply IHf2; trivial.

intro h.
destruct IHf1 as [IHf1_1 IHf1_2].
destruct IHf2 as [IHf2_1 IHf2_2].
destruct h as [h1 | h2].
  rewrite IHf1_2; trivial.
  rewrite IHf2_2; trivial.
  SearchAbout orb.
  rewrite orb_true_r; trivial.
(* False *)
destruct IHf as [IHf_1 IHf_2].
case_eq (isT_formula f).
  discriminate 2.
  intros h1 _ h3.
  generalize h1.
  rewrite IHf_2; trivial.
  discriminate 1.
destruct IHf as [IHf_1 IHf_2].
case_eq (isT_formula f); trivial.
intros h1 h2.
absurd (formula_holds f); trivial.
apply IHf_1.
trivial.
Qed.

(* Exercise 5 *)
(* We use the inductive type defined in the lecture:*)
Inductive natBinTree : Set :=
| Leaf : natBinTree
| Node : nat -> natBinTree -> natBinTree -> natBinTree.

(*
Define a function which sums all the values present in the tree.
*)
Fixpoint sum_natBinTree (t : natBinTree) :=
  match t with
    |Leaf => 0
    |Node n t1 t2 => n + (sum_natBinTree t1) + (sum_natBinTree t2)
  end.

(*
Define a function is_zero_present : natBinTree -> bool, which tests if
the value 0 is present in the tree.
*)
Fixpoint is_zero_present (t : natBinTree) :=
  match t with
    |Leaf  => false
    |Node n t1 t2 =>
      match n with
        |0 => true
          |_ =>
            (is_zero_present t1) || (is_zero_present t2)
      end
  end.


(*
Check nat_rect.
*)

Fixpoint nat_rect'
    (P:nat -> Type)
    (p:P 0)
    (q:forall (n:nat), P n -> P (S n))
    (n:nat) : P n :=
    match n with
    | 0     => p
    | S m   => q m (nat_rect' P p q m)
    end.

Definition nat_rect'' := fix f
    (P:nat -> Type)
    (p:P 0)
    (q:forall (n:nat), P n -> P (S n))
    (n:nat) : P n :=
    match n with
    | 0     => p
    | S m   => q m (f P p q m)
    end.

Lemma rect_correct : forall
    (P:nat -> Type)
    (p:P 0)
    (q:forall (n:nat), P n -> P (S n))
    (n:nat),
    nat_rect' P p q n = nat_rect'' P p q n.
Proof. reflexivity. Qed.

Definition nat_rect3
    (P:nat -> Type)
    (p:P 0)
    (q:forall (n:nat), P n -> P (S n))
    : forall (n:nat), P n :=
    fix f (n:nat) : P n :=
        match n with
        | 0     => p
        | S m   => q m (f m)
        end.
Lemma rect3_correct : forall
    (P:nat -> Type)
    (p:P 0)
    (q:forall (n:nat), P n -> P (S n))
    (n:nat),
    nat_rect3 P p q n = nat_rect' P p q n.
Proof.
    intros P p q. induction n as [|n IH].
    - reflexivity.
    - simpl. rewrite IH. reflexivity.
Qed.

Definition nat_ind' (P:nat -> Prop) := nat_rect' P.
Definition nat_rec' (P:nat -> Set)  := nat_rect' P.

(*
Check nat_ind'.
Check nat_rec'.
*)

Lemma plus_n_0' : forall (n:nat), plus n 0 = n.
Proof.
    apply nat_ind'.
    - reflexivity.
    - intros n IH. simpl. rewrite IH. reflexivity.
Qed.

(*
Check nat_rec'.
nat_rec : forall P : nat -> Set,
    P 0 ->
    (forall n : nat, P n -> P (S n)) ->
    forall n : nat, P n
*)

Lemma nat_rec_init :
    forall (P:nat -> Set),
    forall (p:P 0),
    forall (q: forall n, P n -> P (S n)),
    nat_rec' P p q 0 = p.
Proof. reflexivity. Qed.

Lemma nat_rec_inc :
    forall (P:nat -> Set),
    forall (p:P 0),
    forall (q: forall n, P n -> P (S n)),
    forall (n:nat),
    nat_rec' P p q (S n) = q n (nat_rec' P p q n).
Proof. reflexivity. Qed.

Definition plus': nat -> nat -> nat :=
    nat_rec' (fun _ => nat -> nat) (fun m => m) (fun _ f m => S (f m)).

Lemma plus_0_n' : forall (n:nat), plus' 0 n = n.
Proof. reflexivity. Qed.

Lemma plus_Sn_m' : forall (n m:nat), plus' (S n) m = S (plus' n m).
Proof. reflexivity. Qed.

Lemma plus'_correct : forall (n m:nat), plus' n m = plus n m.
Proof.
    apply (nat_ind' (fun n => forall (m:nat), plus' n m = plus n m));
    intros n; simpl.
    - unfold plus'. unfold nat_rec'. unfold nat_rect'. reflexivity.
    - intros IH m. rewrite plus_Sn_m', IH. reflexivity.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Axiom replace_with_your_solution_here : forall {A : Type}, A.

(*
Use your solution of Homework 2 and prove correctness of your implementations.
I'm repeating some (partial) definitions here just to make sure
the lemma statements make sense.
*)

(* A language of arithmetic expression *)
Inductive expr : Type :=
| Const of nat
| Plus of expr & expr
| Minus of expr & expr
| Mult of expr & expr.

Fixpoint eval (e : expr) : nat :=
  match e with
  | Const n => n
  | Plus n m => addn (eval n) (eval m)
  | Minus n m => subn (eval n) (eval m)
  | Mult n m => muln (eval n) (eval m)
  end.

(* Stack language *)
Inductive instr := Push (n : nat) | Add | Sub | Mul.

Definition prog := seq instr.
Definition stack := seq nat.

Fixpoint run (p : prog) (s : stack) : stack :=
  match p, s  with
  | [::], t => s
  | Push n :: r, t => run r (n :: t)
  | Add :: r, n :: m :: t => run r ((addn m n) :: t)
  | Sub :: r, n :: m :: t => run r ((subn m n) :: t)
  | Mul :: r, n :: m :: t => run r ((muln m n) :: t)
  | _, _ => [::]
  end.

(* Compiler from the expression language to the stack language *)

Fixpoint compile (e : expr) : prog :=
  match e with
  | Const n => [:: Push n]
  | Plus m n => compile m ++ compile n ++ [:: Add]
  | Minus m n => compile m ++ compile n ++ [:: Sub]
  | Mult m n => compile m ++ compile n ++ [:: Mul]
  end.

Arguments compile e : simpl nomatch.

Definition E := (Plus (Const 10) (Mult (Const 11) (Const 3))).

Check erefl : run (compile E) [::] = [:: eval E].
Compute (compile E).

(** Here is a correctness theorem for the compiler: it preserves the
meaning of programs. By "meaning", in this case, we just mean the final
answer computed by the program. For a high-level expression, the answer
is the result of calling [eval]. For stack programs, the answer
is whatever [run] leaves on the top of the stack. The correctness
theorem states that these answers are the same for an expression and
the corresponding compiled program. *)

Lemma run_order (e : expr) (p : prog) (s : stack) :
  run (compile e ++ p) s = run p (eval e :: s).
Proof.
  move : e p s.
  elim.
  - move => //.
  - move => ex hx ey hy p s.
    rewrite /= -!catA.
    rewrite (hx (compile ey ++ [:: Add] ++ p) s).
    rewrite (hy ([:: Add] ++ p) (eval ex :: s)).
    by rewrite /=.
  - move => ex hx ey hy p s.
    rewrite /= -!catA.
    rewrite (hx (compile ey ++ [:: Sub] ++ p) s).
    rewrite (hy ([:: Sub] ++ p) (eval ex :: s)).
    by rewrite /=.
  - move => ex hx ey hy p s.
    rewrite /= -!catA.
    rewrite (hx (compile ey ++ [:: Mul] ++ p) s).
    rewrite (hy ([:: Mul] ++ p) (eval ex :: s)).
    by rewrite /=.
Qed.

Theorem compile_correct e :
  run (compile e) [::] = [:: eval e].
Proof.
  move : (run_order e [::] [::]).
  rewrite cats0.
  exact.
Qed.

(* ==== OPTIONAL part: decompiler ==== *)

Print option.

Fixpoint decompile_rec (p : prog) (s : seq expr) {struct p} : option expr :=
  match p, s with
  | Push n :: r, t => decompile_rec r (Const n :: s)
  | Mul :: r, n :: m :: t => decompile_rec r (Mult m n :: t)
  | Sub :: r, n :: m :: t => decompile_rec r (Minus m n :: t)
  | Add :: r, n :: m :: t => decompile_rec r (Plus m n :: t)
  | [::], [:: e] => Some e
  | _, _ => None
  end.

Arguments decompile_rec p s : simpl nomatch.

Definition decompile (p : prog) : option expr := decompile_rec p [::].

(** Prove [decompile] cancels [compile]. *)

Lemma decompile_rec_compile (e : expr) (p : prog) (s : seq expr) :
  decompile_rec (compile e ++ p) s = decompile_rec p (e :: s).
Proof.
  move : e p s.
  elim.
  - by move => //.
  - move => em hm en hn p s.
    move => /=.
    rewrite -!catA.
    rewrite hm hn.
      by exact.
  - move => em hm en hn p s.
    move => /=.
    rewrite -!catA.
    rewrite hm hn.
      by exact.
  - move => em hm en hn p s.
    move => /=.
    rewrite -!catA.
    rewrite hm hn.
      by exact.
Qed.

Lemma decompile_compile e :
  decompile (compile e) = Some e.
Proof.
  move : (decompile_rec_compile e [::] [::]).
  rewrite /= cats0.
  done.
Qed.

(* Prove the [compile] function is injective *)

Definition decrec (p : prog) := decompile_rec p [::].

(* Lemma compile_inj :
  injective compile.
Proof.
  rewrite /injective.
  case => /=.
  - move => n e.
    move => h1.
    move : (congr1 decompile h1).
    rewrite decompile_compile /decompile /decompile_rec.
    by case.
  - move => ex ey e.
    case : e.
    - move => n h1.
      move : (congr1 decrec h1).
      by rewrite /decrec !decompile_rec_compile /(compile (Const n)) //.
    - move => em en.
      rewrite /=.
      move => h1.
      move : (congr1 decrec h1).
      rewrite /decrec !decompile_rec_compile /=.
      case.
      move => exm eyn.
      set h2 := (proj2 (pair_equal_spec ex em ey en)) (conj exm eyn).
        by exact (congr1 (fun '(x, y) => Plus x y) h2).
    - move => em en.
      rewrite /=.
      move => h1.
      move : (congr1 decrec h1).
      rewrite /decrec !decompile_rec_compile /=.
      case.
        by exact.
    - move => em en.
      rewrite /=.
      move => h1.
      move : (congr1 decrec h1).
      rewrite /decrec !decompile_rec_compile /=.
      case.
        by exact.
  - move => em en.
    rewrite /=.
    case.
    - move => n.
      rewrite /(compile (Const n)).
      move => h1.
      move : (congr1 decrec h1).
        by rewrite !/decrec !decompile_rec_compile //.
    - move => n.
      rewrite /=.
      move => e h1.
      move : (congr1 decrec h1).
        by rewrite !/decrec !decompile_rec_compile //.
    - move => n.
      rewrite /=.
      move => e h1.
      move : (congr1 decrec h1).
      rewrite !/decrec !decompile_rec_compile //.
      case.
      move => emn ene.
      set h2 := (proj2 (pair_equal_spec em n en e)) (conj emn ene).
        by exact (congr1 (fun '(x, y) => Minus x y) h2).
    - move => n.
      rewrite /=.
      move => e h1.
      move : (congr1 decrec h1).
        by rewrite !/decrec !decompile_rec_compile //.

  - move => em en.
    rewrite /=.
    case.
    - move => n.
      rewrite /(compile (Const n)).
      move => h1.
      move : (congr1 decrec h1).
        by rewrite !/decrec !decompile_rec_compile //.
    - move => n.
      rewrite /=.
      move => e h1.
      move : (congr1 decrec h1).
        by rewrite !/decrec !decompile_rec_compile //.
    - move => n.
      rewrite /=.
      move => e h1.
      move : (congr1 decrec h1).
      by rewrite !/decrec !decompile_rec_compile //.
    - move => n.
      rewrite /=.
      move => e h1.
      move : (congr1 decrec h1).
      rewrite !/decrec !decompile_rec_compile //.
      case.
      move => emn ene.
      set h2 := (proj2 (pair_equal_spec em n en e)) (conj emn ene).
      by exact (congr1 (fun '(x, y) => Mult x y) h2).
Qed. *)

Lemma compile_inj :
  injective compile.
Proof.
  rewrite /injective.
  move => ex ey h1.
  move : (congr1 decompile h1).
  rewrite !decompile_compile.
  case.
  exact.
Qed.