(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(**********************************************************************
    FGroup.v

    Defintion and properties of finite groups

    Definition: FGroup
  **********************************************************************)
Require Import List.
Require Import UList.
Require Import Tactic.
Require Import ZArith.

Open Scope Z_scope.

Set Implicit Arguments.

(**************************************
  A finite group is defined for an operation op
  it has a support  (s)
  op operates inside the group (internal)
  op is associative (assoc)
  it has an element (e) that is neutral (e_is_zero_l e_is_zero_r)
  it has an inverse operator (i)
  the inverse operates inside the group (i_internal)
  it gives an inverse (i_is_inverse_l is_is_inverse_r)
 **************************************)

Record FGroup (A: Set) (op: A -> A -> A): Set := mkGroup
  {s : (list A);
   unique_s: ulist s;
   internal: forall a b, In a s -> In b s -> In (op a b) s;
   assoc: forall a b c, In a s -> In b s -> In c s -> op a (op b c) = op (op a b) c;
   e: A;
   e_in_s: In e s;
   e_is_zero_l:  forall a, In a s ->  op e a = a;
   e_is_zero_r:  forall a, In a s ->  op a e = a;
   i: A -> A;
   i_internal: forall a, In a s -> In (i a) s;
   i_is_inverse_l:  forall a, (In a s) -> op (i a) a = e;
   i_is_inverse_r:  forall a, (In a s) -> op a (i a) = e
}.

(**************************************
   The order of a group is the lengh of the support
 **************************************)

Definition g_order  (A: Set) (op: A -> A -> A) (g: FGroup op)  := Z_of_nat (length g.(s)).

Unset Implicit Arguments.

Hint Resolve unique_s internal e_in_s e_is_zero_l e_is_zero_r i_internal
  i_is_inverse_l i_is_inverse_r assoc.

Section FGroup.

Variable A: Set.
Variable op: A -> A -> A.

(**************************************
   Some properties of a finite group
 **************************************)

Theorem g_cancel_l: forall (g : FGroup op), forall a b c, In a g.(s) -> In b g.(s) -> In c g.(s) -> op a b = op a c -> b = c.
intros g a b c H1 H2 H3 H4; apply trans_equal with (op g.(e) b); sauto.
replace (g.(e)) with (op (g.(i) a)  a); sauto.
apply trans_equal with (op (i g a) (op a b)); sauto.
apply sym_equal; apply assoc with g; auto.
rewrite H4.
apply trans_equal with (op (op  (i g a) a) c); sauto.
apply assoc with g; auto.
replace (op (g.(i) a)  a) with g.(e); sauto.
Qed.

Theorem g_cancel_r: forall (g : FGroup op), forall a b c, In a g.(s) -> In b g.(s) -> In c g.(s) -> op b a = op c a -> b = c.
intros g a b c H1 H2 H3 H4; apply trans_equal with (op b g.(e)); sauto.
replace (g.(e)) with (op a (g.(i) a)); sauto.
apply trans_equal with (op (op b  a) (i g a)); sauto.
apply assoc with g; auto.
rewrite H4.
apply trans_equal with (op c (op  a (i g a))); sauto.
apply sym_equal; apply assoc with g; sauto.
replace (op a (g.(i) a)) with g.(e); sauto.
Qed.

Theorem e_unique: forall (g : FGroup op), forall e1, In e1 g.(s) ->  (forall a, In a g.(s) -> op e1 a = a) -> e1 = g.(e).
intros g e1 He1 H2.
apply trans_equal with (op e1 g.(e)); sauto.
Qed.

Theorem inv_op: forall (g: FGroup op) a b, In a g.(s) -> In b g.(s) ->  g.(i) (op a b) = op (g.(i) b) (g.(i) a).
intros g a1 b1 H1 H2; apply g_cancel_l with (g := g) (a := op a1 b1); sauto.
repeat rewrite g.(assoc); sauto.
apply trans_equal with g.(e); sauto.
rewrite <- g.(assoc) with (a := a1); sauto.
rewrite g.(i_is_inverse_r); sauto.
rewrite g.(e_is_zero_r); sauto.
Qed.

Theorem i_e: forall (g: FGroup op), g.(i) g.(e) = g.(e).
intro g; apply g_cancel_l with (g:= g) (a := g.(e)); sauto.
apply trans_equal with g.(e); sauto.
Qed.

(**************************************
   A group has at least one element
 **************************************)

Theorem g_order_pos: forall g: FGroup op, 0 < g_order g.
intro g; generalize g.(e_in_s); unfold g_order; case g.(s); simpl; auto with zarith.
Qed.

End FGroup.


Require Import Coq.Arith.Mult.
Require Import Coq.Arith.Plus.

Definition divides (n m:nat) : Prop := exists (k:nat), k * n = m.

Notation "n | m" := (divides n m) (at level 50).

Definition prime (p:nat) : Prop :=
    (p <> 1) /\ forall (n:nat), n | p -> (n = 1) \/ (n = p).

Lemma div_n_0 : forall (n:nat), n | 0.
Proof. intros n. exists 0. reflexivity. Qed.

Lemma div_0_n : forall (n:nat), 0 | n <-> n = 0.
Proof.
    intros. split; intros H.
    - destruct H as [k H].
      rewrite mult_comm in H. simpl in H. symmetry. assumption.
    - rewrite H. exists 0. reflexivity.
Qed.

Lemma div_n_1 : forall (n:nat), n | 1 <-> n = 1.
Proof.
    intros n. split.
    - intros [k H]. destruct n as [|n].
        + simpl in H. rewrite <- mult_n_O in H. inversion H.
        + destruct n as [|n].
            { reflexivity. }
            { destruct k as [|k].
                { simpl in H. inversion H. }
                { simpl in H. inversion H. }
            }
    - intros H. exists 1. rewrite H. reflexivity.
Qed.


Require Import Arith.
Require Import Monoid.

(* a monoid can be defined from nat 0 and plus *)
Definition NatPlus : Monoid nat := monoid
    0           (* identity  *)
    plus        (* product   *)
    plus_0_l    (* proof_idl *)
    plus_0_r    (* proof_idr *)
    plus_assoc  (* proof_asc *)
    .

(* a monoid can be defined from nat 1 and mult *)
Definition NatMult : Monoid nat := monoid
    1
    mult
    mult_1_l
    mult_1_r
    mult_assoc
    .

(*
Check NatPlus.
Check identity  NatPlus.
Check product   NatPlus.
Check proof_idl NatPlus.
Check proof_idr NatPlus.
Check proof_asc NatPlus.

Check NatMult.
Check identity  NatMult.
Check product   NatMult.
Check proof_idl NatMult.
Check proof_idr NatMult.
Check proof_asc NatMult.
*)

Example plus_identity_test : identity NatPlus = 0.
Proof. reflexivity. Qed.

Example plus_product_test : forall n m: nat, product NatPlus n m = n + m.
Proof. reflexivity. Qed.

Example mult_identity_test : identity NatMult = 1.
Proof. reflexivity. Qed.

Example mult_product_test : forall n m: nat, product NatMult n m = n * m.
Proof. reflexivity. Qed.


Require Import Arith JMeq FiniteTypes Substitution.
Require Import Containers Max Eqdep.

(** * Vectors - lists with finite length *)

Set Implicit Arguments.

Section Vectors.

 Variable X : Type.

 Inductive Vec  : nat -> Type :=
  | vnil : Vec 0
  | vcons : forall (n : nat) , X ->  Vec n -> Vec (S n).

 (** concatenating two vectors *)
 Fixpoint vPlus (n m : nat)(i : Vec n) (j :  Vec m) {struct i}:  Vec (n + m) :=
 match i as e in (Vec n) return (Vec (n + m)) with
 | vnil => j
 | vcons _ x i' => vcons  x (vPlus i' j)
 end.

 (** concatenation is commutative  *)
 Lemma vPlus_comm (n m nm : nat) (i : Vec n) (j : Vec m) (k : Vec nm) :
  JMeq (vPlus (vPlus i j) k) (vPlus i (vPlus j k)).
 Proof.
  induction i; simpl; auto.
  intros j k.
  exact (dp_rwt Vec
         (fun (z : nat)  (px : Vec z) =>
             JMeq (vcons x px)
                      (vcons x (vPlus i (vPlus j k))) )
         (plus_assoc n m nm) (sym_JMeq (IHi j k))
        (JMeq_refl (vcons x (vPlus i (vPlus j k))))
         ).
 Qed.

 (** case non-standard eliminators for Vec 0 and Vec (S n)  *)
 Inductive VNil : Vec 0 -> Type := isvnil : VNil vnil.

  Inductive VCons (n : nat) : Vec (S n) -> Type :=
   isvcons : forall (a :X ) (i : Vec n), VCons (vcons a i) .

  Definition vNil (i : Vec 0): VNil i :=
  match i in Vec t return match t return Vec t -> Set with
                               | O => @VNil
                               | _ => fun _ => unit
                               end i with
  | vnil => isvnil
  | _ => tt
  end.

  Definition vCons (n : nat) (i : Vec (S n)) : VCons i :=
   match i in Vec t return match t return Vec t -> Type with
                           | S _ => @VCons _
                           | _   => fun _ => unit
                           end i with
  | vcons _ x j => isvcons x j
  | _ => tt
  end.

 (** compute a constant vector of some required size*)
 Fixpoint vec (n : nat) (x: X) : Vec n :=
   match n as e return (Vec e) with
   | O => vnil
   | S n' => vcons x (vec n' x)
   end.

 (** head and tail  *)
 Definition vhead n (i : Vec (S n)) : X :=
    match vCons i with
    | isvcons a _ => a
    end.

 Definition vtail n (i : Vec (S n)) :  Vec n :=
  match vCons i with
  | isvcons _ a => a
  end.

 (** and dually, first and last *)
  Fixpoint vfirst_aux n a (v : Vec n) : Vec n :=
    match v in Vec e return (Vec e)  with
    | vnil => vnil
    | vcons _ x xs => vcons a (vfirst_aux x xs)
    end.

  (* removes the last element of a vector *)
  Definition vfirst n (v : Vec (S n)) := vfirst_aux (vhead v) (vtail v).

  Fixpoint vlast_aux n a (v : Vec n) :=
    match v with
    | vnil => a
    | vcons _ x xs => vlast_aux x xs
    end.

  (* returns the last element of a vector  *)
  Definition vlast n (v : Vec (S n)) := vlast_aux (vhead v) (vtail v).

  (* Vsnoc - adds an element to the end of a vector  *)
  Fixpoint vSnoc n (a : X) (v : Vec n) : Vec (S n) :=
     match v in Vec n return Vec (S n) with
     | vnil => vcons a vnil
     | vcons _ x xs => vcons x (vSnoc a xs)
     end.

 (** reverse a vector  *)
  Fixpoint vrev n (v : Vec n) : Vec n :=
    match v in Vec n return Vec n with
    | vnil => vnil
    | vcons _ b bs => vSnoc b (vrev bs)
    end.

 (**
-----
Some properties of vrev, vSnoc, vfirst and vlast *)
(* vrev is involutive *)
  Lemma vrevSnoc : forall  n (x : X) (v : Vec n), vrev (vSnoc x v) = vcons x (vrev v).
  Proof.
    induction v; simpl; auto.
    rewrite IHv; simpl; trivial.
  Qed.

 (** vrev is involutive  *)
 Lemma vrev_inv : forall n (v : Vec n), vrev (vrev v) = v.
 Proof.
   induction v; simpl; trivial.
   rewrite (vrevSnoc x (vrev v)); rewrite IHv; trivial.
 Qed.

 Lemma vlast_vcons : forall  n (x : X) (v : Vec (S n)), vlast (vcons x v) = vlast v.
 Proof.
   intros. destruct (vCons v); unfold vlast; unfold vhead; unfold vtail; simpl; trivial.
 Qed.

 Lemma vfirst_vcons : forall  n (x : X) (v : Vec (S n)), vfirst (vcons x v) = vcons x (vfirst v).
 Proof.
   intros. destruct (vCons v); unfold vfirst; unfold vhead; unfold vtail; simpl; trivial.
 Qed.

 Lemma vlast_vSnoc : forall  n (x : X) (v : Vec n), vlast (vSnoc x v) = x.
  induction v; simpl; trivial;  rewrite (vlast_vcons x0 (vSnoc x v)); trivial.
 Qed.

 Lemma vfirst_vSnoc : forall  n (x : X) (v : Vec n), vfirst (vSnoc x v) = v.
  induction v; simpl; trivial. rewrite (vfirst_vcons x0 (vSnoc x v));
  rewrite IHv; trivial.
 Qed.

 Lemma vlast_rev n (v : Vec (S n)):  vhead v = vlast (vrev v).
 Proof.
    intros n v; unfold vhead;  destruct (vCons v);  simpl.
    rewrite (vlast_vSnoc a (vrev i));  trivial.
 Qed.

 Lemma vfirst_rev n (v : Vec (S n)):  vrev (vtail v) = vfirst (vrev v).
 Proof.
   intros n v; unfold vtail; destruct (vCons v); simpl. rewrite (vfirst_vSnoc a  _); trivial.
 Qed.

 (** fold for vectors *)
 Fixpoint vfold n ( B : Type) (f : X -> B -> B) (b : B) (v : Vec  n) : B :=
   match v with
   | vnil => b
   | vcons _ a ass => f a (vfold f b ass)
   end.

  (** Non-standard eliminator for  View (n + m) *)
  Inductive vPlusView (n m : nat) : Vec (n + m) -> Type :=
   | vplus : forall (i : Vec n) (j : Vec m), vPlusView n m (vPlus i j).

  Fixpoint vplusView (n m : nat) : forall i : Vec (n + m), vPlusView n m i :=
    match n as e return (forall i : Vec (e + m), vPlusView e m i) with
    | O    => fun i => vplus vnil i
    | S n' => fun i =>
          match (vCons i) in (VCons k) return (vPlusView (S n') m k) with
          | isvcons a i0 => let v0 := vplusView _ m i0 in
             match
             v0 in (vPlusView _ _ v1) return (vPlusView (S n') m (vcons a v1))
             with
             | vplus i1 j => vplus (vcons a i1) j
             end
         end
    end.

 (* Definition vTimes n m (i : Vec n) (j :  Vec m) : Vec (n * m).
    intros n m i; induction i; simpl.
    exact (fun _ => vnil ).
    intros h. exact (vPlus h (IHi h)).
  Defined. *)

 (*
  Fixpoint vTimes n m (i : Vec n) (j : Vec m)  : Vec (n * m) :=
    match i in Vec e return  Vec (e * m) with
    | vnil =>  vnil
    | vcons _ _ i1 =>  vPlus j (vTimes  i1 j)
    end.

Inductive VecTimes (n m : nat)  : Vec (n * m) -> Type :=
  |isVecPair : forall (i : Vec n) (j : Vec m) , VecTimes n m (vTimes i j).

 Definition vectimes ( n m : nat)  : forall i : Vec (n * m), VecTimes n m i.
    cut (forall m  (i : Vec 0), VecTimes 0 m i). intro.
    induction n. simpl in *.  exact (X0 ).
    intros. cut (Vec (S n * m) -> Vec (S (n * m))).
    intro H. simpl in *. destruct (vCons (H i)). clear i0.
    destruct (vplusView m (n * m) i).
    destruct (IHn m j).  set  (isVecPair (m :=m)  (vcons a i0) ). simpl in v.
    exact v.
    simpl in i.

    cut ( forall   (i : Vec 0) ( j : Vec m) , VecTimes 0 m (vTimes i j)  -> VecTimes 0 m i).
    intros. induction m; simpl.
    exact (X0 i vnil (isVecPair (m := 0)  i vnil) ).

  *)

 (* decomposiiton i nterms of vhead and vtail *)
 Lemma vec_decompose : forall n (v : Vec (S n)), v = vcons (vhead v) (vtail v).
 Proof.
   intros n v; destruct (vCons v); auto.
 Qed.

  (* decompositon in terms of vSnoc, vlast and vfirst *)
   Lemma vVsnoc n (v : Vec (S n)) : v = vSnoc (vlast v) (vfirst v).
   Proof.
     intros n v; destruct (vCons v) . generalize a; unfold vlast; unfold vfirst;
     unfold vhead; unfold vtail; simpl.
    induction i ; simpl; trivial. intros; rewrite (IHi x); trivial.
  Qed.

 (** * Equality  *)
 Definition vecEq1 (n : nat) (H : forall x y : X, {x = y}+{x <> y}) (i j: Vec n) : bool.
  intros n H i; induction i. intro j; destruct  j.
  exact true. exact false. intro j; destruct (vCons j).
  destruct (H x a) as [l | r]. exact (IHi i0). exact false.
 Defined.

 Lemma VecEq1_sym (n : nat) (H : forall x y : X, {x = y}+{x <> y}) (i j: Vec n) :
   vecEq1 H i j = true -> vecEq1 H j i = true.
 Proof.
   induction i. intro j; destruct (vNil j); trivial.
   intro j; destruct (vCons j); simpl.
   destruct (H x a); subst. intros. destruct ( H a a).
   apply (IHi i0 H0). case (n0 (refl_equal a)).
   intro h; discriminate h.
 Qed.

 Lemma vecEq1_and (n m : nat) (H :forall x y : X, {x = y}+{x <> y}) (i i1 : Vec n) (j j1 : Vec m) :
  vecEq1 H i i1 = true -> vecEq1 H j j1 = true -> vecEq1 H (vPlus i j) (vPlus i1 j1) = true.
 Proof.
   induction i. intros. destruct (vNil i1); simpl in *. trivial.
   intros. destruct (vCons i1); simpl in *.
   destruct ( H x a). exact (IHi i0 j j1 H0 H1). exact H0.
 Qed.

 Lemma vec_and_Eq1 (n m : nat) (H :forall x y : X, {x = y}+{x <> y}) (i i1 : Vec n) (j j1 : Vec m) :
  vecEq1 H (vPlus i j) (vPlus i1 j1) = true -> vecEq1 H i i1 = true /\ vecEq1 H j j1 = true .
 Proof.
   induction i. intros. destruct (vNil i1); simpl in *. auto.
   intros. destruct (vCons i1); simpl in *.
   destruct ( H x a). exact (IHi i0 j j1 H0).
   discriminate  H0.
 Qed.

 Fixpoint vecEqBool (n : nat) ( H : X -> X -> bool) (i  : Vec n) {struct i} : Vec n -> bool :=
   match i in Vec e return Vec e -> bool with
   | vnil => fun _ => true
   | vcons _ a ls => fun x => match vCons x with
                            | isvcons b bs => if H a b then
                                                 vecEqBool H ls bs
                                               else false
                            end
   end.

 Lemma vecEqBool_and (n m : nat) (H : X -> X -> bool) (i i1 : Vec n) (j j1 : Vec m) :
  vecEqBool H i i1 = true -> vecEqBool H j j1 = true ->  vecEqBool H (vPlus i j) (vPlus i1 j1) = true.
 Proof.
   induction i. intros. destruct (vNil i1); simpl in *. trivial.
   intros. destruct (vCons i1); simpl in *.
   destruct ( H x a). exact (IHi i0 j j1 H0 H1). exact H0.
 Qed.

 Lemma VecInj1 : forall (n : nat) (a a1 : X) (i j : Vec n), vcons a i = vcons a1 j -> a = a1.
  Proof.
    intros. injection H; auto.
  Qed.

 Definition vecEqDec (n : nat) (H : forall x y : X, {x = y}+{x <> y}): forall (i j: Vec n), {i = j}+{i <> j} .
   induction i. intro j; destruct (vNil j).
   left; trivial. intro j; destruct (vCons j).
   destruct (H x a); subst. destruct (IHi i0); subst. left ;trivial.
   right.
    cut (forall (n : nat) (i j : Vec (S n)),
    i = j -> vtail i = vtail j). intros.
   intro h;  set (r := H0 n (vcons a i) (vcons a i0) h); simpl in r.
   case (n0 r). intros. case H0; trivial.
   right. intro h; case (n0 (VecInj1 h)).
 Defined.

 Definition vecEq (n m : nat) (H : forall x y : X, {x = y}+{x <> y}) (i : Vec n) (j : Vec m) : bool.
  intros n m; destruct (eq_nat_dec n m) as [l | r].
  destruct l. exact (fun H i j => vecEq1 H i j).
  intros; exact false.
 Defined.

  Definition vecEq_bool (n m : nat)  (H : X -> X -> bool) (i : Vec n) (j : Vec m) : bool.
  intros n m; destruct (eq_nat_dec n m) as [l | r].
  destruct l. exact (fun H i j => vecEqBool H i j).
   exact (fun _ _ _ => false).
 Defined.

 Definition VecEQt (n  : nat) (H : forall x y : X, {x = y}+{x <> y})(i j: Vec n) :  vecEq1 H i j = true -> vecEq H i j = true.
 Proof.
  intros. unfold vecEq. replace (eq_nat_dec n n) with (left (n <> n) (refl_equal n)); auto.
  destruct (eq_nat_dec n n); trivial. rewrite (UIP_refl nat n e); trivial.
  case (n0 (refl_equal n)).
 Defined.

 Definition eqvecEqn (n : nat) (H : forall x y : X, {x = y} + {x <> y}) (i j : Vec n) : vecEq H i j = true -> i = j.
 Proof.
   induction i. intro j;  destruct (vNil j); trivial.
   intros. destruct (vCons j). unfold vecEq in H0.
   destruct (eq_nat_dec (S n) (S n)).
   rewrite  (UIP_refl nat (S n) e) in H0.
   destruct (H x a); simpl in *; subst.
   destruct (H a a). case (IHi i0 (VecEQt H i i0 H0)); trivial.
   discriminate H0. destruct (H x a) as [l | r ]. case (n0 l).
   discriminate H0.
   discriminate H0.
 Defined.

  Definition eqvecEq (n m : nat) (H : n = m) (H : forall x y : X, {x = y} + {x <> y})
   (i : Vec n) (j : Vec  m) : vecEq H i j  =  true ->  JMeq i  j.
    intros n m H; case H. intros. case (eqvecEqn H0 i j H1); trivial.
  Defined.

  Lemma VeqInj2 : forall (n : nat) (v1 v2 : Vec (S n)), v1 = v2 -> vhead v1 = vhead v2 /\ vtail v1 = vtail v2.
  Proof.
    intros until v2. intro H; destruct H.
    destruct (vCons v1); simpl. auto.
  Qed.

End Vectors.

  Fixpoint vmap (n : nat)  (A B : Set) (f : A -> B) (i : Vec A n) {struct i} :
     Vec B n :=
   match i in (Vec _ e) return (Vec B e) with
   | vnil => vnil B
   | vcons _ x xs => vcons (f x) (vmap f xs)
   end.

 Lemma vplusMap  (A B : Set) (n m : nat)  (f : A -> B)
  (i : Vec A n) (j : Vec A m) :  vPlus (vmap f i) (vmap f j) = vmap f (vPlus i j).
 Proof.
   induction i; simpl; trivial.
   intros. rewrite (IHi j); trivial.
 Qed.

 Fixpoint vApp (X Y : Type) (n : nat) (i :  Vec (X -> Y) n ) {struct i} :
      Vec X n -> Vec Y n :=
   match i in (Vec _ e) return Vec X e -> Vec Y e with
   | vnil => fun _ => vnil Y
   | vcons _ F fi => fun i =>
                  match vCons i with
                  | isvcons x xs => vcons (F x) (vApp fi xs)
                  end
   end.

 (** Matrix transpose*)
 Fixpoint vXpose (X : Type) (i j :nat) (a : Vec (Vec X j) i) {struct a} : Vec (Vec X i) j :=
  match a in (Vec _ e1) return Vec (Vec X e1) _ with
  | vnil => vec j (vnil X)
  | vcons n x xs =>
       vApp (vApp (vec j (vcons (X := X) (n := n) )) x) (vXpose xs)
  end.

Section VecFin.
(** Vectors and Finite Sets *)
 Fixpoint vecfin (A : Type) (n : nat) (i : Vec A n) {struct i} :  Fin n -> A :=
   match i in (Vec _ e) return (Fin e -> A) with
   | vnil  => fun x =>  match (fin_0_empty x) return A with end
   | vcons _ a i => fun j =>  match finSN j with
                            | isfz => a
                            | isfs j' => vecfin i j'
                            end
   end.

 Fixpoint finVec A (n : nat) {struct n} : (Fin n -> A) -> Vec A n :=
  match n as e return ((Fin e -> A) -> Vec A e) with
  | O => fun _ => (vnil A)
  | S n'  => fun f => vcons (f (fz n')) (finVec (fun i => f (fs i)))
  end.

(* Isomorphism extends to dependent sums : \Sigma n : nat. Fin n -> X *)
(* Here we use the extension of a container for lists *)
 Definition extVec (i : Ext (ucont Fin) nat) : Vec nat (u i) := finVec (f i).

 Definition vecExt  (n: nat) (i : Vec nat n) := uext (ucont Fin) n (vecfin i) .

 Lemma finVecfin A (n : nat) : forall (i : Vec A n), finVec (vecfin i) = i.
 Proof.
   induction i; simpl; trivial.
   rewrite <- (extensionality (vecfin i) (fun i0 => vecfin i i0) (fun x => refl_equal (vecfin i x))).
   pattern i at 2; rewrite <- IHi; trivial.
 Qed.

 Lemma vecFinVec A (n : nat):
   forall (i : Fin n -> A), vecfin (finVec i) = i.
   induction n; simpl; auto.
   intros.  apply (extensionality (fun x : Fin 0 => match fin_0_empty x return A with
                     end) i).
   intro a; inversion a. intros.  apply extensionality .
   intro a; destruct (finSN a); trivial.
   rewrite (IHn (fun x => i (fs x))); subst; trivial.
 Qed.

 Lemma finVecEQ A (n : nat): forall  (i j : Fin n -> A), (finVec i) = (finVec j) ->  i = j.
   intros A n i j H; set (r := f_equal (vecfin (A := A) (n := n)) H); simpl in r.
   rewrite (vecFinVec i) in r; rewrite (vecFinVec j) in r; trivial.
 Qed.

 Lemma vecJmeq X (n m : nat) (h : n = m)  (F : Fin n -> X) (G : Fin m -> X) : JMeq (finVec F) (finVec G) -> JMeq F G.
  intros X n m h; destruct h. intros F G h.
  replace F with (vecfin (finVec F)).  replace G with (vecfin (finVec G)).
  case (JMeq_eq h); trivial. apply vecFinVec. apply vecFinVec.
 Defined.

 Lemma ExtVecN X (n m : nat) (H : n = m) (F : Fin n -> X) (G : Fin m -> X) :
   (forall (x : Fin n) (x1 : Fin m), JMeq x x1 -> JMeq (finVec F) (finVec G))-> JMeq F G.
   intros X n m h; destruct h.
   intros F G H. apply (dextensionality Fin (refl_equal n) F G) .
   intros x y h; case (JMeq_eq h). case (finVecEQ F G (JMeq_eq (H x y h))); trivial.
  Qed.

 Lemma finVecJMeq A (n m : nat) (H : n = m)
                 (i : Fin n -> A) (j : Fin m -> A)
                 (H0 : JMeq (finVec i) (finVec j)) (ix : Fin n) (jx : Fin m):
                 JMeq ix jx -> i ix = j jx.
 Proof.
   intros A n m H; case H. intros F G H0; case (finVecEQ F G (JMeq_eq H0)).
   intros i j H1; case (JMeq_eq H1); trivial.
 Qed.

  (** Indexing a vector by a fnite type *)
  Fixpoint vecIn X n (i : Fin n) : Vec X n -> X :=
    match i in (Fin e) return Vec _ e -> X with
    | fz _ => fun v => match vCons v with
                       | isvcons x _ => x
                       end
    | fs _ i => fun v => match vCons v with
                       | isvcons _ j => vecIn i j
                       end
    end.

   (** indexing a vector from the last element *)
  Definition rev_ind X  (n : nat) (i : Fin n) (v : Vec X n) := vecIn (rv i) v.

  (* this belongs to the vectors file *)
  Lemma vecfin_emb A n (i : Fin n) (v : Vec A (S n)) : vecfin v (emb i) = vecfin (vfirst v) i.
    induction i; intros; repeat (match goal with
                                | [ v : Vec _ (S _ ) |- _ ] =>  destruct (vCons v)
                                end); simpl. unfold vhead; simpl; trivial.
     generalize (IHi (vcons a0 i0)); simpl. intro h; rewrite h.
    unfold vfirst; unfold vhead; unfold vtail; simpl; trivial.
  Qed.

  Lemma vecfin_tp A n  (v : Vec A (S n)) : vecfin v (tp n) =  vlast v.
  Proof.
    induction n; intros ; repeat (match goal with
                                | [ v : Vec _ (S _ ) |- _ ] =>  destruct (vCons v)
                                | [ v : Vec _ 0 |- _ ] =>  destruct (vNil v)
                                end); simpl.  unfold vlast; simpl; trivial.
    generalize (IHn (vcons a0 i)); simpl. intro h; rewrite h.
   unfold vlast; unfold vhead; unfold vtail; simpl; trivial.
  Qed.

End VecFin.

Section Tuples.

 Variable A: Type.
 (** * Vectors as Tuples *)
  Fixpoint Tuple (n:nat){struct n}: Type :=
  match n with
  O => unit
  | (S n') => (A*(Tuple n'))%type
  end.

 (* Vector is a n-tuple *)
 Fixpoint tup2vec n :  Tuple n -> Vec A n :=
   match n as n return Tuple n -> Vec A n with
   | O => fun _ => vnil _
   | S m => fun tp => vcons (fst tp) (tup2vec _ (snd tp))
   end.

 Fixpoint vec2tup n (i : Vec A n) : Tuple n :=
    match i in (Vec _ e) return Tuple e with
    | vnil => tt
    | vcons _ x xs => (x, (vec2tup xs))
   end.

 Fixpoint tuple_proj (n:nat){struct n}: forall k:nat, k<n -> Tuple n -> A :=
  match n return (forall k:nat, k<n -> Tuple n -> A) with
  O => fun (k:nat)(h:k<O)(v:Tuple 0) =>
         match (lt_n_O k h) return A with end
  | (S n') => fun k:nat =>
              match k return (k<(S n') -> Tuple (S n') -> A) with
                O => fun (h:0<(S n'))(v:Tuple (S n')) => (fst v)
              | (S k') => fun (h:S k' < S n')(v:Tuple (S n')) =>
                            (tuple_proj (lt_S_n k' n' h) (snd v))
              end
 end.

End Tuples.

Section Function_Tuples.

   Variables A B: Type.

   Fixpoint mult_app (n:nat){struct n}: Tuple (A->B) n -> A -> Tuple B n :=
     match n return Tuple (A->B) n -> A -> Tuple B n with
       0 => fun (f:unit)(a:A) => tt
       | (S n') => fun (f:(A->B)*(Tuple (A->B) n')) (a:A)
                     => let (f0,f'):=f in (f0 a, mult_app n' f' a)
     end.

End Function_Tuples.

 (** * Exporting notations and tactics *)

 (* Infix " >>> " := vmap (at level 20) : Vec_scope.
  Infix " `+` " := vPlus (at level 20) : Vec_scope.
  Notation "v !! i" := (vecfin v i) (at level 20) : Vec_scope.
  Open Scope Vec_scope. *)

  (* decompose vCons, VNil and Vplus automatically *)
  Ltac vNil_vcons H x  :=
        match x with
        | context [?a + ?b] =>  destruct (vplusView a b H)
        | 0    => destruct (vNil H)
        | _ => destruct (vCons H)
        end.

   Ltac vecRwt :=
      match goal with
      | [ |- context[vrev (vrev ?v)]] => let R := constr:(vrev_inv v) in rewrite R
      | [|- context[vrev (vSnoc ?x ?v)]] => let R := constr:(vrevSnoc x v) in rewrite R
      | [ |- context[vlast (vcons ?x ?v)]] => let R := constr:(vlast_vcons x v) in rewrite R
      | [ |- context[vlast (vSnoc ?x ?v)]] => let R := constr:(vlast_vSnoc x v) in rewrite R
      | [ |- context[vfirst (vcons ?x ?v)]] => let R := constr:(vfirst_vcons v) in rewrite R
      | [ |- context[vfirst (vSnoc ?x ?v)]] => let R := constr:(vfirst_vSnoc x v) in rewrite R
      | [ |- context[vlast (vrev ?v)]] => let R := constr:(vlast_rev v) in rewrite <- R
      | [ |- _] =>
            match goal with
            | [ |- context[vPlus (vmap ?F v) (vmap _ ?h)]] =>
                     let R := constr:(vplusMap F v h) in rewrite R
             end
      end.

   (* simpliy cases with vhead, vtail, vplus and do rewrites *)

   Ltac vSimp_aux :=
        match goal with
       | [ H : Vec _ ?n |- _ ] => vNil_vcons H n
       | [ |- context[vhead v]] =>  unfold vhead; simpl
       | [ |- context[vtail v]] =>  unfold vhead; simpl
       | [ H : ?X |- _ ] => match X with
                            | context[vhead] =>  unfold vhead in *; simpl in *
                            | context[vtail] =>  unfold vhead in *; simpl in *
                            | context[vfirst] =>  unfold vfirst in *; simpl in *
                            | context[vlast] =>  unfold vlast in *; simpl in *
                            end
       end.
   Ltac vSimp := repeat vecRwt; repeat vSimp_aux.


(* 1.1 *)

Definition negb (b: bool) := if b then false else true.

Definition andb (b1 b2: bool) := if b1 then b2 else false.

Eval compute in  (fun x:bool => negb (andb false x)).
Eval compute in  (fun x:bool => negb (andb x false)).

(* 1.2 *)

Parameter (A B : Type) (t1:A) (t2:B).

Fail Definition g {A B} (b:bool) := match b with true => t1 | false => t2 end.

Definition g (b:bool)  :=
	match b return (if b then A else B) with true => t1 | false => t2
end.

Eval compute in (g true).
Eval compute in (g false).

Definition g2 (b:bool) :=
	match negb b as b0 return (if b0 then B else A) with true => t2 | false => t1
end.

(* 1.3 *)

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

Lemma even_is_double : forall n, even n -> exists m, n=m+m.
Proof.
	intros.
	induction H.
	- exists 0.
	  intuition.
	- destruct IHeven.
	  exists (S x).
	  rewrite H0.
    simpl.
    intuition.
Qed.

Lemma even_is_double' : forall n,
(even n -> exists m, n=m+m) /\ (even (S n) -> exists m, n=S(m+m)).
Proof.
  intro.
  induction n; split; intro.
  - exists 0. intuition.
  - inversion H.
  - destruct IHn.
    specialize (H1 H).
    destruct H1.
    exists (S x).
    simpl.
    rewrite H1.
    intuition.
  - destruct IHn.
    inversion H.
    specialize (H0 H3).
    destruct H0.
    exists (x).
    f_equal.
    assumption.
Qed.

Require Import List.
Import ListNotations.

Fixpoint belast (x:nat) (l: list nat) : list nat :=
  match l with
  |[] => []
  |y::l => x::(belast y l)
  end.

Lemma length_belast (x : nat) (s : list nat) : length (belast x s) = length s.
Proof.
  revert x.
  induction s.
  - unfold belast. reflexivity.
  - intro.
    simpl.
    specialize (IHs a).
    f_equal.
    assumption.
Qed.

Fixpoint skip (l : list nat) : list nat :=
  match l with
  |x::(y::ll) => x:: skip (ll)
  |_=> []
end.

Parameter (x y z : nat).
Eval compute in (skip [x;y;z]).
Eval compute in (belast y (skip [x;y;z])).

Require Import Lia.

Lemma length_skip :
forall l, 2 * length (skip l) <= length l.
Proof.
  fix H 1.
  intro.
  destruct l; simpl.
  - trivial.
  - destruct l; simpl.
    * auto.
    * specialize (H l).
      lia.
Qed.

Fixpoint prodn (A:Type) (n:nat) : Type :=
  match n with
  |0 => unit
  |1 => A
  |S n => prod A (prodn A n)
  end.

Eval compute in (prodn nat 10).

Fixpoint length {A:Type} (l:list A) : nat :=
  match l with
  |[] => 0
  |h::t => S (length t)
  end.

Fixpoint embed {A:Type} (l:list A) : prodn A (length l) :=
  match l return prodn A (length l) with
  |[] => tt
  |x::l' =>
    let p' : prodn A (length l') := embed l' in
    let h : prodn A (length l') -> prodn A (length (x::l')) :=
      match l' with
      |[] => fun _:unit => x
      |x2::ll =>
        fun p' : prodn A (length (x2::ll)) =>
        (x,p')
      end
    in
    h p'
  end.

Eval compute in (embed [1;5;6;8;7;6;3;4]).


Require Import ssreflect.
Set Implicit Arguments.
Set Asymmetric Patterns.

Inductive natural : Set :=
  | O : natural
  | S : natural -> natural.

Fixpoint plus (a : natural) (b : natural) : natural :=
  match a with
  | O => b
  | S n => S (plus n b)
  end.
Notation "a +++ b" := (plus a b) (at level 50, left associativity).

Axiom a_plus_one : forall a, a +++ S O = S a.
Axiom a_plus_s_b : forall a b, a +++ S b = S (a +++ b).

Lemma o_plus_a : forall a, O +++ a = a.
Proof. done. Qed.

Lemma a_plus_o : forall a, a +++ O = a.
Proof. by elim => > //= ->. Qed.

Example two_plus_two : S (S O) +++ S (S (S O)) = S (S (S (S (S O)))).
Proof. done. Qed.

Lemma plus_comm : forall a b, a +++ b = b +++ a.
Proof.
  elim => [| a IHa] b;
    by [rewrite a_plus_o | rewrite a_plus_s_b -IHa].
Qed.

Lemma s_a_plus_b : forall a b, S a +++ b = S (a +++ b).
Proof. done. Qed.

Lemma plus_assoc : forall a b c, a +++ (b +++ c) = (a +++ b) +++ c.
Proof.
  move => a + c; elim=> /= [| b IHb].
  - by rewrite a_plus_o.
  - by rewrite a_plus_s_b IHb a_plus_s_b s_a_plus_b.
Qed.

Lemma s_a_eq_s_b : forall a b, S a = S b -> a = b.
Proof.
  (* TODO: replace inversion by ssreflect more natural (haha) approach *)
  move => > succ_eq; by inversion succ_eq.
Qed.

Lemma a_eq_b : forall a b, a = b -> S a = S b.
Proof. by move => > ->. Qed.

Fixpoint mul (n : natural) (m : natural) : natural :=
  match n with
  | O => O
  | S num => m +++ (mul num m)
  end.
Notation "A *** B" := (mul A B) (at level 40, left associativity).

Axiom a_mul_o : forall a, a *** O = O.
Axiom a_mul_s_b : forall a b, a *** S b = a +++ (a *** b).

Lemma o_mul_a : forall a, O *** a = O.
Proof. done. Qed.

Lemma a_mul_s_o : forall a, a *** S O = a.
Proof.
  elim => [| a IHa]; by [|rewrite -{2}IHa].
Qed.

Lemma s_o_mul_a : forall a, S O *** a = a.
Proof.
  move => > //=; by rewrite a_plus_o.
Qed.

Lemma mul_comm : forall a b, a *** b = b *** a.
Proof.
  elim => [| a IHa] b; by [rewrite a_mul_o | rewrite a_mul_s_b -IHa].
Qed.

Lemma s_a_mul_b : forall a b, S a *** b = b +++ (b *** a).
Proof.
  elim => /= [| a IHa] b;
    by [rewrite a_mul_o | rewrite a_mul_s_b mul_comm].
Qed.

Lemma mul_distr : forall a b c, a *** (b +++ c) = a *** b +++ a *** c.
Proof.
  move => a + c; elim => [| b IHb].
  - by rewrite a_mul_o.
  - by rewrite a_mul_s_b -plus_assoc -IHb -a_mul_s_b -s_a_plus_b.
Qed.

Lemma mul_assoc : forall a b c, a *** (b *** c) = (a *** b) *** c.
Proof.
  move => a b +; elim => [| c IHc].
  - by rewrite 3! a_mul_o.
  - by rewrite 2! a_mul_s_b; symmetry; rewrite mul_comm mul_distr mul_comm IHc.
Qed.


(* chapter 2 of "coq in a hurry" *)

(* Constants are defined with the Definition keyword *)

Definition example1anon := fun x : nat => x*x+2*x+1.

(* alternative definition, without an anonymous function: *)

Definition example1 (x : nat) := x * x+2 * x+1.

Check example1anon.
Check example1.
(* nat -> nat *)

Compute example1 1.
(* = 4 : nat *)

(* the "Reset" command will force Coq to forget a definition you just made *)

(* Reset example1. *)

(* I'm assuming this is more useful in an interpreter, rather than executing lines in a file *)

(* "Print" will show you the definition of a command *)

Print example1.

(*
  example1 = fun x : nat => x * x + 2 * x + 1
     : nat -> nat

  Argument scope is [nat_scope]
*)

(* booleans are "true" and "false" *)

Require Import Bool.

Compute if true then 3 else 5.

(* = 3 : nat *)

SearchPattern bool.

(*
  "SearchPattern" takes a pattern and returns any symbol whose type finishes with that pattern
  "Search" takes a list of patterns and returns any symbol whose type contains all the patterns in the list

  kind of like a regex search on function signatures
*)

Require Import Arith.

(*
  For natural numbers, we can think of each number as satisfying one of two properties:
  - it is 0
  - it is a successor of some natural number P

  For example, see the is_zero function below, which uses pattern matching to identify if a number is zero or not:
*)

Definition is_zero (n:nat) :=
  match n with
    0 => true
    | S p => false
  end.

(* Recursive functions need to be declared using the keyword "Fixpoint" *)

Fixpoint sum_n n :=
  match n with
    0 => 0
  | S p => p + sum_n p
  end.

Compute sum_n 4.
(*  = 6 : nat *)

(*
  Coq will check that the recursive call to a function occurs on a subterm of the initial argument

  Calling sum_n on (S p) would have thrown an error, instead of running forever
*)

(* We can also use ~deep~ pattern matching: *)

Fixpoint evenb n :=
  match n with
    0 => true
  | 1 => false
  | S (S p) => evenb p
  end.

Compute evenb 6. (* true *)
Compute evenb 7. (* false *)

(* Lists *)

Require Import List.

Check 1::2::3::nil. (* : list nat *)

(* list concatenation: ++ or app *)

Check 1::2::nil ++ 3::nil.
Compute 1::2::nil ++ 3::nil. (* 1::2::3::nil : list nat *)

(* map does what you'd expect *)

Compute map (fun x => x + 3) (1::2::3::nil). (* 4::5::6::nil *)
Compute map S (1::22::3::nil). (* 2::23::4::nil *)

Compute let l := (1::2::3::nil) in l ++ map (fun x => x + 3) l.
(* 1::2::3::4::5::6::nil *)

(* "Search" can give us all known theorems (in scope) that mention a given symbol *)
Search Nat.eqb.

Locate "_ =? _".
(* "x =? y" := Nat.eqb x y : nat_scope (default interpretation) *)

(* exercise: write a function that takes an input n and returns a list with elements 0 through n - 1 *)

Fixpoint list_n n :=
  match n with
    0 => nil
  | S p => p :: list_n p
  end.

Compute list_n 4.

(* Gah! it's backwards. turns out the solution was this: *)
Fixpoint list_n_aux (n:nat)(m:nat) :=
  match n with
    0 => nil
  | S p => m :: list_n_aux p (m+1)
  end.

Definition list_n_solution n := list_n_aux n 0.

Compute list_n_solution 4.

(*
  Exercise on sorting: write two functions:
  - return true if:
    - list length < 2
    - given a :: b :: tail, a < b
  - return true if input list is sorted
*)

Fixpoint first_two_ordered list :=
  match list with
    nil => true
  | head :: nil => true
  | frst :: scnd :: tail => frst <? scnd
  end.

Compute first_two_ordered (1::2::nil).
Compute first_two_ordered (2::nil).
Compute first_two_ordered (3::2::nil).

Search andb.

Fixpoint is_sorted list :=
  match list with
    nil => true
  | head :: nil => true
  | frst :: tail => andb (first_two_ordered list) (is_sorted tail)
  end.

Compute is_sorted (1::2::3::nil).
Compute is_sorted (1::2::3::1::nil).
Compute is_sorted (1::2::nil).
Compute is_sorted (1::nil).

(* Example: count occurrences of element in list *)
Fixpoint count list n :=
  match list with
    nil => 0
  | head :: tail => (if (head =? n) then 1 else 0) + (count tail n)
  end.

Compute count (1::2::3::nil) 1.
Compute count (1::2::3::1::3::4::nil) 3.


Module Playground1.

Inductive bool : Type :=
  | False
  | True
.

Inductive nat : Type :=
  | O : nat
  | S : nat -> nat
.

Definition one := S O.

Definition pred (n: nat) :=
  match n with
  | O => O
  | S n => n
  end.

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

Fixpoint minus (n m:nat) : nat :=
  match n, m with
  | O , _ => O
  | S _ , O => n
  | S n', S m' => minus n' m'
  end.

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

Fixpoint exp (base power : nat) : nat :=
  match power with
    | O => S O
    | S p => mult base (exp base p)
  end.

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.

Fixpoint eq (n m : nat) : bool :=
  match n, m with
  | O, O => True
  | O, S _ => False
  | S _, O => False
  | S n', S m' => eq n' m'
  end.

Fixpoint leq (n m : nat) : bool :=
  match n,m with
  | O, O => True
  | O, S _ => True
  | S _, O => False
  | S n', S m' => leq n' m'
  end.

Definition andb ( n m : bool) : bool :=
  match n,m with
  | True, True => True
  | _, _ => False
  end.
Definition notb (n:bool) : bool :=
  match n with
  | True => False
  | False => True
  end.
Definition orb (n m: bool) : bool :=
  match n,m with
    |False,False => False
    |_,_ => True
  end.

Definition less (n m: nat) : bool :=
  andb  (leq n m) (notb (eq n m ) ).

Example test_less: (less (S(S(S(S O)))) (S(S(S O) ))) = False.
Proof.
simpl.
compute.
reflexivity.
Qed.

(*Now, the real deal!*)

Theorem zero_absorption_l: forall n: nat , O + n = n.
Proof.
intros n.
reflexivity.
Qed.

Theorem one_absorption_l: forall n: nat ,
                            mult  O n = O.
Proof.
intros n.
simpl.
compute.
reflexivity.
Qed.

Theorem plus_id_example: forall n m : nat ,
                           n = m -> n + n = m + m.
Proof.
intros n m.
intros H.
rewrite <- H.
reflexivity.
Qed.

(* Exercise *)

Theorem plus_id_exercise: forall n m o: nat,
                            n=m -> m = o -> n + m = m + o.
intros n m o.
intros H1 H2.
rewrite -> H1.
rewrite -> H2.
reflexivity.
Qed.

(* Exercise *)

Theorem mult_S_1 : forall n m : nat,
                     m = S n ->
                     m * (S O + n) = m * m.
Proof.
intros n m H.
simpl.
rewrite -> H.
reflexivity.
Qed.

Theorem plus_1_neq_0: forall n : nat,
                        eq  (n + one) O = False.
Proof.
intros n.
destruct n as [| n'].
simpl.
reflexivity.
simpl.
reflexivity.
Qed.

Theorem double_negation: forall b : bool,
                           notb (notb b) = b.
Proof.
destruct b as [|b'].
simpl.
reflexivity.
simpl.
reflexivity.
Qed.

(* Exercise *)
Theorem identity_fn_applied_twice: forall
                                     ( f : bool -> bool ),
                                     ( forall (x:bool), f x = x ) ->
                                     forall (b: bool), f (f b) = b.
Proof.
intros f H b.
rewrite -> H.
rewrite -> H.
reflexivity.
Qed.

(* Exercise *)

Theorem not_fn_applied_twice: forall
                                     ( f : bool -> bool ),
                                     ( forall (x:bool), f x = notb x ) ->
                                     forall (b: bool), f (f b) = b.
Proof.
intros f H b.
rewrite -> H.
rewrite -> H.
destruct b as [|b'].
reflexivity.
reflexivity.
Qed.

(* Exercise  i  failed

Lemma and_with_false: forall (b: bool),
                        and False b = False.
Proof.
intro b.
reflexivity.
Qed.

Lemma or_with_true: forall (b: bool),
                      or True b = True.
Proof.
intro b.
reflexivity.
Qed.

Theorem andb_eq_orb :   forall (b c : bool),
                          (and b c = or b c) ->
                          b = c.

Proof.
  destruct b.
  intros c.
  intros H.
  rewrite <- or_with_true with c.
  rewrite <- H.
  destruct c.
  reflexivity.
  reflexivity.
  intros c.
  intros H.
  rewrite <- andb_always_false with c.
  rewrite -> H.
  destruct c.
  reflexivity.
  reflexivity.
Qed.

Proof.
  destruct b.
intros c H.
rewrite <- and_with_false with c.

  intros b c.
  destruct b. destruct c.
  reflexivity.
  simpl.
  intro H.
reflexivity.
  intro H.
  rewrite H.
reflexivity.
simpl.

reflexivity.

Theorem zero_absorption_r: forall n: nat, n + O = n.
intros n.

compute.
reflexivity.
Qed.

Theorem plus_comm: forall (n m: nat), n + m = m + n.
Proof.

intros n m.*)

End Playground1.


Inductive day : Type :=
  | monday : day
  | tuesday : day
  | wednesday : day
  | thursday : day
  | friday : day
  | saturday : day
  | sunday : day.

Definition next_weekday (d:day) : day :=
  match d with
  | monday    => tuesday
  | tuesday   => wednesday
  | wednesday => thursday
  | thursday  => friday
  | friday    => monday
  | saturday  => monday
  | sunday    => monday
  end.

Compute (next_weekday friday).

Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.

Proof. simpl. reflexivity. Qed.

Inductive bool : Type :=
  | true : bool
  | false : bool.

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

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

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

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Example test_orb5: false || false || true = true.
Proof. simpl. reflexivity. Qed.

Check true.

Check (negb true).

Check negb.

Inductive rgb : Type :=
  | red : rgb
  | green : rgb
  | blue : rgb.

Inductive color : Type :=
  | black : color
  | white : color
  | primary : rgb -> color.

Definition monochrome (c : color) : bool :=
  match c with
  | black => true
  | white => true
  | primary p => false
  end.

Definition isred (c : color) : bool :=
  match c with
  | black => false
  | white => false
  | primary red => true
  | primary _ => false
  end.

Module NatPlayground.

  Inductive nat : Type :=
  | O : nat
  | S : nat -> nat.

  Definition pred (n : nat) : nat :=
  match n with
    | O => O
    | S n' => n'
  end.

End NatPlayground.

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

Definition minustwo (n : nat) : nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

Compute (minustwo 4).

Check S.
Check pred.
Check minustwo.

Fixpoint evenb (n:nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => evenb n'
  end.

Definition oddb (n:nat) : bool := negb (evenb n).

Example test_oddb1: oddb 1 = true.
Proof. simpl. reflexivity. Qed.
Example test_oddb2: oddb 4 = false.
Proof. simpl. reflexivity. Qed.

Module NatPlayground2.

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

  Compute (plus 3 2).

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

Example test_mult1: (mult 3 3) = 9.
Proof. simpl. reflexivity. Qed.

Fixpoint minus (n m:nat) : nat :=
  match (n, m) with
  | (O , _) => O
  | (S _ , O) => n
  | (S n', S m') => minus n' m'
  end.
End NatPlayground2.

Fixpoint exp (base power : nat) : nat :=
  match power with
    | O => S O
    | S p => mult base (exp base p)
  end.

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.

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.

Example test_leb1: (leb 2 2) = true.
Proof. simpl. reflexivity. Qed.
Example test_leb2: (leb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_leb3: (leb 4 2) = false.
Proof. simpl. reflexivity. Qed.

Notation "x + y" := (plus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x - y" := (minus x y)
                       (at level 50, left associativity)
                       : nat_scope.
Notation "x * y" := (mult x y)
                       (at level 40, left associativity)
                       : nat_scope.

Check ((0 + 1) + 1).

Theorem plus_O_n : forall (n : nat), 0 + n = n.
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem plus_1_l : forall  n:nat, 1 + n = S n.
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem mult_0_l : forall  n:nat, 0 * n = 0.
Proof.
  intros n. reflexivity. Qed.

Theorem plus_id_example : forall n m:nat, n = m -> n + n = m + m.
Proof.
  (* move both quantifiers into the context: *)
  intros n m.
  (* move the hypothesis into the context: *)
  intros H.
  (* rewrite the goal using the hypothesis: *)
  rewrite <- H.
  reflexivity. Qed.

Theorem mult_0_plus : forall n m : nat, (0 + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_O_n.
  reflexivity. Qed.

Theorem plus_1_neq_0_firsttry : forall n : nat, beq_nat (n + 1) 0 = false.
Proof.
  intros n.
  simpl. (* does nothing! *)
Abort.

Theorem plus_1_neq_0 : forall n : nat, beq_nat (n + 1) 0 = false.
Proof.
  intros n. destruct n as [| n'].
  - reflexivity.
  - reflexivity. Qed.

Theorem negb_involutive : forall b : bool, negb (negb b) = b.
Proof.
  intros b. destruct b.
  - reflexivity.
  - reflexivity. Qed.

Theorem andb_commutative : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b.
  - destruct c.
    + reflexivity.
    + reflexivity.
  - destruct c.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb3_exchange :
  forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d. destruct b.
  - destruct c.
    { destruct d.
      - reflexivity.
      - reflexivity. }
    { destruct d.
      - reflexivity.
      - reflexivity. }
  - destruct c.
    { destruct d.
      - reflexivity.
      - reflexivity. }
    { destruct d.
      - reflexivity.
      - reflexivity. }
Qed.

Theorem plus_1_neq_0' : forall n : nat, beq_nat (n + 1) 0 = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity. Qed.

Theorem andb_commutative'' :
  forall b c, andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Require Export Basics.


Inductive bool : Type :=
  | true
  | false.

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

Definition andb (b_1 : bool) (b_2 : bool) : bool :=
  match b_1 with
  | true => b_2
  | false => false
  end.

Definition orb (b_1 : bool) (b_2 : bool) : bool :=
  match b_1 with
  | true => true
  | false => b_2
  end.

Compute negb true.
Compute andb true false.

Example test_orb1: orb true false = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: orb false false = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: orb false true = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: orb true true = true.
Proof. simpl. reflexivity. Qed.

(* Notation "! x" := (negb x). *)
Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

Compute true && false.

Definition andb3 (b_1 : bool) (b_2 : bool) (b_3 : bool) : bool :=
  andb b_1 (andb b_2 b_3).

Example test_andb31: andb3 true true true = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: andb3 false true true = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: andb3 true false true = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: andb3 true true false = false.
Proof. simpl. reflexivity. Qed.

Check andb3.

Inductive rgb : Type :=
  | red
  | green
  | blue.

Inductive color : Type :=
  | black
  | white
  | primary (p : rgb).

Definition monochrome (c : color) : bool :=
  match c with
  | black => true
  | white => true
  | primary _ => false
  end.

Compute monochrome (primary blue).

Inductive nat : Type :=
  | O
  | S (n : nat).

Check S.

Inductive bit : Type :=
  | B_0
  | B_1.

Inductive nybble : Type :=
  | bits (b_0 b_1 b_2 b_3 : bit).

Check bits B_0 B_0 B_0 B_0.

Definition all_zero (bits : nybble) : bool :=
  match bits with
  | bits B_0 B_0 B_0 B_0 => true
  | bits _ _ _ _ => false
  end.

Compute all_zero (bits B_0 B_0 B_0 B_0).
Compute all_zero (bits B_0 B_0 B_0 B_1).


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.

(* Exercise snd_fst_is_swap *)

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.

(* Exercise fst_swap_is_snd *)
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) ..).

Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1;2;3].

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.
Example test_app2: nil ++ [4;5] = [4;5].
Proof. reflexivity. Qed.
Example test_app3: [1;2;3] ++ nil = [1;2;3].
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.
Example test_hd2: hd 0 [] = 0.
Proof. reflexivity. Qed.
Example test_tl: tl [1;2;3] = [2;3].
Proof. reflexivity. Qed.

(* Exercise list_funs *)
Fixpoint nonzeros (l:natlist) : natlist :=
  match l with
  | nil => nil
  | O :: t => nonzeros t
  | (S n') :: t => (S n') :: (nonzeros t)
  end.

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

Search oddb.

Compute (oddb 0).

Fixpoint oddmembers (l:natlist) : natlist
  := match l with
  | nil => nil
  | h :: t =>
    match (oddb h) with
    | true => h :: (oddmembers t)
    | false => 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.

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

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

Example test_alternate2:
  alternate [1][4;5;6] = [1;4;5;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.

Compute (beq_nat 3 2).
Compute (1 + 2).

(* Exercise bag_functions *)
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(b1:bag)(b2:bag) : bag :=
  match b1 with
  | nil => b2
  | _ => b1 ++ b2
  end.

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

Definition add(v:nat)(s:bag) : bag :=
  v :: s.

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
  := negb (beq_nat (count v s) 0).

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

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

(* Exercise bag more functions *)
Fixpoint remove_one(v:nat)(s:bag) : bag :=
  match s with
  | nil => nil
  | h :: t =>
    match (beq_nat h v) with
    | true => t
    | false => h :: (remove_one v 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. reflexivity. Qed.

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

Example test_remove_all1: count 5 (remove_all 5 [2;1;5;4;1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_all2: count 5 (remove_all 5 [2;1;4;1]) = 0.
Proof. reflexivity. Qed.
Example test_remove_all3: count 4 (remove_all 5 [2;1;4;5;1;4]) = 2.
Proof. reflexivity. Qed.
Example test_remove_all4: count 5 (remove_all 5 [2;1;5;4;5;1;4;5;1;4]) = 0.
Proof. reflexivity. Qed.

Compute (member 2 [1;2;3]).

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

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

Theorem nil_app : forall l : natlist,
  [] ++ l = l.
Proof. reflexivity. Qed.

Theorem tl_length_pred : forall l : natlist,
  pred (length l) = length (tl l).
Proof.
  intros l. destruct l as [| n l'].
  - reflexivity.
  - 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'].
  - 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 rev.

(* Exercise list_exercise *)

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

Search app.

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

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
  intros l. induction l as [| n l' H].
  - reflexivity.
  - simpl. rewrite -> rev_app_distr.
  rewrite -> H.
  simpl.
  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.
  induction l1 as [| n l' H].
  - simpl.
  rewrite <- app_assoc.
  reflexivity.
  - simpl.
  rewrite -> H.
  reflexivity.
  Qed.

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

(* Exercise beq_natlist *)

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

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 [| n l' H].
  - reflexivity.
  - induction n as [| n'' In].
    + simpl. rewrite H. reflexivity.
    + rewrite In. simpl. rewrite <- H.
    reflexivity.
  Qed.

(* Exercise bag proofs *)
Theorem count_member_nonzero: forall s : bag,
  leb 1 (count 1 (1 :: s)) = true.
Proof.
  intros s. induction s as [| n s' H].
  - reflexivity.
  - simpl. reflexivity.
  Qed.

Theorem ble_n_Sn : forall n,
  leb n (S n) = true.
Proof.
  intros n. induction n as [| n' H].
  - simpl. reflexivity.
  - simpl. rewrite H. 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 [| n s' H].
  - simpl. reflexivity.
  - induction n as [| n' Hn'].
    + simpl. rewrite ble_n_Sn. reflexivity.
    + simpl. rewrite H. reflexivity.
  Qed.

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

Fixpoint nth_bad(l:natlist)(n:nat) : nat :=
  match l with
  | nil => 42
  | a :: l' => match beq_nat n O with
              | true => a
              | false => nth_bad l' (pred n)
              end
  end.

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.

(* Exercise hd error *)

Definition hd_error(l:natlist) : natoption :=
  match l with
  | nil => None
  | h :: _ => 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.

(* Exercise option elim hd *)
Theorem option_elim_hd : forall (l:natlist)(default:nat),
  hd default l = option_elim default (hd_error l).
Proof.
  intros l default.
  induction l as [| n l' H].
  - simpl. reflexivity.
  - simpl. reflexivity.
  Qed.

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

(* Exercise beq_id_refl *)
Theorem beq_id_refl : forall x : id,
  true = beq_id x x.
Proof.
  intros x. destruct x as [n].
  simpl.
  induction n as [| n' H].
  + reflexivity.
  + simpl. rewrite H.
  reflexivity.
  Qed.

Module PartialMap.
Export NatList.

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.

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

(* Exercise update_neq *)
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 d x y o eq.
  simpl. rewrite -> eq.
  reflexivity.
  Qed.

End PartialMap.


Require Import ZArith Div2 Even.
Require Import Psatz.
Require Import Recdef.
Require Import Coq.NArith.BinNat.
Require Import Coq.Program.Wf.
Require Import Coq.NArith.BinNat.

Section Expo.

  Fixpoint power (x : Z) (n : nat) : Z :=
    match n with
    | O => 1%Z
    | S n' => Z.mul x (power x n')
    end.

  Function fast_expo_acc (x acc : Z) (n : nat) {measure (fun i => i) n} : Z :=
    match n with
    | O => acc
    | _ => match even_odd_dec n with
          | left _ => fast_expo_acc (Z.mul x x) acc (div2 n)
          | right _ => fast_expo_acc (Z.mul x x) (Z.mul x acc) (div2 n)
          end
    end.
  Proof.
    intros; apply lt_div2; lia.
    intros; apply lt_div2; lia.
  Defined.

  Definition fast_expo (a : Z) (n : nat) : Z :=
    fast_expo_acc a 1%Z n.

  Lemma power_unit :
    forall m, power 1 m = 1%Z.
  Proof.
    induction m.
    cbn.  auto.
    cbn.  rewrite IHm.
    auto.
  Qed.

  Lemma power_add_dist :
    forall (x : Z) (n m : nat),
      power x (n + m) = Z.mul (power x n) (power x m).
  Proof.
    intros.
    induction n.
    assert (power x 0 = 1%Z). cbn. auto.
    rewrite H.
    replace (0 + m)
      with m by lia.
    lia.
    cbn. rewrite IHn. lia.
  Qed.

  Lemma power_distribute :
    forall (x : Z) (n m : nat),
      power (power x n) m = power x (Nat.mul n m).
  Proof.
    intros x n m.
    revert x n.
    induction m.
    + cbn. intros x n. replace (n * 0) with 0 by lia.
      cbn.  auto.
    + intros x n. cbn.
      replace (n * S m) with (n + n * m) by lia.
      rewrite power_add_dist.
      f_equal. apply IHm.
  Qed.

  Lemma fast_power_acc :
    forall (n : nat) (x ret : Z),
      fast_expo_acc x ret n = Z.mul ret (power x n).
  Proof.
    Opaque Nat.div2.
    induction n using lt_wf_ind; intros.
    rewrite fast_expo_acc_equation.
    destruct n.
    + cbn. lia.
    + destruct (even_odd_double (S n)) as [[H1 H2] [H3 H4]].
      unfold Nat.double in * |-.
      destruct (even_odd_dec (S n)) as [Hl | Hr].
      pose proof (lt_div2 (S n) (Nat.lt_0_succ n)).
      pose proof (H (Nat.div2 (S n)) H0).
      rewrite H5. f_equal.
      assert (Hm : Z.mul x x = power x 2).
      cbn. lia. rewrite Hm.
      rewrite power_distribute.
      replace (2 * Nat.div2 (S n)) with (double (Nat.div2 (S n))).
      pose proof (even_double (S n) Hl). rewrite <- H6. auto.
      unfold double. lia.
      pose proof (lt_div2 (S n) (Nat.lt_0_succ n)).
      pose proof (H (Nat.div2 (S n)) H0 (Z.mul x x) (Z.mul x ret)).
      rewrite H5.
      replace (x * ret * power (x * x) (Nat.div2 (S n)))%Z with
          (ret * (x * power (x * x) (Nat.div2 (S n))))%Z by lia.
      f_equal. cbn. f_equal.
      assert (Hm : Z.mul x x = power x 2).
      cbn. lia. rewrite Hm.
      rewrite power_distribute.
      pose proof (odd_double (S n) Hr).
      assert (n = Nat.double (Nat.div2 (S n))) by lia.
      replace (2 * Nat.div2 (S n)) with (double (Nat.div2 (S n))).
      rewrite <- H7. auto.
      unfold Nat.double.  lia.
  Qed.

  Lemma slow_is_equal_to_fast :
    forall a n, fast_expo a n = power a n.
  Proof.
    unfold fast_expo.
    intros. rewrite fast_power_acc.
    lia.
  Qed.

  Fixpoint expo_recursive (m acc : Z) (p : positive) :=
    match p with
    | xH => Z.mul m acc
    | xO w => expo_recursive (Z.mul m m) acc w
    | xI w => expo_recursive (Z.mul m m) (Z.mul acc m) w
    end.

  Definition expo_acc (m acc : Z) (n : N) : Z :=
    match n with
    | N0 => acc
    | Npos p => expo_recursive m acc p
    end.

  Eval compute in expo_acc 2 1 10.

  Lemma binexpo_equal_power :
    forall a acc n , expo_acc a acc n = Z.mul acc (power a (nat_of_N n)).
  Proof.
    intros a acc n.
    revert a acc.
    destruct n.
    + intros a acc.
      cbn. lia.
    + induction p.
      ++  intros a acc. cbn in *.
          assert (Hm : Z.mul a a = power a 2).
          cbn. lia.
          pose proof (IHp (Z.mul a a) (Z.mul acc a)).
          rewrite H.
          replace (acc * a * power (a * a) (Pos.to_nat p))%Z
            with (acc * (a * power (a * a) (Pos.to_nat p)))%Z by lia.
          f_equal. rewrite Pos2Nat.inj_xI.
          cbn. f_equal.  rewrite Hm.
          rewrite power_distribute.
          replace ((Pos.to_nat p + (Pos.to_nat p + 0))) with
              (2 * Pos.to_nat p) by lia.  auto.
      ++ intros a acc. cbn in *.
         assert (Hm : Z.mul a a = power a 2).
         cbn. lia.
         pose proof (IHp (Z.mul a a) acc).
         rewrite H. f_equal.
         rewrite Pos2Nat.inj_xO.
         rewrite Hm. rewrite power_distribute.
         auto.
      ++ intros a acc. cbn in *.
         rewrite Pos2Nat.inj_1. cbn.
         lia.
  Qed.

  Definition expo (a : Z) (m : N) : Z :=
    expo_acc a 1 m.

  (* Fairly fast. I can't believe Coq is so good at computing stuff.
     Kudos to Inria *)
  Eval compute in expo 2 10000.

  Lemma expo_is_equal_to_power :
    forall a n, expo a n = power a (nat_of_N n).
  Proof.
    intros a n. unfold expo.
    pose proof (binexpo_equal_power a 1 n).
    lia.
  Qed.

End Expo.


(* Chapter 7: Properties of relations *)

Require Export SfLib.

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

(* le:  x <= y *)
Print le.
Check le : nat -> nat -> Prop.
Check le : relation nat.

(* Basic properties of relations *)
Definition partial_function {X:Type} (R:relation X) := forall x y1 y2 : X,
  R x y1 -> R x y2 -> y1 = y2.

Theorem le_not_partial_function: ~ (partial_function le).
Proof.
  unfold not, partial_function. intros.
  assert (0 = 1) as contra.
  Case "proof of contra".
    apply H with (x:=0). apply le_n. apply le_S. apply le_n.
  inversion contra.
Qed.

Definition reflexive {X:Type} (R:relation X) :=
  forall a:X, R a a.

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

Definition transitive {X:Type} (R:relation X) :=
  forall a b c : X, R a b -> R b c -> R a c.

Theorem le_transitive: transitive le.
Proof.
  unfold transitive. intros. induction H0.
  Case "b<=c". apply H.
  Case "b<=S c". apply le_S. apply IHle.
Qed.

Theorem lt_trans: transitive lt.
Proof.
  unfold lt, transitive. intros a b c Hab Hbc.
  apply le_S in Hab. apply le_transitive with (a := (S a)) (b := (S b)) (c := c).
  apply Hab. apply Hbc.
Qed.

Theorem lt_trans': transitive lt.
Proof.
  unfold lt, transitive. intros a b c Hab Hbc. induction Hbc.
  Case "b<=0". apply le_S. apply Hab.
  Case "b<=S". apply le_S. apply IHHbc.
Qed.

Theorem lt_trans'': transitive lt.
Proof.
  unfold lt, transitive. intros n m o Hnm Hmo. induction o.
  Case "o=0". inversion Hmo. apply le_S. apply IHo. inversion Hmo.
Admitted.

Theorem le_Sn_le: forall n m, S n <= m -> n <= m.
Proof.
  intros. apply le_transitive with (S n).
  Case "n<=S n". apply le_S. reflexivity.
  Case "S n <= m". apply H.
Qed.

(* Exercise: * *)
Theorem le_S_n: forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  intros. inversion H. reflexivity.
  apply le_Sn_le. apply H1.
Qed.

(* Exercise: * *)
Theorem le_Sn_n: forall n,
  ~ (S n <= n).
Proof.
  unfold not. intros.
  apply le_Sn_n in H. apply H.
Qed.

Definition symmetric {X:Type} (R:relation X) :=
  forall a b : X, R a b -> R b a.

(* Exercise: ** *)
Theorem le_not_symmetric: ~ (symmetric le).
Proof.
  unfold not, symmetric.
  intros. assert (1 <= 0) as contra.
  Case "proof of assert".
    apply H with (b:=1). apply H. apply H. apply le_S. reflexivity.
  inversion contra.
Qed.

Definition antisymmetric {X:Type} (R:relation X) := forall a b : X,
  R a b -> R b a -> a = b.

(* Exercise: ** *)
Theorem le_antisymmetric: antisymmetric le.
Proof.
  unfold antisymmetric. intros a b Hab Hba.
Admitted.

(* Exercise: ** *)
Theorem le_step: forall n m p,
  n < m -> m <= S p -> n <= p.
Proof.
  intros. apply le_transitive with n.
  Case "n<=n". reflexivity.
  Case "n<=Sn". unfold "<" in H. rewrite H0 in H. apply le_S_n. apply H.
Qed.

Definition preorder {X:Type} (R:relation X) :=
  (reflexive R) /\ (transitive R).

Definition equivalence {X:Type} (R:relation X) :=
  (preorder R) /\ (symmetric R).

(* Really a partial order. Coq stdlib calls it order *)
Definition order {X:Type} (R:relation X) :=
  (preorder R) /\ (antisymmetric R).

Theorem le_order: order le.
Proof.
  unfold order, preorder. split. split.
  Case "refl". apply le_reflexive.
  Case "trans". apply le_transitive.
  Case "antisymmetric". apply le_antisymmetric.
Qed.

(* Reflexive, transitive closure *)
Inductive clos_refl_trans {A:Type} (R:relation A) : relation A :=
  | rt_step  : forall x y, R x y -> clos_refl_trans R x y
  | rt_refl  : forall x, clos_refl_trans R x x
  | rt_trans : forall x y z, clos_refl_trans R x y ->
                             clos_refl_trans R y z ->
                             clos_refl_trans R x z.

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

(* more useful definition of reflexive, transitive closure *)
Inductive refl_step_closure {X:Type} (R:relation X) : relation X :=
| rsc_refl : forall x:X, refl_step_closure R x x
| rsc_step : forall x y z : X, R x y ->
                               refl_step_closure R y z ->
                               refl_step_closure R x z.

Tactic Notation "rt_cases" tactic(first) ident(c) :=
  first; [
    Case_aux c "rt_step"
  | Case_aux c "rt_refl"
  | Case_aux c "rt_trans"
  ].

Tactic Notation "rsc_cases" tactic(first) ident(c) :=
  first; [
    Case_aux c "rsc_refl"
  | Case_aux c "rsc_step"
  ].

(* Need to check that the 2 definitions of reflexive, transitive closure are the
   same
*)
Theorem rsc_R: forall (X:Type) (R:relation X) (x y : X),
  R x y -> refl_step_closure R x y.
Proof.
  intros.
  apply rsc_step with y. apply H. apply rsc_refl.
Qed.

(* Exercise: ** *)
Theorem rsc_trans : forall (X:Type) (R:relation X) (x y z : X),
  refl_step_closure R x y ->
  refl_step_closure R y z ->
  refl_step_closure R x z.
Proof.
  intros. induction H.
  Case "refl". apply H0.
  Case "step". apply IHrefl_step_closure in H0.
Admitted.

(* Exercise: *** *)
Theorem rtc_rsc_coincide: forall (X:Type) (R:relation X) (x y : X),
  clos_refl_trans R x y <-> refl_step_closure R x y.
Proof.
  unfold iff. split. intros.
  Case "->".
Admitted.


Set Warnings "-notation-overriden, -parsing".
Require Export Tactics.
Check 3=3.
Check forall n m: nat, n + m = m + n.
Check 2=2.
Check forall n:nat, n = 2.
Check 3 = 4.
Theorem plus_2_2_is_4:
  2+2=4.
Proof. reflexivity. Qed.
Definition plus_fact: Prop := 2 + 2 = 4.
Check plus_fact.
Theorem plus_fact_is_true: plus_fact.
Proof. reflexivity. Qed.
Definition is_three (n:nat): Prop := n = 3.
Check is_three.
Definition injective {A B} (f: A -> B) :=
  forall x y: A, f x = f y -> x = y.

Lemma succ_inj: injective S.
Proof. intros n m H. inversion H. reflexivity. Qed.
Check @eq.

Example and_example: 3 + 4 = 7 /\ 2 * 2 = 4.
Proof.
  split.
  - reflexivity.
  - reflexivity.
Qed.
Lemma and_intro: forall A B: Prop, A -> B -> A /\ B.
Proof.
  intros A B HA HB. split.
  - apply HA.
  - apply HB.
Qed.

Example and_example': 3 + 4 = 7 /\ 2 * 2 = 4.
Proof. apply and_intro; reflexivity. Qed.

(** *Exercise and_exercise *)
Example and_exercise:
  forall n m: nat, n + m = 0 -> n = 0 /\ m = 0.
Proof.
  destruct n as [|n]; destruct m as [|m]; intros H; try inversion H.
  split; reflexivity.
Qed.

Lemma and_example2: forall n m: nat, n = 0 /\ m = 0 -> n + m = 0.
Proof.
  intros n m H. destruct H as [Hn Hm]. rewrite Hn, Hm. reflexivity. Qed.

Lemma and_example2': forall n m: nat, n = 0 /\ m = 0 -> n + m = 0.
Proof. intros n m [Hn Hm]. rewrite Hn, Hm. reflexivity. Qed.
Lemma and_example2'': forall n m: nat, n = 0 -> m = 0 -> n + m = 0.
Proof. intros n m Hn Hm. rewrite Hn, Hm. reflexivity. Qed.
Lemma and_example3:
  forall n m: nat, n + m = 0 -> n * m = 0.
Proof.
  intros n m H.
  assert (H' : n = 0 /\ m = 0).
  { apply and_exercise. apply H. }
  destruct H' as [Hn Hm].
  rewrite Hn. reflexivity.
Qed.
Lemma proj1: forall P Q: Prop, P /\ Q -> P.
Proof. intros P Q [HP HQ]. exact HP. Qed.
(** *Exercise proj2 *)
Lemma proj2: forall P Q: Prop, P /\ Q -> Q.
Proof. intros P Q [_ HQ]. exact HQ. Qed.
Theorem and_commit: forall P Q: Prop, P /\ Q -> Q /\ P.
Proof.
  intros P Q [HP HQ]. split.
  - exact HQ.
  - exact HP.
Qed.
(** *Exercise and_assoc *)
Theorem and_assoc: forall P Q R: Prop,
    P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R [HP [HQ HR]]. split.
  - split.
    + exact HP.
    + exact HQ.
  - exact HR.
Qed.
Check and.

Lemma or_example:
  forall n m: nat, n = 0 \/ m = 0 -> n * m = 0.
Proof.
  intros n m [Hn | Hm].
  - rewrite Hn. reflexivity.
  - rewrite Hm. symmetry. apply mult_n_O.
Qed.
Lemma or_intro: forall A B: Prop, A -> A \/ B.
Proof. intros A B HA. left. exact HA. Qed.

Lemma zero_or_succ: forall n: nat, n = 0 \/ n = S (pred n).
Proof.
  intros [| n].
  - left. reflexivity.
  - right. reflexivity.
Qed.

(** *Exercise mult_eq_0 *)
Lemma mult_eq_0: forall n m, n * m = 0 -> n = 0 \/ m = 0.
Proof.
  intros n m H. destruct n.
  - left. reflexivity.
  - simpl in H. apply and_exercise in H. destruct H as [H _].
    right. exact H.
Qed.

(** *Exericse or_commut *)
Theorem or_commut: forall P Q: Prop, P \/ Q -> Q \/ P.
Proof. intros P Q [p|q].
       - right. exact p.
       - left. exact q.
Qed.
Module MyNot.
  Definition not (P:Prop) := P -> False.
  Notation "~ x" := (not x): type_scope.
  Check not.
End MyNot.
Theorem ex_falso_quodlibet: forall P: Prop, False -> P.
Proof. intros P contra. destruct contra. Qed.
Fact not_implies_our_not: forall P : Prop,
    ~ P -> (forall Q: Prop, P -> Q).
Proof.
  intros P H Q p. apply H in p. destruct p. Qed.
Theorem zero_not_one: ~(0 = 1).
Proof. intros contra. inversion contra. Qed.
Check (0 <> 1).
Theorem zero_not_one': 0 <> 1.
Proof.
  intros H. inversion H. Qed.

Theorem not_False: ~ False.
Proof. unfold not. intros H. destruct H. Qed.
Theorem contradiction_implies_anything: forall P Q: Prop,
    P /\ ~P -> Q.
Proof.
  intros P Q [p np]. apply np in p. destruct p. Qed.

Theorem double_neg: forall P: Prop, P -> ~~P.
Proof.
  intros P H. unfold not. intros G. apply G. apply H. Qed.

(** *Exercise double_neg_inf
P implies ~~P for any P.
Assume P. We need to prove ~~P, or that ~P doesn't hold.
Indeed, if ~P holds, then P taken with ~P is a contradiction. *)
(** *Exercise contrapositive *)
Theorem contrapositive: forall P Q: Prop,
    (P -> Q) -> (~Q -> ~P).
Proof. intros P Q H NQ p. apply NQ. apply H. exact p. Qed.
(** *Exercise not_both_true_and_false *)
Theorem not_both_true_and_false: forall P: Prop, ~ (P /\ ~P).
Proof. intros P [p np]. apply np. exact p. Qed.
(** *Exercise informal_not_PNP *)
Definition informal_not_PNP_TODO := 1.
(* for any proposition P, ~(P /\ ~ P).
   That is, P /\ ~P implies anything.
   Indeed P /\ ~P contrains both P and ~P, which give False term. *)
Theorem not_true_is_false: forall b: bool, b <> true -> b = false.
Proof. intros [|] H.
       - exfalso. apply H. reflexivity.
       - reflexivity. Qed.
Lemma True_is_true: True.
Proof. apply I. Qed.

Module MyIff.
  Definition iff (P Q: Prop) := (P -> Q) /\ (Q -> P).
  Notation "P <-> Q" := (iff P Q) (at level 95, no associativity): type_scope.
End MyIff.
Theorem iff_sym: forall P Q: Prop, (P <-> Q) -> (Q <-> P).
Proof.
  intros P Q [HAB HBA]. split.
  - apply HBA.
  - apply HAB.
Qed.
Lemma not_true_iff_false: forall b, b <> true <-> b = false.
Proof.
  intros b. split.
  - apply not_true_is_false.
  - intros H. rewrite H. intros H'. inversion H'.
Qed.

(** *Exercise or_distributes_over_and *)
Theorem or_distributes_over_and: forall P Q R: Prop, P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R. split; intros H.
  - destruct H as [p|H2]; split; try destruct H2 as [q r].
    + left. exact p.
    + left. exact p.
    + right. exact q.
    + right. exact r.
  - destruct H as [H1 H2]. destruct H1 as [p|q].
    + left. exact p.
    + destruct H2 as [p|r].
      * left. exact p.
      * right. split. exact q. exact r.
Qed.

Require Import Coq.Setoids.Setoid.
Lemma mult_0: forall n m, n * m = 0 <-> n = 0 \/ m = 0.
Proof.
  split.
  - apply mult_eq_0.
  - apply or_example.
Qed.
Lemma or_assoc: forall P Q R: Prop, P \/ (Q \/ R) <-> (P \/ Q) \/ R.
Proof.
  intros P Q R. split.
  - intros [H|[H|H]]; [left;left|left;right|right]; exact H.
  - intros [[H|H]|H]; [left|right;left|right;right]; exact H.
Qed.
Lemma mult_0_3:
  forall n m p, n*m*p = 0 <-> n = 0 \/ m = 0 \/ p = 0.
Proof.
  intros n m p. rewrite mult_0, mult_0, or_assoc.
  reflexivity. Qed.

Lemma four_is_even: exists n: nat, 4 = n + n.
Proof. exists 2. reflexivity. Qed.

Theorem exists_example_2: forall n, (exists m, n = 4 + m) -> exists o, n = 2 + o.
Proof.
  intros n [m Hm]. exists (2+m). apply Hm. Qed.
(** *Exercise dist_not_exist *)
Theorem dist_not_exist: forall (X: Type)(P: X -> Prop),
    (forall x, P x) -> ~(exists x, ~ P x).
Proof.
  intros X P H E. destruct E as [e p]. apply p. apply H.
Qed.
(** *Exercise dist_exists_or *)
Theorem dist_exists_or: forall (X: Type)(P Q: X -> Prop),
    (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  intros X P Q. split.
  - intros [x [p|q]].
    + left. exists x. exact p.
    + right. exists x. exact q.
  - intros [[x p]|[x q]]; exists x.
    + left. exact p.
    + right. exact q.
Qed.

Fixpoint In {A: Type}(x: A)(l: list A): Prop :=
  match l with
  | [] => False
  | x' :: l' => x' = x \/ In x l'
  end.

Example In_example_1: In 4 [1;2;3;4;5].
Proof.
  simpl. right. right. right. left. reflexivity.
Qed.

Example In_example_2: forall n, In n [2;4] -> exists n', n = 2 * n'.
Proof.
  simpl. intros n [H|[H|[]]].
  - exists 1. rewrite <- H. reflexivity.
  - exists 2. rewrite <- H. reflexivity.
Qed.

Lemma In_map: forall (A B: Type)(f: A -> B) (l: list A)(x: A),
    In x l -> In (f x) (map f l).
Proof.
  intros A B f l x.
  induction l as [|x' l' IHl'].
  - simpl. intros [].
  - simpl. intros [H|H].
    + rewrite H. left. reflexivity.
    + right. apply IHl'. apply H.
Qed.

(** *Exercise in_map_iff *)
Lemma and_distributes_over_or: forall P Q R: Prop, P /\ (Q \/ R) <-> (P /\ Q) \/ (P /\ R).
Proof.
  intros P Q R. split.
  - intros [p [q|r]].
    + left. split; [exact p|exact q].
    + right. split; [exact p|exact r].
  - intros [[p q]|[p r]].
    + split; [exact p|left;exact q].
    + split; [exact p|right;exact r].
Qed.
Lemma In_map_iff:
  forall (A B: Type) (f: A -> B) (l: list A) (y: B),
    In y (map f l) <-> exists x, f x = y /\ In x l.
Proof.
  intros A B f. induction l as [|h t I]; intros y; simpl; split.
  - intros [].
  - intros [_ [_ []]].
  - intros [H|H].
    + exists h. split; [exact H|left;reflexivity].
    + apply I in H. destruct H as [m H]. exists m.
      rewrite -> and_distributes_over_or. right. exact H.
  - intros [m [H [H'|H']]].
    + rewrite H'. left. exact H.
    + right. apply I. exists m. split; [exact H|exact H'].
Qed.

(** *Exersie In_app_iff *)
Lemma In_app_iff: forall A l l' (a: A),
    In a (l++l') <-> In a l \/ In a l'.
Proof.
  intros A l l' a. generalize dependent l'. induction l as [|h t IH].
  - intros l'. simpl. split.
    + intros H; right; exact H.
    + intros [H|H]; [inversion H|exact H].
  - intros l'. simpl. split.
    + intros [H|H].
      * left. left. exact H.
      * rewrite <- or_assoc. right. apply IH. exact H.
    + intros [[H|H]|H].
      * left. exact H.
      * right. apply IH. left. exact H.
      * right. apply IH. right. exact H.
Qed.

(** *Exercise All *)
Fixpoint All {T: Type} (P: T -> Prop) (l: list T) : Prop :=
  match l with
  | [] => True
  | h :: t => P h /\ All P t
  end.
Lemma All_in: forall T (P: T -> Prop)(l: list T),
    (forall x, In x l -> P x) <-> All P l.
Proof.
  intros T P l. induction l as [|h t IH].
  - simpl. split.
    + intros _. apply I.
    + intros _ x [].
  - simpl. split.
    + intros H. split.
      * apply H. left. reflexivity.
      * apply IH. intros x H1. apply H. right. exact H1.
    + intros [H1 H2] x [H3|H3].
      * rewrite <- H3. exact H1.
      * apply IH. exact H2. exact H3.
Qed.

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

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 Ho He. unfold combine_odd_even.
  destruct (oddb n).
  - apply Ho. reflexivity.
  - apply He. reflexivity.
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 Podd Peven n H H'. unfold combine_odd_even in H.
  destruct (oddb n).
  - exact H.
  - inversion 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.
  unfold combine_odd_even. intros Podd Peven n H H'. destruct (oddb n).
  - inversion H'.
  - exact H.
Qed.

Check plus_comm.

Lemma plus_comm3:
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z. rewrite plus_comm. rewrite plus_comm. Abort.

Lemma plus_comm3_take2:
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  assert (H : y + z = z + y).
  { rewrite plus_comm. reflexivity. }
  rewrite H.
  reflexivity.
Qed.

Lemma plu_comm3_take3:
  forall x y z, x + (y + z) = (z + y) + x.
Proof.
  intros x y z.
  rewrite plus_comm.
  rewrite (plus_comm y z).
  reflexivity.
Qed.

Example lemma_application_ex:
  forall {n: nat} {ns: list nat},
    In n (map (fun m => m * 0) ns) -> n = 0.
Proof.
  intros n ns H.
  destruct (proj1  _ _ (In_map_iff _ _ _ _ _) H) as [m [Hm _]].
  rewrite mult_0_r in Hm. rewrite <- Hm. reflexivity.
Qed.

Example function_equality_ex1: plus 3 = plus (pred 4).
Proof. reflexivity. Qed.

Example function_equality_ex2:
  (fun x => plus x 1) = (fun x => plus 1 x).
Proof.
Abort.

Axiom functional_extensionality: forall {X Y: Type} {f g: X -> Y},
    (forall x, f x = g x) -> f = g.

Example function_equality_ex2:
  (fun x => plus x 1) = (fun x => plus 1 x).
Proof.
  apply functional_extensionality.
  intros x. apply plus_comm.
Qed.

Print Assumptions function_equality_ex2.
(** *Exercise tr_rev_correct *)
Fixpoint rev_append {X} (l1 l2: list X): list X :=
  match l1 with
  | [] => l2
  | x :: l1' => rev_append l1' (x :: l2)
  end.

Definition tr_rev {X} (l: list X): list X :=
  rev_append l [].

Lemma tr_rev_correct: forall X, @tr_rev X = @rev X.
Proof.
  assert (L: forall X (l1 l2: list X), rev_append l1 l2 = rev l1 ++ l2).
  {
    intros X. induction l1 as [|h t IH].
    - simpl. intros. reflexivity.
    - intros l2. simpl. rewrite <- app_assoc. simpl. apply IH.
  }
  intros X. apply functional_extensionality. unfold tr_rev.
  destruct x as [|h t].
  - reflexivity.
  - simpl. apply L.
Qed.

Theorem evenb_double: forall k, evenb (double k) = true.
Proof.
  intros k. induction k as [|k' IHk'].
  - reflexivity.
  - simpl. apply IHk'.
Qed.

(** *Exercise evenb_double_conv *)
Theorem evenb_double_conv : forall n,
    exists k, n = if evenb n then double k else S (double k).
Proof.
  induction n as [|n' IHn'].
  - exists 0. reflexivity.
  - destruct IHn' as [k H].
    destruct (evenb (S n')) eqn:En;
      rewrite evenb_S in En;
      apply (f_equal _ _ negb) in En;
      rewrite negb_involutive in En;
      rewrite En in H;
      simpl in H.
    + exists (S k). rewrite H. reflexivity.
    + exists k. rewrite H. reflexivity.
Qed.

Theorem even_bool_prop : forall n,
    evenb n = true <-> exists k, n = double k.
Proof.
  intros n. split.
  - intros H. destruct (evenb_double_conv n) as [k' H'].
    rewrite H in H'. exists k'. exact H'.
  - intros [k H]. rewrite H. apply evenb_double.
Qed.

Theorem beq_nat_true_iff: forall n1 n2 : nat,
    beq_nat n1 n2 = true <-> n1 = n2.
Proof.
  intros n1 n2. split.
  - apply beq_nat_true.
  - intros E. rewrite E. symmetry. apply beq_nat_refl.
Qed.

Fail Definition is_even_prime n :=
  if n = 2 then true else false.

Example even_1000: exists k, 1000 = double k.
Proof. exists 500. reflexivity. Qed.

Example even_1000' : evenb 1000 = true.
Proof. reflexivity. Qed.

Example even_1000'': exists k, 1000 = double k.
Proof. apply even_bool_prop. reflexivity. Qed.

(** *Exercise and_true_iff *)
Lemma andb_true_iff : forall b1 b2: bool,
    b1 && b2 = true <-> b1 = true /\ b2 = true.
Proof.
  intros b1 b2. split.
  - intros H. split.
    + destruct b1.
      * reflexivity.
      * inversion H.
    + destruct b2.
      * reflexivity.
      * destruct b1; inversion H.
  - intros [H1 H2]. rewrite H1, H2. reflexivity.
Qed.

Lemma orb_true_iff: forall b1 b2: bool,
    b1 || b2 = true -> b1 = true \/ b2 = true.
Proof.
  intros [|] [|]; simpl; intros H; try inversion H; try (left;reflexivity); try (right;reflexivity).
Qed.

(** *Exercise beq_nat_false_iff *)
Theorem beq_nat_false_iff : forall x y,
    beq_nat x y = false <-> x <> y.
Proof.
  intros x y. split.
  - intros H E. apply beq_nat_true_iff in E. rewrite H in E. inversion E.
  - intros H. destruct (beq_nat x y) eqn:E.
    + exfalso. apply H, beq_nat_true, E.
    + reflexivity.
Qed.

Fixpoint beq_list {A: Type} (beq: A -> A -> bool) (l1 l2: list A): bool :=
  match (l1, l2) with
  | ([] , []) => true
  | ([] , _::_) | (_::_, []) => false
  | (h1::t1, h2::t2) => beq h1 h2 && beq_list beq t1 t2
  end.

Lemma beq_list_true_iff: forall A (beq: A -> A -> bool),
    (forall a1 a2, beq a1 a2 = true <-> a1 = a2) ->
    forall l1 l2, beq_list beq l1 l2 = true <-> l1 = l2.
Proof.
  intros A beq R l1 l2. generalize dependent l2.
  induction l1 as [|h1 t1 IH1]; destruct l2 as [|h2 t2]; split;
    intros H; try reflexivity; try (inversion H;fail); simpl in H.
  - rewrite andb_true_iff in H. destruct H as [H1 H2].
    apply R in H1. apply IH1 in H2.
    rewrite H1, H2. reflexivity.
  - simpl. rewrite andb_true_iff. split; [apply R|apply IH1]; inversion H; reflexivity.
Qed.
(** *Exercise All_forallb *)
Theorem forallb_true_iff : forall X test (l : list X),
    forallb test l = true <-> All (fun x => test x = true) l.
Proof.
  intros X test. induction l as [|h t IH]; split; intro H; simpl; simpl in H; try reflexivity.
  - rewrite andb_true_iff in H. destruct H as [Hl Hr]. split.
    + exact Hl.
    + apply IH, Hr.
  - rewrite andb_true_iff. destruct H as [Hl Hr]. split.
    + exact Hl.
    + apply IH, Hr.
Qed.
(* forallb has short circuit behavior and can be tested in match *)

Definition excluded_middle := forall P: Prop, P \/ ~ P.
Theorem restricted_excluded_middle: forall P b,
    (P <-> b = true) -> P \/ ~ P.
Proof.
  intros P [] H.
  - left. rewrite H. reflexivity.
  - right. rewrite H. intros contra. inversion contra.
Qed.

Theorem restricted_excluded_middle_eq: forall (n m : nat), n = m \/ n <> m.
Proof.
  intros n m. apply (restricted_excluded_middle (n=m) (beq_nat n m)). symmetry.
  apply beq_nat_true_iff.
Qed.

(** *Exercise excluded_middle_irrefutable *)
Theorem excluded_middle_irrefutable: forall P: Prop, ~~(P \/ ~P).
Proof.
  intros P H. apply H. right. intro p. apply H. left. exact p.
Qed.

(** *Exercise not_exists_dist *)
Theorem net_exists_dist :
  excluded_middle -> forall (X: Type) (P: X -> Prop),
    ~ (exists x, ~ P x) -> forall x, P x.
Proof.
  intros Ex X P H x.
  destruct (Ex (P x)) as [H'|H'].
  - exact H'.
  - exfalso. apply H. exists x. exact H'.
Qed.

(** *Exercise classical_axioms *)
Definition pierce := forall P Q: Prop, ((P -> Q) -> P) -> P.
Definition double_negation_elimination := forall P: Prop, ~~P -> P.
Definition de_morgan_not_and_not := forall P Q: Prop, ~(~P /\ ~Q) -> P \/ Q.
Definition implies_to_or := forall P Q : Prop, (P -> Q) -> (~P \/ Q).
Lemma excluded_middle_double_negation_elimination:
  excluded_middle <-> double_negation_elimination.
Proof.
  split; intros H.
  - intros P nnp. destruct (H P) as [H'|H'].
    + exact H'.
    + exfalso. apply nnp. exact H'.
  - intros P. apply H. apply excluded_middle_irrefutable.
Qed.
Lemma excluded_middle_pierce: excluded_middle <-> pierce.
Proof.
  split; intros H0.
  - intros P Q H1. destruct (H0 P) as [H2|H2].
    + exact H2.
    + apply H1. intros H3. exfalso. apply H2, H3.
  - intros P. apply (H0 (P \/ ~P) False). intros H1. exfalso.
    apply excluded_middle_irrefutable with P. exact H1.
Qed.
Lemma excluded_middle_de_morgan_not_and_not :
  excluded_middle <-> de_morgan_not_and_not.
Proof.
  split; intros H0.
  - intros P Q H1.
    destruct (H0 P) as [H2|H2]; destruct (H0 Q) as [H3|H3];
      try (left; exact H2); try (right; exact H3).
    exfalso. apply H1. split; [exact H2|exact H3].
  - intros P. apply H0. intros [H1 H2]. apply H2, H1.
Qed.
Lemma excluded_middle_implies_to_or:
  excluded_middle <-> implies_to_or.
Proof.
  split; intros H0.
  - intros P Q H1. destruct (H0 P) as [H2|H2].
    + right. apply H1, H2.
    + left. exact H2.
  - intros P. rewrite <- or_comm. apply H0. intro p; exact p.
Qed.
Theorem classical_axioms:
  (excluded_middle <-> pierce)
  /\ (pierce <-> double_negation_elimination)
  /\ (double_negation_elimination <-> de_morgan_not_and_not)
  /\ (de_morgan_not_and_not <-> implies_to_or).
Proof.
  rewrite <- excluded_middle_de_morgan_not_and_not.
  rewrite <- excluded_middle_pierce.
  rewrite <- excluded_middle_double_negation_elimination.
  rewrite <- excluded_middle_implies_to_or.
  assert (L: forall P, P <-> P).
  { intro P. split; intro p; exact p. }
  split. apply L. split. apply L. split. apply L. apply L.
Qed.