Require Import ZArith List Arith Bool Lia.
Import ListNotations.

(* 6.5 * Dependent Inductive Types *)

(* 6.5.1 First-Order Data as Parameters *)
Inductive ltree (n : nat) : Set
  := lleaf : ltree n
   | lnode : forall p : nat, p <= n -> ltree n -> ltree n -> ltree n.

Check ltree_ind.
(* ltree_ind : forall (n : nat) (P : ltree n -> Prop),
     P (lleaf n)
     -> (forall (p : nat) (l : p <= n) (l0 : ltree n),
         P l0 -> forall l1 : ltree n, P l1 -> P (lnode n p l l0 l1))
     -> forall l : ltree n, P l *)

Inductive sqrt_data (n : nat) : Set
  := sqrt_intro : forall x : nat, x * x <= n -> n <  S x * S x -> sqrt_data n.

Check sqrt_data_ind.
(* sqrt_data_ind : forall (n : nat) (P : sqrt_data n -> Prop),
     (forall (x : nat) (l : x * x <= n) (l0 : n < S x * S x),
             P (sqrt_intro n x l l0))
     -> forall s : sqrt_data n, P s *)

(* 6.5.2 Variably Dependent Inductive Types *)
Inductive htree (X : Type) : nat -> Type
  := hleaf : X -> htree X 0
   | hnode : forall h : nat, X -> htree X h -> htree X h -> htree X (S h).

Arguments hleaf {X} x.
Arguments hnode {X} h x t1 t2.

Check htree_ind.
(* htree_ind : forall (A : Type) (P : forall n : nat, htree A n -> Prop),
     (forall a : A, P 0 (hleaf A a))
     -> (forall (n : nat) (a : A) (h : htree A n),
          P n h -> forall h0 : htree A n,
                     P n h0 -> P (S n) (hnode A n a h h0))
     -> forall (n : nat) (h : htree A n), P n h *)

(* repeat Z_btree definition *)
Open Scope Z_scope.
Inductive Z_btree : Set
  := Z_leaf : Z_btree
   | Z_bnode : Z -> Z_btree -> Z_btree -> Z_btree.

Fixpoint htree_to_btree (n : nat) (t : htree Z n) {struct t} : Z_btree
  := match t with
     | hleaf x => Z_bnode x Z_leaf Z_leaf
     | hnode p v t1 t2
       => Z_bnode v (htree_to_btree p t1) (htree_to_btree p t2)
     end.

Fixpoint invert {A : Type} (n : nat) (t : htree A n) {struct t} : htree A n
  := match t in htree _ x return htree A x with
     | hleaf v => hleaf v
     | hnode p v t1 t2 => hnode p v (invert p t2) (invert p t1)
     end.

(* Exercise 6.46 **
   Prove one of the injection lemmas for the hnode construct: *)
Open Scope nat_scope.
Definition htree_left (X : Type) (n : nat) (t : htree X (S n)) : htree X n
  := match t with
     | hnode n v t1 t2 => t1
     end.

Theorem injection_left_htree (n : nat) (t1 t2 t3 t4 : htree nat n)
   : hnode n O t1 t2 = hnode n O t3 t4 ->  t1 = t3.
Proof.
  intro H. apply (f_equal (htree_left nat n)) in H. apply H.
Qed.

