From LF Require Export Tactics.

Check (3 = 3) : Prop.
Check (forall n m : nat, n + m = m + n) : Prop.

Definition plus_claim : Prop := 2 + 2 = 4.
Check plus_claim : Prop.
Definition plus_claim_is_true : plus_claim.
Proof. reflexivity. Qed.

(* Functions that return propositions are said to define
   properties of their arguments. *)
Definition is_three (n : nat) : Prop := n = 3.

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. injection H as H1. apply H1. Qed.

(* The equality operator `=` is a binary function that returns a Prop. *)
Check @eq : forall A : Type, A -> A -> Prop.

(* Logical Connectives *)

Example and_example : 3 + 4 = 7 /\ 2 * 2 = 4.
Proof. split; 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.

Theorem plus_comm : forall n m : nat, n + m = m + n.
Proof. intros n m. induction n.
       - simpl. rewrite <- plus_n_O. reflexivity.
       - simpl. rewrite -> IHn. rewrite -> plus_n_Sm. reflexivity. Qed.

Example and_exercise :
  forall n m : nat, n + m = 0 -> n = 0 /\ m = 0.
Proof. intros n m H. split.
       - induction n.
         + reflexivity.
         + discriminate H.
       - induction m.
         + reflexivity.
         + rewrite -> plus_comm in H. discriminate H. 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. rewrite Hm. reflexivity. Qed.

(* Shortcut: *)
Lemma and_example2'' :
  forall n m : nat, n = 0 /\ m = 0 -> n + m = 0.
Proof. intros n m [Hn Hm]. rewrite Hn. rewrite Hm. reflexivity. Qed.

Lemma and_example3 :
  forall n m : nat, n + m = 0 -> n * m = 0.
Proof. intros n m H. apply and_exercise in H.
       destruct H as [Hn Hm]. rewrite Hn. reflexivity. Qed.

Lemma proj1 : forall P Q : Prop, P /\ Q -> P.
Proof. intros P Q HPQ. destruct HPQ as [HP _]. apply HP. Qed.

Lemma proj2 : forall P Q : Prop, P /\ Q -> Q.
Proof. intros P Q [_ HQ]. apply HQ. Qed.

Theorem and_cummut : forall P Q : Prop, P /\ Q -> Q /\ P.
Proof. intros P Q [HP HQ]. split.
       - apply HQ.
       - apply HP. Qed.

Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof. intros P Q R [HP [HQ HR]]. split.
       - split.
         + apply HP.
         + apply HQ.
       - apply HR. Qed.

Lemma mult_n_0 : forall n : nat, n * 0 = 0.
Proof. intros n. induction n.
       - reflexivity.
       - simpl. rewrite -> IHn. reflexivity. Qed.

Lemma factor_is_0 :
  forall n m : nat, n = 0 \/ m = 0 -> n * m = 0.
Proof. intros n m [Hn |Hm].
       - rewrite -> Hn. reflexivity.
       - rewrite -> Hm. rewrite -> mult_n_0. reflexivity. Qed.

Lemma or_intro_l : forall A B : Prop, A -> A \/ B.
Proof. intros A B HA. left. apply HA. Qed.

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

Lemma mult_is_0 :
  forall n m, n * m = 0 -> n = 0 \/ m = 0.
Proof. intros n m H. destruct n.
       - left. reflexivity.
       - right. destruct m.
         + reflexivity.
         + discriminate H. Qed.

Theorem or_commut : forall P Q : Prop, P \/ Q -> Q \/ P.
Proof. intros P Q H. inversion H as [HP | HQ].
       - right. apply HP.
       - left. apply HQ. Qed.


Lemma ind_ex1 : forall n : nat, n * 1 = n.
intro.
elim n.
simpl.
reflexivity.
intros.
simpl.
rewrite H.
reflexivity.
Qed.

Fixpoint f (x : nat) {struct x} : nat :=
  match x with
  |0 => 1
  |S x => 2 * f(x)
  end.
Lemma ind_ex2 : f(10) = 1024.
simpl.
reflexivity.
Qed.

Require Import Lists.List.

Open Scope list_scope.
Lemma ind_ex3 : forall (E : Type) (l : list E) (e : E),
    rev(l ++ e :: nil) = e :: rev(l).
intros.
induction l.
simpl.
reflexivity.
simpl.
rewrite IHl.
reflexivity.
Qed.

Lemma ind_ex4 : forall (E : Type) (l : list E), rev (rev l) = l.
intros.
induction l.
simpl.
reflexivity.
simpl.
rewrite ind_ex3.
rewrite IHl.
reflexivity.
Qed.

Require Import Classical.

Lemma auto_eq_nat_dec : forall n m : nat, {n = m} + {n <> m}.
intros.
decide equality.
Qed.

Lemma man_eq_nat_dec : forall n m : nat, {n = m} + {n <> m}.
intros.
induction m.
induction n.
left.
reflexivity.
intros.
destruct IHn.
right.
rewrite e.
congruence.
right.
congruence.
destruct IHm.
right.
rewrite e.
apply n_Sn.


Add LoadPath "lf/".
Require Import numbers.

Theorem plus_n_0: forall n : nat, n = n + 0.

Proof.
  intros n.
  induction n as [| n' IHn' ].
    - reflexivity. (* n = 0 *)
    - simpl.
      rewrite <- IHn'.
      reflexivity.
  Qed.

(* Exercise *)
Theorem mult_0_r: forall n : nat, n * 0 = 0.

Proof.
  intros.
  induction n as [| n' IHn' ].
    - reflexivity. (* n = 0 *)
    - simpl.
      rewrite -> IHn'.
      reflexivity.
  Qed.

(* Exercise *)
Theorem plus_n_Sm: forall n m : nat,
  S (n + m) = n + (S m).

Proof.
  intros.
  induction n as [| n' IHn' ].
  - simpl. reflexivity.
  - simpl. rewrite <- IHn'. reflexivity.
  Qed.

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

Proof.
  intros n m.
  induction n as [| n' IHn' ].
  - rewrite -> plus_0_n. rewrite <- plus_n_0. reflexivity.
  - simpl. rewrite -> IHn'. rewrite ->  plus_n_Sm. reflexivity.
  Qed.

(* Exercise *)
Theorem plus_assoc: forall n m p : nat,
  n + (m + p) = (n + m) + p.

Proof.
  intros.
  induction n as [| n' IHn' ].
  - simpl. reflexivity.
  - simpl. rewrite -> IHn'. reflexivity.
  Qed.

(* Exercise *)
Fixpoint double (n : nat) :=
  match n with
    | O => O
    | S n' => S (S (double n'))
  end.

Lemma double_plus: forall n, double n = n + n.

Proof.
  intros.
  induction n as [| n' IHn' ].
  - simpl. reflexivity.
  - simpl. rewrite -> IHn'. rewrite -> plus_n_Sm. reflexivity.
  Qed.

(* Exercise *)
Theorem even_S: forall n : nat,
  even (S n) = negb (even n).

Proof.
  intros.
  induction n as [| n' IHn' ].
  - simpl. reflexivity.
  - rewrite -> IHn'. rewrite -> negb_involutive. simpl. reflexivity.
  Qed.


(** * The Stack Datatype

The Stack is the first data type defined in chapter 2 of PFDS.

Its signature is defined as (in SML):

<<
signature STACK =
sig
  type a Stack

  val empty       :: a Stack
  val isEmpty     :: a Stack -> bool

  val cons        :: a x a Stack -> a Stack
  val head        :: a Stack -> a
  val tail        :: a Stack -> a Stack
end
>>
*)

(** ----- *)

Require Import Bool Arith.

(** ** The Implementation *)

(** A stack is either empty, or it is constructed from a series of Cons.

    That is, the list that would be expressed in Haskell as <<[1, 2, 3]>> would
    be represented herein as [Cons nat 1 (Cons nat 2 (Cons nat 3 (Empty nat)))].
 *)

Inductive stack (T:Type) : Type :=
  | Empty : stack T
  | Cons : T -> stack T -> stack T.

(** An empty stack is represented by the value Empty; therefore, an
    implementation of isEmpty only needs to match that value.
 *)

Definition isEmpty T (s : stack T) : bool :=
  match s with
    | Empty => true
    | _     => false
  end.

(** Retrieving the head of the list poses some interesting problems. The book
    desires an exception be raised for the head of an empty list; however, a
    formally verified program shouldn't have any erroneous conditions. There
    is very likely a better way to express this in a definition, but this is
    day 3 with the language. For now, an option property will suffice. This
    returns None for an empty list, and Some value for the non-empty stack.
 *)

Definition head T (s : stack T) : option T :=
  match s with
    | Empty => None
    | Cons s' _ => Some s'
  end.

Definition tail T (s : stack T) : stack T :=
  match s with
    | Empty => Empty T
    | Cons _ s' => s'
  end.

(** In order to allow cons to take a head, the value has to have the option
    property.
  *)

Definition cons T (x : option T) (s : stack T) : stack T :=
  match x with
    | None => s
    | Some x' => Cons T x' s
  end.

Fixpoint length T (s : stack T) : nat :=
  match s with
    | Empty => 0
    | Cons _ s' => 1 + (length T s')
  end.

(** ----- *)
(** ** Some examples *)

(** *** The empty stack. *)

Eval simpl in Empty nat. (** <<= Empty nat : stack nat >>*)
Eval simpl in isEmpty nat (Empty nat). (** <<= true : bool >> *)

(** *** A stack of length 1. *)

Eval simpl in Cons nat 1 (Empty nat). (** <<= Cons nat 1 (Empty nat) : stack nat >> *)
Eval simpl in isEmpty nat (Cons nat 1 (Empty nat)). (** <<= false : bool >>*)

(** *** Heads or tails? *)
Definition list1 := Cons nat 1 (Empty nat).
Definition list2 := Cons nat 2 list1.
Definition list3 := Cons nat 2 (Cons nat 1 (Empty nat)).

Eval simpl in head nat list1. (** <<= Some 1 : option nat>> *)
Eval simpl in head nat list2. (** <<= Some 2 : option nat>> *)
Eval simpl in tail nat list1. (** <<= Empty nat : stack nat>> *)
Eval simpl in tail nat list2. (** <<= list1 : stack nat>> *)
Eval simpl in head nat (tail nat list2). (** <<= Some 1 : option nat>> *)
Eval simpl in length nat list2. (** <<= 2 : nat>> *)
Eval simpl in cons nat (head nat list3) (tail nat list3).

Eval simpl in cons nat (head nat list2) (tail nat list2).

(** ----- *)
(** ** Proving head/tail consistency.

   Theorem: consing the head of a list onto the tail of a list returns the
   original list. *)

Theorem head_tail_consistency: forall t s,
  cons t (head t s) (tail t s) = s.
Proof.
  (** Prologue: _dramatis personae_ and split the proof into two cases: one in
     which the stack is empty, and the other when the stack is not empty. *)

  intros. induction s.

  (** Case 1: the stack is empty. *)

  reflexivity.

  (** Case 2: the stack is not empty. *)

  rewrite <- IHs.
  reflexivity.
Qed.

(** ** The extracted program (in OCaml) *)

(*
Extraction "stack.ml" stack isEmpty head tail cons length list1 list2.
Extraction Language Haskell.
Extraction "stack.hs" stack isEmpty head tail cons length list1 list2.
 *)