(* authors' solution *)
Definition first_of_htree {A : Type} (n : nat)
  : htree A n -> htree A (S n) -> htree A n.
  intros v t. generalize v.
  change (htree A (pred (S n)) -> htree A (pred (S n))).
  case t.
  - intros x v'. exact v'.
  - intros p x t1 t2 v'. exact t1.
Defined.

Print first_of_htree.
(* first_of_htree : forall (A : Type) (n : nat),
                           htree A n -> htree A (S n) -> htree A n
   = fun (A : Type) (n : nat) (v : htree A n) (t : htree A (S n))
     => (match t in (htree _ n0)
             return (htree A (pred n0) -> htree A (pred n0))
         with
         | hleaf _ _ => fun (v' : htree A (pred 0)) => v'
         | hnode _ p _ t1 _ => fun _ : htree A (pred (S p)) => t1
         end) v *)

Check (first_of_htree 0 (hleaf 1)
                      (hnode 0 2 (hleaf 3) (hleaf 4))).
(* first_of_htree 0 (hleaf 1) (hnode 0 2 (hleaf 3) (hleaf 4))
   : htree nat 0 *)

Compute (first_of_htree 0 (hleaf 1)
                        (hnode 0 2 (hleaf 3) (hleaf 4))).
(* = hleaf 3 : htree nat 0 *)

Theorem injection_first_htree (n : nat) (t1 t2 t3 t4 : htree nat n)
  : hnode n O t1 t2 = hnode n O t3 t4 -> t1 = t3.
Proof.
  intro H.
  change
    (first_of_htree n t1 (hnode n O t1 t2)
     = first_of_htree n t1 (hnode n O t3 t4)).
  now rewrite H.
Qed.

(** Exercise 6.47
   Define a function that takes a number n and builds
   a fixedheight tree of height n containing
   pairwise different -integer- natural values
   (proofs with [nat] is slightly simpler). *)

(* [pn_tree] is for "perfect numbered tree" *)

(* Helper function for [pn_tree]
   * h - height of tree
   * n - value of root of tree
   Nodes numbered like its arryay indexes in ahnentafel tree representaton.
   See [Binary heap implementation](https://en.wikipedia.org/wiki/Binary_heap#Heap_implementation)
 *)
Fixpoint pn_tree_aux (h n : nat) {struct h} : htree nat h
  := match h with
     | O => hleaf n
     | S h' => hnode h' n
                    (pn_tree_aux h' (2*n + 1))
                    (pn_tree_aux h' (2*n + 2))
     end.

Definition pn_tree (h : nat) : htree nat h := pn_tree_aux h 0.

Example pn_tree_ex2
  : pn_tree 2 = hnode 1 0
                      (hnode 0 1 (hleaf 3) (hleaf 4))
                      (hnode 0 2 (hleaf 5) (hleaf 6)).
Proof. reflexivity. Qed.

Example pn_tree_ex3
  : pn_tree 3
    = hnode 2 0
            (hnode 1 1
                   (hnode 0 3 (hleaf 7) (hleaf 8))
                   (hnode 0 4 (hleaf 9) (hleaf 10)))
            (hnode 1 2
                   (hnode 0 5 (hleaf 11) (hleaf 12))
                   (hnode 0 6 (hleaf 13) (hleaf 14))).
Proof. reflexivity. Qed.

(** authors' solution (with Z replaced by [nat])*)
Fixpoint make_htree_aux (h start : nat) : nat * htree nat h
  := match h with
     | 0 => (start + 1, hleaf start)
     | S h' => let (start2, t1) := make_htree_aux h' (start + 1) in
              let (next, t2) := make_htree_aux h' start2 in
              (next, hnode h' start t1 t2)
     end.

Definition make_htree (n : nat) : htree nat n := snd (make_htree_aux n 0).

Example make_htree_ex3
  : make_htree 3
    = hnode 2 0
            (hnode 1 1
                   (hnode 0 2 (hleaf 3) (hleaf 4))
                   (hnode 0 5 (hleaf 6) (hleaf 7)))
            (hnode 1 8
                   (hnode 0 9 (hleaf 10) (hleaf 11))
                   (hnode 0 12 (hleaf 13) (hleaf 14))).
Proof. reflexivity. Qed.

(** my proof of some properties *)

(* get range of natural numbers
   from n0 (inclusive) to n (exclusive) *)
Fixpoint range (n0 n : nat) : list nat
  := match n with
     | O => []
     | S n' => n0 :: range (S n0) n'
     end.

Example range_ex1 : range 0 4 = [0; 1; 2; 3].
Proof. reflexivity. Qed.

(* list htree elements DFS *)
Fixpoint flat_htree_dfs {X : Type} {h : nat} (t : htree X h)
         {struct t} : list X
  := match t with
     | hleaf x => [x]
     | hnode h' x t1 t2 => x :: (flat_htree_dfs t1) ++ (flat_htree_dfs t2)
     end.

Compute flat_htree_dfs (pn_tree 3).
(* = [0; 1; 3; 7; 8; 4; 9; 10; 2; 5; 11; 12; 6; 13; 14] : list nat *)
Compute flat_htree_dfs (make_htree 3).
(* = [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14] : list nat *)
Compute range 0 15.
(* = [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14] : list nat *)

Example flat_htree_dfs_ex3 : flat_htree_dfs (make_htree 3) = range 0 15.
Proof. simpl. reflexivity. Qed.

Definition htree_x {X : Type} {h : nat} (t : htree X h) : X
  := match t with
     | hleaf x => x
     | hnode _ x _ _ => x
     end.

Definition htree_t1 {X : Type} {h : nat} (t : htree X (S h)) : htree X h
  := match t with hnode _ _ t1 _ => t1 end.

Definition htree_t2 {X : Type} {h : nat} (t : htree X (S h)) : htree X h
  := match t with hnode _ _ _ t2 => t2 end.

(** see "convoy pattern" in http://adam.chlipala.net/cpdt/html/MoreDep.html *)
(** illustration on simple example: *)
(*
Definition convoy_test_err (n : nat) (t : htree Z n) : htree Z (pred n)
  := match n with
     | O => t
     | S n' => htree_t1 n' t
     end t.
*)

(* Toplevel input, characters 131-132: *)
(* > Definition convoy_test_err (n : nat) (t : htree Z n) : htree Z (pred n)   := match n with      | O => t      | S n' => htree_t1 n' t      end t. *)
(* >                                                                                ^ *)
(* Error: *)
(* In environment *)
(* n : nat *)
(* t : htree Z n *)
(* n' : nat *)
(* The term "t" has type "htree Z n" while it is expected to have type *)
(*  "htree Z (S n')" (cannot unify "n" and "S n'"). *)

Definition convoy_test_ok (n : nat) (t : htree Z n) : htree Z (pred n)
  := match n return htree Z n -> htree Z (pred n) with
     | O => fun t => t
     | S n' => fun t => htree_t1 t
     end t.

(* It is bad example because "convoy" and even match "in" clause
   is not nececarry *)
Definition convoy_test_no_convoy (n : nat) (t : htree Z n) : htree Z (pred n)
  := match t with
     | hleaf x => hleaf x
     | hnode h x t1 t2 => t1
     end.

(** list htree elements BFS *)
Definition flat_htree_bfs_aux1 {X : Type}
           (h : nat) (t : htree X (S h)) (acc : list (htree X h))
  := (htree_t1 t) :: (htree_t2 t) :: acc.

Fixpoint flat_htree_bfs_aux {X : Type} {h : nat}
         (q : list (htree X h)) {struct h}
  : list X
  := match h return list (htree X h) -> list X with
     | O => fun Q => map htree_x Q
     | S h' => fun Q => let q' := fold_right (flat_htree_bfs_aux1 h') [] Q in
                    let cur_layer := map htree_x Q in
                    let next_layers := (flat_htree_bfs_aux q') in
                    cur_layer ++ next_layers
     end q.

Print flat_htree_bfs_aux.

Definition flat_htree_bfs {X : Type} {h : nat} (t : htree X h) : list X
  := @flat_htree_bfs_aux X h [t].

Compute flat_htree_bfs (pn_tree 1).
(* = [0; 1; 2] : list nat *)

Compute pn_tree 2.
(* = hnode 1 0 (hnode 0 1 (hleaf 3) (hleaf 4))
               (hnode 0 2 (hleaf 5) (hleaf 6))
   : htree nat 2 *)

Compute flat_htree_bfs (pn_tree 2).
(* = [0; 1; 2; 3; 4; 5; 6] : list nat *)

Compute flat_htree_bfs (pn_tree 3).
(* = [0; 1; 2; 3; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14] : list nat *)

Example flat_htree_bfs_ex3 : flat_htree_bfs (pn_tree 3) = range 0 15.
Proof. reflexivity. Qed.

Fixpoint In_htree {X : Type} {h : nat} (y : X) (t : htree X h) {struct t} : Prop
  := match t with
     | hleaf x => x = y
     | hnode h x t1 t2 => x = y \/ In_htree y t1 \/ In_htree y t2
     end.

(* htree is pairwise different *)
Fixpoint htree_is_pwdiff {X : Type} {h : nat} (t : htree X h) {struct t} : Prop
  := match t with
     | hleaf x => True
     | hnode h' x t1 t2
       => htree_is_pwdiff t1 /\ htree_is_pwdiff t2
         /\ (forall y : X, In_htree y t1 -> y <> x)
         /\ (forall y : X, In_htree y t2 -> y <> x)
         /\ (forall y1 y2 : X, In_htree y1 t1 -> In_htree y2 t2 -> y1 <> y2)
     end.

Theorem not_in_tree_iff {X : Type} (x : X) (h : nat) (t : htree X h)
  : (forall y : X, In_htree y t -> y <> x) <-> ~ In_htree x t.
Proof.
  split; intro H.
  - intro H1. apply H in H1. apply H1. reflexivity.
  - intros y H1 eq. subst y. apply H, H1.
Qed.

Theorem not_in_pn_tree_aux (h n k : nat)
  : n < k -> ~ In_htree n (pn_tree_aux h k).
Proof.
  generalize dependent k.
  induction h as [| h1 IH]; simpl; try lia.
  intros k k_gt [H | [H | H]]; try lia.
  - apply (IH (k + (k + 0) + 1)); [lia | apply H].
  - apply (IH (k + (k + 0) + 2)); [lia | apply H].
Qed.

Theorem pn_tree_contains_left_branch (h n y : nat)
  : In_htree y (pn_tree_aux h (2 * n + 1))
    -> In_htree y (pn_tree_aux (S h) n).
Proof.
  intro H. simpl. right. left. exact H.
Qed.

Theorem pn_tree_contains_right_branch (h n y : nat)
  : In_htree y (pn_tree_aux h (2 * n + 2))
    -> In_htree y (pn_tree_aux (S h) n).
Proof.
  intro H. simpl. right. right. exact H.
Qed.

Theorem pn_tree_max (h n y : nat)
  : In_htree y (pn_tree_aux h n) -> y <= 2^h * (n + 2) - 2.
Proof.
  generalize dependent n.
  induction h as [| h1 IH]; intros n H.
  - simpl in *. lia.
  - destruct h1 as [| h2];
      [|remember (S h2) as h1 eqn:eq_h1];
      simpl in H;
      replace (n + (n + 0)) with (2*n) in H by lia;
      destruct H as [H | [H | H]];
      try (subst y; simpl; lia).
    + subst n. rewrite Nat.pow_succ_r'.
      rewrite <- Nat.mul_assoc.
      rewrite <- Nat.mul_pred_r.
      rewrite <- Nat.double_twice. unfold Nat.double.
      apply le_plus_trans, Nat.lt_le_pred.
      rewrite <- (Nat.mul_1_l y) at 1.
      apply Nat.mul_lt_mono; [|lia].
      apply Nat.pow_gt_1; lia.
    + apply IH in H. simpl in *. lia.
    + apply IH in H. simpl in *. lia.
Qed.

Theorem pn_tree_in_Sh' (h n y : nat)
  : In_htree y (pn_tree_aux (S h) n)
    -> In_htree y (pn_tree_aux h n)
      \/ (2^(S h) * (n + 1) - 1) <= y.
Proof.
  generalize dependent n.
  induction h as [| h' IH]; intros n H.
  - simpl in *. lia.
  - remember (S h') as h eqn:eq_h. simpl in H.
    replace (n + (n + 0)) with (2*n) in H by lia.
    destruct H as [H | [H | H]].
    + left. subst h n. simpl. left. reflexivity.
    + apply IH in H. destruct H as [H | H].
      * left. subst h. apply pn_tree_contains_left_branch, H.
      * subst h. right. simpl in *. lia.
    + apply IH in H. destruct H as [H | H].
      * left. subst h. apply pn_tree_contains_right_branch, H.
      * subst h. right. simpl in *. lia.
Qed.

Theorem pn_tree_in_Sh (h n y : nat)
  : In_htree y (pn_tree_aux (S h) n)
    -> In_htree y (pn_tree_aux h n)
      \/ (2^(S h) * (n + 1) - 1) <= y <= 2^(S h) * (n + 2) - 2.
Proof.
  intro H. apply pn_tree_in_Sh' in H as H'.
  destruct H' as [H' | H'].
  - left. assumption.
  - right. split.
    + assumption.
    + apply pn_tree_max in H. lia.
Qed.

Theorem pow_ge_1 (n m : nat) : 1 <= n -> 1 <= n ^ m.
Proof. intro H. induction m as [| m' IH]; simpl; lia. Qed.

Lemma le_sub (a b c : nat) : b <= a -> c <= a -> a - b <= a - c -> c <= b.
Proof.
  intros H1 H2 H.
  apply (Nat.le_sub_le_add_r _ _ b) in H.
  rewrite <- Nat.add_sub_swap in H; [|exact H2].
  apply (plus_le_compat_r _ _ c) in H.
  rewrite <- Nat.add_sub_swap in H; [|lia].
  rewrite Nat.add_sub in H.
  apply (Nat.add_le_mono_l c b a), H.
Qed.

Lemma le_sub2 (a b c d : nat)
  : b <= a -> d <= c -> a - b <= c - d -> a + d <= c + b.
Proof.
  intros H1 H2 H.
  apply (Nat.le_sub_le_add_r _ _ b) in H.
  rewrite <- Nat.add_sub_swap in H; [|exact H2].
  apply (plus_le_compat_r _ _ d) in H.
  rewrite <- Nat.add_sub_swap in H; [|lia].
  rewrite Nat.add_sub in H. exact H.
Qed.

Theorem pow_ge (a b c : nat) : 0 < a <= c -> a <= a ^ b * c.
Proof.
  intros [a_gt a_lt]. rewrite <- (Nat.mul_1_l a) at 1.
  apply Nat.mul_le_mono; [|lia].
  apply pow_ge_1. lia.
Qed.

Theorem pn_tree_last_layer (h n y : nat)
  : (2^h * (n + 1) - 1) <= y <= 2^h * (n + 2) - 2
    -> In_htree y (pn_tree_aux h n).
Proof.
  generalize dependent n.
  induction h as [| h1 IH]; intros n [y_gt y_lt].
  - simpl in *. lia.
  - pose (IH (2*n + 1)) as H1.
    pose (IH (2*n + 2)) as H2.
    destruct (y <=? 2 ^ h1 * (2 * n + 1 + 2) - 2) eqn:neq.
    + apply Nat.leb_le in neq.
      apply pn_tree_contains_left_branch, H1.
      simpl in y_gt. split; lia.
    + apply Nat.leb_gt in neq. unfold lt in neq.
      rewrite <- Nat.add_1_r in neq.
      rewrite <- Nat.add_sub_swap in neq.
      2:{ apply pow_ge. lia. }
      apply pn_tree_contains_right_branch, H2.
      simpl in y_lt. split; lia.
Qed.

Theorem pn_tree_branches_is_diff (h n y : nat)
  : In_htree y (pn_tree_aux h (2*n + 1))
    -> ~ In_htree y (pn_tree_aux h (2*n + 2)).
Proof.
  generalize dependent n.
  induction h as [| h1 IH]; [simpl; lia|].
  intros n H1 H2.
  apply pn_tree_in_Sh in H1.
  apply pn_tree_in_Sh in H2.
  destruct H1 as [H1 | H1]; destruct H2 as [H2 | H2].
  - apply (IH n H1 H2).
  - apply pn_tree_max in H1. destruct H2 as [y_gt y_lt].
    pose (Nat.le_trans _ y _ y_gt H1) as H.
    replace (2 * n + 2 + 1) with (2 * n + 1 + 2) in H by lia.
    rewrite Nat.pow_succ_r' in H.
    assert (2 <= 2 ^ h1 * (2 * n + 1 + 2)) as Hgt.
    { apply pow_ge. lia. }
    apply le_sub2 in H; lia.
  - apply pn_tree_max in H2. destruct H1 as [y_gt y_lt].
    pose (Nat.le_trans _ y _ y_gt H2) as H.
    replace (2 * n + 1 + 1) with (2 * n + 2) in H by lia.
    rewrite Nat.pow_succ_r' in H.
    assert (2 <= 2 ^ h1 * (2 * n + 1 + 2)) as Hgt.
    { apply pow_ge. lia. }
    apply le_sub2 in H; lia.
  - destruct H1 as [_ y_lt]. destruct H2 as [y_gt _].
    pose (Nat.le_trans _ y _ y_gt y_lt) as H.
    replace (2 * n + 2 + 1) with (2 * n + 1 + 2) in H by lia.
    rewrite Nat.pow_succ_r' in H.
    assert (2 <= 2 ^ h1 * (2 * n + 1 + 2)) as Hgt.
    { apply pow_ge. lia. }
    apply le_sub2 in H; lia.
Qed.

Theorem pn_tree_aux_is_pwdiff (h n : nat) : htree_is_pwdiff (pn_tree_aux h n).
Proof.
  generalize dependent n.
  induction h as [| h' IH]; [reflexivity|].
  intro n. simpl. repeat split; try apply IH.
  - apply not_in_tree_iff, not_in_pn_tree_aux. lia.
  - apply not_in_tree_iff, not_in_pn_tree_aux. lia.
  - intros y1 y2 H1 H2. apply not_eq_sym.
    generalize dependent H2.
    generalize dependent y2.
    rewrite (not_in_tree_iff y1).
    apply pn_tree_branches_is_diff, H1.
Qed.

Theorem pn_tree_is_pwdiff (h : nat) : htree_is_pwdiff (pn_tree h).
Proof. apply pn_tree_aux_is_pwdiff. Qed.

Theorem make_htree_aux_fst_eq (h n : nat)
  : fst (make_htree_aux h n) = (n + 2^(S h) - 1).
Proof.
  generalize dependent n.
  induction h as [| h1 IH]; [simpl; lia|].
  intro n. simpl make_htree_aux.
  destruct (make_htree_aux h1 (n + 1)) as (start2, t1) eqn:eq1.
  destruct (make_htree_aux h1 start2) as (next, t2) eqn:eq2.
  simpl fst.
  apply (f_equal fst) in eq1 as eq_start2. simpl in eq_start2.
  apply (f_equal fst) in eq2 as eq_next. simpl in eq_next.
  rewrite IH in eq_next, eq_start2.
  rewrite <- eq_next, <- eq_start2.
  remember (S h1) as h eqn:eq_h. rewrite Nat.pow_succ_r'.
  replace (n + 1 + 2^h - 1 + 2^h - 1) with (n + (2 * 2^h + 1) - 2) by lia.
  rewrite <- Nat.add_sub_assoc.
  replace (2 * 2 ^ h + 1 - 2) with (2 * 2 ^ h - 1); try lia.
  - rewrite Nat.add_sub_assoc; [lia|].
    rewrite <- Nat.pow_succ_r'. apply pow_ge_1. lia.
  - apply le_plus_trans. rewrite Nat.mul_comm. apply pow_ge. lia.
Qed.

Theorem make_htree_start_lt_next (h n : nat)
  : n < fst (make_htree_aux h n).
Proof.
  rewrite make_htree_aux_fst_eq.
  rewrite <- Nat.add_sub_assoc.
  - rewrite plus_n_O at 1. apply plus_le_lt_compat; [lia|].
    pose (Nat.pow_gt_1 2 (S h)) as neq. lia.
  - apply pow_ge_1. lia.
Qed.

Theorem make_htree_bounds (h n y : nat)
  : In_htree y (snd (make_htree_aux h n))
    <-> n <= y < fst (make_htree_aux h n).
Proof.
  generalize dependent n.
  generalize dependent y.
  induction h as [| h1 IH]; [simpl; lia|]. simpl. intros y n.
  destruct (make_htree_aux h1 (n + 1)) as (start2, t1) eqn:eq1.
  destruct (make_htree_aux h1 start2) as (next, t2) eqn:eq2.
  apply (f_equal fst) in eq1 as eq_start2. simpl in eq_start2.
  apply (f_equal fst) in eq2 as eq_next. simpl in eq_next.
  apply (f_equal snd) in eq1 as eq_t1. simpl in eq_t1.
  apply (f_equal snd) in eq2 as eq_t2. simpl in eq_t2.
  simpl. split; intro H.
  - assert (n + 1 < start2) as neq1.
    { subst start2. apply make_htree_start_lt_next. }
    assert (start2 < next) as neq2.
    { subst next. apply make_htree_start_lt_next. }
    destruct H as [H | [H | H]].
    + subst n. split; lia.
    + rewrite <- eq_t1 in H. apply IH in H. rewrite eq_start2 in H. lia.
    + rewrite <- eq_t2 in H. apply IH in H. rewrite eq_next in H. lia.
  - destruct H as [y_ge_n y_lt_next].
    apply le_lt_or_eq in y_ge_n. destruct y_ge_n as [y_gt_n | y_eq_n].
    2:{ subst n. now left. }
    right.
    destruct (le_lt_dec start2 y) as [y_gt_s2 | y_lt_s2].
    + right. rewrite <- eq_t2. apply IH. lia.
    + left. rewrite <- eq_t1. apply IH. lia.
Qed.

Theorem make_htree_aux_is_pwdiff (h n : nat)
  : htree_is_pwdiff (snd (make_htree_aux h n)).
Proof.
  generalize dependent n.
  induction h as [| h1 IH]; intro n; [reflexivity|].
  simpl.
  destruct (make_htree_aux h1 (n + 1)) as (start2, t1) eqn:eq1.
  destruct (make_htree_aux h1 start2) as (next, t2) eqn:eq2.
  apply (f_equal fst) in eq1 as eq_start2. simpl in eq_start2.
  apply (f_equal fst) in eq2 as eq_next. simpl in eq_next.
  apply (f_equal snd) in eq1 as eq_t1. simpl in eq_t1.
  apply (f_equal snd) in eq2 as eq_t2. simpl in eq_t2.
  simpl. repeat split.
  - rewrite <- eq_t1. apply (IH (n + 1)).
  - rewrite <- eq_t2. apply (IH start2).
  - intros y H eq. subst y. rewrite <- eq_t1 in H.
    apply make_htree_bounds in H. lia.
  - intros y H eq. subst y. rewrite <- eq_t2 in H.
    apply make_htree_bounds in H.
    pose (make_htree_start_lt_next h1 (n + 1)) as neq. lia.
  - intros y1 y2 H1 H2 eq.
    rewrite <- eq_t1 in H1. rewrite <- eq_t2 in H2.
    apply make_htree_bounds in H1, H2.
    rewrite eq_start2 in H1. rewrite eq_next in H2. lia.
Qed.

Theorem make_htree_is_pwdiff (h : nat) : htree_is_pwdiff (make_htree h).
Proof. apply make_htree_aux_is_pwdiff. Qed.

Theorem range_cons (n m : nat) : n :: range (S n) m = range n (S m).
Proof. reflexivity. Qed.

Theorem range_app (n1 n2 m1 m2 : nat)
  : n2 = n1 + m1 -> range n1 m1 ++ range n2 m2 = range n1 (m1 + m2).
Proof.
  generalize dependent n2.
  generalize dependent n1.
  induction m1 as [| m1' IH]; intros n1 n2 eq.
  - simpl. subst n2. rewrite Nat.add_0_r. reflexivity.
  - simpl. rewrite (IH (S n1) n2); [reflexivity | lia].
Qed.

Theorem fold_double (n : nat) : n + (n + 0) = 2 * n.
Proof. reflexivity. Qed.

Theorem flat_make_htree_aux_is_range (h n : nat)
  : flat_htree_dfs (snd (make_htree_aux h n)) = range n (2^(S h) - 1).
Proof.
  generalize dependent n.
  induction h as [| h1 IH]; intro n; [reflexivity|].
  simpl make_htree_aux. rewrite Nat.pow_succ_r'.
  destruct (make_htree_aux h1 (n + 1)) as (start2, t1) eqn:eq1.
  destruct (make_htree_aux h1 start2) as (next, t2) eqn:eq2.
  apply (f_equal fst) in eq1 as eq_start2. simpl in eq_start2.
  apply (f_equal fst) in eq2 as eq_next. simpl in eq_next.
  apply (f_equal snd) in eq1 as eq_t1. simpl in eq_t1.
  apply (f_equal snd) in eq2 as eq_t2. simpl in eq_t2.
  simpl. rewrite <- eq_t1, <- eq_t2. rewrite !IH.
  rewrite fold_double, Nat.add_1_r, range_app, range_cons.
  - apply (f_equal (range n)). rewrite <- Nat.add_1_r.
    rewrite fold_double.
    replace (2^(S h1)) with (2 * 2^h1) by auto with arith.
    replace (2 * 2^h1 + (2 * 2^h1 + 0)) with (4 * 2^h1) by lia.
    replace (2 * 2^h1 - 1 + (2 * 2^h1 - 1)) with (4 * 2^h1 - 2) by lia.
    rewrite <- Nat.add_sub_swap. lia.
    rewrite Nat.mul_comm. apply pow_ge. lia.
  - rewrite <- eq_start2, make_htree_aux_fst_eq.
    rewrite Nat.add_sub_assoc; [| apply pow_ge_1]; lia.
Qed.

Theorem flat_make_htree_is_range (h : nat)
  : flat_htree_dfs (make_htree h) = range 0 (2^(S h) - 1).
Proof. apply flat_make_htree_aux_is_range. Qed.

Theorem cons_eq {X : Type} (x1 x2 : X) (xs1 xs2 : list X)
  : x1 = x2 -> xs1 = xs2 -> x1 :: xs1 = x2 :: xs2.
Proof. intros eq_x eq_xs. subst x2 xs2. reflexivity. Qed.

Theorem flat_htree_bfs_aux_Sh {X : Type} (h : nat)
        (ts : list (htree X (S h)))
  : flat_htree_bfs_aux ts
    = (map htree_x ts)
        ++ flat_htree_bfs_aux (fold_right (flat_htree_bfs_aux1 h) [] ts).
Proof. reflexivity. Qed.

Theorem flat_htree_bfs_aux_Sh_cons {X : Type} (h : nat)
        (t : htree X (S h)) (ts : list (htree X (S h)))
  : flat_htree_bfs_aux (t :: ts)
    = (htree_x t)
        :: (map htree_x ts)
        ++ (flat_htree_bfs_aux
              ((htree_t1 t)
                 :: (htree_t2 t)
                 :: (fold_right (flat_htree_bfs_aux1 h) [] ts))).
Proof. reflexivity. Qed.

Theorem flat_htree_bfs_aux0 {X : Type} (ts : list (htree X 0))
  : flat_htree_bfs_aux ts = map htree_x ts.
Proof. reflexivity. Qed.

Theorem pn_trees_range_x (h n0 m : nat)
  : map htree_x (map (pn_tree_aux h) (range n0 m))
    = range n0 m.
Proof.
  generalize dependent n0.
  induction m as [| m' IH]; [reflexivity|].
  intro n0. simpl. rewrite IH.
  destruct h as [| h']; reflexivity.
Qed.

Theorem pn_trees_range_second_layer (n0 m : nat)
  : map htree_x
        (fold_right (flat_htree_bfs_aux1 0) []
                    (map (pn_tree_aux 1) (range n0 m)))
    = range (2 * n0 + 1) (2 * m).
Proof.
  generalize dependent n0.
  induction m as [| m1 IH]; intro n0; [reflexivity|].
  simpl. rewrite IH. simpl. apply cons_eq; [reflexivity|].
  replace (m1 + S (m1 + 0)) with (S (2 * m1)) by lia. simpl.
  apply cons_eq; [lia|]. f_equal. lia.
Qed.

Theorem flat_htree_bfs_aux_nil (X : Type) (h : nat)
  : @flat_htree_bfs_aux X h [] = [].
Proof.
  induction h as [| h' IH]; [reflexivity|].
  simpl. exact IH.
Qed.

Theorem pn_trees_range_next_layers (h n0 m : nat)
  : fold_right (flat_htree_bfs_aux1 h) []
               (map (pn_tree_aux (S h)) (range n0 m))
    = map (pn_tree_aux h) (range (2 * n0 + 1) (2 * m)).
Proof.
  generalize dependent n0.
  induction m as [| m' IH]; intro n0; [reflexivity|].
  simpl in *. rewrite IH. unfold flat_htree_bfs_aux1. simpl.
  apply cons_eq; [reflexivity|]. rewrite (Nat.add_succ_r m').
  simpl. apply cons_eq.
  - f_equal. lia.
  - f_equal. f_equal. lia.
Qed.

Theorem flat_htree_bfs_aux_pn_tree_Sh_head (h n0 m : nat)
  : flat_htree_bfs_aux (map (pn_tree_aux (S h)) (range n0 m))
    = (range n0 m)
        ++ (flat_htree_bfs_aux (map (pn_tree_aux h)
                                    (range (2 * n0 + 1) (2 * m)))).
Proof.
  rewrite flat_htree_bfs_aux_Sh, pn_trees_range_x. apply app_inv_head_iff.
  rewrite pn_trees_range_next_layers. reflexivity.
Qed.

Theorem flat_htree_bfs_aux_pn_tree_Sh_last (h n0 m : nat)
  : flat_htree_bfs_aux (map (pn_tree_aux (S h)) (range n0 m))
    = (flat_htree_bfs_aux
         (map (pn_tree_aux h) (range n0 m)))
        ++ range (2^(S h) * (n0 + 1) - 1) (m * 2^(S h)).
Proof.
  generalize dependent n0.
  generalize dependent m.
  induction h as [| h1 IH]; intros m n0.
  - rewrite flat_htree_bfs_aux_Sh, !flat_htree_bfs_aux0, !pn_trees_range_x.
    apply app_inv_head_iff. rewrite pn_trees_range_second_layer.
    f_equal; simpl; lia.
  - rewrite flat_htree_bfs_aux_pn_tree_Sh_head, IH.
    rewrite flat_htree_bfs_aux_pn_tree_Sh_head.
    rewrite <- app_assoc. repeat apply app_inv_head_iff.
    f_equal; simpl; try lia.
Qed.

Compute (flat_htree_bfs (pn_tree_aux 1 1)).
(* = [1; 3; 4] : list nat *)
Compute range (2^2 * (1 + 1) - 1) (2^2).
(* = [7; 8; 9; 10] : list nat *)
Compute (flat_htree_bfs (pn_tree_aux 2 1)).
(* = [1; 3; 4; 7; 8; 9; 10] : list nat *)

Theorem flat_pn_tree_Sh (h n : nat)
  : flat_htree_bfs (pn_tree_aux (S h) n)
    = (flat_htree_bfs (pn_tree_aux h n))
        ++ range (2^(S h) * (n + 1) - 1) (2^(S h)).
Proof.
  unfold flat_htree_bfs.
  pose (flat_htree_bfs_aux_pn_tree_Sh_last h n 1) as H.
  simpl in *. rewrite H. rewrite !fold_double.
  apply app_inv_head_iff. f_equal. lia.
Qed.

Theorem flat_pn_tree_is_range (h : nat)
  : flat_htree_bfs (pn_tree h) = range 0 (2^(S h) - 1).
Proof.
  unfold pn_tree. induction h as [| h' IH].
  { unfold flat_htree_bfs. reflexivity. }
  rewrite flat_pn_tree_Sh, IH. rewrite range_app; [|lia].
  remember (S h') as h eqn:eq_h. rewrite Nat.pow_succ_r'.
  f_equal. lia.
Qed.

(* Exercise 6.48 * Define inductively the type [binary_word]
   used in section 4.1.1.2 and define recursively
   the function [binary_word_concat]. *)
Inductive binary_word : nat -> Set
  := BW_empty : binary_word 0
   | BW_cons : forall n : nat, bool -> binary_word n -> binary_word (S n).

Arguments BW_cons {n} _ _.

Fixpoint binary_word_concat {n1 n2 : nat}
         (w1 : binary_word n1) (w2 : binary_word n2)
  : binary_word (n1 + n2)
  := match w1 in binary_word n return binary_word (n + n2) with
     | BW_empty => w2
     | BW_cons b w1' => BW_cons b (binary_word_concat w1' w2)
     end.

Fixpoint bin_list_to_word (bs : list bool) : binary_word (length bs)
  := match bs as x return binary_word (length x) with
     | nil => BW_empty
     | cons b bs' => BW_cons b (bin_list_to_word bs')
     end.

Example binary_word_concat_ex
  : (binary_word_concat (bin_list_to_word [true; false; true])
                        (bin_list_to_word [false; false]))
    = (bin_list_to_word [true; false; true; false; false]).
Proof. reflexivity. Qed.

(* Exercise 6.49 ** Define the function [binary_word_or]
   that computes the bit-wise "or" operation of two words
   of the same length (like the "|" operator in the C language). *)

Definition convert_bw_len (n1 n2 : nat) (H : S n2 = S n1)
           (xs : binary_word n1) : binary_word n2.
apply eq_add_S in H. rewrite H. exact xs.
Defined.

Print convert_bw_len.
(* convert_bw_len =
   fun (n1 n2 : nat) (H : S n2 = S n1) (xs : binary_word n1)
   => let H0 : n2 = n1 := eq_add_S n2 n1 H
      in eq_rec_r (fun n3 : nat => binary_word n3) xs H0
   : forall n1 n2 : nat, S n2 = S n1 -> binary_word n1 -> binary_word n2
 *)

Fixpoint binary_word_or {n : nat} (xs ys : binary_word n) : binary_word n
  := match xs in binary_word m1 return binary_word m1 -> binary_word m1 with
     | BW_empty => fun _ => BW_empty
     | @BW_cons n1 x xs'
       => fun ys : binary_word (S n1)
         => match ys in binary_word m2 return m2 = S n1 -> binary_word m2 with
           | BW_empty => fun _ => BW_empty
           | @BW_cons n2 y ys'
             => fun H => BW_cons (x || y)
                             (binary_word_or
                                (convert_bw_len n1 n2 H xs') ys')
           end (eq_refl (S n1))
     end ys.

Theorem binary_word_or_idempotent (n : nat) (xs : binary_word n)
  : binary_word_or xs xs = xs.
Proof.
  induction xs as [| n' b xs' IH]; [reflexivity|].
  simpl. unfold convert_bw_len. simpl.
  replace (b || b) with b.
  2:{ destruct b; reflexivity. }
  f_equal.
  replace (eq_rec_r (fun n2 : nat => binary_word n2) xs' eq_refl) with xs'.
  2:{ unfold eq_rec_r. reflexivity. }
  apply IH.
Qed.

(* Do the same exercises (last two), but considering vectors *)
Require Import Vector.
Definition bword := t bool.
Definition bw_concat := @append bool.

Fixpoint binary_word_to_bword {n : nat} (w : binary_word n)
         {struct w} : bword n
  := match w with
     | BW_empty => nil bool
     | @BW_cons n' b w' => cons bool b n' (binary_word_to_bword w')
     end.

Fixpoint bword_to_binary_word {n : nat} (w : bword n)
         {struct w} : binary_word n
  := match w with
     | nil _ => BW_empty
     | cons _ b n' w' => @BW_cons n' b (bword_to_binary_word w')
     end.

Theorem binary_word_to_bword_inv (n : nat) (w : binary_word n)
  : bword_to_binary_word (binary_word_to_bword w) = w.
Proof.
  induction w as [| n' b w' IH]; [reflexivity|].
  simpl. rewrite IH. reflexivity.
Qed.

Theorem bword_to_binary_word_inv (n : nat) (w : bword n)
  : binary_word_to_bword (bword_to_binary_word w) = w.
Proof.
  induction w as [| b n' w' IH]; [reflexivity|].
  simpl. rewrite IH. reflexivity.
Qed.

Theorem bw_concat_correct (n1 n2 : nat) (w1 : bword n1) (w2 : bword n2)
  : bw_concat n1 n2 w1 w2
    = binary_word_to_bword
        (binary_word_concat (bword_to_binary_word w1)
                            (bword_to_binary_word w2)).
Proof.
  induction w1 as [| b n1' w1' IH].
  - simpl. rewrite bword_to_binary_word_inv. now unfold bw_concat.
  - simpl. rewrite <- IH. unfold bw_concat. reflexivity.
Qed.

Definition bw_or {n : nat} (w1 w2 : bword n) : bword n
  := map2 orb w1 w2.

Theorem bw_or_correct {n : nat} (w1 w2 : bword n)
  : bw_or w1 w2
    = binary_word_to_bword
        (binary_word_or (bword_to_binary_word w1)
                        (bword_to_binary_word w2)).
Proof.
  unfold bword in *.
  generalize dependent w2.
  generalize dependent w1.
  generalize dependent n.
  apply rect2; [reflexivity|].
  intros n' w1' w2' IH x1 x2. simpl.
  unfold convert_bw_len. simpl.
  unfold eq_rec_r. simpl.
  rewrite <- IH. reflexivity.
Qed.

Theorem bw_or_idempotent (n : nat) (xs : bword n) : bw_or xs xs = xs.
Proof.
  rewrite bw_or_correct, binary_word_or_idempotent.
  now rewrite bword_to_binary_word_inv.
Qed.

(* See also Consider the following definition,
   very similar to Standard Library's definition: *)
Section Vector_definitions.

  Variable X : Type.

  Inductive vector : nat -> Type
    := vnil : vector 0
     | vcons (x : X) (n : nat) (v : vector n) : vector (S n).

  (* Define the functions that return respectively
     the head and the tail of a non-empty vector,
     as direct applications of the recursor vector_rect> *)

  Definition vhd {n : nat} (v : vector (S n)) : X
    := match v in vector m
             return (match m with O => unit | S _ => X end)
       with
       | vnil => tt
       | vcons x n' v' => x
       end.

  Definition vtl {n : nat} (v : vector (S n)) : vector n
    := match v in vector m
             return (match m with O => unit | S m' => vector m' end)
       with
       | vnil => tt
       | vcons x n' v' => v'
       end.

  Definition v_Id (n : nat) : vector n -> vector n
    := match n with
       | 0 => fun v => vnil
       | S p => fun v => vcons (vhd v) p (vtl v)
       end.

  Compute fun v : vector 0 => v_Id 0 v.
  (*   = fun _ : vector 0 => vnil : vector 0 -> vector 0 *)

  Lemma v_Id_eq (n : nat) (v : vector n) : v = v_Id n v.
  Proof using.
    pattern n, v. apply vector_rect.
    - reflexivity.
    - intros. reflexivity.
  Qed.

  Lemma vector0 (v : vector 0) : v = vnil.
  Proof using.
    change vnil with (v_Id 0 v).
    apply v_Id_eq.
  Qed.

  Lemma vector_S (n : nat) (v : vector (S n)) : v = vcons (vhd v) n (vtl v).
  Proof using.
    change (vcons (vhd v) n (vtl v)) with (v_Id (S n) v).
    apply v_Id_eq.
  Qed.
End Vector_definitions.

Arguments vnil {X}.
Arguments vcons {X}.
Arguments vhd {X} {n}.
Arguments vtl {X} {n}.

Example vhd_ex : vhd (vcons 42 0 vnil) = 42.
Proof. reflexivity. Qed.

Example vtl_ex : vtl (vcons 42 1 (vcons 22 0 vnil)) = vcons 22 0 vnil.
Proof. reflexivity. Qed.

(* Exercise 6.50 ** Define a function with a dependent type
   that returns [true] for natural numbers of the form [4*n + 1],
   [false] for numbers of the form [4*n + 3],
   and [n] for numbers of the form [2*n]. *)

Fixpoint dep_fn_type (n : nat) : Set
  := match n with
     | 0 => nat
     | 1 => bool
     | (S (S n')) => dep_fn_type n'
     end.

Fixpoint dep_fn (n : nat) : dep_fn_type n
  := match n with
     | 0 => 0
     | 1 => true
     | 2 => 1
     | 3 => false
     | S (S (S (S n'))) => dep_fn n'
     end.

Example dep_fn_ex6 : dep_fn 6 = 1.
Proof. reflexivity. Qed.

Example dep_fn_ex7 : dep_fn 7 = false.
Proof. reflexivity. Qed.

Example dep_fn_ex9 : dep_fn 9 = true.
Proof. reflexivity. Qed.


Require Import Relation.
Require Import Logic_utils.

Definition partial_ordering {A} (R : Relation A A) : Prop :=
reflexive R /\ antisymmetric R /\ transitive R.

Definition strict_ordering {A} (R : Relation A A) : Prop :=
asymmetric R /\ transitive R.

Definition partial_to_strict {A} (R : Relation A A) : Relation A A :=
fun p => match p with
  | (a, b) => R(a, b) /\ a <> b
end.

Definition strict_to_partial {A} (S: Relation A A) : Relation A A :=
fun p => match p with
  | (a, b) => S(a, b) \/ a = b
end.

Theorem partial_to_strict_returns_strict :
forall (A: Type)(R: Relation A A), partial_ordering R -> strict_ordering (partial_to_strict R).
Proof.
intros. set (S:=partial_to_strict R).
destruct H as [refl anti]. destruct anti as [anti trans].
apply conj.
- intros a b Sab. intros Sba.
  apply Sba in anti. contradiction. apply Sba. apply Sab.
- intros a b c Sab Sbc. apply conj.
  + apply trans with (b:=b). apply Sab. apply Sbc.
  + intros ac. rewrite <- ac in Sbc.
    apply Sab in anti. contradiction. apply Sab. apply Sbc.
Qed.

Theorem strict_to_partial_returns_partial :
forall (A:Type)(S: Relation A A), strict_ordering S -> partial_ordering (strict_to_partial S).
Proof.
intros. set (R:=strict_to_partial S).
destruct H as [asymm trans].
apply conj.
- unfold reflexive. intros. right. reflexivity.
- apply conj.
  + unfold antisymmetric. intros a b Rab Rba.
    destruct Rab as [Sab|eq1]. destruct Rba as [Sba|eq2].
    * apply asymm in Sba. contradiction.
    * rewrite eq2. reflexivity.
    * rewrite eq1. reflexivity.
  + unfold transitive. intros a b c Rab Rbc.
    destruct Rab as [Sab|eq1]. destruct Rbc as [Sbc|eq2].
    * left. apply trans with (b:=b). apply Sab. apply Sbc.
    * left. rewrite <- eq2. apply Sab.
    * rewrite eq1. apply Rbc.
Qed.

Definition total_partial_ordering {A} (R : Relation A A) : Prop :=
  partial_ordering R /\ forall (a b : A), R(a, b) \/ R(b, a).

Definition total_strict_ordering {A} (S : Relation A A) : Prop :=
  strict_ordering S /\ forall (a b : A), S(a, b) \/ S(b, a) \/ a = b.

Theorem partial_to_strict_preserves_totality :
forall (A: Type)(R : Relation A A),
total_partial_ordering R -> total_strict_ordering (partial_to_strict R).
Proof.
intros. set (S:=partial_to_strict R).
destruct H as [partialR totalR].
apply conj.
- apply partial_to_strict_returns_strict. apply partialR.
- intros.
  assert (eq : (a=b) \/ (a <> b)).
  { apply law_of_excluded_middle. }
  destruct (totalR a b) as [Rab|Rba].
  + destruct eq as [eq|neq].
    * right. right. apply eq.
    * left. apply conj. apply Rab. apply neq.
  + destruct eq as [eq|neq].
    * right. right. apply eq.
    * right. left. apply conj. apply Rba. apply (neq_comm A). apply neq.
Qed.

Theorem struct_to_partial_preserves_totality :
forall (A: Type)(S : Relation A A),
total_strict_ordering S -> total_partial_ordering (strict_to_partial S).
Proof.
intros. set (R:=strict_to_partial S).
destruct H as [strictS totalS].
apply conj.
- apply strict_to_partial_returns_partial. apply strictS.
- intros. destruct (totalS a b) as [Sab|Rba].
  + left. left. apply Sab.
  + destruct Rba as [Sba|eq].
    * right. left. apply Sba.
    * left. right. apply eq.
Qed.

Theorem strict_to_partial_to_strict_identity :
forall (A: Type)(S : Relation A A),
strict_ordering S -> partial_to_strict (strict_to_partial S) = S.
Proof.
intros. set (R:= strict_to_partial S). set (S':= partial_to_strict R).
apply Relation_eq. intros.
unfold iff. apply conj.
- intros S'ab. apply reduce_or_P_and_notP in S'ab. apply S'ab.
- intros Sab. apply conj.
  + left. apply Sab.
  + destruct H as [asymm trans]. intros eq. destruct (asymm a b).
    * apply Sab.
    * rewrite eq. rewrite eq in Sab. apply Sab.
Qed.

Theorem partial_to_strict_to_partial_identity :
forall (A: Type)(R : Relation A A),
partial_ordering R -> strict_to_partial (partial_to_strict R) = R.
Proof.
intros. set (S:= partial_to_strict R). set (R':= strict_to_partial S).
apply Relation_eq. intros.
unfold iff. apply conj.
- intros R'ab. inversion R'ab.
  + apply H0.
  + destruct H as [refl _]. rewrite H0. apply refl.
- intros Rab.
  assert (eq: (a=b) \/ (a<>b)).
  { apply law_of_excluded_middle. }
  destruct eq as [eq|neq].
  + right. apply eq.
  + left. split. apply Rab. apply neq.
Qed.


Require Export Induction.

Module NatList.

Inductive natprod : Type :=
  | pair : nat -> nat -> natprod.

Check (pair 3 5).

Definition fst (p : natprod) : nat :=
  match p with
  | pair x y => x
  end.

Definition snd (p : natprod) : nat :=
  match p with
  | pair x y => y
  end.

Compute (fst (pair 3 5)).

Notation "( x , y )" := (pair x y).

Compute (fst (3,5)).

Definition fst' (p : natprod) : nat :=
  match p with
  | (x,y) => x
  end.

Definition snd' (p : natprod) : nat :=
  match p with
  | (x,y) => y
  end.

Definition swap_pair (p : natprod) : natprod :=
  match p with
  | (x,y) => (y,x)
  end.

Theorem surjective_pairing' : forall (n m : nat),
  (n,m) = (fst (n,m), snd (n,m)).
Proof.
  reflexivity. Qed.

Theorem surjective_pairing_stuck : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  simpl.
Abort.

Theorem surjective_pairing : forall (p : natprod),
  p = (fst p, snd p).
Proof.
  intros p. destruct p as [n m]. simpl. reflexivity. Qed.

Theorem snd_fst_is_swap : forall (p : natprod),
  (snd p, fst p) = swap_pair p.
Proof.
  intros p.
  destruct p as [n m]. simpl. reflexivity.
Qed.

Theorem fst_swap_is_snd : forall (p : natprod),
  fst (swap_pair p) = snd p.
Proof.
  intros p.
  destruct p as [n m]. simpl. reflexivity. Qed.

Inductive natlist : Type :=
  | nil : natlist
  | cons : nat -> natlist -> natlist.

Definition mylist := cons 1 (cons 2 (cons 3 nil)).

Notation "x :: l" := (cons x l) (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Fixpoint repeat (n count : nat) : natlist :=
  match count with
  | O => nil
  | S count' => n :: (repeat n count')
  end.

Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => O
  | h :: t => S (length t)
  end.

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).

Example test_app1: [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity. Qed.

Definition hd (default : nat) (l : natlist) : nat :=
  match l with
  | nil => default
  | h :: t => h
  end.

Definition tl (l : natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.

Example test_hd1: hd 0 [1;2;3] = 1.
Proof. reflexivity. Qed.

Fixpoint oddmembers (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => match evenb h with
              | true => oddmembers t
              | false => h :: oddmembers t
              end
  end.

Example test_oddmembers:
  oddmembers [0;1;0;2;3;0;0] = [1;3].
Proof. reflexivity. Qed.

Definition countoddmembers (l:natlist) : nat :=
  length (oddmembers l).

Example test_countoddmembers1:
  countoddmembers [1;0;3;1;4;5] = 4.
Proof. reflexivity. Qed.
Example test_countoddmembers2:
  countoddmembers [0;2;4] = 0.
Proof. reflexivity. Qed.
Example test_countoddmembers3:
  countoddmembers nil = 0.
Proof. reflexivity. Qed.

Fixpoint alternate (l1 l2 : natlist) : natlist :=
 match l1 with
 | nil => l2
 | h :: t => match l2 with
             | nil => h :: t
             | h2 :: t2 => h :: h2 :: alternate t t2
             end
 end.

Example test_alternate2:
  alternate [1] [4;5;6] = [1;4;5;6].
Proof. reflexivity. Qed.

Example test_alternate1:
  alternate [1;2;3] [4;5;6] = [1;4;2;5;3;6].
Proof. reflexivity. Qed.

Example test_alternate3:
  alternate [1;2;3] [4] = [1;4;2;3].
Proof. reflexivity. Qed.

Example test_alternate4:
  alternate [] [20;30] = [20;30].
Proof. reflexivity. Qed.

Definition bag := natlist.

Fixpoint beq_nat (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' => beq_nat n' m'
            end
  end.

Theorem beq_nat_same_eq : forall n : nat,
  beq_nat n n = true.
Proof.
  intros n. induction n as [| n' IHn'].
  - reflexivity.
  - simpl. rewrite <- IHn'. reflexivity.
Qed.

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

Example test_count1: count 1 [1;2;3;1;4;1] = 3.
Proof. reflexivity. Qed.
Example test_count2: count 6 [1;2;3;1;4;1] = 0.
Proof. reflexivity. Qed.

Definition sum : bag -> bag -> bag := app.

Example test_sum1: count 1 (sum [1;2;3] [1;4;1]) = 3.
Proof. reflexivity. Qed.

Definition add (v:nat) (s:bag) : bag :=
  match s with
  | nil => [v]
  | ht => v :: ht
  end.

Example test_add1: count 1 (add 1 [1;4;1]) = 3.
Proof. reflexivity. Qed.

Example test_add2: count 5 (add 1 [1;4;1]) = 0.
Proof. reflexivity. Qed.

Definition member (v:nat) (s:bag) : bool :=
  match count v s with
  | 0 => false
  | _ => true
  end.

Example test_member1: member 1 [1;4;1] = true.
Proof. reflexivity. Qed.
Example test_member2: member 2 [1;4;1] = false.
Proof. reflexivity. Qed.

Fixpoint remove_one (v:nat) (s:bag) : bag :=
  match s with
  | nil => nil
  | h :: t => match beq_nat h v with
              | false => h :: remove_one v t
              | true => t
              end
  end.

Example test_remove_one1:
  count 5 (remove_one 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_one2:
  count 5 (remove_one 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_one3:
  count 4 (remove_one 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.
Example test_remove_one4:
  count 5 (remove_one 5 [2;1;5;4;5;1;4]) = 1.
Proof. simpl. reflexivity. Qed.

Fixpoint subset (s1:bag) (s2:bag) : bool :=
  match s1 with
  | nil => true
  | h :: t => match member h s2 with
              | false => false
              | true => subset t (remove_one h s2)
              end
  end.

Example test_subset1: subset [1;2] [2;1;4;1] = true.
Proof. simpl. reflexivity. Qed.
Example test_subset2: subset [1;2;2] [2;1;4;1] = false.
Proof. simpl. reflexivity. Qed.

Theorem add_increase_len : forall n : nat, forall b : bag,
  length (add n b) = S (length b).
Proof.
  intros n b.
  induction b as [| b' IHl'].
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Theorem add_bag_count_succ:
  forall n : nat, forall b : bag,
  count n (add n b) = S (count n b).
Proof.
  intros n b.
  induction b as [| b' IHn'].
  - simpl. rewrite -> beq_nat_same_eq. reflexivity.
  - simpl. rewrite -> beq_nat_same_eq. reflexivity.
Qed.

Theorem add_bag_count_same_if_eq:
  forall n m l: nat, forall b : bag,
  n = m -> (count l (add n b) = count l (add m b)).
Proof.
  intros n m l b IHn. rewrite <- IHn. reflexivity. Qed.

Theorem app_assoc: forall l1 l2 l3 : natlist,
  (l1 ++ l2) ++ l3 = l1 ++ (l2 ++ l3).
Proof.
  intros l1 l2 l3. induction l1 as [| n l1' IHl1'].
  - simpl. reflexivity.
  - simpl. rewrite <- IHl1'. reflexivity. Qed.

Fixpoint rev (l : natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => rev t ++ [h]
  end.

Example test_rev1: rev [1;2;3] = [3;2;1].
Proof. reflexivity. Qed.
Example test_rev2: rev nil = nil.
Proof. reflexivity. Qed.

Theorem rev_length_firsttry : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - reflexivity.
  - simpl. rewrite <- IHl'.
Abort.

Theorem app_length : forall l1 l2 : natlist,
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  intros l1 l2. induction l1 as [| n l1' IHl1'].
  - reflexivity.
  - simpl. rewrite -> IHl1'. reflexivity. Qed.

Theorem rev_length : forall l : natlist,
  length (rev l) = length l.
Proof.
  intros l. induction l as [| n l' IHl'].
  - reflexivity.
  - simpl. rewrite -> app_length. rewrite -> plus_comm.
    simpl. rewrite -> IHl'. reflexivity. Qed.

Search natlist.

Theorem app_nil_r : forall l : natlist,
  l ++ [] = l.
Proof.
  intros l. induction l as [| l' c IHn'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHn'. reflexivity.
Qed.

Search natlist.

Theorem rev_app_distr : forall l1 l2 : natlist,
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros l1 l2. induction l1 as [| l1' c IHn'].
  - simpl. rewrite -> app_nil_r. reflexivity.
  - simpl. rewrite -> IHn'. rewrite <- app_assoc. reflexivity.
Qed.

Search rev.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intros l. induction l as [| l' c IHn'].
  - simpl. reflexivity.
  - simpl. rewrite -> rev_app_distr. simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
  intros l1 l2 l3 l4.
  rewrite -> app_assoc. rewrite -> app_assoc. reflexivity.
Qed.

Search "++".

Fixpoint nonzeros (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => match h with
              | 0 => nonzeros t
              | _ => h :: nonzeros t
              end
  end.

Example test_nonzeros:
  nonzeros [0;1;0;2;3;0;0] = [1;2;3].

Proof. reflexivity. Qed.
Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
  intros l1 l2.
  simpl. induction l1 as [| l1' c IHn'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHn'. destruct l1'.
    + reflexivity.
    + reflexivity.
Qed.

Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
  match l1 with
  | nil => match l2 with
           | nil => true
           | h :: t => false
           end
  | h :: t => match l2 with
              | h' :: t' => match beq_nat h h' with
                            | true => beq_natlist t t'
                            | false => false
                            end
              | nil => false
              end
  end.

Search beq_nat.

Example test_beq_natlist1 :
  (beq_natlist nil nil = true).
Proof. reflexivity. Qed.
Example test_beq_natlist2 :
  beq_natlist [1;2;3] [1;2;3] = true.
Proof. reflexivity. Qed.
Example test_beq_natlist3 :
  beq_natlist [1;2;3] [1;2;4] = false.
Proof. reflexivity. Qed.
Theorem beq_natlist_refl : forall l:natlist,
  true = beq_natlist l l.
Proof.
  intros l. induction l as [| l' c IHn'].
  - reflexivity.
  - simpl. rewrite -> beq_nat_same_eq. rewrite -> IHn'. reflexivity.
Qed.

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.

Theorem count_member_nonzero : forall (s : bag),
  leb 1 (count 1 (1 :: s)) = true.
Proof.
  intros s. simpl. reflexivity. Qed.

Theorem ble_n_Sn : forall n,
  leb n (S n) = true.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* 0 *)
    simpl. reflexivity.
  - (* S n' *)
    simpl. rewrite IHn'. reflexivity. Qed.

Theorem remove_decreases_count: forall (s : bag),
  leb (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
  intros s. induction s as [|s' c IHn'].
  - reflexivity.
  - destruct s'.
    + simpl. rewrite -> ble_n_Sn. reflexivity.
    + simpl. rewrite -> IHn'. reflexivity.
Qed.

Search sum.

Theorem bag_count_sum : forall (s1 s2: bag) (n :nat),
  count n s1 = count n (sum s1 []).
Proof.
  intros s1 s2 n.
  unfold sum. rewrite app_nil_r. reflexivity.
Qed.

Search rev.

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

Inductive natoption : Type :=
  | Some : nat -> natoption
  | None : natoption.

Fixpoint nth_error (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => match beq_nat n O with
               | true => Some a
               | false => nth_error l' (pred n)
               end
  end.

Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [4;5;6;7] 3 = Some 7.
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [4;5;6;7] 9 = None.
Proof. reflexivity. Qed.

Fixpoint nth_error' (l :natlist) (n : nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => if beq_nat n O then Some a
                else nth_error' l' (pred n)
  end.

Definition option_elim (d : nat) (o : natoption) : nat :=
  match o with
  | Some n' => n'
  | None => d
  end.

Definition hd_error (l : natlist) : natoption :=
  match l with
  | nil => None
  | h :: t => Some h
  end.

Example test_hd_error1 : hd_error [] = None.
Proof. reflexivity. Qed.
Example test_hd_error2 : hd_error [1] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_error3 : hd_error [5;6] = Some 5.
Proof. reflexivity. Qed.

Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim default (hd_error l).
Proof.
  intros l default. destruct l.
  - reflexivity.
  - reflexivity.
Qed.

End NatList.

Module PartialMap.
Export NatList.

Inductive id : Type :=
  | Id : nat -> id.

Definition beq_id (x1 x2 : id) :=
  match x1, x2 with
  | Id n1, Id n2 => beq_nat n1 n2
  end.

Search beq_nat.

Theorem beq_id_refl : forall x, true = beq_id x x.
Proof.
  intros x. destruct x.
  - simpl. rewrite -> beq_nat_same_eq. reflexivity.
Qed.

Inductive partial_map : Type :=
  | empty : partial_map
  | record : id -> nat -> partial_map -> partial_map.

Definition update (d : partial_map) (x : id) (value : nat)
  : partial_map :=
record x value d.

Fixpoint find (x : id) (d : partial_map) : natoption :=
  match d with
  | empty => None
  | record y v d' => if beq_id x y
                      then Some v
                      else find x d'
  end.

Theorem update_eq : forall (d : partial_map) (x : id) (v : nat),
  find x (update d x v) = Some v.
Proof.
  intros. simpl. rewrite <- beq_id_refl. reflexivity.
Qed.

Theorem update_neq : forall (d : partial_map) (x y : id) (o : nat),
  beq_id x y = false -> find x (update d y o) = find x d.
Proof.
  intros. simpl. rewrite -> H. reflexivity.
Qed.

End PartialMap.


(** definindo tipos indutivos *)

Inductive True1 : Prop :=
| tt1 : True1.

Inductive False1 : Prop := .

Inductive conj1 (A B : Prop) : Prop :=
| and1 : A -> B -> conj1 A B.

(** exercício 13
    Defina o conectivo de disjunção *)

Inductive disj1 : Prop :=.

(** booleanos *)

Inductive bool1 : Set :=
| true1 : bool1
| false1 : bool1.

Require Import Bool.

Definition not_bool (b : bool) : bool :=
  match b with
  | false => true
  | true  => false
  end.

Definition and_bool (b1 b2 : bool) : bool :=
  match b1 , b2 with
  | true  , b2 => b2
  | false , b2 => false
  end.

(** exercício 14: Defina funções para os conectivos de disjunção, "ou", e
    exclusive-or, "xor" *)

Eval compute in not_bool false.

Lemma not_bool_inv : forall b : bool, not_bool (not_bool b) = b.
Proof.
  intro b.
  destruct b.
  +
    simpl.
    reflexivity.
  +
    simpl.
    reflexivity.
Qed.

(** exercício 15 *)

Lemma and_true_left : forall b, and_bool true b = b.
Proof.
Admitted.

(** exercício 16 *)

Lemma and_false_left : forall b, and_bool false b = false.
Proof.
Admitted.

(** exercício 17 *)

Lemma and_com : forall b b', and_bool b b' = and_bool b' b.
Proof.
Admitted.

(** exercício 18 *)

Lemma and_assocc : forall b1 b2 b3, and_bool b1 (and_bool b2 b3) = and_bool (and_bool b1 b2) b3.
Proof.
Admitted.

(** Números naturais *)

Lemma zero_identity_add_left : forall n, 0 + n = n.
Proof.
    intro n.
    simpl.
    reflexivity.
Qed.

Lemma zero_identity_add_right : forall n, n + 0 = n.
Proof.
   intro n.
   simpl.
   Restart.
   intro n.
   destruct n.
   +
     simpl.
     reflexivity.
   +
     simpl.
     (** reflexivity. *)
     Restart.
   intro n.
   induction n as [ | n' IHn'].
   +
     simpl.
     reflexivity.
   +
     simpl.
     rewrite IHn'.
     reflexivity.
Qed.

Lemma add_inc : forall m n, S (m + n) = m + S n.
Proof.
  intros m n.
  induction m as [ | m' IHm'].
  +
    simpl.
    reflexivity.
  +
    simpl.
    rewrite IHm'.
    reflexivity.
Qed.

Lemma add_commut : forall n m, n + m = m + n.
Proof.
  intros n m.
  induction n as [| n' IHn'].
  +
    simpl.
    symmetry.
    apply zero_identity_add_right.
  +
    simpl.
    rewrite IHn'.
    apply add_inc.
Qed.

(** exercício 19 *)

Lemma add_associative : forall n m p, n + (m + p) = (n + m) + p.
Proof.
Admitted.

(**
Exercício 20

A seguir apresentamos uma definição da operação de multiplicação sobre números
naturais.

A partir desta definição, enuncie e prove os seguintes fatos sobre a multiplicação:

- O número 1 é identidade à esquerda da multiplicação.
- O número 1 é identidade à direita da multiplicação.
- A operação de multiplicação é associativa.
- A operação de multiplicação é comutativa.
 **)

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

(**
Exercício 21

Defina a função `even_bool : nat -> bool` que, a partir de um número natural, retorne
verdadeiro se este é par.
 **)

Definition even_bool (n : nat) : bool.
Admitted.

(**
Exercício 22
 **)

Lemma even_add_n : forall n, even_bool (n + n) = true.
Proof.
Admitted.

(**
Exercício 23
Defina a função `odd_bool : nat -> bool` que, a partir de um número natural,
retorne verdadeirso se este é ímpar
 **)

Definition odd_bool (n : nat) : bool.
Admitted.

(** Exercício 24 *)

Lemma odd_add_n_Sn : forall n, odd_bool (n + S n) = true.
Proof.
Admitted.

(** Exercício 25 *)

Lemma even_SS : forall n, even_bool n = even_bool (S (S n)).
Proof.
Admitted.

(** Exercício 26 *)

Lemma odd_SS : forall n, odd_bool n = odd_bool (S (S n)).
Proof.
Admitted.

(** Exercício 27 *)

Lemma even_bool_S : forall n, even_bool n = not_bool (even_bool (S n)).
Proof.
Admitted.

(** Listas *)

Require Import List.

Notation "x :: l" := (cons x l)
                       (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Definition list1 : list nat := 1 :: 2 :: 3 :: nil.
Definition list2 : list nat := [1 ; 2 ; 3].

Fixpoint repeat {A : Type}(n : nat)(x : A) : list A :=
  match n with
  | O => []
  | S n' => x :: repeat n' x
  end.

Fixpoint length {A : Type}(xs : list A) : nat :=
  match xs with
  | []        => O
  | (x :: xs) => S (length xs)
  end.

Lemma length_app
  : forall {A : Type}(xs ys : list A), length (xs ++ ys) = length xs + length ys.
Proof.
  intros A xs ys.
  induction xs as [| z zs IHzs].
  +
    simpl.
    reflexivity.
  +
    simpl.
    rewrite IHzs.
    reflexivity.
Qed.

Fixpoint map {A B : Type}(f : A -> B)(xs : list A) : list B :=
  match xs with
  | []      => []
  | y :: ys =>  f y :: map f ys
  end.

Lemma map_length {A B : Type}{f : A -> B} : forall xs, length (map f xs) = length xs.
Proof.
  intros xs.
  induction xs as [ | y ys IHys].
  +
    reflexivity.
  +
    simpl.
    rewrite IHys.
    reflexivity.
Qed.

Fixpoint reverse {A : Type}(xs : list A) : list A :=
  match xs with
  | [] => []
  | y :: ys => reverse ys ++ [ y ]
  end.

Lemma reverse_length {A : Type}: forall (xs : list A), length xs = length (reverse xs).
Proof.
  intros xs.
  induction xs.
  +
    reflexivity.
  +
    simpl.
    rewrite length_app, add_commut.
    rewrite IHxs.
    reflexivity.
Qed.

(** exercício 28 *)

Lemma repeat_length {A : Type} : forall (n : nat)(x : A), length (repeat n x) = n.
Proof.
Admitted.

(** exercício 29 *)

Lemma app_nil_right {A : Type} : forall (xs : list A), xs ++ [] = xs.
Proof.
Admitted.

(** exercício 30 *)

Lemma app_assoc {A : Type} : forall (xs ys zs : list A), xs ++ (ys ++ zs) = (xs ++ ys) ++ zs.
Proof.
Admitted.

(** exercício 31 *)

Lemma map_app {A B : Type}{f : A -> B}
  : forall xs ys, map f (xs ++ ys) = map f xs ++ map f ys.
Proof.
Admitted.

(** exercício 32 *)

Lemma reverse_app {A : Type}
  : forall (xs ys : list A), reverse (xs ++ ys) = reverse ys ++ reverse xs.
Proof.
Admitted.

(** exercício 33 *)

Lemma reverse_inv {A : Type}
  : forall (xs : list A), reverse (reverse xs) = xs.
Proof.
Admitted.

(** Predicados indutivos *)

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

Example eight_is_even : even 8.
Proof.
  apply ev_ss.
  apply ev_ss.
  apply ev_ss.
  apply ev_ss.
  apply ev_zero.
Qed.

Example teste : even 1 -> 1 = 2.
Proof.
  intro H.
  inversion H.
Qed.
Definition double (n : nat) := 2 * n.

(** exercício 34 *)

Lemma double_even : forall n, even (double n).
Proof.
Admitted.

(** Princípio de inversão *)

Lemma one_not_even : ~ even 1.
Proof.
  intros Hone.
  inversion Hone.
Qed.

Lemma even_2_inv : forall n, even (2 + n) -> even n.
Proof.
  intros n H.
  inversion H.
  assumption.
Qed.

(**
   Inductive le (n : nat) : nat -> Prop :=
   | le_n : n <= n
   | le_S : forall m : nat, n <= m -> n <= S m
 *)

Example teste_le : 3 <= 6.
Proof.
  apply le_S.
  apply le_S.
  apply le_S.
  apply le_n.
Qed.

Example teste_le_false : 2 <= 1 -> 1 + 1 = 10.
Proof.
  intros H.
  inversion H.
  inversion H1.
Qed.

Lemma le_0_n : forall n, 0 <= n.
Proof.
  intros n.
  induction n as [| n' IHn'].
  +
    apply le_n.
  +
    apply le_S.
    assumption.
Qed.

(** exercício 35 *)

Lemma le_refl : forall n, n <= n.
Proof.
Admitted.

Lemma le_cong_S : forall n m, n <= m -> S n <= S m.
Proof.
  intros n m Hnm.
  induction Hnm.
  +
    apply le_refl.
  +
    apply le_S.
    assumption.
Qed.

Lemma le_S_cong : forall n m, S n <= S m -> n <= m.
Proof.
  intros n m.
  induction m as [| m' IHm'].
  +
    intros Hnm.
    inversion Hnm.
    -
      apply le_refl.
    -
      inversion H0.
   +
     intros Hnm.
     inversion Hnm.
     -
       subst.
       apply le_refl.
     -
       subst.
       apply le_S.
       apply IHm'.
       assumption.
Qed.

(** exercício 36 *)

Lemma le_trans : forall n m p, n <= m -> m <= p -> n <= p.
Proof.
Admitted.

(** exercício 37 *)

Ltac inverts H := inversion H ; subst ; clear H.

Lemma le_antisym : forall n m, n <= m -> m <= n -> n = m.
Proof.
Admitted.

(** exercício 38

Considere a tarefa de projetar um predicado indutivo
`Sorted : list nat -> Prop` que constitui uma prova
de que uma certa lista de números naturais está ordenada.
Sua definição deve utilizar o predicado `<=` e conseguir
demonstrar os casos de teste abaixo.

*)

Inductive Sorted : list nat -> Prop := .

Example test_sorted1 : Sorted [].
Proof.
Admitted.

Example test_sorted2 : Sorted [10].
Proof.
Admitted .

Example test_sorted3 : Sorted [1 ; 3 ; 5 ].
Proof.
Admitted.

Reserved Notation "x '<<=' y" (at level 40, no associativity).

Inductive le_alt : nat -> nat -> Prop :=
| le_alt_zero : forall n, 0 <<= n
| le_alt_succ : forall n m, n <<= m -> S n <<= S m
where "x '<<=' y" := (le_alt x y).

(** exercício 39 *)

Lemma le_alt_refl : forall n, n <<= n.
Proof.
Admitted.

(** exercício 40 *)

Lemma le_alt_trans
  : forall n m p, n <<= m -> m <<= p -> n <<= p.
Proof.
Admitted.

(** exercício 41 *)

Lemma le_alt_antisym : forall n m, n <<= m -> m <<= n -> n = m.
Proof.
Admitted.

(** exercício 42 *)

Lemma le_alt_equiv_le : forall n m, n <<= m <-> n <= m.
Proof.
Admitted.


From Coq Require Import
  Lia
  List
  ZArith.
From FunProofs.Lib Require Import
  Arith
  Function
  List
  Tactics.
From FunProofs.Lib Require Export
  AltMap.

#[local] Open Scope Z.

Section Maximum.
  Definition maximum min (xs : list Z) : Z :=
    fold_right Z.max min xs.

  Definition maximum0 (xs : list Z) : Z :=
    maximum (hd 0 xs) xs.

  Lemma maximum_case min xs (m := maximum min xs) :
    Forall (fun x => x <= m) xs /\
    (In m xs \/ (m = min /\ Forall (fun x => x < min) xs)).
  Proof.
    induction xs as [| x xs]; cbn in *; auto;
      destruct IHxs as (Hmax & Hin); fold (maximum min xs); split.
    - constructor; auto using Z.le_max_l.
      rewrite Forall_forall in *; intros * Hin'; apply Hmax in Hin'; lia.
    - rewrite Z.max_comm; pattern (Z.max (maximum min xs) x);
        apply Zmax_case_strong_lt; intros; intuition auto.
      right; split; auto; constructor; auto; lia.
  Qed.

  Lemma maximum0_case xs (m := maximum0 xs) :
    xs <> [] -> Forall (fun x => x <= m) xs /\ In m xs.
  Proof.
    intros; pose proof (maximum_case (hd 0 xs) xs).
    repeat intuition auto.
    destruct xs as [| x xs]; cbn in *; [easy |].
    prename (fun _ => _ < _) into Hfalse; inv Hfalse; lia.
  Qed.

  Lemma maximum_lower_bound min xs : min <= maximum min xs.
  Proof. unfold maximum; induction xs as [| x xs]; cbn; intros; lia. Qed.

  Lemma maximum_le_mono min min' xs : min <= min' -> maximum min xs <= maximum min' xs.
  Proof. unfold maximum; induction xs as [| x xs]; cbn; intros; lia. Qed.

  Lemma maximum_cons_le min xs x : maximum min xs <= maximum min (x :: xs).
  Proof. unfold maximum; intros; cbn; lia. Qed.

  Lemma maximum_in min xs (m := maximum min xs) : min < maximum min xs -> In m xs.
  Proof.
    induction xs as [| x xs]; cbn; intros; [lia |].
    fold (maximum min xs) in *.
    destruct (Z.lt_ge_cases x (maximum min xs));
      rewrite ?Z.max_l in * by lia; rewrite ?Z.max_r in * by lia; auto.
  Qed.

  Lemma maximum_weaken_in min min' xs :
    min <= min' -> In (maximum min' xs) xs -> maximum min xs = maximum min' xs.
  Proof.
    induction xs as [| x xs]; cbn; intros Hlt Hin; [easy |].
    pose proof (maximum_le_mono min min' xs); unfold maximum in *.
    destruct Hin as [Heq | Hin]; try lia.
    pattern (Z.max x (fold_right Z.max min' xs)); apply Z.max_case_strong; intros;
      try lia.
    rewrite Z.max_r in Hin by auto; apply IHxs in Hin; auto; lia.
  Qed.

  Corollary maximum_weaken_lt min min' xs :
    min <= min' < maximum min' xs -> maximum min xs = maximum min' xs.
  Proof. intros; apply maximum_weaken_in, maximum_in; lia. Qed.

  Lemma maximum0_unfold x xs : 0 <= x -> maximum0 (x :: xs) = Z.max x (maximum0 xs).
  Proof.
    intros; destruct xs as [| x' xs]; cbn; [lia |].
    fold (maximum x xs); fold (maximum x' xs).
    destruct (Z.lt_ge_cases x x').
    - destruct (maximum_case x' xs) as (? & [? | (? & Hmax)]).
      + rewrite (maximum_weaken_in x x' xs); auto; lia.
      + destruct (maximum_case x xs) as (? & [Hin | (? & ?)]); try lia.
        rewrite Forall_forall in Hmax; apply Hmax in Hin; lia.
    - destruct (maximum_case x xs) as (? & [? | (? & Hmax)]).
      + rewrite (maximum_weaken_in x' x xs); auto; lia.
      + destruct (maximum_case x' xs) as (? & [Hin | (? & ?)]); try lia.
        rewrite Forall_forall in Hmax; apply Hmax in Hin; lia.
  Qed.
End Maximum.

Section Minimum.
  Definition minimum max (xs : list Z) : Z :=
    fold_right Z.min max xs.

  Definition minimum0 (xs : list Z) : Z :=
    minimum (hd 0 xs) xs.

  Lemma minimum_case max xs (m := minimum max xs) :
    Forall (fun x => m <= x) xs /\
    (In m xs \/ (m = max /\ Forall (fun x => max < x) xs)).
  Proof.
    induction xs as [| x xs]; cbn in *; auto;
      destruct IHxs as (Hmin & Hin); fold (minimum max xs); split.
    - constructor; auto using Z.le_min_l.
      rewrite Forall_forall in *; intros * Hin'; apply Hmin in Hin'; lia.
    - pattern (Z.min x (minimum max xs)); apply Zmin_case_strong_lt; intros;
        intuition auto.
      right; split; auto; constructor; auto; lia.
  Qed.

  Lemma minimum0_case xs (m := minimum0 xs) :
    xs <> [] -> Forall (fun x => m <= x) xs /\ In m xs.
  Proof.
    intros; pose proof (minimum_case (hd 0 xs) xs).
    repeat intuition auto.
    destruct xs as [| x xs]; cbn in *; [easy |].
    prename (fun _ => _ < _) into Hfalse; inv Hfalse; lia.
  Qed.

  Lemma minimum_upper_bound max xs : minimum max xs <= max.
  Proof. unfold minimum; induction xs as [| x xs]; cbn; intros; lia. Qed.

  Lemma minimum_le_mono max max' xs : max <= max' -> minimum max xs <= minimum max' xs.
  Proof. unfold minimum; induction xs as [| x xs]; cbn; intros; lia. Qed.

  Lemma minimum_cons_le max xs x : minimum max (x :: xs) <= minimum max xs.
  Proof. unfold minimum; intros; cbn; lia. Qed.

  Lemma minimum_in max xs (m := minimum max xs) : minimum max xs < max -> In m xs.
  Proof.
    induction xs as [| x xs]; cbn; intros; [lia |].
    fold (minimum max xs) in *.
    destruct (Z.lt_ge_cases x (minimum max xs));
      rewrite ?Z.min_l in * by lia; rewrite ?Z.min_r in * by lia; auto.
  Qed.

  Lemma minimum_weaken_in max max' xs :
    max' <= max -> In (minimum max' xs) xs -> minimum max xs = minimum max' xs.
  Proof.
    induction xs as [| x xs]; cbn; intros Hlt Hin; [easy |].
    pose proof (minimum_le_mono max' max xs); unfold minimum in *.
    destruct Hin as [Heq | Hin]; try lia.
    pattern (Z.min x (fold_right Z.min max' xs)); apply Z.min_case_strong; intros;
      try lia.
    rewrite Z.min_r in Hin by auto; apply IHxs in Hin; auto; lia.
  Qed.

  Corollary minimum_weaken_lt max max' xs :
    minimum max' xs < max' <= max -> minimum max xs = minimum max' xs.
  Proof. intros; apply minimum_weaken_in, minimum_in; lia. Qed.
End Minimum.


(** Use some very basic facilities of mathcomp library *)
From mathcomp Require Import ssreflect.

Module My.
(** We introduce these definitions inside a new module
    to avoid name clashes with the standard library later *)

Inductive bool : Type :=
| true
| false.

Check true : bool.
Check true.

(** Definitions (not part of Coq's type theory, by the way, it's
    a meta-linguistic feature) *)
Definition idb := fun b : bool => b.

Check (fun b : bool => b).
Check idb.

(** Pattern-matching *)
Definition negb (b : bool) :=
  match b with
  | true => false
  | false => true
  end.

Compute idb true.
Compute idb false.

Compute negb true.
Compute negb false.

Variable c : bool.

Compute idb c.

Compute negb c.

Definition andb (b c : bool) : bool :=
  match b with
  | true => c
  | false => false
  end.

(** Symbolic computations *)
Compute andb c true.
Compute andb c false.
Compute andb false c.

(** Peano numbers -- the first truly inductive type *)
Inductive nat : Type :=
| S of nat
| O.
Print nat.

Check O.
Check S.
Check (S O).
Check S (S O).
Check S (S (S O)).

(** Incrementing function *)
Definition inc := S.
(** [Definition inc (n : nat) := S n.] is the same definition,
    only eta-expanded *)

(**
eta-expansion is baked into Coq' notion of definitional equality, i.e
(fun x => f x) and f are definitionally equal
but
extensionally equal functions are not necessarily equal, i.e.
(forall x, f x = g x -> f = g)
does not have to hold.
*)
Print inc.

Compute inc (S (S O)).

Definition inc2 (n : nat) := S (S n).
Compute inc2 (S (S O)).

(** predecessor function *)
Definition pred (n : nat) : nat :=
  match n with
  | S n' => n'
  | O => O   (* truncation! Coq's functions are total *)
  end.

(**
Some options to go about implementing [pred] function:

 pred : nat -> nat  (* way to go *)
 pred : nat -> option nat
 pred : forall (n : nat), (n <> 0) -> nat

*)

(** Addition of natural numbers *)

(** [{struct n}] means structural recursion on parameter [n].
    Coq can infer the [struct] annotation in this case. *)

Fixpoint addn (n m : nat) {struct n} : nat :=
  match n with
  | S n' => S (addn n' m)
  | O => m
  end.

Compute addn (S (S O)) (S (S O)).  (* 2 + 2 is 4 *)

(** Alternative implementation by recursion on the second parameter *)
Fixpoint addn' (n m : nat) : nat :=
  match m with
  | S m' => S (addn' n m')
  | O => n
  end.

Print addn'.

Fixpoint muln (n m : nat) : nat :=
  match n with
  | S n' => addn m (muln n' m)
  | O => O
  end.

Compute muln (S (S (S O))) (S (S O)).  (* 3 * 2 is 6 *)
Compute muln (S (S O)) O.              (* 2 * 0 is 0 *)

Definition square (n : nat) : nat := muln n n.

Definition two := (S (S O)).
Definition apply2 (f : nat -> nat) (n : nat) :=
  f (f n).
Eval hnf in (apply2 (apply2 square) two).
(** Various reduction strategies:
- Eval cbn in ...              call-by-name
- Eval lazy in ...             call-by-need
- Eval cbv in ...              call-by-value
- Eval compute in ...          call-by-value (cbv's synonym)
- Eval vm_compute in ...       call-by-value using a bytecode virtual machine
                               [Compute] is synonym for [Eval vm_compute in]
- Eval native_compute in ...   compile to OCaml and evaluate
*)

End My.

(** After closing a module, the identifiers defined in it,
    get prefixed with the module's name *)
Check My.apply2.

From mathcomp Require Import ssrfun ssrbool ssrnat.

(** Some interactive queries *)
About nat.
About S.

Locate ".+1".     (* Notation "n .+1" := (S n). *)

(** Apply [n] times a function [f] on natural numbers to
    an input [x] *)
Definition applyn (f : nat -> nat) :=
  fix rec (n : nat) (x : nat) :=
    if n is n'.+1 then rec n' (f x)
    else x.

(* a test *)
Compute applyn S 5 42.

(** An alternative implementation whose behavior is
    different when we evaluate it symbolically *)
Definition applyn' :=
  fix rec (f : nat -> nat) (n : nat) (x : nat) :=
    if n is n'.+1 then rec f n' (f x)
    else x.

Axiom fun_ext :
  forall (A B : Type) (f g : A -> B),
    (forall x, f x = g x) -> f = g.

(** A way of defining [applyn] using Coq's section mechanism *)
Section Applyn.

Variable f : nat -> nat.

Fixpoint applyn'' (n : nat) (x : nat) : nat :=
  if n is n'.+1 then applyn'' n' (f x)
  else x.

Variable n : nat.
Compute applyn'' (S n) 0.

Print applyn''.

End Applyn.

Print applyn''.  (* compare the output to the one inside the above section *)

(** A proposition which can never be constructed (in the empty context *)
Inductive False : Prop :=
  .    (* no constructors! *)

Print False.

(** Let's illustrate why "in the empty context" is important *)
Check (fun f : False => f (* here we construct a value of type
                             [False], but the context is not empty,
                             since the function parameter becomes
                             part of context here *)
      ).
(** Since it's impossible to construct a value of an empty type,
    it's impossible to call a function of type
    False -> SomeType *)
(** ... provided we are talking about empty contexts again: *)
Check (fun g : False =>
         (fun f : False => f) g     (* call [fun f : False => f]
                                       with [g] as the argument *)
      ).

(** This is why Coq does not allow non-terminating functions *)
Fail Fixpoint loop (n : nat) : False :=
  loop n.
(* loop : n -> False *)

(** If this was allowed, we could construct a value of an empty type
    in the empy context like so: *)
Fail Check (loop O : False).

(** And this would preclude Coq from being a logic *)

(** To be continued... *)


Require Import ZArith.
Require Import Omega.
Require Import Bool.
From Coq Require Import ssreflect.

Open Scope Z_scope.

Goal forall (x y : Z),
    x + y = 2 -> 2 * x + y = 5 -> x = 3.
Proof.
  move=> x y H1 H2.
  omega.
Qed.

Definition Step (b : bool) := if b then 5 else 0.

Goal forall b, b = true -> Step b = 5.
Proof.
  move=> b Ht.
  by rewrite /Step Ht.
Qed.

Definition OverThresholdLe (m x : Z) := m <=? x.
Definition OverThresholdLt (m x : Z) := m <? x.
Definition InnerRange (m1 m2 x : Z) := (m1 <=? x) && (x <=? m2).

Goal forall x, 5 <= x -> OverThresholdLe 5 x = true.
Proof.
  move=> x Ht.
  rewrite /OverThresholdLe.
    by apply/Z.leb_le.
Qed.

Goal forall x, 5 <= x <-> OverThresholdLe 5 x = true.
Proof.
  rewrite /OverThresholdLe.
  split.
  - move=> Hle.
    move/Z.leb_le in Hle.
      by [].
  - move=> Hleb.
      by apply/Z.leb_le.
Qed.

Goal forall x, x < 5 -> OverThresholdLe 5 x = false.
Proof.
  move=> x Ht.
  rewrite /OverThresholdLe.
    by apply/Z.leb_gt.
Qed.

Goal forall x, 5 < x -> OverThresholdLt 5 x = true.
Proof.
  move=> x Ht.
  rewrite /OverThresholdLt.
    by apply/Z.ltb_lt.
Qed.

Goal forall x, x <= 5 -> OverThresholdLt 5 x = false.
Proof.
  move=> x Ht.
  rewrite /OverThresholdLt.
    by apply/Z.ltb_ge.
Qed.

Goal forall x, 1 <= x <= 5 <-> InnerRange 1 5 x = true.
Proof.
  rewrite /InnerRange.
  split.
  - case.
    move=> H1 H5.
    move/Z.leb_le in H1.
    move/Z.leb_le in H5.
      by rewrite H1 H5.
  - move=> H15.
    move/andb_true_iff in H15.
    case: H15 => H1 H5.
    move/Z.leb_le in H1.
    move/Z.leb_le in H5.
    split.
    + done.
    + done.
Qed.

Goal forall x, x < 1 \/ 5 < x <-> InnerRange 1 5 x = false.
Proof.
  rewrite /InnerRange.
  split.
  - case => H1.
    + apply/andb_false_iff.
      left.
        by apply/Z.leb_gt.
    + apply/andb_false_iff.
      right.
        by apply/Z.leb_gt.
  - move=> H15.
    move/andb_false_iff in H15.
    case: H15.
    + move=> H1.
      move/Z.leb_gt in H1.
        by left.
    + move=> H5.
      move/Z.leb_gt in H5.
        by right.
Qed.


Require Import Setoid.
Require Import Arith.
Require Import Bool.
Module EvenAndOdd.
Inductive even:nat->Prop:=
|even_0:even 0
|even_SS:forall n,even n->even(S(S n)).

Inductive odd:nat->Prop:=
|odd_1:odd 1
|odd_SS:forall n,odd n->odd(S(S n)).

Theorem even_add_SS:
forall n,
even(S(S n))->even n.
Proof.
intros.
generalize (refl_equal(S(S n))).
pattern(S(S n))at 2.
case H.
discriminate.
intros.
repeat apply eq_add_S in H1.
rewrite H1.
exact H0.
Qed.

Theorem odd_add_SS:forall n,
odd(S(S n))->odd n.
intros.
generalize (refl_equal(S(S n))).
pattern(S(S n))at 2.
info case H.
info discriminate.
intros.
repeat apply eq_add_S in H1.

rewrite H1.
exact H0.
Qed.
Lemma even_S:
forall n,
even n->odd (S n).
intros.
elim H.
exact odd_1.
intros.
apply odd_SS.
exact H1.
Qed.
Lemma odd_S:
forall n,
odd n->even (S n).
intros.
elim H.
exact (even_SS 0 even_0).
intros.
apply even_SS.
exact H1.
Qed.

Lemma even_S_iff:
forall n,
even n<->odd(S n).
intro.
split.
apply even_S.
intros.
apply even_add_SS.
apply odd_S.
exact H.
Qed.

Lemma odd_S_iff:
forall n,
odd n<->even(S n).
intro.
split.
apply odd_S.
intros.
apply odd_add_SS.
apply even_S.
exact H.
Qed.

Lemma even_odd_dec:
forall n,
{even n}+{odd n}.
induction n.
left.
apply even_0.
case IHn.
right.
exact (even_S n e).
left.
exact (odd_S n o).
Qed.

Lemma even_and_odd:
forall n,
even n->odd n->False.
induction n.
intros.
generalize (refl_equal 0).
pattern 0 at 2.
case H0;
discriminate.

intros.
rewrite <-odd_S_iff in H.
rewrite <-even_S_iff in H0.
exact(IHn H0 H).
Qed.

Fixpoint beven(n:nat):bool:=
match n with
|0=>true
|1=>false
|S(S n')=>beven n'
end.

Lemma beven_true:
forall n:nat,
beven n=true->even n.
fix IHn 1.
intro.
case_eq n.
intros.
exact even_0.
intro;case n0.
discriminate.
intros.
apply even_SS.
apply IHn.
simpl in H0.
exact H0.
Qed.
Lemma beven_true_iff:
forall n,
beven n=true<->even n.
intros.
split.
apply beven_true.
intros.
elim H.
auto.
intros.
exact H1.
Qed.
Lemma beven_false:
forall n,
beven n=false->odd n.
intros.
assert(~even n).
rewrite <-beven_true_iff.
rewrite H.
SearchPattern(false<>true).
apply diff_false_true.
case (even_odd_dec n);auto.
intros.
case H0.
exact e.
Qed.

Lemma beven_false_iff:
forall n,
beven n=false<->odd n.
intro.
split.
apply beven_false.
intros.
apply not_true_is_false.
intro.
apply beven_true in H0.
exact (even_and_odd n H0 H).
Qed.

Theorem even_is_mul_2:
forall n,
even n->exists x,n=2*x.
simpl.

intros.
elim H.
exists 0.
auto.
intros.
destruct H1.
exists (S x).
rewrite H1.
simpl.
rewrite (plus_comm x 0).
simpl.
rewrite plus_n_Sm.
info auto.
Qed.
Theorem odd_is_S_mul_2:
forall n,
odd n->exists x,n=S(2*x).
Proof.
intros.
elim H.
exists 0;auto.
intros.
destruct H1.
exists (S x).
rewrite H1.
simpl.
rewrite (plus_comm x 0).
simpl.
rewrite plus_n_Sm.
info auto.
Qed.

Theorem even_plus_odd_is_odd:
forall x y:nat,
even x->odd y->
odd(x+y).
intros.
elim H.
apply H0.
intros.
simpl.
apply odd_SS.
apply H2.
Qed.

End EvenAndOdd.

Section OddIsNotEven.
Inductive even:nat->Prop:=
|even_0:even 0
|even_SS:forall n,even n->even(S(S n)).
Definition odd(n:nat):Prop:=
~even n.
Theorem even_add_SS:
forall n,
even(S(S n))->even n.
Proof.
intros.
generalize (refl_equal(S(S n))).
pattern(S(S n))at 2.
case H.
discriminate.
intros.
repeat apply eq_add_S in H1.
rewrite H1.
exact H0.
Qed.

Theorem odd_add_SS:forall n,
odd(S(S n))->odd n.
intros.
intro.
apply H.
apply even_SS.
exact H0.
Qed.
Theorem odd_SS:
forall n,
odd n->odd(S(S n)).
intros n H H0.
apply H.
apply even_add_SS.
exact H0.
Qed.

Lemma odd_1:odd 1.
intro.
generalize (refl_equal 1).
pattern 1 at 2.
case H;discriminate.
Qed.

Lemma even_S:
forall n,
even n->odd (S n).
intros.
elim H.
exact odd_1.
intros.
apply odd_SS.
exact H1.
Qed.
Lemma odd_S:
forall n,
odd n->even (S n).
fix IHn 1.
induction n.
intros.
elim H.
exact even_0.
case_eq n.
intros.
apply even_SS.
exact even_0.
intros.
apply even_SS.
apply odd_add_SS in H0.
apply IHn.
apply H0.
Qed.

Lemma even_S_iff:
forall n,
even n<->odd(S n).
intro.
split.
apply even_S.
intros.
apply even_add_SS.
apply odd_S.
exact H.
Qed.

Lemma odd_S_iff:
forall n,
odd n<->even(S n).
intro.
split.
apply odd_S.
intros.
apply odd_add_SS.
apply even_S.
exact H.
Qed.

Lemma even_odd_dec:
forall n,
{even n}+{odd n}.
induction n.
left.
apply even_0.
case IHn.
right.
exact (even_S n e).
left.
exact (odd_S n o).
Qed.

Lemma even_and_odd:
forall n,
even n->odd n->False.
auto.
Qed.

Fixpoint beven(n:nat):bool:=
match n with
|0=>true
|1=>false
|S(S n')=>beven n'
end.

Lemma beven_true:
forall n:nat,
beven n=true->even n.
fix IHn 1.
intro.
case_eq n.
intros.
exact even_0.
intro;case n0.
discriminate.
intros.
apply even_SS.
apply IHn.
simpl in H0.
exact H0.
Qed.
Lemma beven_true_iff:
forall n,
beven n=true<->even n.
intros.
split.
apply beven_true.
intros.
elim H.
auto.
intros.
exact H1.
Qed.
Lemma beven_false:
forall n,
beven n=false->odd n.
intros.
unfold odd.
rewrite <-beven_true_iff.
rewrite H.
SearchPattern(false<>true).
apply diff_false_true.
Qed.

Lemma beven_false_iff:
forall n,
beven n=false<->odd n.
intro.
split.
apply beven_false.
intros.
apply not_true_is_false.
intro.
apply beven_true in H0.
exact (even_and_odd n H0 H).
Qed.

Theorem even_is_mul_2:
forall n,
even n->exists x,n=2*x.
simpl.

intros.
elim H.
exists 0.
auto.
intros.
destruct H1.
exists (S x).
rewrite H1.
simpl.
rewrite (plus_comm x 0).
simpl.
rewrite plus_n_Sm.
info auto.
Qed.
Theorem odd_is_S_mul_2:
forall n,
odd n->exists x,n=S(2*x).
Proof.
fix IHn 1.
intro n.
case n.
 intros.
 absurd (even 0).
 exact H.
 exact even_0.

intro n0.
case n0.
 intros.
 exists 0.
 auto.
intros.
apply odd_add_SS in H.
destruct (IHn n1 H).
exists (S x).
simpl in *.
rewrite H0.
rewrite plus_n_Sm.
reflexivity.
Qed.

Theorem even_plus_odd_is_odd:
forall x y:nat,
even x->odd y->
odd(x+y).
intros.
elim H.
apply H0.
intros.
simpl.
apply odd_SS.
apply H2.
Qed.


From Coq Require Import ZArith.

Open Scope Z.

Fixpoint sum (f : Z -> Z) (n : nat) : Z :=
  match n with
  | O => f 0
  | S n => f (Z.of_nat (S n)) + (sum f n)
  end.

Lemma sum_decomposition :
  forall f n, sum f (S n) = sum f n + f (Z.of_nat (S n)).
Proof.
  intros f n.
  simpl.
  rewrite Z.add_comm.
  reflexivity.
Qed.

Axiom square_plus :
  forall a b,
  Z.square (a + b) = Z.square a + 2 * a * b + Z.square b.

Lemma Z_of_nat_succ : forall n, Z.of_nat (S n) = Z.of_nat n + 1.
Proof.
  intros n.
  rewrite -> Nat2Z.inj_succ.
  reflexivity.
Qed.

Theorem thm_1_9_Z :
  forall n,
  sum (fun n => 2 * n + 1) n = Z.square (Z.of_nat n + 1).
Proof.
  intros.
  induction n.
  + simpl.
    reflexivity.
  + rewrite sum_decomposition.
    rewrite IHn.
    rewrite square_plus.
    rewrite square_plus.
    rewrite Z_of_nat_succ.
    rewrite square_plus.
    rewrite Z.mul_1_r.
    rewrite Z.add_assoc.
    rewrite Z.mul_1_r.
    reflexivity.
Qed.


(** Programming exercices in Coq *)

(* Write a function addodd that sums the n first odd numbers.
   Check on a few values that this function produces square numbers.
   How do you state such a fact ? *)

(* Same for the sum of the n first natural numbers, and the
   formula n(n+1)/2. *)

Inductive comparison := Eq | Lt | Gt. (* equal / less-than / greater-than *)

(* Write a compare function of type nat->nat->comparison. *)

(* Write a compare_pos function of type positive->positive->comparison. *)

(* Write a conversion function of type positive->nat.
   State that your comparison functions are compatible with
   this conversion, and test this fact on a few examples. *)

(* Write a few usual functions on lists : append, map, rev... *)

(* Write a function
    tabulate : forall A, (nat -> A) -> nat -> list A
   such that (tabulate f n = f 0 :: f 1 :: ... :: f (n-1)). *)

(* Write a compose function of type :
    forall A B C, (A->B)->(B->C)->(A->C) *)

(* Write a function natiter : forall A, (A->A) -> n -> (A->A)
   such that natiter f n = f^n.
   How do you write the addition over nat via natiter ?
   Same for the multiplication and exponentiation. *)

(* Write a function syracuse : positive->positive such that
    syracuse p = p/2 when p is even, and 3p+1 otherwise.
   State the Syracuse conjecture : repetition of this process
   ultimately reachs 1, regardless of the starting value.
   How do you experimently verify this conjecture for a few values ? *)

(* Define the inductive type of binary trees whose nodes contain
   elements of a given type A.
   Define a conversion function from trees to lists according
   to your favorite traversal order.
   Define a function checking whether a binary tree is perfect
   or not. *)

(* Small arithmetic expressions and stack machine. *)

Inductive expr :=
| Num  : nat -> expr            (* Constant: n *)
| Plus : expr -> expr -> expr   (* Sum:      e1 + e2 *)
| Mult : expr -> expr -> expr.  (* Product:  e1 * e2 *)

(* Define a function eval : expr -> nat. *)

Inductive instr :=
| PUSH : nat -> instr (* Push a value on top of the stack *)
| ADD : instr  (* remove the two topmost values on the stack
                  and replace them by their sum. *)
| MUL : instr.  (* same for multiplication *)
Definition prog := list instr.
Definition stack := list nat.

(* Define a function exec_instr : instr -> stack -> stack.
   Its behavior is unspecified if the stack hasn't enough elements. *)
(* Same for exec_prog : prog -> stack -> stack. *)

(* Provide a compile function of type expr -> prog. *)
(* State its correctness, and test it on some examples *)


From mathcomp Require Import all_ssreflect.

(** *** Exercise 1:
    - 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
}.

(* Prove the main property of [odd_nat] *)
Lemma oddP (n : odd_nat) : odd n.
Proof.
(*D*)by case: n.
Qed.

Structure even_nat := Even {
  eval :> nat;
  eprop : ~~ (odd eval)
}.

(* Prove the main property of [even_nat] *)
Lemma evenP (n : even_nat) : ~~ (odd n).
Proof.
(*D*) by case: n.
Qed.

(* The objective is to make it work: knowing that [n] is [odd]
   Coq should infer that [n * 3] is also odd, and that [6] is even *)
Example test_odd (n : odd_nat) : ~~ (odd 6) && odd (n * 3).
Proof. Fail by rewrite oddP evenP. Abort.

(* Let's start by telling Coq that 0 is even *)
Canonical even_0 : even_nat := 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.

(* Here we teach Coq that if [m] is even, then [m.+1] is odd *)
Canonical odd_even (m : even_nat) : odd_nat :=
  Odd m.+1 (oddS m (eprop m)).

(* Implement the dual, teach coq that if [m] is odd then [m.+1] is even *)
Canonical even_odd (m : odd_nat) : even_nat :=
(*D*)Even m.+1 (evenS m (oprop m)).

(* Now let's deal with multiplication *)
Lemma odd_mulP (n m : odd_nat) : odd (n * m).
Proof.
(*D*)by rewrite odd_mul !oddP.
Qed.

(* Teach Coq that [*] preserves being odd *)
Canonical odd_mul (n m : odd_nat) : odd_nat :=
(*D*)Odd (n * m) (odd_mulP n m).

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

(* We can't use [==] on odd natural numbers because
   [odd_nat] is not an [eqType] *)
Fail Check forall n m : odd_nat, n == m.

(* Use the subtype machinery (that we used for tuples) in order
   to teach Coq that [odd_nat] is an [eqType] *)
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.

(* Enjoy *)
Check forall n m : odd_nat, n == m.

(* Now do the same for [even_nat] *)
Fail Check forall (n m : even_nat), m == n.

(*D*)Canonical even_subType := Eval hnf in [subType for eval].
(*D*)Definition even_eqMixin := Eval hnf in [eqMixin of even_nat by <:].
(*D*)Canonical even_eqType := Eval hnf in EqType even_nat even_eqMixin.

Check forall (n m : even_nat), m == n.


(* This file is part of the Linear Logic  formalization in Coq: https://github.com/brunofx86/LL *)

(** ** Auxiliar Results

Some arithmetic results needed in the proofs.
*)

Require Import Arith.

Lemma GtZero : forall n, n >0 -> exists n', n = S n'.
Proof.
  intros.
  destruct n.
  inversion H.
  exists n;auto.
Qed.

Lemma plus_le_reg_r: forall n m q : nat, n + q <= m + q -> n <= m.
Proof.
  intros.
  assert (n+q = q + n) by (apply plus_comm).
  assert (m+q = q + m) by (apply plus_comm).
  rewrite H0 in H. rewrite H1 in H.
  eapply plus_le_reg_l in H.
  assumption.
Qed.