(**
<<
type bool =
| True
| False

type nat =
| O
| S of nat

type 'a option =
| Some of 'a
| None

(** val plus : nat -> nat -> nat **)

let rec plus n m =
  match n with
  | O -> m
  | S p -> S (plus p m)

type 't stack =
| Empty
| Cons of 't * 't stack

(** val isEmpty : 'a1 stack -> bool **)

let isEmpty = function
| Empty -> True
| Cons (t, s0) -> False

(** val head : 'a1 stack -> 'a1 option **)

let head = function
| Empty -> None
| Cons (s', s0) -> Some s'

(** val tail : 'a1 stack -> 'a1 stack **)

let tail = function
| Empty -> Empty
| Cons (t, s') -> s'

(** val cons : 'a1 option -> 'a1 stack -> 'a1 stack **)

let cons x s =
  match x with
  | Some x' -> Cons (x', s)
  | None -> s

(** val length : 'a1 stack -> nat **)

let rec length = function
| Empty -> O
| Cons (t, s') -> plus (S O) (length s')
>>
*)

Eval simpl in tail nat (Empty nat).
Eval simpl in head nat (Cons nat 1 (Empty nat)).


From Hammer Require Import Hammer.

Require Import Bvector.
Require Import ZArith.
Require Export Zpower.
Require Import Omega.

Section VALUE_OF_BOOLEAN_VECTORS.

Definition bit_value (b:bool) : Z :=
match b with
| true => 1%Z
| false => 0%Z
end.

Lemma binary_value : forall n:nat, Bvector n -> Z.
Proof. hammer_hook "Zdigits" "Zdigits.binary_value".
refine (nat_rect _ _ _); intros.
exact 0%Z.

inversion H0.
exact (bit_value h + 2 * H H2)%Z.
Defined.

Lemma two_compl_value : forall n:nat, Bvector (S n) -> Z.
Proof. hammer_hook "Zdigits" "Zdigits.two_compl_value".
simple induction n; intros.
inversion H.
exact (- bit_value h)%Z.

inversion H0.
exact (bit_value h + 2 * H H2)%Z.
Defined.

End VALUE_OF_BOOLEAN_VECTORS.

Section ENCODING_VALUE.

Definition Zmod2 (z:Z) :=
match z with
| Z0 => 0%Z
| Zpos p => match p with
| xI q => Zpos q
| xO q => Zpos q
| xH => 0%Z
end
| Zneg p =>
match p with
| xI q => (Zneg q - 1)%Z
| xO q => Zneg q
| xH => (-1)%Z
end
end.

Lemma Zmod2_twice :
forall z:Z, z = (2 * Zmod2 z + bit_value (Z.odd z))%Z.
Proof. hammer_hook "Zdigits" "Zdigits.Zmod2_twice".
destruct z; simpl.
trivial.

destruct p; simpl; trivial.

destruct p; simpl.
destruct p as [p| p| ]; simpl.
rewrite <- (Pos.pred_double_succ p); trivial.

trivial.

trivial.

trivial.

trivial.
Qed.

Lemma Z_to_binary : forall n:nat, Z -> Bvector n.
Proof. hammer_hook "Zdigits" "Zdigits.Z_to_binary".
simple induction n; intros.
exact Bnil.

exact (Bcons (Z.odd H0) n0 (H (Z.div2 H0))).
Defined.

Lemma Z_to_two_compl : forall n:nat, Z -> Bvector (S n).
Proof. hammer_hook "Zdigits" "Zdigits.Z_to_two_compl".
simple induction n; intros.
exact (Bcons (Z.odd H) 0 Bnil).

exact (Bcons (Z.odd H0) (S n0) (H (Zmod2 H0))).
Defined.

End ENCODING_VALUE.

Section Z_BRIC_A_BRAC.

Lemma binary_value_Sn :
forall (n:nat) (b:bool) (bv:Bvector n),
binary_value (S n) ( b :: bv) =
(bit_value b + 2 * binary_value n bv)%Z.
Proof. hammer_hook "Zdigits" "Zdigits.binary_value_Sn".
intros; auto.
Qed.

Lemma Z_to_binary_Sn :
forall (n:nat) (b:bool) (z:Z),
(z >= 0)%Z ->
Z_to_binary (S n) (bit_value b + 2 * z) = Bcons b n (Z_to_binary n z).
Proof. hammer_hook "Zdigits" "Zdigits.Z_to_binary_Sn".
destruct b; destruct z; simpl; auto.
intro H; elim H; trivial.
Qed.

Lemma binary_value_pos :
forall (n:nat) (bv:Bvector n), (binary_value n bv >= 0)%Z.
Proof. hammer_hook "Zdigits" "Zdigits.binary_value_pos".
induction bv as [| a n v IHbv]; cbn.
omega.

destruct a; destruct (binary_value n v); simpl; auto.
auto with zarith.
Qed.

Lemma two_compl_value_Sn :
forall (n:nat) (bv:Bvector (S n)) (b:bool),
two_compl_value (S n) (Bcons b (S n) bv) =
(bit_value b + 2 * two_compl_value n bv)%Z.
Proof. hammer_hook "Zdigits" "Zdigits.two_compl_value_Sn".
intros; auto.
Qed.

Lemma Z_to_two_compl_Sn :
forall (n:nat) (b:bool) (z:Z),
Z_to_two_compl (S n) (bit_value b + 2 * z) =
Bcons b (S n) (Z_to_two_compl n z).
Proof. hammer_hook "Zdigits" "Zdigits.Z_to_two_compl_Sn".
destruct b; destruct z as [| p| p]; auto.
destruct p as [p| p| ]; auto.
destruct p as [p| p| ]; simpl; auto.
intros; rewrite (Pos.succ_pred_double p); trivial.
Qed.

Lemma Z_to_binary_Sn_z :
forall (n:nat) (z:Z),
Z_to_binary (S n) z =
Bcons (Z.odd z) n (Z_to_binary n (Z.div2 z)).
Proof. hammer_hook "Zdigits" "Zdigits.Z_to_binary_Sn_z".
intros; auto.
Qed.

Lemma Z_div2_value :
forall z:Z,
(z >= 0)%Z -> (bit_value (Z.odd z) + 2 * Z.div2 z)%Z = z.
Proof. hammer_hook "Zdigits" "Zdigits.Z_div2_value".
destruct z as [| p| p]; auto.
destruct p; auto.
intro H; elim H; trivial.
Qed.

Lemma Pdiv2 : forall z:Z, (z >= 0)%Z -> (Z.div2 z >= 0)%Z.
Proof. hammer_hook "Zdigits" "Zdigits.Pdiv2".
destruct z as [| p| p].
auto.

destruct p; auto.
simpl; intros; omega.

intro H; elim H; trivial.
Qed.

Lemma Zdiv2_two_power_nat :
forall (z:Z) (n:nat),
(z >= 0)%Z ->
(z < two_power_nat (S n))%Z -> (Z.div2 z < two_power_nat n)%Z.
Proof. hammer_hook "Zdigits" "Zdigits.Zdiv2_two_power_nat".
intros.
enough (2 * Z.div2 z < 2 * two_power_nat n)%Z by omega.
rewrite <- two_power_nat_S.
destruct (Zeven.Zeven_odd_dec z) as [Heven|Hodd]; intros.
rewrite <- Zeven.Zeven_div2; auto.
generalize (Zeven.Zodd_div2 z Hodd); omega.
Qed.

Lemma Z_to_two_compl_Sn_z :
forall (n:nat) (z:Z),
Z_to_two_compl (S n) z =
Bcons (Z.odd z) (S n) (Z_to_two_compl n (Zmod2 z)).
Proof. hammer_hook "Zdigits" "Zdigits.Z_to_two_compl_Sn_z".
intros; auto.
Qed.

Lemma Zeven_bit_value :
forall z:Z, Zeven.Zeven z -> bit_value (Z.odd z) = 0%Z.
Proof. hammer_hook "Zdigits" "Zdigits.Zeven_bit_value".
destruct z; unfold bit_value; auto.
destruct p; tauto || (intro H; elim H).
destruct p; tauto || (intro H; elim H).
Qed.

Lemma Zodd_bit_value :
forall z:Z, Zeven.Zodd z -> bit_value (Z.odd z) = 1%Z.
Proof. hammer_hook "Zdigits" "Zdigits.Zodd_bit_value".
destruct z; unfold bit_value; auto.
intros; elim H.
destruct p; tauto || (intros; elim H).
destruct p; tauto || (intros; elim H).
Qed.

Lemma Zge_minus_two_power_nat_S :
forall (n:nat) (z:Z),
(z >= - two_power_nat (S n))%Z -> (Zmod2 z >= - two_power_nat n)%Z.
Proof. hammer_hook "Zdigits" "Zdigits.Zge_minus_two_power_nat_S".
intros n z; rewrite (two_power_nat_S n).
generalize (Zmod2_twice z).
destruct (Zeven.Zeven_odd_dec z) as [H| H].
rewrite (Zeven_bit_value z H); intros; omega.

rewrite (Zodd_bit_value z H); intros; omega.
Qed.

Lemma Zlt_two_power_nat_S :
forall (n:nat) (z:Z),
(z < two_power_nat (S n))%Z -> (Zmod2 z < two_power_nat n)%Z.
Proof. hammer_hook "Zdigits" "Zdigits.Zlt_two_power_nat_S".
intros n z; rewrite (two_power_nat_S n).
generalize (Zmod2_twice z).
destruct (Zeven.Zeven_odd_dec z) as [H| H].
rewrite (Zeven_bit_value z H); intros; omega.

rewrite (Zodd_bit_value z H); intros; omega.
Qed.

End Z_BRIC_A_BRAC.

Section COHERENT_VALUE.

Lemma binary_to_Z_to_binary :
forall (n:nat) (bv:Bvector n), Z_to_binary n (binary_value n bv) = bv.
Proof. hammer_hook "Zdigits" "Zdigits.binary_to_Z_to_binary".
induction bv as [| a n bv IHbv].
auto.

rewrite binary_value_Sn.
rewrite Z_to_binary_Sn.
rewrite IHbv; trivial.

apply binary_value_pos.
Qed.

Lemma two_compl_to_Z_to_two_compl :
forall (n:nat) (bv:Bvector n) (b:bool),
Z_to_two_compl n (two_compl_value n (Bcons b n bv)) = Bcons b n bv.
Proof. hammer_hook "Zdigits" "Zdigits.two_compl_to_Z_to_two_compl".
induction bv as [| a n bv IHbv]; intro b.
destruct b; auto.

rewrite two_compl_value_Sn.
rewrite Z_to_two_compl_Sn.
rewrite IHbv; trivial.
Qed.

Lemma Z_to_binary_to_Z :
forall (n:nat) (z:Z),
(z >= 0)%Z ->
(z < two_power_nat n)%Z -> binary_value n (Z_to_binary n z) = z.
Proof. hammer_hook "Zdigits" "Zdigits.Z_to_binary_to_Z".
induction n as [| n IHn].
unfold two_power_nat, shift_nat; simpl; intros; omega.

intros; rewrite Z_to_binary_Sn_z.
rewrite binary_value_Sn.
rewrite IHn.
apply Z_div2_value; auto.

apply Pdiv2; trivial.

apply Zdiv2_two_power_nat; trivial.
Qed.

Lemma Z_to_two_compl_to_Z :
forall (n:nat) (z:Z),
(z >= - two_power_nat n)%Z ->
(z < two_power_nat n)%Z -> two_compl_value n (Z_to_two_compl n z) = z.
Proof. hammer_hook "Zdigits" "Zdigits.Z_to_two_compl_to_Z".
induction n as [| n IHn].
unfold two_power_nat, shift_nat; simpl; intros.
assert (z = (-1)%Z \/ z = 0%Z). omega.
intuition; subst z; trivial.

intros; rewrite Z_to_two_compl_Sn_z.
rewrite two_compl_value_Sn.
rewrite IHn.
generalize (Zmod2_twice z); omega.

apply Zge_minus_two_power_nat_S; auto.

apply Zlt_two_power_nat_S; auto.
Qed.

End COHERENT_VALUE.


From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Implicit Type p q r : bool.
Implicit Type m n a b c : nat.

(** *** Exercise 1:

Prove that the equation #$$ 8y = 6x + 1 $$# has no solution.

- Hint 1: take the modulo 2 of the equation.
- Hint 2: [Search _ modn addn] and [Search _ modn muln]
#

# *)
Lemma ex1 x y : 8 * y != 6 * x + 1.
Proof.
(*D*)apply/negP => /eqP /(congr1 (modn^~ 2)).
(*D*)by rewrite -modnMml mul0n -modnDml -modnMml.
(*A*)Qed.

(** #
#
*** Exercise 2:

The ultimate Goal of this exercise is to find the solutions of the equation
#$$ 2^n = a^2 + b^2,$$# where n is fixed and a and b unkwown.

We hence study the following predicate:
#
# *)
Definition sol n a b := [&& a > 0, b > 0 & 2 ^ n == a ^ 2 + b ^ 2].
(** #
#
- First prove that there are no solutions when n is 0.

  - Hint: do enough cases on a and b.
#
# *)
Lemma sol0 a b : ~~ sol 0 a b.
(*A*)Proof. by move: a b => [|[|[|a]]] [|[|[|b]]]. Qed.
(** #
#
- Now prove the only solution when n is 1.

  - Hint: do enough cases on a and b.
#
# *)
Lemma sol1 a b : sol 1 a b = (a == 1) && (b == 1).
(*A*)Proof. by move: a b => [|[|[|a]]] [|[|[|b]]]. Qed.
(** #
#
- Now prove a little lemma that will guarantee that a and b are even.

  - Hint 1: first prove [(x * 2 + y) ^ 2 = y ^ 2 %[mod 4]].
  - Hint 2: [About divn_eq] and [Search _ modn odd]
#
# *)
Lemma mod4Dsqr_even a b : (a ^ 2 + b ^ 2) %% 4 = 0 -> (~~ odd a) && (~~ odd b).
Proof.
(*D*)have sqr_x2Dy_mod4 x y : (x * 2 + y) ^ 2 = y ^ 2 %[mod 4].
(*D*)  rewrite sqrnD addnAC mulnAC [2 * _]mulnC -mulnA -[2 * 2]/4.
(*D*)  by rewrite expnMn -[2 ^ 2]/4 -mulnDl -modnDml modnMl.
(*D*)rewrite {1}(divn_eq a 2) {1}(divn_eq b 2) -modnDm.
(*D*)by rewrite !sqr_x2Dy_mod4 modnDm !modn2; do 2!case: odd.
(*A*)Qed.
(** #
#
- Deduce that if n is greater than 2 and a and b are solutions, then they are even.
#
# *)
Lemma sol_are_even n a b : n > 1 -> sol n a b -> (~~ odd a) && (~~ odd b).
Proof.
(*D*)case: n => [|[|n]]// _; rewrite /sol => /and3P[_ _ /eqP eq_a2Db].
(*D*)by rewrite mod4Dsqr_even// -eq_a2Db !expnS mulnA modnMr.
(*A*)Qed.
(** #
#
- Prove that the solutions for n are the halves of the solutions for n + 2.

  - Hint: [Search _ odd double] and [Search _ "eq" "mul"].

#
# *)
Lemma solSS n a b : sol n.+2 a b -> sol n a./2 b./2.
Proof.
(*D*)move=> soln2ab; have [//|a_even b_even] := andP (sol_are_even _ soln2ab).
(*D*)rewrite /sol -[a]odd_double_half -[b]odd_double_half in soln2ab.
(*D*)rewrite (negPf a_even) (negPf b_even) ?add0n ?double_gt0 in soln2ab.
(*D*)rewrite /sol; move: soln2ab => /and3P[-> -> /=].
(*D*)by rewrite -(addn2 n) expnD -!muln2 !expnMn -mulnDl eqn_mul2r.
(*A*)Qed.
(** #
#
- Prove there are no solutions for n even

  - Hint: Use [sol0] and [solSS].
#
# *)
Lemma sol_even a b n : ~~ sol (2 * n) a b.
Proof.
(*D*)elim: n => [|n IHn] in a b *; first exact: sol0.
(*D*)by apply/negP; rewrite mulnS => /solSS; apply/negP.
(*A*)Qed.
(** #
#
- Certify the only solution when n is odd.

  - Hint 1: Use [sol1], [solSS] and [sol_are_even].
  - Hint 2: Really sketch it on paper first!
#
# *)
Lemma sol_odd a b n : sol (2 * n + 1) a b = (a == 2 ^ n) && (b == 2 ^ n).
Proof.
(*D*)apply/idP/idP=> [|/andP[/eqP-> /eqP->]]; last first.
(*D*)  by rewrite /sol !expn_gt0/= expnD muln2 addnn -expnM mulnC.
(*D*)elim: n => [|n IHn] in a b *; first by rewrite sol1.
(*D*)rewrite mulnS !add2n !addSn => solab.
(*D*)have [//|/negPf aNodd /negPf bNodd] := andP (sol_are_even _ solab).
(*D*)rewrite /sol -[a]odd_double_half -[b]odd_double_half aNodd bNodd.
(*D*)by rewrite -!muln2 !expnSr !eqn_mul2r IHn// solSS.
(*A*)Qed.
(** #
#
*** Exercise 3:
Certify the solutions of this problem.

- Hint: Do not hesitate to take advantage of Coq's capabilities
  for brute force case analysis
#
# *)
Lemma ex3 n : (n + 4 %| 3 * n + 32) = (n \in [:: 0; 1; 6; 16]).
Proof.
(*D*)apply/idP/idP => [Hn|]; rewrite !inE; last first.
(*D*)  by move=> /or4P[] /eqP->.
(*D*)have : n + 4 %| 3 * n + 32 - 3 * (n + 4) by rewrite dvdn_sub// dvdn_mull.
(*D*)by rewrite mulnDr subnDl /= {Hn}; move: n; do 21?[case=>//].
(*A*)Qed.
(** #
#
*** Exercise 4:

Certify the result of the euclidean division of
#$$a b^n - 1\quad\textrm{  by  }\quad b ^ {n+1}$$#

#
# *)
Lemma ex4 a b n : a > 0 -> b > 0 -> n > 0 ->
   edivn (a * b ^ n - 1) (b ^ n.+1) =
   ((a - 1) %/ b, ((a - 1) %% b) * b ^ n + b ^ n - 1).
Proof.
(*D*)move=> a_gt0 b_gt0 n_gt0; rewrite /divn modn_def.
(*D*)have [q r aB1_eq r_lt] /= := edivnP (a - 1).
(*D*)rewrite b_gt0 /= in r_lt.
(*D*)have /(congr1 (muln^~ (b ^ n))) := aB1_eq.
(*D*)rewrite mulnBl mulnDl mul1n.
(*D*)move=> /(congr1 (addn^~ (b ^ n - 1))).
(*D*)rewrite addnBA ?expn_gt0 ?b_gt0// subnK; last first.
(*D*)  by rewrite -[X in X <= _]mul1n leq_mul2r a_gt0 orbT.
(*D*)rewrite -mulnA -expnS -addnA => ->.
(*D*)rewrite edivn_eq addnBA ?expn_gt0 ?b_gt0//.
(*D*)rewrite subnS subn0 prednK ?addn_gt0 ?expn_gt0 ?b_gt0 ?orbT//.
(*D*)rewrite -[X in _ + X]mul1n -mulnDl addn1 expnS.
(*D*)by rewrite leq_mul2r r_lt orbT.
(*A*)Qed.
(** #
#
*** Exercise 5:

Prove that the natural number interval #$$[n!+2\ ,\ n!+n]$$#
contains no prime number.

- Hint: Use [Search _ prime dvdn], [Search _ factorial], ...

#
# *)
Lemma ex5 n m : n`! + 2 <= m <= n`! + n -> ~~ prime m.
Proof.
(*D*)move=> m_in; move: (m_in); rewrite -[m](@subnKC n`!); last first.
(*D*)  by rewrite (@leq_trans (n`! + 2)) ?leq_addr//; by case/andP: m_in.
(*D*)set k := (_ - _); rewrite !leq_add2l => /andP[k_gt1 k_le_n].
(*D*)apply/primePn; right; exists k.
(*D*)  by rewrite k_gt1/= -subn_gt0 addnK fact_gt0.
(*D*)by rewrite dvdn_add// dvdn_fact// k_le_n (leq_trans _ k_gt1).
(*A*)Qed.
(** #
# *)


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                                  ex1.v                                   *)
(****************************************************************************)

Theorem trivial : forall A : Prop, A -> A.
intros A H'; exact H'.
Qed.

Theorem and_commutative : forall A B : Prop, A /\ B -> B /\ A.
intros A B H'; split.
elim H'; intros H'0 H'1; clear H'; exact H'1.
elim H'; intros H'0 H'1; clear H'; exact H'0.
Qed.

Theorem or_commutative : forall A B : Prop, A \/ B -> B \/ A.
intros A B h; elim h; [ intro H'; clear h; try exact H' | clear h; intro H' ].
right; assumption.
left; assumption.
Qed.

Theorem mp : forall A B : Prop, A -> (A -> B) -> B.
intros A B H' H'0.
apply H'0.
exact H'.
Qed.

Theorem S : forall A B C : Prop, (A -> B -> C) -> (A -> B) -> A -> C.
intros A B C H' H'0 H'1.
apply H'.
exact H'1.
apply H'0.
exact H'1.
Qed.

Theorem Praeclarum :
 forall x y z t : Prop, (x -> z) /\ (y -> t) -> x /\ y -> z /\ t.
intros x y z t h; elim h; intros H' H'0; clear h.
intro h; elim h; intros H'1 H'2; clear h.
split.
apply H'; assumption.
apply H'0; assumption.
Qed.

Theorem resolution :
 forall (p q : Type -> Prop) (a : Type),
 p a -> (forall x : Type, p x -> q x) -> q a.
intros p q a H' H'0.
apply H'0.
exact H'.
Qed.

Theorem Witnesses :
 forall (a b : Type) (p : Type -> Prop), p a \/ p b -> exists x : Type, p x.
intros a b p h; elim h; intro H'; clear h.
exists a; assumption.
exists b; assumption.
Qed.

Theorem Simple :
 forall (A : Set) (R : A -> A -> Prop),
 (forall x y z : A, R x y /\ R y z -> R x z) ->
 (forall x y : A, R x y -> R y x) ->
 forall x : A, (exists y : A, R x y) -> R x x.
intros A R H' H'0 x h; elim h; intros y E; clear h.
apply H' with y.
split; [ assumption | idtac ].
apply H'0; assumption.
Qed.

Theorem not_not : forall a : Prop, a -> ~ ~ a.
intros a H'; red in |- *; intro H'0; elim H'0; assumption.
Qed.

Theorem mini_cases : forall x y : Prop, (x \/ ~ y) /\ y -> x.
intros x y h; elim h; intros h0 H'; elim h0;
 [ intro H'0; clear h h0; try exact H'0 | clear h h0; intro H'0 ].
elim H'0; try assumption.
Qed.

Require Import Classical.
(*This theorem needs classical logic*)

Theorem not_not_converse : forall a : Prop, ~ ~ a -> a.
intros a H'.
generalize (classic a); intro h; elim h;
 [ intro H'0; clear h; try exact H'0 | clear h; intro H'0 ].
elim H'; assumption.
Qed.

Theorem not_quite_classic : forall a : Prop, ~ ~ (a \/ ~ a).
intro a; red in |- *; intro H'; elim H'; right; red in |- *; intro H'0.
elim H'; left; try assumption.
Qed.


Require Import Frap Modeling Hoare Helpers.

(* This logical formula is a proposition that described what it means
   for an array to be sorted. The array in question here is
   stored in the given heap, between indices [startI, endI) *)
Definition is_sorted (arr: heap) (startI: nat) (endI: nat): Prop :=
  forall (k1 k2: nat), (le startI k1) /\ (lt k1 k2) /\ (lt k2 endI) -> (le (arr $! k1) (arr $! k2)).

(* The program for merging two arrays:
   1. It assumes that two arrays are already provided on the heap, the
   first between indices [0, len1) and the second between [len1, len1 + len2).
   2. It writes out a merged sorted array to the end of the heap, so
   that the first two arrays are not changed, and are followed by the sorted
   array between indices [len1+len2, 2*(len1+len2) )
   3. The assertion for the for loop is given as a parameter, to allow you
   to define it without having to modify this program. The parameters to the
   assertion will be len1 and len2. *)
Definition merge_program (len1 len2: nat) (I: nat -> nat -> assertion): cmd := (
  (* i will be the current index in the merged resulting array *)
  "i" <- (len1 + len2) ;;
  "i1" <- 0 ;; (* current index in first array *)
  "i2" <- len1 ;; (* current index in the second array *)

  {{ I len1 len2 }} (* you will define this invariant *)
  _while_ "i" < (len1 + len2 + len1 + len2) _loop_
    (* standard merge: if arr1[i1] < arr2[i2], we add arr[i1] to the
        end of the merged array and increment i1, if arr1[i1] >= arr[i2],
        we choose arr[i2]. We must pay attention to special cases where
        i1 or i2 are out of range. *)
    _if_ "i1" < len1 _then_
      _if_ "i2" < len1 + len2 _then_
        _if_ *["i1"] < *["i2"] _then_
          *["i"] <- *["i1"] ;;
          "i1" <- "i1" + 1
        _else_
          *["i"] <- *["i2"] ;;
          "i2" <- "i2" + 1
        _done_
      _else_
        *["i"] <- *["i1"] ;;
        "i1" <- "i1" + 1
      _done_
    _else_
      (* i2 must be < len1 + len2 *)
      *["i"] <- *["i2"] ;;
      "i2" <- "i2" + 1
    _done_;;
    "i" <- "i" + 1
  _done_) % cmd.

Module Type Problem4.
  (* Start off by proving this simple lemma:
     if the array starting at startI and ending at endI is sorted,
     then the sub array starting at startI and ending at endI' is also sorted,
     where endI' <= endI. *)
  Axiom is_sorted_smaller: forall (arr: heap) (startI endI endI': nat),
    is_sorted arr startI endI -> endI' <= endI -> is_sorted arr startI endI'.

  (* an array made out of a single element is sorted ! *)
  Axiom singletone_is_sorted: forall (arr: heap) (startI: nat),
    is_sorted arr startI (startI + 1).

  (* You can extend an array that is sorted with an element at the end
     as long as that element is the greater or equal to the right most
     element (the largest element in the array), and get a new sorted array *)
  Axiom is_sorted_extend: forall (arr: heap) (startI endI x: nat),
    is_sorted arr startI endI
    -> arr $! (endI - 1) <= x
    -> is_sorted (arr $+ (endI, x)) startI (endI + 1).

  (* Changing elements in the heap that are outside an array will not
     affect whether the array is sorted or not *)
  Axiom is_sorted_remains_sorted_with_useless:
    forall (arr: heap) (startI endI: nat) (i x: nat),
      is_sorted arr startI endI
      -> i >= endI
      -> is_sorted (arr $+ (i, x)) startI endI.

  (* You must define the invariant for the while loop of the program above:
     Remember, the invariant must:
     1. Be true before the execution of the while loop start.
     2. Remain true after each execution of the while loop.
     3. Imply the post condition we desired (defined below) *)
  Parameter merge_invariant: nat -> nat -> assertion.

  (* The first version of correctness: the resulting array must be sorted,
     given that the two input arrays are sorted *)
  (* Helpers.v contain some helpful tactics that will automate a large chunk of
     this proof, as well as some hints, read the comments there carefully *)
  (* HINT: At some point in the proof, you will reach the body of the while loop,
     using [ht1] or [ht] or manually applying the HtIf rule will spit out
     4 goals for you, this is because we have 4 cases in the body of the loop:
     1. i1 is out of range
     2. i2 is out of range
     3. both in range but the element at i1 < element at i2.
     4. both in range but the element at i1 >= element at i2.
     The goals produces at all these cases are very similar, and can be
     solved by exactly the same proof if written generally enough. Consider
     using the tactic [first_order] in these proofs! *)
  (* HINT: In both the manual and automatic version of my solutions, I got a total
     of 6 proof obligations.
     1. for showing the invariant of the while loop is initally true.
     2-5. the proof obligations corresponding to the cases above.
     6. Obligation for showing that the loop invariant implies the post condition
        when the loop is done. You will want to use 'is_sorted_smaller' here. *)
  Axiom merge_correct: forall (len1 len2: nat),
    {{ fun h v => is_sorted h 0 len1 /\ is_sorted h len1 (len1 + len2) }}
    merge_program len1 len2 merge_invariant
    {{ fun h v => (is_sorted h (len1 + len2) (len1 + len2 + len1 + len2)) }}.
End Problem4.


(**
有限集合の濃度の存在を証明する
======
2019/05/01

この文書のソースコードは以下にあります。

https://github.com/suharahiromichi/coq/blob/master/pearl/ssr_ex_card.v

 *)

(**
OCaml 4.07.1, Coq 8.9.0, MathComp 1.9.0
 *)

(**
# 説明

へんなタイトルですが、MathComp を使った定理の証明の問題です。

有限集合の濃度、すなわち要素の個数は、適当な自然数に一意的に決まります。
濃度を ``#| _ |`` で表すとすると、

``∃ i : nat, #| p | = i``

ですね。これ自体は自明なのですが、MathComp で証明しようとすると、
取り付く島もないように見えます。

でも、すこし考えてみると、
MathComp の場合、集合は有限型(finType)をドメインとするbooleanな関数で
表されます。すなわち、``T : finType`` とすると、

``p : pred T``

なお、``pred T`` は単に ``T -> bool`` の Notation (構文糖衣) です。

pが、常にtrueを返す場合が全集合、常にfalseを返す場合が空集合になります。
このように、集合pと関数pが同一視されるので、集合pの濃度は、
「型Tの要素のうち、関数pがtrueを返す要素の数」
ということになります。

このことから、
型Tの要素の全体をしめす finType の enum フィールドの中身 (リスト、seq型) について、
関数pでフィルタした結果のサイズが決まることを証明すればよいことになります。

型 T から、その enum フィールドの中身を取り出すのは、次のようにします。

``Finite.enum T``

後の証明は、単にリストの要素についての帰納法です。

ほとんど自明であるがゆえに、
MathCompにおける実装の裏側を知らないと解けない問題の例といえるでしょうか。
 *)

(**
# コード例
 *)

From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* Set Print All. *)

Section Test.

  Variable T : finType.
  Variable p : pred T.                      (* T -> bool *)

  Lemma ex_card : exists (i : nat), #| p | = i.
  Proof.
    rewrite unlock /card /enum_mem.
    elim: (Finite.enum T).
    - by exists 0.
    - move=> x s /= [i IHs].
      case: ifP => /=.
      + exists i.+1.
          by rewrite IHs.
      + by exists i.
  Qed.

End Test.

(**
# 最初に使った箇所

単一化の証明 http://fetburner.hatenablog.com/entry/2015/12/06/224619

Unify.v を MathComp への移植するときに必要になりました。移植例：

https://github.com/suharahiromichi/coq/blob/master/unify/ssr_unify_bool_3.v
*)

(* END *)


Require Export D.

(** **** Problem #1: 1 star (factorial) *)
(** Recall the standard factorial function:
<<
    factorial(0)  =  1
    factorial(n)  =  n * factorial(n-1)     (if n>0)
>>
    Translate this into Coq.

    Note that plus and multiplication are already defined in Coq.
    use "+" for plus and "*" for multiplication.
*)

Eval compute in 3 * 5.
Eval compute in 3+5*6.

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

Example test_factorial1:          (factorial 3) = 6.
Proof. reflexivity. Qed.
Example test_factorial2:          (factorial 5) = 10 * 12.
Proof. reflexivity. Qed.


Require Import List.
Require Import Cpdt.CpdtTactics.
Require Coq.extraction.Extraction.
Set Implicit Arguments.
Set Asymmetric Patterns.
Extraction Language OCaml.

(* PART 2: Programming with Dependent Types *)
(* Chapter 6. Subset Types and Variations *)

Extraction pred.
(*
(** val pred : nat -> nat **)
let pred = function
  | O -> O
  | S u -> u
*)

(* We might like to be sure that we never try to take the predecessor of 0.
   We can enforce this by giving pred a stronger, dependent type.  *)

Lemma zgtz : 0 > 0 -> False.
  crush.
Qed.

Definition pred_strong1 (n : nat) : n > 0 (* : proof *) -> nat :=
  match n with
    | O => fun pf : 0 > 0 => match zgtz pf with end
    | S n' => fun _ => n'
  end.

(* argument n of pred strong1 can be made implicit,
   since it can be deduced from the type of the second argument *)
Theorem two_gt0 : 2 > 0.
  crush.
Qed.

Eval compute in pred_strong1 two_gt0.

Lemma zero_gt0 : 0 > 0. (* absurd! *)
Admitted.
Eval compute in pred_strong1 zero_gt0.
(*
    = match zgtz zero_gt0 return nat with
      end
    : nat
*)

(*
(* following example fails to type-check *)
Definition pred_strong1' (n : nat) (pf : n > 0) : nat :=
  match n with
    | O => match zgtz pf with end
    | S n' => n'
  end.
*)

(* Coq's heuristics had inferred [return n > 0 -> nat] in the above example. *)
Definition pred_strong1' (n : nat) : n > 0 -> nat :=
  match n return n > 0 -> nat with
    | O => fun pf : 0 > 0 => match zgtz pf with end
    | S n' => fun _ => n'
  end.

Extraction pred_strong1.

(* Curry-Howard twin of ex (sig : Type, ex : Prop) *)
Print sig.
(*
  Inductive sig (A : Type) (P : A -> Prop) : Type :=
      exist : forall x : A, P x -> { x : A | P x }
  (Argument A is implicit)
*)
(* cf. *)
Print ex.
(*
  Inductive ex (A : Type) (P : A -> Prop) : Prop :=
      ex_intro : forall x : A, P x -> exists y, P y
  (Argument A is implicit)
*)

Locate "{ _ : _ | _ }".
(*
  Notation
  "{ x : A  |  P }" := sig (fun x : A => P)
*)

Definition pred_strong2 (s : {n : nat | n > 0}) : nat :=
  match s with
    | exist O pf => match zgtz pf with end
    | exist (S n') _ => n'
  end.

                                 (* v "P" in the definition of sig *)
Eval compute in pred_strong2 (exist _ 2 two_gt0).
                             (* ^ constructor of sig *)
(* ... the above is the same as this: *)
Eval compute in pred_strong2 (exist (fun n => n > 0) 2 two_gt0).
Extraction pred_strong2.

(*
  Definition proj1_sig (e:sig P) := match e with
                                    | exist _ a b => a
                                    end.

  : function to extract the first argument of sig (the value that 'exists')
*)
Definition pred_strong3 (s : {n : nat | n > 0}) : {m : nat | proj1_sig s = S m} :=
  match s return {m : nat | proj1_sig s = S m} with
    | exist 0 pf => match zgtz pf with end
    | exist (S n') pf => exist _ n' (eq_refl _)
  end.

Eval compute in proj1_sig (exist _ 2 two_gt0). (* 2 *)
Eval compute in pred_strong3 (exist _ 2 two_gt0).

(*
  = exist (fun m : nat => 2 = S m) 1 eq_refl
  : {m : nat | proj1_sig (exist (lt 0) 2 two_gt0) = S m}

  ** eq_refl: law of 'reflexivity'
*)

Extraction pred_strong3.

Check False_rec.
(* forall P : Set, False -> P *)

(* tactic-based theorem proving
   cf) https://softwarefoundations.cis.upenn.edu/lf-current/ProofObjects.html#lab268 *)
Definition pred_strong4 : forall n : nat, n > 0 -> {m : nat | n = S m}.
  (* refine _term_ : provide _term_ as proof.
                     _term_ should have the same type as the goal. *)
  refine (fun n =>
    match n with
      | O => fun _ => False_rec _ _
      | S n' => fun _ => exist _ n' _
    end).
  crush.
  reflexivity.
Restart.
  destruct n as [| n']; intros.
  - apply exist with (x:=0). inversion H.
  - apply exist with (x:=n'). reflexivity.
Defined. (* <- by using 'Defined', proof will remain transparent
               (using 'Qed' instead will make the proof opaque) *)

Print pred_strong4.
Eval compute in pred_strong4 two_gt0.

Definition pred_strong4' : forall n : nat, n > 0 -> {m : nat | n = S m}.
  (* abstract : produces shorter terms, by automatically abstracting subgoals
                into named lemmas (???) *)
  refine (fun n =>
    match n with
      | O => fun _ => False_rec _ _
      | S n' => fun _ => exist _ n' _
    end); abstract crush.
Defined.

Print pred_strong4'.
(*
  pred_strong4' =
  fun n : nat =>
  match n as n0 return (n0 > 0 -> {m : nat | n0 = S m}) with
  | 0 =>
      fun _H : 0 > 0 =>
      False_rec {m : nat | 0 = S m} (pred_strong4'_subproof n _H)
  | S n' =>
      fun _H : S n' > 0 =>
      exist (fun m : nat => S n' = S m) n' (pred_strong4'_subproof0 n _H)
  end
       : forall n : nat, n > 0 -> {m : nat | n = S m}
*)
Print pred_strong4'_subproof.
(*
  pred_strong4'_subproof =
  fun g : 0 > 0 =>
  Bool.diff_false_true
    (Bool.absurd_eq_true false
       (Bool.diff_false_true
          (Bool.absurd_eq_true false (pred_strong4'_subproof_subproof g))))
       : 0 > 0 -> False
*)
Print pred_strong4'_subproof0.
(*
  pred_strong4'_subproof0 =
  fun n' : nat => eq_refl
       : forall n' : nat, S n' = S n'
*)

Notation "!" := (False_rec _ _).
Notation "[ e ]" := (exist _ e _).

Definition pred_strong5 : forall n : nat, n > 0 -> {m : nat | n = S m}.
  refine (fun n =>
    match n with
      | O => fun _ => !
      | S n' => fun _ => [n']
    end); crush.
Defined.

Eval compute in pred_strong5 two_gt0.

(* using Coq's new feature [Program] *)
(* cf: https://sites.google.com/site/suharahiromichi/program-ing-coq/coq_subset *)
Obligation Tactic := crush.
Program Definition pred_strong6 (n : nat) (_ : n > 0) : {m : nat | n = S m} :=
  match n with
    | O => _
    | S n' => n'
  end.

Eval compute in pred_strong6 two_gt0.

(* 6.2 Decidable Proposition Types *)

(* another type in STL which captures the idea of program values *)
Print sumbool.
(*
Inductive sumbool (A : Prop) (B : Prop) : Set :=
    left : A -> {A} + {B} | right : B -> {A} + {B}
*)

Notation "'Yes'" := (left _ _).
Notation "'No'" := (right _ _).
Notation "'Reduce' x" := (if x then Yes else No) (at level 50).
(* ^ The [if] form actually works when the test expression has any two-constructor
   inductive type. *)

Inductive funny : Set :=
| Foo
| Bar.
Eval compute in (if Foo then Yes else No).

Definition eq_nat_dec : forall n m : nat, {n = m} + {n <> m}.
  refine (fix f (n m : nat) : {n = m} + {n <> m} :=
    match n, m with
      | O, O => Yes
      | S n', S m' => Reduce (f n' m')
      | _, _ => No
    end); congruence.
    (* congruence: http://proofcafe.org/sf/UseAuto_J.html *)
Restart.
  induction n.
  - destruct m.
    + left. reflexivity.
    + right. congruence.
  - induction m.
    + right. congruence.
    + destruct (IHn m).
      { left. congruence. }
      { right. congruence. }
Defined.

Eval compute in eq_nat_dec 2 2.
Eval compute in eq_nat_dec 2 3.
(* Note: Yes and No notations are hiding proofs establishing the correctness of the outputs. *)

Extraction eq_nat_dec.
(*
(** val eq_nat_dec : nat -> nat -> sumbool **)

let rec eq_nat_dec n m =
  match n with
    | O -> (match m with
              | O -> Left
              | S n0 -> Right)
    | S n' -> (match m with
                 | O -> Right
                 | S m' -> eq_nat_dec n' m')
*)

(* Proving this kind of decidable equality result is so common that Coq comes with a tactic for automating it.
 https://coq.inria.fr/refman/proof-engine/tactics.html#coq:tacn.decide-equality
*)
Definition eq_nat_dec' (n m : nat) : {n = m} + {n <> m}.
  decide equality.
Defined.
Extraction eq_nat_dec'.

(* use "true" and "false" instead of "Left" and "Right" *)
Extract Inductive sumbool => "bool" ["true" "false"].
Extraction eq_nat_dec'.

Notation "x || y" := (if x then Yes else Reduce y).

(* function to decide list membership *)
Section In_dec.
  Variable A : Set.
  Variable A_eq_dec : forall x y : A, {x = y} + {x <> y}. (* ??? *)

  Definition In_dec : forall (x : A) (ls : list A), {In x ls} + {~ In x ls}.
    refine (fix f (x : A) (ls : list A) : {In x ls} + {~ In x ls} :=
      match ls with
      | nil => No
      | x' :: ls' => A_eq_dec x x' || f x ls'
      end); crush.
  Restart.
    induction ls.
    - right. intros contra. inversion contra.
    - simpl. destruct (A_eq_dec a x).
      + subst. left. left. reflexivity.
      + destruct IHls.
        { left. right. assumption. }
        { right. intros contra. destruct contra; auto. }
  Defined.
End In_dec.

Eval compute in In_dec eq_nat_dec 2 (1 :: 2 :: nil).
Eval compute in In_dec eq_nat_dec 3 (1 :: 2 :: nil).
Extraction In_dec.
(*
(** val in_dec : ('a1 -> 'a1 -> bool) -> 'a1 -> 'a1 list -> bool **)

let rec in_dec a_eq_dec x = function
  | Nil -> false
  | Cons (x', ls') ->
      (match a_eq_dec x x' with
         | true -> true
         | false -> in_dec a_eq_dec x ls')
*)

(* 6.3 Partial Subset Types *)

(* use 'maybe' to allow obligation-free failure *)
Inductive maybe (A : Set) (P : A -> Prop) : Set :=
| Unknown : maybe P
| Found : forall x : A, P x -> maybe P.

Notation "{{ x | P }}" := (maybe (fun x => P)).
Notation "??" := (Unknown _).
Notation "[| x |]" := (Found _ x _).

Definition pred_strong7 : forall n : nat, {{m | n = S m}}.
  refine (fun n =>
    match n return {{m | n = S m}} with
      | O => ??
      | S n' => [|n'|]
    end); trivial.
Defined.

Eval compute in pred_strong7 2.
Eval compute in pred_strong7 0.

(* How to make sure we'll allow [Unknown] only when the result is really unknown?
   => ex. [sumor]
*)

Print sumor.
(*
Inductive sumor (A : Type) (B : Prop) : Type :=
    inleft : A -> A + {B} | inright : B -> A + {B}

  : sumor is either value of A or proofs of B.
*)
Locate "_ + { _ }".

Notation "!!" := (inright _ _). (* proof *)
Notation "[|| x ||]" := (inleft _ [x]). (* value *)
(* ^ supecialized to [sumor]s whose [A] params are instantiated with regular subset types *)

(* possibly failing predecessor ([sumor]-based, maximally expressive) *)
Definition pred_strong8 : forall n : nat, {m : nat | n = S m} + {n = 0}.
  refine (fun n =>
    match n with
      | O => !!
      | S n' => [||n'||]
    end); trivial.
Defined.

Eval compute in pred_strong8 2.
Eval compute in pred_strong8 0.

(* 6.4 Monadic Notations *)

(* "bind"-like notation *)
Notation "x <- e1 ; e2" := (match e1 with
                             | Unknown => ??
                             | Found x _ => e2
                           end)
(right associativity, at level 60).

(* a function to take the predecessors of two naturals at once *)
Definition doublePred : forall n1 n2 : nat,
  {{p | n1 = S (fst p) /\ n2 = S (snd p)}}.
  refine (fun n1 n2 =>
    m1 <- pred_strong7 n1;
    m2 <- pred_strong7 n2;
    [|(m1, m2)|]); tauto.
Defined.

(* [sumor] version of the "bind" notation *)
Notation "x <-- e1 ; e2" := (match e1 with
                               | inright _ => !!
                               | inleft (exist x _) => e2
                             end)
(right associativity, at level 60).

Definition doublePred' : forall n1 n2 : nat,
  {p : nat * nat | n1 = S (fst p) /\ n2 = S (snd p)}
  + {n1 = 0 \/ n2 = 0}.
  refine (fun n1 n2 =>
    m1 <-- pred_strong8 n1;
    m2 <-- pred_strong8 n2;
    [||(m1, m2)||]); tauto.
Defined.

(* 6.5 A Type-Checking Example *)

Inductive exp : Set :=
| Nat : nat -> exp
| Plus : exp -> exp -> exp
| Bool : bool -> exp
| And : exp -> exp -> exp.

Inductive type : Set := TNat | TBool.

Inductive hasType : exp -> type -> Prop :=
| HtNat : forall n,
  hasType (Nat n) TNat
| HtPlus : forall e1 e2,
  hasType e1 TNat
  -> hasType e2 TNat
  -> hasType (Plus e1 e2) TNat
| HtBool : forall b,
  hasType (Bool b) TBool
| HtAnd : forall e1 e2,
  hasType e1 TBool
  -> hasType e2 TBool
  -> hasType (And e1 e2) TBool.

(* function to compare two types *)
Definition eq_type_dec : forall t1 t2 : type, {t1 = t2} + {t1 <> t2}.
  decide equality.
Defined.

(* notation for "assertion" *)
Notation "e1 ;; e2" := (if e1 then e2 else ??)
  (right associativity, at level 60).

(* every [[|e|]] expression adds a [hasType] proof obligation *)
Definition typeCheck : forall e : exp, {{t | hasType e t}}.
  (* Note: {{t | hasType e t}} = maybe (fun t => hasType e t) *)
  Hint Constructors hasType.
  refine (fix F (e : exp) : {{t | hasType e t}} :=
    match e return {{t | hasType e t}} with
      | Nat _ => [|TNat|]
      | Plus e1 e2 =>
        t1 <- F e1;
        t2 <- F e2;
        eq_type_dec t1 TNat;;
        eq_type_dec t2 TNat;;
        [|TNat|]
      | Bool _ => [|TBool|]
      | And e1 e2 =>
        t1 <- F e1;
        t2 <- F e2;
        eq_type_dec t1 TBool;;
        eq_type_dec t2 TBool;;
        [|TBool|]
    end); crush.
Defined.

Eval simpl in typeCheck (Nat 0).
Eval simpl in typeCheck (Plus (Nat 1) (Nat 2)).
Eval simpl in typeCheck (Plus (Nat 1) (Bool false)).
Extraction typeCheck.
(*
(** val typeCheck : exp -> type0 maybe **)

let rec typeCheck = function
  | Nat n -> Found TNat
  | Plus (e1, e2) ->
      (match typeCheck e1 with
         | Unknown -> Unknown
         | Found t1 ->
             (match typeCheck e2 with
                | Unknown -> Unknown
                | Found t2 ->
                    (match eq_type_dec t1 TNat with
                       | true ->
                           (match eq_type_dec t2 TNat with
                              | true -> Found TNat
                              | false -> Unknown)
                       | false -> Unknown)))
  | Bool b -> Found TBool
  | And (e1, e2) ->
      (match typeCheck e1 with
         | Unknown -> Unknown
         | Found t1 ->
             (match typeCheck e2 with
                | Unknown -> Unknown
                | Found t2 ->
                    (match eq_type_dec t1 TBool with
                       | true ->
                           (match eq_type_dec t2 TBool with
                              | true -> Found TBool
                              | false -> Unknown)
                       | false -> Unknown)))
*)

Notation "e1 ;;; e2" := (if e1 then e2 else !!)
  (right associativity, at level 60).

(* det = deterministic *)
Lemma hasType_det : forall e t1,
  hasType e t1 ->
  forall t2, hasType e t2 ->
  t1 = t2.
Proof.
  induction 1; inversion 1; crush.
Restart.
  induction e; intros.
  - (* Nat *)  inversion H. inversion H0. reflexivity.
  - (* Plus *) inversion H. inversion H0. reflexivity.
  - (* Bool *) inversion H. inversion H0. reflexivity.
  - (* And *)  inversion H. inversion H0. reflexivity.
Qed.

Definition typeCheck' : forall e : exp,
  {t : type | hasType e t} + {forall t, ~ hasType e t}.
  Hint Constructors hasType.
  Hint Resolve hasType_det.
  (* Since its statement includes [forall]-bound variables that do not appear in its conclusion,
     only [eauto] will apply this hint. *)

  refine (fix F (e : exp) : {t : type | hasType e t} + {forall t, ~ hasType e t} :=
    match e return {t : type | hasType e t} + {forall t, ~ hasType e t} with
      | Nat _ => [||TNat||]
      | Plus e1 e2 =>
        t1 <-- F e1;
        t2 <-- F e2;
        eq_type_dec t1 TNat;;;
        eq_type_dec t2 TNat;;;
        [||TNat||]
      | Bool _ => [||TBool||]
      | And e1 e2 =>
        t1 <-- F e1;
        t2 <-- F e2;
        eq_type_dec t1 TBool;;;
        eq_type_dec t2 TBool;;;
        [||TBool||]
    end); clear F; crush' tt hasType; eauto.
  (* We clear [F], the local name for the recursive function, to avoid strange proofs that refer to recursive calls
     that we never make. Such a step is usually warranted when defining a recursive function with [refine].
     The [crush] variant [crush'] helps us by performing automatic inversion on instances of the predicates specified
     in its second argument. Once we throw in [eauto] to apply [hasType_det] for us, we have discharged all the subgoals. *)
Restart.
  induction e.
  - left. exists TNat. (* somehow worked! *) constructor.
  - destruct IHe1 as [IHe1' | IHe1'].
    + destruct IHe2 as [IHe2' | IHe2'].
      { inversion IHe1' as [t1 H1]. inversion IHe2' as [t2 H2].
        destruct t1.
        - (* t1 = TNat *) destruct t2.
          + (* t2 = TNat *) left. exists TNat. auto.
          + (* t2 = TBool *) right. intros t H. inversion H; subst.
            apply hasType_det with (t1:=TNat) in H2. inversion H2. trivial.
        - (* t1 = TBool *) right. intros t H. inversion H; subst.
          apply hasType_det with (t1:=TNat) in H1. inversion H1. trivial. }
      { (* e2 is untypable *)
         right. intros t H. inversion H; subst. apply IHe2' in H4. auto. }
    + (* e1 is untypable *)
      right. intros t H. inversion H; subst. apply IHe1' in H2. auto.
  - left. exists TBool. constructor.
  - destruct IHe1 as [IHe1' | IHe1'].
    + destruct IHe2 as [IHe2' | IHe2'].
      { inversion IHe1' as [t1 H1]. inversion IHe2' as [t2 H2].
        destruct t1.
        - (* t1 = TNat *) right. intros t H. inversion H; subst.
          apply hasType_det with (t1:=TBool) in H1. inversion H1. trivial.
        - (* t1 = TBool *) destruct t2.
          + (* t2 = TNat *) right. intros t H. inversion H; subst.
            apply hasType_det with (t1:=TBool) in H2. inversion H2. trivial.
          + (* t2 = TBool *) left. exists TBool. auto. }
      { (* e2 is untypable *)
         right. intros t H. inversion H; subst. apply IHe2' in H4. auto. }
    + (* e1 is untypable *)
      right. intros t H. inversion H; subst. apply IHe1' in H2. auto.
Defined.

Eval simpl in typeCheck' (Nat 0).
Eval simpl in typeCheck' (Plus (Nat 1) (Nat 2)).
Eval simpl in typeCheck' (Plus (Nat 1) (Bool false)).
(* Extraction typeCheck'. *)


Require Import Problem PeanoNat Omega.

Lemma binom_n_Sn (n : nat) : binom n (S n) = 0.
Proof.
  remember (S n) as k.
  assert (k > n) by omega; clear Heqk.
  revert k H.
  induction n; simpl; intros.
  - destruct k; omega.
  - destruct k; [omega|].
    rewrite IHn; [|omega].
    rewrite IHn; omega.
Qed.

Lemma binom_sum_split (m n : nat) : binom_sum (S m) (S n) = binom_sum m (S n) + binom_sum m n.
Proof.
  simpl.
  repeat rewrite <- Nat.add_assoc.
  apply Nat.add_cancel_l.
  induction n.
  * destruct m; simpl; auto.
  * simpl.
    repeat rewrite <- Nat.add_assoc.
    rewrite IHn.
    omega.
Qed.

Theorem solution: task.
Proof.
  unfold task.
  induction n; [auto|].
  replace (2 ^ S n) with (2 * 2^n) by (simpl; omega).
  rewrite <- IHn; clear IHn.
  rewrite binom_sum_split.
  simpl.
  rewrite binom_n_Sn.
  auto.
Qed.


Require Import Arith.
Require Import List.

Require Import Omega.

Require Import listkit.

Parameter char : Set.

Definition leftpad c n (s : list char) :=
  repeat c (n - length s) ++ s.

(** Proving all three correctness conditions at once. *)
Lemma correctness:
  forall c n s,
    length (leftpad c n s) = max n (length s) /\
    allEq _ (take _ (n - length s) (leftpad c n s)) c /\
    drop _ (n - length s) (leftpad c n s) = s.
Proof.
 unfold leftpad.
 firstorder (autorewrite with list_lemmas; auto).
    destruct (le_lt_dec n (length s)).
     rewrite max_r; omega.
    rewrite max_l; omega.
   apply listall_repeat.
  firstorder (autorewrite with list_lemmas; auto).
 firstorder (autorewrite with list_lemmas; auto).
Qed.


(* Coq Exercise 1 / http://qnighy.github.io/coqex2014/ex1.html *)

Theorem tautology : forall P : Prop, P -> P.
Proof.
  intros P H.
  assumption.
Qed.

(*
Theorem wrong : forall P : Prop, P.
Proof.
  intros P.
Qed.
*)

Theorem Modus_ponens : forall P Q : Prop, P -> (P -> Q) -> Q.
Proof.
intros P Q p pq.
apply pq. assumption.
Qed.

Theorem Modus_tollens : forall P Q : Prop, ~Q /\ (P -> Q) -> ~P.
Proof.
intros P Q H p.
destruct H as [nq pq].
apply nq. apply pq. assumption.
Qed.

Theorem Disjunctive_syllogism : forall P Q : Prop, (P \/ Q) -> ~P -> Q.
Proof.
intros P Q pq np.
destruct pq as [p|q].
 elim np. assumption.
assumption.
Qed.

Theorem DeMorgan1 : forall P Q : Prop, ~P \/ ~Q -> ~(P /\ Q).
Proof.
intros P Q H pq. destruct pq as [p q].
destruct H as [np|nq].
 apply np. assumption.
apply nq. assumption.
Qed.

Theorem DeMorgan2 : forall P Q : Prop, ~P /\ ~Q -> ~(P \/ Q).
Proof.
intros P Q H pq. destruct H as [np nq].
destruct pq as [p|q].
 apply np. assumption.
apply nq. assumption.
Qed.

Theorem DeMorgan3 : forall P Q : Prop, ~(P \/ Q) -> ~P /\ ~Q.
Proof.
intros P Q H. split.
 intro p. apply H. left. assumption.
intro q. apply H. right. assumption.
Qed.

Theorem NotNot_LEM : forall P : Prop, ~ ~(P \/ ~P).
Proof.
intros P H. apply H.
right. intro p. apply H. left. assumption.
Qed.


(* ************************************************************************** *)
(* ************************************************************************** *)
(* Pairs of Numbers *)
Module NatList.
Inductive natprod : Type :=
| pair (n1 n2 : nat).
Check (pair 3 2) : natprod.
Definition fst (p : natprod) : nat :=
  match p with
  | pair x _ => x
  end.
Definition snd (p : natprod) : nat :=
  match p with
  | pair _ y => y
  end.
Compute (fst (pair 2 3)) : nat.
Notation "( x , y )" := (pair x y).
Compute (fst (2, 3)) : nat.
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_impairing' : forall (n m : nat),
    (n, m) = (fst (n, m), snd (n, m)).
Proof.  reflexivity.
Qed.
Theorem surjective_impairing : forall (p : natprod),
    p = (fst p, snd p).
Proof.
  intros p.
  destruct p as [n m].
  reflexivity.
Qed.

(* ************************************************************************** *)
(* Exercise: 1 star, standard (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: 1 star, standard, optional (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.

(* ************************************************************************** *)
(* Lists of Numbers *)
Inductive natlist : Type :=
| nil
| cons (n : nat) (l : natlist).
Definition mylist := cons 1 (cons 2 (cons 3 nil)).
Notation "x :: l" := (cons x l)
                       (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).
Fixpoint repeat (n count : nat) : natlist :=
  match count with
  | O => []
  | S count => n :: (repeat n count)
  end.
Fixpoint length (l : natlist) : nat :=
  match l with
  | [] => 0
  | _ :: tl => 1 + length tl
  end.
Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | [] => l2
  | hd :: tl => hd :: (app tl 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
  | [] => default
  | hd :: _ => hd
  end.
Definition tl (l : natlist) : natlist :=
  match l with
  | [] => []
  | _ :: tl => tl
  end.

(* ************************************************************************** *)
(* Exercise: 2 stars, standard, especially useful (list_funs) *)
Fixpoint nonzeros (l : natlist) : natlist :=
  match l with
  | [] => []
  | 0 :: tl => nonzeros tl
  | hd :: tl => hd :: nonzeros tl
  end.
Example test_nonzeros :
  nonzeros [0;1;0;2;3;0;0] = [1;2;3].
Proof. simpl. reflexivity. Qed.
Fixpoint is_odd (n : nat) : bool :=
  match n with
  | 0 => false
  | 1 => true
  | S (S n) => is_odd n
  end.
Fixpoint oddmembers (l : natlist) : natlist :=
  match l with
  | [] => []
  | hd :: tl =>
    if is_odd hd then hd :: oddmembers tl
    else oddmembers tl
  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: 3 stars, advanced (alternate) *)
Fixpoint alternate (l1 l2 : natlist) : natlist :=
  match l1, l2 with
  | [], [] => []
  | [], l2 => l2
  | l1, [] => l1
  | hd1 :: tl1, hd2 :: tl2 => hd1 :: hd2 :: (alternate tl1 tl2)
  end.
Example test_alternate1:
  alternate [1;3;5] [2;4;6] = [1;2;3;4;5;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.

(* ************************************************************************** *)
(* Exercise: 3 stars, standard, especially useful (bag_functions) *)
Definition bag := natlist.
Fixpoint count (v : nat) (s : bag) : nat :=
  match s with
  | [] => 0
  | hd :: tl =>
    if Nat.eqb hd v then 1 + count v tl
    else count v tl
  end.
Example test_count1: count 1 [1;2;3;1;4;1] = 3.
Proof. reflexivity. Qed.
Example test_count2: count 6 [1;2;3;1;4;1] = 0.
Proof. reflexivity. Qed.
Definition sum : bag -> bag -> bag := app.
Example test_sum1: count 1 (sum [1;2;3] [1;4;1]) = 3.
Proof. reflexivity. Qed.
Definition add (v : nat) (s : bag) : bag := 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.
Fixpoint member (v : nat) (s : bag) : bool :=
  match s with
  | [] => false
  | hd :: tl =>
    if Nat.eqb hd v then true
    else member v tl
  end.
Example test_member1: member 1 [1;4;1] = true.
Proof. reflexivity. Qed.
Example test_member2: member 2 [1;4;1] = false.
Proof. reflexivity. Qed.

(* ************************************************************************** *)
(* Exercise: 3 stars, standard, optional (bag_more_functions) *)
Fixpoint remove_one (v : nat) (s : bag) : bag :=
  match s with
  | [] => []
  | hd :: tl =>
    if Nat.eqb hd v then tl
    else hd :: remove_one v tl
  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
  | [] => []
  | hd :: tl =>
    if Nat.eqb hd v then remove_all v tl
    else hd :: remove_all v tl
  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.
Fixpoint included (s1 : bag) (s2 : bag) : bool :=
  match s1 with
  | [] => true
  | hd :: tl =>
    if member hd s2 then included tl (remove_one hd s2)
    else false
  end.
Example test_included1: included [1;2] [2;1;4;1] = true.
Proof. reflexivity. Qed.
Example test_included2: included [1;2;2] [2;1;4;1] = false.
Proof. reflexivity. Qed.

(* ************************************************************************** *)
(* Exercise: 2 stars, standard, especially useful (add_inc_count) *)
Theorem eq_n_n_true : forall n : nat,
    Nat.eqb n n = true.
Proof.
  intros n.
  induction n as [|n' IHn].
  - reflexivity.
  - simpl. rewrite -> IHn. reflexivity.
Qed.
Theorem add_inc_count : forall (n : nat) (s : bag),
    count n s + 1 = count n (n :: s) .
Proof.
  intros n s.
  induction s as [|n' s' IHs].
  - simpl.
    rewrite -> eq_n_n_true.
    reflexivity.
  - simpl.
    rewrite -> eq_n_n_true.
    assert (H: forall a, S a = a + 1). {
      intros a.
      induction a as [|a IHa].
      - reflexivity.
      - simpl. rewrite <- IHa. reflexivity.
    }
    rewrite <- H.
    reflexivity.
Qed.

(* ************************************************************************** *)
(* Reasoning About Lists *)


Set Implicit Arguments.
Import Nat.

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

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

  Definition le0 : forall n, 0 <= n :=
    fix h n :=
      match n with
        0 => le_n 0
      | S k => le_S (h k)
      end.

(**)

  Fixpoint le0' n : 0 <= n :=
    match n with
      0 => le_n 0
    | S k => le_S (le0' k)
    end.

  Lemma le0'' : forall n, 0 <= n.

(**)

  Definition lt m n := le (S m) n.
  Notation "m < n" := (lt m n).

  Lemma lt0 : forall n, n = 0 \/ 0 < n.

(**)

  Theorem f_equal : forall A B (f : A -> B) x y, x = y -> f x = f y.
  Proof.
    intros. rewrite H. reflexivity.
  Qed.


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

Definition even (n: nat): Prop :=
    evenb n = true.

Inductive ev: nat -> Prop :=
| ev_0: ev O
| ev_SS: forall n: nat, ev n -> ev (S (S n)).

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

Theorem double_even: forall n, ev (double n).
Proof.
    intros n.
    induction n. apply ev_0.
    simpl. apply ev_SS. apply IHn.
Qed.

Theorem ev__even: forall n, ev n -> even n.
Proof.
    intros n E.
    induction E as [| n' E'].
    unfold even. reflexivity.
    unfold even. apply IHE'.
Qed.

Lemma plus_helper: forall n m: nat, (S n) + m = S (n + m).
Proof.
    intros n m.
    induction m as [| m'].
    reflexivity.
    reflexivity.
Qed.
Theorem ev_sum: forall n m,
    ev n -> ev m -> ev (n+m).
Proof.
    intros n m Hn Hm.
    induction Hn.
    apply Hm.
    rewrite -> plus_helper. rewrite -> plus_helper. apply ev_SS. apply IHHn.
Qed.

Inductive beautiful: nat -> Prop :=
| b_0: beautiful 0
| b_3: beautiful 3
| b_5: beautiful 5
| b_sum: forall n m, beautiful n -> beautiful m -> beautiful (n+m).

Theorem three_is_beautiful: beautiful 3.
Proof.
    apply b_3.
Qed.
Theorem eight_is_beautiful: beautiful 8.
Proof.
    apply b_sum with (n:=3) (m:=5).
    apply b_3.
    apply b_5.
Qed.
Theorem beautiful_plus_eight: forall n, beautiful n -> beautiful (n+8).
Proof.
    intros n B.
    apply b_sum with (m:=8).
    apply B. apply eight_is_beautiful.
Qed.
Theorem b_times2: forall n, beautiful n -> beautiful (2*n).
Proof.
    intros n B.
    simpl.
    apply b_sum with (n:=n) (m:=n+0).
    apply B.
    apply b_sum.
    apply B. apply b_0.
Qed.
Theorem b_times3: forall n, beautiful n -> beautiful (3*n).
Proof.
    intros n B.
    simpl.
    apply b_sum with (n:=n) (m:=n+(n+0)). apply B.
    apply b_times2. apply B.
Qed.

Inductive gorgeous: nat -> Prop :=
| g_0: gorgeous 0
| g_plus3: forall n, gorgeous n -> gorgeous (3+n)
| g_plus5: forall n, gorgeous n -> gorgeous (5+n).

Theorem gorgeous_plus13: forall n, gorgeous n -> gorgeous (13+n).
Proof.
    intros n B.
    apply g_plus3. apply g_plus5. apply g_plus5. apply B.
Qed.

Theorem gorgeous_beautiful: forall n, gorgeous n -> beautiful n.
Proof.
    intros n H.
    induction H as [| n' | n'].
    apply b_0.
    apply b_sum. apply b_3. apply IHgorgeous.
    apply b_sum. apply b_5. apply IHgorgeous.
Qed.

Theorem gorgeous_sum: forall n m, gorgeous n -> gorgeous m -> gorgeous (n+m).
Proof.
    intros n m Hn Hm.
    induction Hn.
    apply Hm.
    apply g_plus3 with (n:=n+m). apply IHHn.
    apply g_plus5 with (n:=n+m). apply IHHn.
Qed.

Theorem ev_minus2: forall n, ev n -> ev (pred (pred n)).
Proof.
    intros n E.
    inversion E as [| n' E'].
    apply ev_0.
    apply E'.
Qed.


(* Exercise 62 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_062 : (forall x, ~exists y, R x y) -> (forall x, forall y, ~ R x y).
Proof.
imp_i a1.
all_i a.
all_i b.
neg_i (exists y:D, R a y) a2.
all_e (forall x:D, ~(exists y:D, R x y)) a.
hyp a1.
exi_i b.
hyp a2.
Qed.


Set Warnings "-notation-overridden,-parsing".
From LF Require Export IndProp.

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

Check le : nat -> nat -> Prop.
Check le : relation nat.

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

Print next_nat.

Check next_nat : relation nat.

Theorem next_nat_partial_function : partial_function next_nat.
Proof.
  unfold partial_function. intros x y1 y2 H1 H2.
  inversion H1. inversion H2. reflexivity.
Qed.

Print total_relation.

Theorem le_not_a_partial_function : ~ (partial_function le).
Proof.
  unfold partial_function. intro H.
  assert (Nonsense: 0 = 1).
  { apply H with (x := 0).
    - apply le_n.
    - apply le_S. apply le_n.
  }
  discriminate Nonsense.
Qed.

Theorem total_relation_not_partial :
  ~(partial_function total_relation).
Proof.
  unfold partial_function. intro H.
  Print total_relation.
  assert (Nonsense : 0 = 1).
  { apply H with (x := 0).
    - apply re_n.
    - apply arti_sym. apply re_n.
  }
  discriminate Nonsense.
Qed.

Print empty_relation.

Theorem empty_relation_pairtial:
  partial_function empty_relation.
Proof.
  unfold partial_function.
  intros x y1 y2 H1 H2.
  inversion H1. inversion H.
Qed.

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

Theorem le_reflexive : reflexive le.
Proof. unfold reflexive. 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_trans : transitive le.
Proof.
  unfold transitive. intros a b c Hab Hbc.
  induction Hbc.
  - apply Hab.
  - apply le_S. apply IHHbc.
Qed.

Theorem le_trans' : transitive le.
Proof.
  unfold transitive. intros a b c Hab.
  apply le_ind.
  - apply Hab.
  - intros m H1 H2. apply le_S. apply H2.
Qed.

Theorem lt_trans : transitive lt.
Proof.
  unfold transitive. unfold lt.
  intros a b c H. apply le_trans.
  apply le_S. apply H.
Qed.

Theorem lt_trans' : transitive lt.
Proof.
  unfold transitive. unfold lt.
  intros a b c H1. apply le_ind.
  - apply le_S. apply H1.
  - intros m H2 H3. apply le_S. apply H3.
Qed.

Theorem lt_trans'' : transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  - inversion Hmo.
  - inversion Hmo.
    + apply le_S. rewrite H0 in Hnm. apply Hnm.
    + apply le_S. apply IHo'. apply H0.
Qed.

Theorem lt_trans''': transitive lt.
Proof.
  unfold transitive. intros a b c.
  generalize dependent b.
  generalize dependent a.
  induction c as [|c' IH].
  - intros. inversion H0.
  - intros. unfold lt in *.
    apply le_n_S. apply le_S_n in H0.
    destruct a as [| a'] eqn:Ea.
    + apply O_le_n.
    + destruct b as [| b'] eqn:Eb.
      * inversion H.
      * apply IH with (a := a') (b := b').
        { apply le_S_n. apply H. }
        { apply H0. }
Qed.

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof.
  intros n m.
  apply (le_trans n (S n) m).
  apply le_S. apply le_reflexive.
Qed.

Theorem le_S_n : forall n m, S n <= S m -> n <= m.
Proof.
  intros n m H. inversion H.
  - apply le_reflexive.
  - apply (le_trans n (S n) m).
    + apply le_S. apply le_reflexive.
    + apply H1.
Qed.

Theorem le_Sn_n : forall n, ~(S n <= n).
Proof.
  apply nat_ind.
  - intro H. inversion H.
  - intros n H. unfold not in *. intro H1. apply H.
    apply le_S_n. apply H1.
Qed.

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

Theorem le_not_symmetric : ~ (symmetric le).
Proof.
  unfold symmetric. intro H.
  assert (Hf : 0 <= 1 -> False).
  { intro H'. apply H in H'. inversion H'. }
  apply Hf. apply le_S. apply le_reflexive.
Qed.

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

Theorem le_antisymmetric : antisymmetric le.
Proof.
  unfold antisymmetric.
  intros a b H1 H2.
  induction H2.
  - reflexivity.
  - apply (le_trans (S m) b m) in H1.
    Search le. apply le_Sn_n in H1.
    + contradiction.
    + apply H2.
Qed.

Theorem le_step : forall n m p,
    n < m -> m <= S p -> n <= p.
Proof.
  unfold lt. intros n m p H1 H2.
  apply le_S_n. apply (le_trans _ m _).
  - apply H1.
  - apply H2.
Qed.

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

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

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

Theorem le_order : order le.
Proof.
  unfold order.
  split.
  - apply le_reflexive.
  - split.
    + apply le_antisymmetric.
    + apply le_trans.
Qed.

Inductive clos_refl_trans {A : Type} (R : relation A) : relation A :=
| rt_step x y (H : R x y) : clos_refl_trans R x y
| rt_refl x : clos_refl_trans R x x
| rt_trans x y z
           (Hxy : clos_refl_trans R x y)
           (Hyz : 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.
  - intro H. induction H.
    + apply rt_refl.
    + apply (rt_trans _ n m (S m)).
      * apply IHle.
      * apply rt_step. apply nn.
  - intro H. induction H.
    + inversion H. apply le_S. apply le_reflexive.
    + apply le_reflexive.
    + apply (le_trans x y z); assumption.
Qed.

Inductive clos_refl_trans_ln {A : Type} (R : relation A) (x : A)
  : A -> Prop :=
| rtln_refl : clos_refl_trans_ln R x x
| rtln_trans (y z : A) (Hxy : R x y) (Hrest : clos_refl_trans_ln R y z) :
    clos_refl_trans_ln R x z.

Lemma rsc_R : forall (X : Type) (R : relation X) (x y : X),
    R x y -> clos_refl_trans_ln R x y.
Proof.
  intros X R x y H. apply (rtln_trans R x y y).
  - apply H.
  - apply rtln_refl.
Qed.

Lemma rsc_trans : forall (X : Type) (R : relation X) (x y z : X),
    clos_refl_trans_ln R x y ->
    clos_refl_trans_ln R y z ->
    clos_refl_trans_ln R x z.
Proof.
  intros X R x y z H1 H2.
  induction H1.
  - apply H2.
  - apply (rtln_trans R x y z).
    + apply Hxy.
    + apply IHclos_refl_trans_ln. apply H2.
Qed.

Theorem rtc_rsc_coincide :
  forall (X : Type) (R : relation X) (x y : X),
    clos_refl_trans R x y <-> clos_refl_trans_ln R x y.
Proof.
  intros X R x y. split.
  - intro H. induction H.
    + apply (rtln_trans R x y y).
      * apply H.
      * apply rtln_refl.
    + apply rtln_refl.
    + apply (rsc_trans X R x y z); assumption.
  - intro H. induction H.
    + apply rt_refl.
    + apply (rt_trans R x y z).
      * apply rt_step. apply Hxy.
      * apply IHclos_refl_trans_ln.
Qed.


Require Import Permutation.
Require Import Recdef FunInd.
Require Import Omega.

Require List.
Import List.ListNotations.
Open Scope list.

Set Implicit Arguments.

Section GroupEqual.

  Variable A:Type.
  Variable equal:A -> A -> bool.

  Fixpoint gather_eq (x0: A) (acc: list A) (l: list A) : list A * list A :=
    match l with
    | [] => (acc, l)
    | x::xs => if equal x x0 then
                gather_eq x0 (acc ++ [x]) xs
              else
                let (xs, l') := gather_eq x0 acc xs in
                (xs, x::l')
    end.

  Definition gather_eq1 (x:A) l : list A :=
    fst (gather_eq x [] l).

  Definition gather_eq2 (x:A) l : list A :=
    snd (gather_eq x [] l).

  Theorem gather_eq_lengths : forall x l acc xs l',
      gather_eq x acc l = (xs, l') ->
      length xs + length l' = length acc + length l.
  Proof.
    induction l; simpl; intros; auto.
    inversion H; subst; auto.
    destruct (equal a x); simpl.
    apply IHl in H; simpl in *.
    rewrite List.app_length in *; simpl in *.
    omega.
    destruct_with_eqn (gather_eq x acc l); simpl in *.
    inversion H; subst; clear H; simpl.
    apply IHl in Heqp.
    omega.
  Qed.

  Lemma gather_eq12_lengths : forall (x:A) l,
      length (gather_eq1 x l) + length (gather_eq2 x l) = length l.
  Proof.
    unfold gather_eq1, gather_eq2; intros.
    destruct_with_eqn (gather_eq x [] l).
    apply gather_eq_lengths in Heqp; simpl in *; auto.
  Qed.

  Lemma gather_eq2_smaller : forall (x:A) xs,
      length (gather_eq2 x xs) < S (length xs).
  Proof.
    intros.
    pose proof (gather_eq12_lengths x xs).
    omega.
  Qed.

  Hint Resolve gather_eq2_smaller.

  Function group_eq (l: list A) {measure length l} : list A :=
    match l with
    | [] => []
    | x::xs => x::gather_eq1 x xs ++ group_eq (gather_eq2 x xs)
    end.
  Proof.
    simpl; intros; subst; auto.
  Qed.

  Theorem group_eq_length : forall (l: list A),
      length (group_eq l) = length l.
  Proof.
    intros.
    remember (length l).
    generalize dependent l.
    induction n using lt_wf_ind; intros; subst.
    rewrite group_eq_equation.
    destruct l; intros; subst; simpl in *; auto.
    rewrite List.app_length.
    erewrite H; try reflexivity.
    rewrite gather_eq12_lengths; auto.
    auto.
  Qed.

  Hint Constructors Permutation.
  Hint Resolve Permutation_sym.
  Hint Resolve Permutation_middle.

  Theorem gather_eq_permutation : forall (x:A) l acc xs l',
      gather_eq x acc l = (xs, l') ->
      Permutation (xs ++ l') (acc ++ l).
  Proof.
    induction l; simpl; intros.
    inversion H; subst; clear H; simpl.
    rewrite List.app_nil_r; auto.
    destruct (equal a x).
    apply IHl in H.
    rewrite <- List.app_assoc in H; auto.
    destruct_with_eqn (gather_eq x acc l).
    inversion H; subst; clear H.
    apply IHl in Heqp.
    eauto.
  Qed.

  Theorem gather_eq12_permutation : forall (x:A) l,
      Permutation (gather_eq1 x l ++ gather_eq2 x l) l.
  Proof.
    unfold gather_eq1, gather_eq2; intros.
    destruct_with_eqn (gather_eq x [] l); simpl.
    apply gather_eq_permutation in Heqp; auto.
  Qed.

  Theorem group_eq_permutation : forall (l: list A),
      Permutation (group_eq l) l.
  Proof.
    intros.
    remember (length l).
    generalize dependent l.
    induction n using lt_wf_ind; intros; subst.
    rewrite group_eq_equation.
    destruct l.
    auto.
    constructor.
    transitivity (gather_eq1 a l ++ gather_eq2 a l);
      [ | eauto using gather_eq12_permutation ].
    eapply Permutation_app; eauto.
    eapply H; simpl; eauto.
  Qed.

End GroupEqual.

Ltac compute_group_eq :=
  rewrite group_eq_equation; unfold gather_eq1, gather_eq2;
  cbn beta iota zeta delta [gather_eq fst snd].

Module Examples.

  Example gather_eq_ex1 :
    gather_eq (fun x y => if PeanoNat.Nat.eq_dec x y then true else false)
              3 [] [2;3;4;3;2;3;5] =
    ([3;3;3], [2;4;2;5]) := eq_refl.

  Example group_eq_ex1 :
    group_eq (fun x y => if Nat.eq_dec x y then true else false)
             [2;3;4;3;2;3;5] = [2;2;3;3;3;4;5].
  Proof.
    repeat (compute_group_eq; cbn [Nat.eq_dec app nat_rec nat_rect]).
    reflexivity.
  Qed.

End Examples.