Require Export Arith.
Require Export ZArith.
Require Export List.

(*** The Succ function ***)
(* Succ x y l means that x and y occur directly after each other in the list l *)

Fixpoint Succ (A: Set) (x: A) (y: A) (l: list A) {struct l}: Prop :=
  match l with
  | nil => False
  | hd :: tl => match tl with
                      | nil => False
                      | hd2 :: tl2 => ((x = hd) /\ (y = hd2)) \/ (Succ A x y tl)
                      end
  end.

(***  Primitive Recursive Arithmetic  ***)

Inductive form : Set :=
  | f_lt : nat -> nat -> form
  | f_le : nat -> nat -> form
  | f_eq : nat -> nat -> form
  | f_p_eq: (nat * nat) -> (nat * nat) -> form
  | f_ge : nat -> nat -> form
  | f_gt : nat -> nat -> form
  | f_zlt : Z -> Z -> form
  | f_zle : Z -> Z -> form
  | f_zeq : Z -> Z -> form
  | f_p_zeq: (Z * Z) -> (Z * Z) -> form
  | f_zge : Z -> Z -> form
  | f_zgt : Z -> Z -> form
  | f_not : form -> form
  | f_and : form -> form -> form
  | f_or : form -> form -> form
  | f_imp : form -> form -> form
  | f_all : nat -> (nat -> form) -> form
  | f_ex : nat -> (nat -> form) -> form
  | f_all_el : list nat -> (nat -> form) -> form
  | f_ex_el : list nat -> (nat -> form) -> form
  | f_in : nat -> list nat -> form
  | f_p_in : (nat * nat) -> list (nat * nat) -> form
  | f_succ: nat -> nat -> list nat -> form
	| f_zsucc: Z -> Z -> list Z -> form
  | f_zall : Z -> (Z -> form) -> form
  | f_zex : Z -> (Z -> form) -> form
  | f_zall_el : list Z -> (Z -> form) -> form
  | f_zex_el : list Z -> (Z -> form) -> form
  | f_zin : Z -> list Z -> form
  | f_p_zin : (Z * Z) -> list (Z * Z) -> form.

(***  Boolean logic  ***)

Fixpoint b_le (n : nat) : nat -> bool :=
  match n with
  | O => fun m : nat => true
  | S x => fun m : nat => match m with
                          | O => false
                          | S y => b_le x y
                          end
  end.

Fixpoint b_eq (n m : nat) {struct m} : bool :=
  match n, m with
  | O, O => true
  | O, S y => false
  | S x, O => false
  | S x, S y => b_eq x y
  end.

Definition b_lt (n m : nat) := b_le (S n) m.
Definition b_ge (n m : nat) := b_le m n.
Definition b_gt (n m : nat) := b_lt m n.

Definition b_not (x : bool) :=
  match x with
  | true => false
  | false => true
  end.
Definition b_and (x y : bool) :=
  match x with
  | true => y
  | false => false
  end.
Definition b_or (x y : bool) := match x with
                                | true => true
                                | false => y
                                end.
Definition b_imp (x y : bool) := match x with
                                 | true => y
                                 | false => true
                                 end.

Definition b_p_eq (n m: nat * nat): bool :=
  match n, m with
  | pair n1 n2, pair m1 m2 => b_and (b_eq n1 m1) (b_eq n2 m2)
  end.

Fixpoint b_all (b : nat) (f : nat -> bool) {struct b} : bool :=
  match b with
  | O => (f O)
  | S m => b_and (f (S m)) (b_all m f)
  end.

Fixpoint b_ex (b : nat) (f : nat -> bool) {struct b} : bool :=
  match b with
  | O => (f O)
  | S m => b_or (f (S m)) (b_ex m f)
  end.

Fixpoint b_all_el (l : list nat) (f : nat -> bool) {struct l} : bool :=
  match l with
  | nil => true
  | hd :: tl => b_and (f hd) (b_all_el tl f)
  end.

Fixpoint b_ex_el (l : list nat) (f : nat -> bool) {struct l} : bool :=
  match l with
  | nil => false
  | hd :: tl => b_or (f hd) (b_ex_el tl f)
  end.

Fixpoint b_in (n: nat) (l: list nat) {struct l}: bool :=
  match l with
  | nil => false
  | hd :: tl => b_or (b_eq hd n) (b_in n tl)
  end.

Fixpoint b_p_in (p: nat * nat) (l: list (nat * nat)) {struct l}: bool :=
  match l with
  | nil => false
  | hd :: tl => b_or (b_p_eq hd p) (b_p_in p tl)
  end.

Fixpoint b_succ (x y: nat) (l: list nat) {struct l} : bool :=
  match l with
  | nil => false
  | hd :: tl => match tl with
                      | nil => false
                      | hd2 :: tl2 => (b_or (b_and (b_eq hd x) (b_eq hd2 y)) (b_succ x y tl))
                      end
  end.

Fixpoint b_pos_less (x y : positive) (r : bool) {struct x} : bool :=
  match x with
  | xO x' =>
      match y with
      | xO y' => b_pos_less x' y' r
      | xI y' => b_pos_less x' y' true
      | xH => false
      end
  | xI x' =>
      match y with
      | xO y' => b_pos_less x' y' false
      | xI y' => b_pos_less x' y' r
      | xH => false
      end
  | xH => match y with
          | xO y' => true
          | xI y' => true
          | xH => r
          end
  end.

Fixpoint b_pos_eq (x y : positive) {struct x} : bool :=
  match x with
  | xO x' =>
      match y with
      | xO y' => b_pos_eq x' y'
      | xI y' => false
      | xH => false
      end
  | xI x' =>
      match y with
      | xO y' => false
      | xI y' => b_pos_eq x' y'
      | xH => false
      end
  | xH => match y with
          | xO y' => false
          | xI y' => false
          | xH => true
          end
  end.

Definition b_zeq (x y : Z) : bool :=
  match x with
  | Zpos x' =>
      match y with
      | Zpos y' => b_pos_eq x' y'
      | Zneg y' => false
      | Z0 => false
      end
  | Zneg x' =>
      match y with
      | Zpos y' => false
      | Zneg y' => b_pos_eq x' y'
      | Z0 => false
      end
  | Z0 => match y with
          | Zpos y' => false
          | Zneg y' => false
          | Z0 => true
          end
  end.

Definition b_p_zeq (p q: Z * Z) : bool :=
  match p, q with
     pair p1 p2, pair q1 q2 => (b_and (b_zeq p1 q1) (b_zeq p2 q2))
  end.

Definition b_zle (x y : Z) : bool :=
  match x with
  | Zpos x' =>
      match y with
      | Zpos y' => b_pos_less x' y' true
      | Zneg y' => false
      | Z0 => false
      end
  | Zneg x' =>
      match y with
      | Zpos y' => true
      | Zneg y' => b_pos_less y' x' true
      | Z0 => true
      end
  | Z0 => match y with
          | Zpos y' => true
          | Zneg y' => false
          | Z0 => true
          end
  end.

Definition b_zlt (x y : Z) : bool :=
  match x with
  | Zpos x' =>
      match y with
      | Zpos y' => b_pos_less x' y' false
      | Zneg y' => false
      | Z0 => false
      end
  | Zneg x' =>
      match y with
      | Zpos y' => true
      | Zneg y' => b_pos_less y' x' false
      | Z0 => true
      end
  | Z0 => match y with
          | Zpos y' => true
          | Zneg y' => false
          | Z0 => false
          end
  end.

Definition b_zgt (x y : Z) : bool :=
  match x with
  | Zpos x' =>
      match y with
      | Zpos y' => b_pos_less y' x' false
      | Zneg y' => true
      | Z0 => true
      end
  | Zneg x' =>
      match y with
      | Zpos y' => false
      | Zneg y' => b_pos_less x' y' false
      | Z0 => false
      end
  | Z0 => match y with
          | Zpos y' => false
          | Zneg y' => true
          | Z0 => false
          end
  end.

Definition b_zge (x y : Z) : bool :=
  match x with
  | Zpos x' =>
      match y with
      | Zpos y' => b_pos_less y' x' true
      | Zneg y' => true
      | Z0 => true
      end
  | Zneg x' =>
      match y with
      | Zpos y' => false
      | Zneg y' => b_pos_less x' y' true
      | Z0 => false
      end
  | Z0 => match y with
          | Zpos y' => false
          | Zneg y' => true
          | Z0 => true
          end
  end.

Fixpoint b_all_nat (n: nat) (f: Z -> bool) {struct n}: bool :=
  match n with
  | O => true
  | S n' => b_and (f (Zpos (P_of_succ_nat n'))) (b_all_nat n' f)
  end.

Definition b_zall (n : Z) (f : Z -> bool) : bool :=
  match n with
  | Z0 => true
  | Zneg x => true
  | Zpos p => b_all_nat (nat_of_P p) f
  end.

Fixpoint b_ex_nat (n : nat) (f : Z -> bool) {struct n} : bool :=
  match n with
  | O => false
  | S n' => b_or (f (Zpos (P_of_succ_nat n'))) (b_ex_nat n' f)
  end.

Definition b_zex (n : Z) (f : Z -> bool) : bool :=
  match n with
  | Z0 => false
  | Zneg x => false
  | Zpos p => b_ex_nat (nat_of_P p) f
  end.

Fixpoint b_zall_el (l : list Z) (f : Z -> bool) {struct l} : bool :=
  match l with
  | nil => true
  | hd :: tl => b_and (f hd) (b_zall_el tl f)
  end.

Fixpoint b_zex_el (l : list Z) (f : Z -> bool) {struct l} : bool :=
  match l with
  | nil => false
  | hd :: tl => b_or (f hd) (b_zex_el tl f)
  end.

Fixpoint b_zin (z: Z) (l: list Z) {struct l}: bool :=
  match l with
  | nil => false
  | hd :: tl => b_or (b_zeq z hd) (b_zin z tl)
  end.

Fixpoint b_p_zin (p: Z * Z) (l: list (Z * Z)) {struct l} : bool :=
  match l with
  | nil => false
  | hd :: tl => b_or (b_p_zeq p hd) (b_p_zin p tl)
  end.

Fixpoint b_zsucc (x y: Z) (l: list Z) {struct l} : bool :=
  match l with
  | nil => false
  | hd :: tl => match tl with
                      | nil => false
                      | hd2 :: tl2 => (b_or (b_and (b_zeq hd x) (b_zeq hd2 y)) (b_zsucc x y tl))
                      end
  end.

(***  Translate form to bool  ***)

Fixpoint checkValid (p : form) : bool :=
  match p with
  | f_lt s t => b_lt s t
  | f_le s t => b_le s t
  | f_eq s t => b_eq s t
  | f_p_eq s t => b_p_eq s t
  | f_ge s t => b_ge s t
  | f_gt s t => b_gt s t
  | f_zlt s t => b_zlt s t
  | f_zle s t => b_zle s t
  | f_zeq s t => b_zeq s t
  | f_p_zeq s t => b_p_zeq s t
  | f_zge s t => b_zge s t
  | f_zgt s t => b_zgt s t
  | f_not q => b_not (checkValid q)
  | f_and q r => b_and (checkValid q) (checkValid r)
  | f_or q r => b_or (checkValid q) (checkValid r)
  | f_imp q r => b_imp (checkValid q) (checkValid r)
  | f_all t f => b_all t (fun y : nat => checkValid (f y))
  | f_ex t f => b_ex t (fun y : nat => checkValid (f y))
  | f_all_el l f => b_all_el l (fun y : nat => checkValid (f y))
  | f_ex_el l f => b_ex_el l (fun y : nat => checkValid (f y))
  | f_in n l => b_in n l
  | f_p_in n l => b_p_in n l
  | f_succ s t l => b_succ s t l
	| f_zsucc s t l => b_zsucc s t l
  | f_zall n p => b_zall n (fun s : Z => checkValid (p s))
  | f_zex n p => b_zex n (fun s : Z => checkValid (p s))
  | f_zall_el l p => b_zall_el l (fun s : Z => checkValid (p s))
  | f_zex_el l p => b_zex_el l (fun s : Z => checkValid (p s))
  | f_zin z l => b_zin z l
  | f_p_zin p l => b_p_zin p l
  end.

(***  Translate form to Prop  ***)

Fixpoint isValid (p : form) : Prop :=
  match p with
  | f_lt s t => s < t
  | f_le s t => s <= t
  | f_eq s t => s = t
  | f_p_eq s t => s = t
  | f_ge s t => s >= t
  | f_gt s t => s > t
  | f_zlt s t => (s < t)%Z
  | f_zle s t => (s <= t)%Z
  | f_zeq s t => s = t
  | f_p_zeq s t => s = t
  | f_zge s t => (s >= t)%Z
  | f_zgt s t => (s > t)%Z
  | f_not q => ~ isValid q
  | f_and q r => isValid q /\ isValid r
  | f_or q r => isValid q \/ isValid r
  | f_imp q r => isValid q -> isValid r
  | f_all t f => forall y : nat, y <= t -> isValid (f y)
  | f_ex t f => exists y : nat, y <= t /\ isValid (f y)
  | f_all_el l f => forall y : nat, In y l -> isValid (f y)
  | f_ex_el l f => exists y : nat, In y l /\ isValid (f y)
  | f_in n l => (In n l)
  | f_p_in p l => (In p l)
  | f_succ s t l => Succ nat s t l
	| f_zsucc s t l => Succ Z s t l
  | f_zall n f => forall s : Z, (s > 0)%Z /\ (s <= n)%Z -> isValid (f s)
  | f_zex n f => exists s : Z, ((s > 0)%Z /\ (s <= n)%Z) /\ isValid (f s)
  | f_zall_el l f => forall s : Z, In s l -> isValid (f s)
  | f_zex_el l f => exists s : Z, In s l /\ isValid (f s)
  | f_zin z l => (In z l)
  | f_p_zin p l => (In p l)
  end.

(***  Translate bool to Prop  ***)

Definition istrue (x : bool) := if x then True else False.

Lemma b_and_intro :
 forall x y : bool, istrue x -> istrue y -> istrue (b_and x y).
Proof.
   intro x. case x. simpl in |- *. tauto. simpl in |- *. tauto.
Qed.

Lemma b_and_elim1 : forall x y : bool, istrue (b_and x y) -> istrue x.
Proof.
   intro x. case x. simpl in |- *. tauto. simpl in |- *. tauto.
Qed.

Lemma b_and_elim2 : forall x y : bool, istrue (b_and x y) -> istrue y.
Proof.
   intro x. case x. simpl in |- *. tauto. simpl in |- *. tauto.
Qed.

Lemma b_or_intro1 : forall x y : bool, istrue x -> istrue (b_or x y).
Proof.
   intro x. case x. simpl in |- *. tauto. simpl in |- *. tauto.
Qed.

Lemma b_or_intro2 : forall x y : bool, istrue y -> istrue (b_or x y).
Proof.
   intro x. case x. simpl in |- *. tauto. simpl in |- *. tauto.
Qed.

Lemma b_or_elim :
 forall x y : bool, istrue (b_or x y) -> istrue x \/ istrue y.
Proof.
   intro x. case x. simpl in |- *. tauto. simpl in |- *. tauto.
Qed.

Lemma bpl_false_true :
 forall p q : positive,
 istrue (b_pos_less p q false) -> istrue (b_pos_less p q true).
Proof.
  simple induction p.
    simple induction q.
      intros. apply (H p1). apply H1.
      intros. apply H1.
      contradiction.
    simple induction q.
      intro. intro. simpl in |- *. trivial.
      intro. intro. simpl in |- *. apply (H p1).
      contradiction.
    intros. case q.
      simpl in |- *. trivial.
      simpl in |- *. trivial.
      simpl in |- *. trivial.
Qed.

Lemma bpl_true_false :
 forall p q : positive,
 istrue (b_pos_less p q true) -> istrue (b_pos_less p q false) \/ p = q.
Proof.
  double induction p q.
    intros. elim (H0 p0).
      intros. left. simpl in |- *. apply H2.
      intros. right. elim H2. reflexivity.
      simpl in H1. apply H1.
    intros. elim (H0 p0).
      intros. simpl in |- *. left. apply H2.
      intros. simpl in H1. left. simpl in |- *. apply H1.
      simpl in H1. apply bpl_false_true. apply H1.
    intros. simpl in H0. contradiction.
    intros. simpl in H1. left. simpl in |- *. apply H1.
    intros. elim (H0 p0).
      intros. simpl in |- *. left. apply H2.
      intros. right. elim H2. reflexivity.
      simpl in H1. apply H1.
    intros. simpl in H0. contradiction.
    intros. simpl in |- *. left. trivial.
    intros. simpl in |- *. left. trivial.
    intros. right. reflexivity.
Qed.

Lemma bpl_inductive1 :
 forall p0 p1 : positive,
 (Zpos p1 <= Zpos p0)%Z ->
 ((Zpos p1 < Zpos p0)%Z -> istrue (b_pos_less p1 p0 false)) ->
 (istrue (b_pos_less p1 p0 false) -> (Zpos p1 < Zpos p0)%Z) ->
 istrue (b_pos_less p1 p0 true).
Proof.
  double induction p0 p1.
    intros. simpl in |- *. apply H0.
      apply H1.
      apply H2.
      apply H3.
    intros. apply bpl_false_true. apply H2. elim (Zle_lt_or_eq (Zpos (xO p)) (Zpos (xI p2))).
      trivial.
      intros. discriminate H4.
      exact H1.
    intros. simpl in |- *. trivial.
    intros. simpl in |- *. apply H2. elim (Zle_lt_or_eq (Zpos (xI p)) (Zpos (xO p2))).
      trivial.
      intros. discriminate H4.
      exact H1.
    intros. simpl in |- *. apply H0.
      apply H1.
      apply H2.
      apply H3.
    intros. simpl in |- *. trivial.
    intro. case p.
      intros. change (4 * Zpos p2 + 3 <= 1)%Z in H0. absurd (4 * Zpos p2 + 3 <= 1)%Z.
        compute in |- *. auto.
        apply H0.
      intros. change (4 * Zpos p2 + 2 <= 1)%Z in H0. absurd (4 * Zpos p2 + 2 <= 1)%Z.
        compute in |- *. auto.
        apply H0.
      intros. absurd (3 <= 1)%Z.
        compute in |- *. auto.
        apply H0.
    intro. case p.
      intros. change (4 * Zpos p2 + 2 <= 1)%Z in H0. absurd (4 * Zpos p2 + 2 <= 1)%Z.
        compute in |- *. auto.
        apply H0.
      intros. change (4 * Zpos p2 <= 1)%Z in H0. simpl in |- *. simpl in H1. apply H1. change (4 * Zpos p2 < 1)%Z in |- *. omega.
      intros. absurd (2 <= 1)%Z.
        auto.
        apply H0.
    intros. simpl in |- *. trivial.
Qed.

Lemma bpl_inductive2 :
 forall p0 p1 : positive,
 istrue (b_pos_less p1 p0 true) ->
 ((Zpos p1 < Zpos p0)%Z -> istrue (b_pos_less p1 p0 false)) ->
 (istrue (b_pos_less p1 p0 false) -> (Zpos p1 < Zpos p0)%Z) ->
 (Zpos p1 <= Zpos p0)%Z.
Proof.
  double induction p0 p1.
    intros. change (Zpos p <= Zpos p2)%Z in |- *. apply H0. apply H1.
    intros. simpl in H2. apply H2. apply H4.
    intros. apply H3.  simpl in |- *. apply H4.
    intros. apply Zlt_le_weak. apply H3. simpl in |- *. simpl in H1. apply H1.
    intros. apply Zlt_le_weak. apply H2. simpl in |- *. trivial.
    intros. apply Zlt_le_weak. apply H3. simpl in |- *. simpl in H1. apply H1.
    intros. change (Zpos p <= Zpos p2)%Z in |- *. apply H0. apply H1. apply H2. apply H3.
    intros. apply Zlt_le_weak. apply H2. simpl in |- *. trivial.
    intros. simpl in H0. contradiction.
    intros. simpl in H0. contradiction.
    intros. omega.
Qed.

Lemma pos_lt :
 forall p q : positive, (Zpos p < Zpos q)%Z <-> istrue (b_pos_less p q false).
Proof.
  double induction p q.
    intros. split.
      intros. simpl in |- *. elim (H0 p0). intros. apply H2. apply H1.
      intros. change (Zpos p1 < Zpos p0)%Z in |- *. elim (H0 p0). intros. apply H3. apply H1.
    intros. split.
      intros. simpl in |- *. elim (H0 p0). intros. apply H2. change (Zpos (xO p1) < Zpos (xO p0))%Z in |- *. apply Zlt_trans with (Zpos (xI p1)).
        replace (Zpos (xI p1)) with (Zsucc (Zpos (xO p1))).
          apply Zle_lt_succ. omega.
          trivial.
          exact H1.
      intros. elim (H0 p0). intros. assert (Zpos p1 < Zpos p0)%Z.
        apply H3. apply H1.
        change (2 * Zpos p1 + 1 < 2 * Zpos p0)%Z in |- *. omega.
    intros. split.
      intros. compute in H0. discriminate H0.
      intros. simpl in H0. contradiction.
    intros. split.
      intro. assert (Zpos p1 <= Zpos p0)%Z.
        change (2 * Zpos p1 < 2 * Zpos p0 + 1)%Z in H1. omega.
          simpl in |- *. elim (H0 p0). intros. apply bpl_inductive1. apply H2.
        apply H3.
        apply H4.
      intro. simpl in H1. elim (H0 p0). intros. assert (Zpos p1 <= Zpos p0)%Z.
        apply bpl_inductive2. apply H1. apply H2. apply H3. change (2 * Zpos p1 < 2 * Zpos p0 + 1)%Z in |- *. omega.
    intros. split.
      intros. simpl in |- *. elim (H0 p0). intros. apply H2. apply H1.
      intros. elim (H0 p0). intros. apply H3. apply H1.
    intros. split.
      intros. compute in H0. discriminate H0.
      intros. simpl in H0. contradiction.
    intros. split.
      intros. simpl in |- *. trivial.
      intros. compute in |- *. reflexivity.
    intros. split.
      intros. simpl in |- *. trivial.
      intros. compute in |- *. reflexivity.
    intros. split.
      intros. compute in H. discriminate H.
      intros. simpl in H. contradiction.
Qed.

Lemma pos_eq : forall p q : positive, p = q <-> istrue (b_pos_eq p q).
Proof.
  double induction p q.
    intros. split.
      intros. elim H1. simpl in |- *. elim (H0 p1). intros. apply H2. reflexivity.
      intros. simpl in H1. elim (H0 p0). intros. assert (p1 = p0).
        apply H3. apply H1.
        elim H4. reflexivity.
    intros. split.
      intros. discriminate H1.
      intros. simpl in H1. contradiction.
    intros. split.
      intros. discriminate H0.
      intros. simpl in H0. contradiction.
    intros. split.
      intros. discriminate H1.
      intros. simpl in H1. contradiction.
    intros. split.
      intros. elim H1. simpl in |- *. elim (H0 p1). intros. apply H2. reflexivity.
      intros. simpl in H1. elim (H0 p0). intros. assert (p1 = p0).
        apply H3. apply H1.
        elim H4. reflexivity.
    intros. split.
      intros. discriminate H0.
      intros. simpl in H0. contradiction.
    intros. split.
      intros. discriminate H0.
      intros. simpl in H0. contradiction.
    intros. split.
      intros. discriminate H0.
      intros. simpl in H0. contradiction.
    intros. split.
      intros. simpl in |- *. trivial.
      intros. reflexivity.
Qed.

Lemma b_zlt_le : forall s t : Z, istrue (b_zlt s t) -> istrue (b_zle s t).
Proof.
  double induction s t.
    intros. simpl in |- *. trivial.
    intros. simpl in |- *. trivial.
    intros. simpl in H. contradiction.
    intros. simpl in H. contradiction.
    intros. simpl in |- *. simpl in H. apply bpl_false_true. apply H.
    intros. simpl in H. contradiction.
    intros. simpl in |- *. trivial.
    intros. simpl in |- *. trivial.
    intros. simpl in |- *. simpl in H. apply bpl_false_true. apply H.
Qed.

Lemma b_zle_lt_or_eq :
 forall s t : Z,
 istrue (b_zle s t) -> istrue (b_zlt s t) \/ istrue (b_zeq s t).
  double induction s t.
    intros. right. trivial.
    intros. left. trivial.
    intros. simpl in H. contradiction.
    intros. simpl in H. contradiction.
    intros. simpl in |- *. simpl in H. elim (bpl_true_false p0 p). intros.
      left. apply H0.
      intros. right. elim (pos_eq p0 p). intros. apply H1. apply H0.
      apply H.
    intros. simpl in H. contradiction.
    intros. simpl in |- *. left. trivial.
    intros. simpl in |- *. left. trivial.
    intros. simpl in |- *. simpl in H. elim (bpl_true_false p p0). intros.
      left. apply H0.
      intros. right. elim (pos_eq p0 p). intros. apply H1. elim H0. reflexivity.
      apply H.
Qed.

Lemma b_zlt_gt : forall s t : Z, istrue (b_zlt s t) <-> istrue (b_zgt t s).
Proof.
  double induction s t.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
Qed.

Lemma b_zle_ge : forall s t : Z, istrue (b_zle s t) <-> istrue (b_zge t s).
Proof.
  double induction s t.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
    intros. simpl in |- *. tauto.
Qed.

(***  Correctness  ***)

Lemma leok : forall s t : nat, s <= t <-> istrue (b_le s t).
Proof.
   simple induction s.
      simple induction t.
         simpl in |- *. split.
            trivial.
            auto.
         intros t1 IHt1. simpl in |- *. split.
            auto.
            (* Auto.  Werkt hier niet meer in 6.2... *)
            intro. apply le_S. apply lt_n_Sm_le. apply lt_O_Sn.
      intros s1 IHs1. simple induction t.
         simpl in |- *. split.
            exact (le_Sn_O s1).
            tauto.
         intros t1 IHt1. simpl in |- *. case (IHs1 t1). split.
            intro. apply H. apply le_S_n. assumption.
            intro. apply le_n_S. apply H0. assumption.
Qed.

Lemma eqok : forall s t : nat, s = t <-> istrue (b_eq s t).
Proof.
   simple induction s.
      simple induction t.
         simpl in |- *. split.
            trivial.
            auto.
         intros t1 IHt1. simpl in |- *. split.
            intro H. discriminate H.
            tauto.
      intros s1 IHs1. simple induction t.
         simpl in |- *. split.
            intro H. discriminate H.
            tauto.
         intros t1 IHt1. simpl in |- *. case (IHs1 t1). split.
            intro. apply H. injection H1. tauto.
            intro. rewrite H0. reflexivity. assumption.
Qed.

Lemma ltok : forall s t : nat, s < t <-> istrue (b_lt s t).
Proof.
   intros s t. unfold lt, b_lt in |- *. exact (leok (S s) t).
Qed.

Lemma geok : forall s t : nat, s >= t <-> istrue (b_ge s t).
Proof.
   intros s t. unfold ge, b_ge in |- *. exact (leok t s).
Qed.

Lemma gtok : forall s t : nat, s > t <-> istrue (b_gt s t).
Proof.
   intros s t. unfold gt, b_gt in |- *. exact (ltok t s).
Qed.

Lemma notok :
 forall (p : Prop) (a : bool), (p <-> istrue a) -> (~ p <-> istrue (b_not a)).
Proof.
   intros p a. case a. simpl in |- *. split. case H. intros. apply H2. apply H1.
   tauto. tauto. simpl in |- *. split. tauto. case H. tauto.
Qed.

Lemma andok :
 forall (p q : Prop) (a b : bool),
 (p <-> istrue a) -> (q <-> istrue b) -> (p /\ q <-> istrue (b_and a b)).
Proof.
   intros p q a b. case a. case b. simpl in |- *. tauto. simpl in |- *. tauto.
   case b. simpl in |- *. tauto. simpl in |- *. tauto.
Qed.

Lemma orok :
 forall (p q : Prop) (a b : bool),
 (p <-> istrue a) -> (q <-> istrue b) -> (p \/ q <-> istrue (b_or a b)).
Proof.
   intros p q a b. case a. case b. simpl in |- *. tauto. simpl in |- *. tauto.
   case b. simpl in |- *. tauto. simpl in |- *. tauto.
Qed.

Lemma impok :
 forall (p q : Prop) (a b : bool),
 (p <-> istrue a) -> (q <-> istrue b) -> ((p -> q) <-> istrue (b_imp a b)).
Proof.
   intros p q a b. case a. case b. simpl in |- *. tauto.
   simpl in |- *. split. intros. case H0. intros. apply H2. apply H1. case H.
   intros. apply H5. trivial. intros. case H1.
   case b. simpl in |- *. tauto. simpl in |- *. tauto.
Qed.

Lemma peqok : forall s t : (nat * nat), s = t <-> istrue (b_p_eq s t).
Proof.
  simple induction s.
    simple induction t.
      split.
         intros. simpl. elim (andok (a = a0) (b = b0) (b_eq a a0) (b_eq b b0)).
            intros. apply H0. inversion H. split.
              trivial.
              trivial.
            apply eqok.
            apply eqok.
         intros. elim (andok (a = a0) (b = b0) (b_eq a a0) (b_eq b b0)).
            intros. elim H1.
              intros. replace a0 with a. replace b0 with b. trivial.
              apply H.
           apply eqok.
           apply eqok.
Qed.

Lemma allok :
 forall (n : nat) (p : nat -> Prop) (f : nat -> bool),
 (forall x : nat, p x <-> istrue (f x)) ->
 ((forall x : nat, x <= n -> p x) <-> istrue (b_all n f)).
Proof.
   simple induction n.
   simpl. intros. split.
      intros. elim (H 0). intros. apply H1. apply H0. trivial.
      intros. replace x with 0.
         elim (H 0). intros. apply H3. apply H0.
         apply le_n_O_eq. apply H1.
  simpl. intros. split.
     case (H p f).
       assumption.
       intros. apply b_and_intro.
          case (H0 (S n0)). intros. apply H4. apply H3. trivial.
          apply H1. intros. apply H3. apply le_S. assumption.
       intros. case (H0 x). intros. apply H4. case (le_lt_or_eq x (S n0)).
          assumption.
          intro. elim (H p f).
             intros. apply H3. apply H7. apply (b_and_elim2 (f (S n0)) (b_all n0 f)). apply H1.
             apply lt_n_Sm_le. assumption.
             assumption.
          intros. rewrite H5. apply (b_and_elim1 (f (S n0)) (b_all n0 f)). assumption.
Qed.

Lemma exok :
 forall (n : nat) (p : nat -> Prop) (f : nat -> bool),
 (forall x : nat, p x <-> istrue (f x)) ->
 ((exists x : nat, x <= n /\ p x) <-> istrue (b_ex n f)).
Proof.
   simple induction n.
   simpl. intros. split.
      intros. case H0. intros. case H1. intros. case (le_lt_or_eq x 0).
        assumption.
        intros. absurd (x < 0).
          apply (lt_n_O x).
          assumption.
        intros. replace x with 0 in H3. elim (H 0). intros. apply H5. assumption.
       intros. exists 0. split.
         trivial.
         elim (H 0). intros. apply H2. assumption.
  simpl. intros. split.
     intros.  elim H1. intros. elim H2. intros. elim (le_lt_or_eq x (S n0)).
       intros. apply (b_or_intro2 (f (S n0)) (b_ex n0 f)). elim (H p f).
          intros. apply H6. exists x. split.
             apply lt_n_Sm_le. assumption.
             assumption.
          assumption.
       intros. apply (b_or_intro1 (f (S n0)) (b_ex n0 f)). replace (S n0) with x.  elim (H0 x). intros. apply H6. assumption.
       apply H3.
    intros. elim (b_or_elim (f (S n0)) (b_ex n0 f)).
       intros. exists (S n0). split.
          trivial.
          elim (H0 (S n0)). intros. apply H4. assumption.
       intros. elim (H p f).
         intros. elim H4. intros. exists x. elim H5. intros. split.
            apply le_S. assumption.
            assumption.
         assumption.
         assumption.
      assumption.
Qed.

Lemma allelok :
 forall (l : list nat) (p : nat -> Prop) (f : nat -> bool),
 (forall x : nat, p x <-> istrue (f x)) ->
 ((forall x : nat, In x l -> p x) <-> istrue (b_all_el l f)).
Proof.
  induction l.
    split.
      simpl in |- *. trivial.
      simpl in |- *. contradiction.
    intros. elim (IHl p f).
      split.
        simpl in |- *. intros. apply b_and_intro.
          elim (H a). intros. apply H3. apply H2. left. trivial.
          intros. apply H0. intros. apply (H2 x). right. exact H3.
        intros. elim H3.
          intros. replace x with a. elim (H a). intros. apply H6. apply (b_and_elim1 (f a) (b_all_el l f)). apply H2.
          apply H1. apply (b_and_elim2 (f a)). apply H2.
      exact H.
Qed.

Lemma exelok :
 forall (l : list nat) (p : nat -> Prop) (f : nat -> bool),
 (forall x : nat, p x <-> istrue (f x)) ->
 ((exists x : nat, In x l /\ p x) <-> istrue (b_ex_el l f)).
Proof.
  induction l.
    split.
      simpl in |- *. intros. elim H0. intros. elim H1. intros. exact H2.
      simpl in |- *. contradiction.
    intros. elim (IHl p f).
      split.
        intros. simpl in |- *. elim H2. intros. elim H3. intros. elim H4.
          intros. apply b_or_intro1. replace a with x. elim (H x). intros. apply H7. exact H5.
          intros. apply b_or_intro2. apply H0. exists x. split.
            exact H6.
            exact H5.
        simpl in |- *. intros. case (b_or_elim (f a) (b_ex_el l f)).
          exact H2.
          intros. exists a. split.
            left. trivial.
            elim (H a). intros. apply H5. exact H3.
          intros. elim H1.
            intros. exists x. elim H4. intros. split.
              right. exact H5.
              exact H6.
            exact H3.
      exact H.
Qed.

Lemma inok : forall (n: nat) (l: list nat), (In n l) <-> istrue (b_in n l).
Proof.
  intros. split.
    intros. induction l.
      simpl. trivial.
      simpl. elim H.
        intros. apply b_or_intro1. elim (eqok a n). intros. apply H1. apply H0.
        intros. apply b_or_intro2. apply IHl. apply H0.
    intros. induction l.
      trivial.
      simpl in H. elim (b_or_elim (b_eq a n) (b_in n l)).
        intros. simpl. left. elim (eqok a n). intros. apply H2. apply H0.
        intros. simpl. right. apply IHl. apply H0.
        apply H.
Qed.

Lemma pinok : forall (p: nat * nat) (l: list (nat * nat)), (In p l) <-> istrue (b_p_in p l).
Proof.
  intros. split.
     intros. induction l.
        simpl. trivial.
        simpl. elim H.
          intros. apply b_or_intro1. elim (peqok a p). intros. apply H1. apply H0.
          intros. apply b_or_intro2. apply IHl. apply H0.
     intros. induction l.
       trivial.
       simpl in H. elim (b_or_elim (b_p_eq a p) (b_p_in p l)).
          intros. simpl. left. elim (peqok a p). intros. apply H2. apply H0.
          intros. simpl. right. apply IHl. apply H0.
          apply H.
Qed.

Lemma succok : forall (x y: nat) (l: list nat),
  (Succ nat x y l) <-> (istrue (b_succ x y l)).
Proof.
  intros. split.
     intros. induction l.
        simpl in H. contradiction.
        induction l.
           simpl in H. contradiction.
           elim H.
              intros. simpl. apply b_or_intro1. elim H0. intros. apply b_and_intro.
                elim (eqok a x). intros. apply H3. replace x with a. trivial.
                elim (eqok a0 y). intros. apply H3. replace y with a0. trivial.
              intros. simpl. apply b_or_intro2. change (istrue (b_succ x y (a0::l))).  apply IHl. apply H0.
     intros. induction l.
        simpl in H. contradiction.
        induction l.
           simpl in H. contradiction.
           elim (b_or_elim (b_and (b_eq a x) (b_eq a0 y)) (b_succ x y (a0::l))).
              intros. simpl. left. split.
                 symmetry. elim (eqok a x). intros. apply H2. apply (b_and_elim1 (b_eq a x) (b_eq a0 y)). apply H0.
                 symmetry. elim (eqok a0 y). intros. apply H2. apply (b_and_elim2 (b_eq a x) (b_eq a0 y)). apply H0.
              intros. simpl. right. change (Succ nat x y (a0::l)). apply IHl. apply H0.
           apply H.
Qed.

Lemma zltok : forall s t : Z, (s < t)%Z <-> istrue (b_zlt s t).
Proof.
  simple induction s.
    simple induction t.
      (* ZERO < ZERO *)
      simpl in |- *. split.
        apply Zlt_irrefl.
        contradiction.
      (* ZERO < POS *)
      simpl in |- *. split.
        trivial.
        intros. apply Zgt_lt. apply Zorder.Zgt_pos_0.
      (* ZERO < NEG *)
      simpl in |- *. split.
        apply Zle_not_lt. apply Zlt_le_weak. apply Zorder.Zlt_neg_0.
        contradiction.
    simple induction t.
      (* POS < ZERO *)
      simpl in |- *. split.
        apply Zle_not_lt. apply Zlt_le_weak. apply Zgt_lt. apply Zorder.Zgt_pos_0.
        contradiction.
      (* POS < POS *)
      simpl in |- *. intro. apply pos_lt.
      (* POS < NEG *)
      intros. split.
        intros. compute in H. discriminate H.
        intros. simpl in H. contradiction.
    simple induction t.
      (* NEG < ZERO *)
      simpl in |- *. split.
        trivial.
        intros. compute in |- *. reflexivity.
      (* NEG < POS *)
      simpl in |- *. split.
        trivial.
        intros. compute in |- *. reflexivity.
      (* NEG < NEG *)
      intros. simpl in |- *. replace (Zneg p) with (- Zpos p)%Z.
        replace (Zneg p0) with (- Zpos p0)%Z.
          elim (pos_lt p0 p). intros. split.
            intros. apply H. change ((Zpos p0 ?= Zpos p)%Z = Datatypes.Lt) in |- *. rewrite Zcompare_opp. exact H1.
            intros. change ((- Zpos p ?= - Zpos p0)%Z = Datatypes.Lt) in |- *. rewrite <- Zcompare_opp. apply H0. exact H1.
	    rewrite <- Zopp_neg. apply Zopp_involutive.
            rewrite <- Zopp_neg. apply Zopp_involutive.
Qed.

Lemma zeqok : forall s t : Z, s = t <-> istrue (b_zeq s t).
Proof.
  double induction s t.
    split.
      intros. simpl in |- *. trivial.
      intros. reflexivity.
    intros. split.
      intros. discriminate H.
      intros. simpl in H. contradiction.
    intros. split.
      intros. discriminate H.
      intros. simpl in H. contradiction.
    intros. split.
      intros. discriminate H.
      intros. simpl in H. contradiction.
    intros. split.
      intros. simpl in |- *. elim (pos_eq p0 p). intros. apply H0. injection H. trivial.
      intros. elim (pos_eq p0 p). intros. assert (p0 = p).
        apply H1. apply H.
        elim H2. reflexivity.
    intros. split.
      intros. discriminate H.
      intros. simpl in H. contradiction.
    intros. split.
      intros. discriminate H.
      intros. simpl in H. contradiction.
    intros. split.
      intros. discriminate H.
      intros. simpl in H. contradiction.
    intros. split.
      intros. simpl in |- *. elim (pos_eq p0 p). intros. apply H0. injection H. trivial.
      intros. elim (pos_eq p0 p). intros. assert (p0 = p).
        apply H1. apply H.
        elim H2. reflexivity.
Qed.

Lemma pzeqok : forall s t : (Z * Z), s = t <-> istrue (b_p_zeq s t).
Proof.
  intros. split.
     elim s. elim t. intros. elim H.
        simpl. apply b_and_intro.
           elim (zeqok a0 a0). intros. apply H0. trivial.
           elim (zeqok b0 b0). intros. apply H0. trivial.
    elim s. elim t. intros. simpl in H. replace a with a0. replace b with b0. trivial.
       elim (zeqok b0 b). intros. apply H1. apply (b_and_elim2 (b_zeq a0 a) (b_zeq b0 b)). apply H.
       elim (zeqok a0 a). intros. apply H1. apply (b_and_elim1 (b_zeq a0 a) (b_zeq b0 b)). apply H.
Qed.

Lemma zleok : forall s t : Z, (s <= t)%Z <-> istrue (b_zle s t).
Proof.
  intros. split.
    intros. elim (Zle_lt_or_eq s t).
      intros. elim (zltok s t). intros. apply b_zlt_le. apply H1. apply H0.
      intros. elim H0. case s.
        simpl in |- *. trivial.
        simpl in |- *. intros. induction p.
          simpl in |- *. apply IHp.
          simpl in |- *. apply IHp.
          simpl in |- *. trivial.
      intros. simpl in |- *. induction p.
        simpl in |- *. apply IHp.
        simpl in |- *. apply IHp.
        simpl in |- *. trivial.
      apply H.
    intros. elim (b_zle_lt_or_eq s t).
      intros. apply Zlt_le_weak. elim (zltok s t). intros. apply H2.  apply H0.
      intros. elim (zeqok s t). intros. replace t with s.
        apply Zeq_le. reflexivity.
        apply H2. apply H0.
      apply H.
Qed.

Lemma zgtok : forall s t : Z, (s > t)%Z <-> istrue (b_zgt s t).
Proof.
  intros. elim (b_zlt_gt t s). intros. split.
    intros. apply H. assert (t < s)%Z.
      apply Zgt_lt. apply H1.
      elim (zltok t s). intros. apply H3. apply H2.
    intros. apply Zlt_gt. elim (zltok t s). intros. apply H3. apply H0. apply H1.
Qed.

Lemma zgeok : forall s t : Z, (s >= t)%Z <-> istrue (b_zge s t).
Proof.
  intros. elim (b_zle_ge t s). intros. split.
    intros. apply H. assert (t <= s)%Z.
      apply Zge_le. apply H1.
      elim (zleok t s). intros. apply H3. apply H2.
    intros. apply Zle_ge. elim (zleok t s). intros. apply H3. apply H0. apply H1.
Qed.

Theorem allnatok :
 forall (n : nat) (p : Z -> Prop) (f : Z -> bool),
 (forall x : positive, p (Zpos x) <-> istrue (f (Zpos x))) ->
 ((forall x : positive, (Zpos x < Zpos (P_of_succ_nat n))%Z -> p (Zpos x)) <->
  istrue (b_all_nat n f)).
Proof.
  intros. split.
    intros. induction n as [| n Hrecn].
      intros. simpl in |- *. trivial.
      intros. simpl in |- *. apply b_and_intro.
        elim (H (P_of_succ_nat n)). intros. apply H1. apply H0. simpl in |- *. rewrite Zpos_succ_morphism. apply Zlt_succ.
        apply Hrecn. intros. apply H0. simpl in |- *. rewrite Zpos_succ_morphism. apply Zlt_lt_succ. assumption.
      intros. elim (H x). intros. apply H3. induction n as [| n Hrecn].
        absurd (Zpos x < Zsucc 0)%Z.
          apply Zle_not_lt. apply Zgt_le_succ. apply Zorder.Zgt_pos_0.
          apply H1.
      elim
       (andok (istrue (f (Zpos (P_of_succ_nat n))))
          (istrue (b_all_nat n f)) (f (Zpos (P_of_succ_nat n)))
          (b_all_nat n f)).
        intros. elim H5.
          intros. elim (Zle_lt_or_eq (Zpos x) (Zpos (P_of_succ_nat n))).
            intros. apply Hrecn.
              apply H7.
              apply H8.
            intros. rewrite H8. apply H6.
            simpl in H1. rewrite Zpos_succ_morphism in H1. apply Zlt_succ_le. apply H1.
          apply H0.
        tauto.
        tauto.
Qed.

Theorem zallok :
 forall (z : Z) (p : Z -> Prop) (f : Z -> bool),
 (forall x : Z, p x <-> istrue (f x)) ->
 ((forall x : Z, (x > 0)%Z /\ (x <= z)%Z -> p x) <-> istrue (b_zall z f)).
Proof.
  intros. split.
    intros. induction z as [| p0| p0].
      simpl in |- *. trivial.
      simpl in |- *. elim (allnatok (nat_of_P p0) p f).
        intros. apply H1. intros. apply H0. split.
          apply Zorder.Zgt_pos_0.
          rewrite P_of_succ_nat_o_nat_of_P_eq_succ in H3. rewrite Zpos_succ_morphism in H3. apply Zlt_succ_le. apply H3.
        intros. apply H.
      simpl in |- *. trivial.
    intros. induction z as [| p0| p0].
      elim H1. intros. absurd (x <= 0)%Z.
        apply Zlt_not_le. apply Zgt_lt. apply H2.
        apply H3.
      induction x as [| p1| p1].
        elim H1. intros. absurd (0 > 0)%Z.
          apply Zgt_irrefl.
          apply H2.
        simpl in H0. elim (allnatok (nat_of_P p0) p f).
          intros. apply H3.
            apply H0.
            rewrite P_of_succ_nat_o_nat_of_P_eq_succ. rewrite Zpos_succ_morphism. apply Zle_lt_succ. elim H1. intros. apply H5.
          intros. apply H.
        elim H1. intros. absurd (Zneg p1 > 0)%Z.
          apply Zle_not_gt. apply Zlt_le_weak. apply Zorder.Zlt_neg_0.
          apply H2.
      elim H1. intros. absurd (x <= Zneg p0)%Z.
        apply Zlt_not_le. apply Zgt_lt. apply Zgt_trans with 0%Z.
          apply H2.
          apply Zlt_gt. apply Zorder.Zlt_neg_0.
        apply H3.
Qed.

Theorem exnatok :
 forall (n : nat) (p : Z -> Prop) (f : Z -> bool),
 (forall x : positive, p (Zpos x) <-> istrue (f (Zpos x))) ->
 ((exists x : positive, (Zpos x < Zpos (P_of_succ_nat n))%Z /\ p (Zpos x)) <->
  istrue (b_ex_nat n f)).
Proof.
  simple induction n.
  simpl in |- *. split.
    intros. elim H0. intros. elim H1. intros. absurd (Zpos x < Zsucc 0)%Z.
      apply Zle_not_lt. apply Zgt_le_succ. apply Zorder.Zgt_pos_0.
      apply H2.
    tauto.
  simpl in |- *. intros. case (H p f). assumption. split.
    intros. case H3. intros. case H4. intros. case (Zle_lt_or_eq (Zpos x) (Zpos (P_of_succ_nat n0))).
      apply Zlt_succ_le. rewrite Zpos_succ_morphism in H5. apply H5.
      intros. apply b_or_intro2. apply H1. exists x. split.
        apply H7.
        apply H6.
      intros. apply b_or_intro1. rewrite <- H7. case (H0 x). intros. apply H8. assumption.
    intros. case (b_or_elim (f (Zpos (P_of_succ_nat n0))) (b_ex_nat n0 f)).
      apply H3.
      intros. exists (P_of_succ_nat n0). split.
        rewrite Zpos_succ_morphism. apply Zlt_succ.
        case (H0 (P_of_succ_nat n0)). tauto.
      intros. case (H2 H4). intros. case H5. intros. exists x. split.
      rewrite Zpos_succ_morphism. apply Zlt_lt_succ. apply H6. apply H7.
Qed.

Theorem zexok :
 forall (z : Z) (p : Z -> Prop) (f : Z -> bool),
 (forall x : Z, p x <-> istrue (f x)) ->
 ((exists x : Z, ((x > 0)%Z /\ (x <= z)%Z) /\ p x) <-> istrue (b_zex z f)).
Proof.
  intros. split.
    intros. induction z as [| p0| p0].
      case H0. intros. case H1. intros. case H2. intros. absurd (x <= 0)%Z.
        apply Zlt_not_le. apply Zgt_lt. apply H4.
        apply H5.
      simpl in |- *. elim (exnatok (nat_of_P p0) p f).
        intros. apply H1. case H0. intros. case H3. intros. case H4. intros. induction x as [| p1| p1].
          absurd (0 > 0)%Z.
            apply Zgt_irrefl.
            apply H6.
          exists p1. split.
            rewrite P_of_succ_nat_o_nat_of_P_eq_succ. rewrite Zpos_succ_morphism. apply Zle_lt_succ. assumption.
            apply H5.
          absurd (Zneg p1 > 0)%Z.
            apply Zle_not_gt. apply Zlt_le_weak. apply Zorder.Zlt_neg_0.
            apply H6.
        intros.
      apply H.
    case H0. intros. case H1. intros. case H2. intros. absurd (x <= Zneg p0)%Z.
      apply Zlt_not_le. apply Zgt_lt. apply Zgt_trans with 0%Z.
        apply H4.
        apply Zlt_gt. apply Zorder.Zlt_neg_0.
      apply H5.
  intros. induction z as [| p0| p0].
    simpl in H0. contradiction.
    simpl in H0. elim (exnatok (nat_of_P p0) p f).
      intros. case H2.
        apply H0.
        intros. exists (Zpos x). case H3. intros. split.
          split.
            apply Zorder.Zgt_pos_0.
            rewrite P_of_succ_nat_o_nat_of_P_eq_succ in H4. rewrite Zpos_succ_morphism in H4. apply Zlt_succ_le. apply H4.
          apply H5.
      intros. apply H.
    simpl in H0. contradiction.
Qed.

Lemma zallelok :
 forall (l : list Z) (p : Z -> Prop) (f : Z -> bool),
 (forall x : Z, p x <-> istrue (f x)) ->
 ((forall x : Z, In x l -> p x) <-> istrue (b_zall_el l f)).
Proof.
  intros. induction l as [| a l Hrecl].
    split. intros.
      simpl in |- *. trivial.
      simpl in |- *. contradiction.
    intros. elim Hrecl. intros.
      split.
        simpl in |- *. intros. apply b_and_intro.
          elim (H a). intros. apply H3. apply H2. left. reflexivity.
          apply H0. intros. apply H2. right. exact H3.
        simpl in |- *. intros. elim H3.
          intros. elim H4. elim (H a). intros. apply H6. apply (b_and_elim1 (f a) (b_zall_el l f)). apply H2.
          apply H1. apply (b_and_elim2 (f a)). apply H2.
Qed.

Lemma zexelok :
 forall (l : list Z) (p : Z -> Prop) (f : Z -> bool),
 (forall x : Z, p x <-> istrue (f x)) ->
 ((exists x : Z, In x l /\ p x) <-> istrue (b_zex_el l f)).
Proof.
  intros. induction l as [| a l Hrecl].
    split.
      intros. simpl in |- *. elim H0. intros. elim H1. intros. simpl in H2. assumption.
      simpl in |- *. contradiction.
    split.
      intros. simpl in |- *. elim H0. intros. elim H1. intros. elim H2.
        intros. apply b_or_intro1. replace a with x. elim (H x). intros. apply H5. assumption.
        intros. apply b_or_intro2. elim Hrecl. intros. apply H5. exists x. split.
          assumption.
          assumption.
      intros. simpl in H0. elim (b_or_elim (f a) (b_zex_el l f)).
        intros. exists a. split.
          simpl in |- *. left. reflexivity.
          elim (H a). intros. apply H3. assumption.
        intros. elim Hrecl. intros. elim H3.
          intros. exists x. elim H4. intros. split.
            simpl in |- *. right. assumption.
            assumption.
          assumption.
      assumption.
Qed.

Lemma zinok: forall (z: Z) (l: list Z), (In z l) <-> istrue (b_zin z l).
Proof.
  intros. split.
    intros. induction l.
      simpl. trivial.
      simpl. elim H.
        intros. apply b_or_intro1. elim (zeqok z a). intros. apply H1. symmetry. apply H0.
        intros. apply b_or_intro2. apply IHl. apply H0.
    intros. induction l.
      simpl. trivial.
      simpl. simpl in H. elim (b_or_elim (b_zeq z a) (b_zin z l)).
        intros. left. elim (zeqok z a). intros. symmetry. apply H2. apply H0.
        intros. right. apply IHl. apply H0.
        apply H.
Qed.

Lemma pzinok: forall (p: Z * Z) (l: list (Z * Z)), (In p l) <-> istrue (b_p_zin p l).
Proof.
  intros. split.
     intros. induction l.
        simpl in H. contradiction.
        simpl. elim H.
           intros. apply b_or_intro1. elim (pzeqok p a). intros. apply H1. symmetry. apply H0.
           intros. apply b_or_intro2. apply IHl. apply H0.
     intros. induction l.
        simpl in H. contradiction.
        simpl. simpl in H. elim (b_or_elim (b_p_zeq p a) (b_p_zin p l)).
           intros. left. elim (pzeqok p a). intros. symmetry. apply H2. apply H0.
           intros. right. apply IHl. apply H0.
          apply H.
Qed.

Lemma zsuccok : forall (x y: Z) (l: list Z),
  (Succ Z x y l) <-> (istrue (b_zsucc x y l)).
Proof.
  intros. split.
     intros. induction l.
        simpl in H. contradiction.
        induction l.
           simpl in H. contradiction.
           elim H.
              intros. simpl. apply b_or_intro1. elim H0. intros. apply b_and_intro.
                 elim (zeqok a x). intros. apply H3. replace x with a. trivial.
                 elim (zeqok a0 y). intros. apply H3. replace y with a0. trivial.
              intros. simpl. apply b_or_intro2. change (istrue (b_zsucc x y (a0::l))). apply IHl. apply H0.
    intros. induction l.
       simpl in H. contradiction.
        induction l.
           simpl in H. contradiction.
           elim (b_or_elim (b_and (b_zeq a x) (b_zeq a0 y)) (b_zsucc x y (a0::l))).
              intros. simpl. left. split.
                 symmetry. elim (zeqok a x). intros. apply H2. apply (b_and_elim1 (b_zeq a x) (b_zeq a0 y)). apply H0.
                 symmetry. elim (zeqok a0 y). intros. apply H2. apply (b_and_elim2 (b_zeq a x) (b_zeq a0 y)). apply H0.
             intros. simpl. right. change (Succ Z x y (a0::l)). apply IHl. apply H0.
           apply H.
Qed.

Theorem ok : forall p : form, isValid p <-> istrue (checkValid p).
Proof.
  simple induction p.
    intros. exact (ltok n n0).
    intros. exact (leok n n0).
    intros. exact (eqok n n0).
    intros. exact (peqok p0 p1).
    intros. exact (geok n n0).
    intros. exact (gtok n n0).
    intros. exact (zltok z z0).
    intros. exact (zleok z z0).
    intros. exact (zeqok z z0).
    intros. exact (pzeqok p0 p1).
    intros. exact (zgeok z z0).
    intros. exact (zgtok z z0).
    intros. exact (notok (isValid f) (checkValid f) H).
    intros. exact (andok (isValid f) (isValid f0) (checkValid f) (checkValid f0) H H0).
    intros. exact (orok (isValid f) (isValid f0) (checkValid f) (checkValid f0) H H0).
    intros. exact (impok (isValid f) (isValid f0) (checkValid f) (checkValid f0) H H0).
    intros. exact
  (allok n (fun y : nat => isValid (f y)) (fun y : nat => checkValid (f y))
     (fun x : nat => H x)).
    intros. exact
  (exok n (fun y : nat => isValid (f y)) (fun y : nat => checkValid (f y))
     (fun x : nat => H x)).
    intros. exact
  (allelok l (fun y : nat => isValid (f y)) (fun y : nat => checkValid (f y))
     (fun x : nat => H x)).
    intros. exact
  (exelok l (fun y : nat => isValid (f y)) (fun y : nat => checkValid (f y))
     (fun x : nat => H x)).
    intros. exact (inok n l).
    intros. exact (pinok p0 l).
    intros. exact (succok n n0 l).
    intros. exact (zsuccok z z0 l).
    intros. exact
  (zallok z (fun y : Z => isValid (f y)) (fun y : Z => checkValid (f y))
     (fun x : Z => H x)).
    intros. exact
  (zexok z (fun y : Z => isValid (f y)) (fun y : Z => checkValid (f y))
     (fun x : Z => H x)).
    intros. exact
  (zallelok l (fun y : Z => isValid (f y)) (fun y : Z => checkValid (f y))
     (fun x : Z => H x)).
    intros. exact
  (zexelok l (fun y : Z => isValid (f y)) (fun y : Z => checkValid (f y))
     (fun x : Z => H x)).
    intros. exact (zinok z l).
    intros. exact (pzinok p0 l).
Qed.


(**************************************************************)
(*   Copyright                                                *)
(*             Jean-François Monin           [+]              *)
(*             Dominique Larchey-Wendling    [*]              *)
(*                                                            *)
(*            [+] Affiliation VERIMAG - Univ. Grenoble-Alpes  *)
(*            [*] Affiliation LORIA -- CNRS                   *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

(* List traversal from right to left *)

Require Import List Utf8.
Import ListNotations.

Require Import lr.

(* ========================================================================== *)
(* Tools for recursive programming on lists traversed from right to left *)

Section sec_context.

Context {A : Type}.
Implicit Type l u : list A.
Implicit Type r : lr A.
Implicit Type z : A.

(* High-level version *)
(*
                      𝔻listz u
  ----------      ----------------
  𝔻listz []       𝔻listz (u +: z)

 *)

Inductive 𝔻listz : list A → Prop :=
| 𝔻nil : 𝔻listz []
| 𝔻consr : ∀ u z, 𝔻listz u → 𝔻listz (u +: z)
.

Definition 𝔻listz_all l : 𝔻listz l.
Proof.
  induction l as [| x u D].
  - constructor.
  - induction D as [| u z D HD].
    + change [x] with ([] +: x); do 2 constructor.
    + apply (𝔻consr _ _ HD). (* (x :: (u +: z))  =  ((x :: u) +: z) *)
Defined.

Unset Elimination Schemes.

(* We will use the following variant of the previous definition,
   which sticks to the implementation of the fake pattern matching

   |  fakematch l with  |    by     |   match l2r l with    |
   |  | [] => ...       |           |   | Nilr => ...       |
   |  | u +: z => ...   |           |   | Consr u z => ...  |
   |  end               |           |   end                 |

  and turns out to have an easier-to-explain inversion.

  The introduction rules are:

                       𝔻lz u         𝔻lr (l2r l)
   ---------      ---------------     -----------
   𝔻lr Nilr       𝔻lr (Consr u z)       𝔻lz l

 *)

Inductive 𝔻lz : list A -> Prop :=
| 𝔻lz_1 l : 𝔻lr (l2r l) → 𝔻lz l
with 𝔻lr  : lr A -> Prop :=
| 𝔻lr_Nilr : 𝔻lr Nilr
| 𝔻lr_Consr : ∀ u z, 𝔻lz u → 𝔻lr (Consr u z)
.

Set Elimination Schemes.

(* The induction scheme for 𝔻lz is easy to prove, by fixpoint,
   basic pattern matchings, and a trivial rewriting step *)
Theorem 𝔻lz_ind (P: list A → Prop) :
  P []  →  (∀ u, P u → ∀ z, P (u +: z)) →
  ∀ l, 𝔻lz l → P l.
Proof.
  intros Pnil Pconsr.
  refine (fix fxp l D {struct D} : _ := _).
  destruct D as [l D]. rewrite <- lrl_id.
  destruct D as [| u z Pu]; simpl.
  - apply Pnil.
  - apply Pconsr. apply (fxp u Pu).
Qed.

(* Defining 𝔻lz_rect is more difficult.
   Done below using the Braga approach *)

(* The two definition of 𝔻lz are actually equivalent *)
Lemma lz_listz l : 𝔻lz l → 𝔻listz l.
Proof.
  induction 1; constructor; assumption.
Qed.

Lemma listz_lz l : 𝔻listz l → 𝔻lz l.
Proof.
  intros D.
  induction D as [| u z D HD]; constructor.
  - constructor.
  - rewrite l2r_consr. constructor. apply HD.
Qed.

Corollary 𝔻lz_all l : 𝔻lz l.
Proof. apply listz_lz, 𝔻listz_all. Qed.

(* -------------------------------------------------------------------------- *)
(* Structural projection of 𝔻consr *)

Let shape r : Prop :=
  match r with Consr u z => True | _ => False end.

(* Simplest version without "harmless" (or "singleton") Prop to Type elim *)
(* Recovering the u component of r when r is Consr u z with an available default value:
   the u given as input.
   This makes no assumption on the type of u, and
   z could be recovered in the same way if needed, using
        let z := match r with Consr u z => z | _ => z end in
*)

(* Designed in 2 steps *)
Let π_𝔻lr {u z} (D: 𝔻lr (Consr u z)) : 𝔻lz u :=
  match D in 𝔻lr r return
        let u := match r with Consr u z => u | _ => u end
        in shape r → 𝔻lz u with
  | 𝔻lr_Consr u z D => λ G, D
  |  _              => λ G, match G with end
  end I.

(* Versions using an auxiliary function defined first, for recovering u from r *)
(* Version using a "harmless" (or "singleton") Prop to Type elim *)

Let lrleft_he r : shape r → list A :=
  match r with Consr u z => λ _, u | _ => λ G, (match G with end) end.

Let π_𝔻lr_he {u z} (D: 𝔻lr (Consr u z)) : 𝔻lz u :=
  match D in 𝔻lr r return ∀ G, 𝔻lz (lrleft_he r G) with
  | 𝔻lr_Consr u0 z0 D0 => λ G, D0
  |  _                  => λ G, match G with end
  end I.

(** Another version w/o harmless elim Prop -> Type using False_elim *)

Definition False_elim X : False -> X :=
  fix loop f := loop (match f : False with end).

Let lrleft_no_he r : shape r → list A :=
  match r with Consr u z => λ _, u | _ => λ G, False_elim _ G end.

Let π_𝔻lr_no_he {u z} (D: 𝔻lr (Consr u z)) : 𝔻lz u :=
  match D in 𝔻lr r return ∀ G, 𝔻lz (lrleft_no_he r G) with
  | 𝔻lr_Consr u0 z0 D0 => λ G, D0
  |  _                  => λ G, match G with end
  end I.

(* Finally, the simple version given first can be written in a similar way *)
Let lrleft r : list A → list A :=
  match r with Consr u z => λ _, u | _ => λ u0, u0 end.

Let π_𝔻lr' {u z} (D: 𝔻lr (Consr u z)) : 𝔻lz u :=
  match D in 𝔻lr r return ∀(G: shape r), 𝔻lz (lrleft r u) with
  | 𝔻lr_Consr u0 z0 D0 => λ G, D0
  |  _                  => λ G, match G with end
  end I.

(* In contrast, lrleft_he and lrleft_no_he cannot be inlined
   because they require a G argument, whose type depends on r.
*)

(* Definitions of π_𝔻lz *)
Definition π_𝔻lz {u z} (D : 𝔻lz (u +: z)) : 𝔻lz u :=
  match D in 𝔻lz l return l = u+:z → _ with
    𝔻lz_1 l Dr => λ G, π_𝔻lr (same_by_l2r_consr G Dr)
  end eq_refl.

(* Compact Version in 1 step *)
Definition π_𝔻lz_compact {u z} (D : 𝔻lz (u +: z)) : 𝔻lz u :=
 match D in 𝔻lz l return l = u+:z → _ with
 | 𝔻lz_1 _ Dr => λ G,
   match same_by_l2r_consr G Dr in 𝔻lr r return
         let u := match r with Consr u z => u | _ => u end in
         shape r → 𝔻lz u with
   | 𝔻lr_Consr u _ Du => λ G, Du
   |  _               => λ G, match G with end
   end (I : shape (Consr u z))
 end eq_refl.

(* -------------------------------------------------------------------------- *)

(* A recursor for Type which does NOT pattern match over 𝔻lz l
   in Type context but there is eq_rect in it !! *)

(* Using up_llP and down_llT in order to constrain the use of eq_ind
   and eq_rect, hence a clearer view of the underlying reasoning *)
Definition 𝔻lz_rect (P: list A → Type) :
  P []  →  (∀ u, P u → ∀ z, P (u +: z)) →  ∀ l, 𝔻lz l → P l :=
  fun Pnil Pconsr =>
    fix fxp l (D : 𝔻lz l) {struct D} : P l :=
    (match l2r l as r return (𝔻lz (r2l r) → (P (r2l r) → P l) → P l)
     with
     | Nilr      => fun D L => L Pnil
     | Consr u z => fun D L => L (Pconsr u (fxp u (π_𝔻lz D)) z)
     end (up_llP 𝔻lz l D)) (down_llT P l).

(* Interactive version, on all lists *)
Definition list_zrect (P: list A → Type) :
  P []  →  (∀ u, P u → ∀ z, P (u +: z))  →  ∀ l, P l.
Proof.
  intros Pnil Pconsr.
  intro l. generalize (𝔻lz_all l). revert l.
  refine (fix fxp l D {struct D} : _ := _).
  generalize (down_llT P l).
  apply up_llP in D.
  revert D.
  destruct (l2r l) as [| u z]; simpl; intros D L; apply L.
  - apply Pnil.
  - apply Pconsr, fxp, (π_𝔻lz D).
Defined.

End sec_context.


From mathcomp.ssreflect Require Import ssreflect ssrfun.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* exists size *)
Notation "'eS'" := (existT _ _).

(**
 Finite Coinductive Trees (indexed by shape)
*)
Section CTree.
  Context (A : Type).

  Inductive shape : Type :=
  | SL : shape
  | SN : shape -> shape -> shape.

  Inductive tree : Type :=
  | L : tree
  | N : A -> tree -> tree -> tree.

  CoInductive vtree : shape -> Type :=
  | CL : vtree SL
  | CN l r : A -> vtree l -> vtree r -> vtree (SN l r).

  Inductive Fin : shape -> Prop :=
  | FL : Fin SL
  | FN l r : Fin l -> Fin r -> Fin (SN l r).

  Lemma all_fin : forall t, Fin t.
  Proof. by elim=>[|x l r]; constructor. Defined.

  Lemma inv_fin1 : forall n l r, Fin n -> n = SN l r -> Fin l.
  Proof. by move=> n l r; case=>// l' r' H0 H1 [<-]. Defined.

  Lemma inv_fin2 : forall n l r, Fin n -> n = SN l r -> Fin r.
  Proof. by move=> n l r; case=>// l' r' H0 H1 [_ <-]. Defined.

  Fixpoint vtree_to_tree' n (x : vtree n) (d : Fin n) {struct d} : tree :=
    match x in vtree m return n = m -> tree with
    | CL => fun _ => L
    | CN dl dr v l r =>
      fun pf =>
        N v (vtree_to_tree' l (inv_fin1 d pf))
            (vtree_to_tree' r (inv_fin2 d pf))
    end erefl.

  Definition vtree_to_tree n (x : vtree n) : tree :=
    vtree_to_tree' x (all_fin n).

  Fixpoint tshape (t : tree) : shape :=
    match t with
    | L => SL
    | N _ l r => SN (tshape l) (tshape r)
    end.

  Fixpoint tree_to_vtree (t : tree) : vtree (tshape t) :=
    match t return vtree (tshape t) with
    | L => CL
    | N h l r => CN h (tree_to_vtree l) (tree_to_vtree r)
    end.

  Definition ftree := {n & vtree n}.
  Definition f_leaf : ftree := existT _ _ CL.
  Definition f_node h l r := existT _ _ (CN h (projT2 l) (projT2 r)).

  Lemma ftree_ind (P : ftree -> Prop) :
    P f_leaf ->
    (forall h l r, P l -> P r -> P (f_node h l r)) ->
    forall t, P t.
  Proof.
    move=>P_leaf P_node [n v].
    elim: n v=>//; first by case E:_ / =>//.
    move=> l Ihl r Ihr; case E:_ / =>[| l' r' x' cl cr]//.
    move: E cl Ihl cr Ihr =>[<-<-] cl /(_ cl)-Pcl cr /(_ cr)-Pcr.
    rewrite -/(f_node _ (existT _ _ _) (existT _ _ _)).
    by apply: P_node.
  Qed.

  Definition ftree_to_tree v := vtree_to_tree (projT2 v).
  Definition tree_to_ftree v := existT _ _ (tree_to_vtree v).

  Lemma ftree_iso1 l : ftree_to_tree (tree_to_ftree l) = l.
  Proof.
    rewrite /ftree_to_tree/tree_to_ftree/vtree_to_tree/=.
    by elim: l=>//= x l -> r ->.
  Qed.

  Lemma ftree_iso2 l : tree_to_ftree (ftree_to_tree l) = l.
  Proof.
    elim/ftree_ind: l=>//= h l r.
    rewrite /ftree_to_tree/tree_to_ftree/= => IHl IHr.
    rewrite -/(f_node h (existT _ _ _) (existT _ _ _)).
    by rewrite -!/(vtree_to_tree _) IHl IHr.
  Qed.
End CTree.


Coq < Section Distribution.

Coq < Variables P Q R : Prop.
P is assumed
Q is assumed
R is assumed

Coq < Goal (P /\ Q) \/ (P /\ R) -> (P /\ (Q \/ R)).
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  ============================
   P /\ Q \/ P /\ R -> P /\ (Q \/ R)

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  H : P /\ Q \/ P /\ R
  ============================
   P /\ (Q \/ R)

Unnamed_thm < destruct H.
2 subgoals

  P : Prop
  Q : Prop
  R : Prop
  H : P /\ Q
  ============================
   P /\ (Q \/ R)

subgoal 2 is:
 P /\ (Q \/ R)

Unnamed_thm < split.
3 subgoals

  P : Prop
  Q : Prop
  R : Prop
  H : P /\ Q
  ============================
   P

subgoal 2 is:
 Q \/ R
subgoal 3 is:
 P /\ (Q \/ R)

Unnamed_thm < auto.
3 subgoals

  P : Prop
  Q : Prop
  R : Prop
  H : P /\ Q
  ============================
   P

subgoal 2 is:
 Q \/ R
subgoal 3 is:
 P /\ (Q \/ R)

Unnamed_thm < tauto.
2 subgoals

  P : Prop
  Q : Prop
  R : Prop
  H : P /\ Q
  ============================
   Q \/ R

subgoal 2 is:
 P /\ (Q \/ R)

Unnamed_thm < left.
2 subgoals

  P : Prop
  Q : Prop
  R : Prop
  H : P /\ Q
  ============================
   Q

subgoal 2 is:
 P /\ (Q \/ R)

Unnamed_thm < tauto.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  H : P /\ R
  ============================
   P /\ (Q \/ R)

Unnamed_thm < split.
2 subgoals

  P : Prop
  Q : Prop
  R : Prop
  H : P /\ R
  ============================
   P

subgoal 2 is:
 Q \/ R

Unnamed_thm < tauto.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  H : P /\ R
  ============================
   Q \/ R

Unnamed_thm < right.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  H : P /\ R
  ============================
   R

Unnamed_thm < tauto.
Proof completed.

Unnamed_thm < Qed.
intro.
destruct H.
 split.
  auto.
  tauto.

  left.
  tauto.

 split.
  tauto.

  right.
  tauto.

Unnamed_thm is defined


(* Let's look at the following example: *)
Example ex1: forall A B: Prop, (A -> B) -> A -> B.
(* We want to prove, that for all propositions A and B if A implies B and A holds then B also holds.
   Now we step through the proof in Coq, which is a sequence of tactics, and comment every single line
   with its logical sense. Look at list of hypotheses and a subgoals. *)
Proof. (* We start proof *)
  intro. (* Let's take some proposition A. *)
  intro. (* Let's take some proposition B. *)
  intro. (* To prove proposition (P -> Q) we usually assume P as a hypothesis and then prove Q.
             So here we'll get hypothesis H: A -> B and the goal will be A -> B.
             In fact, here we can stop and apply this H to the goal, but we'll go further instead. *)
  intro. (* New hypothesis H0: A, goal: B. *)
  apply H. (* No we can apply hypothesis H, because it's conclusion is the same as our goal.
              Applying H will also set its premise as a new goal. *)
  exact H0. (* Now goal coincides with one of hypotheses, namely H0, that allows us to use 'exact' tactic. *)
  (* No more goals, proof is completed, save it. *)
Qed.

(* This kind of reasoning is called 'backward reasoning, because we move from goals to the implications
   in hypothesis and then to their premices.

   The same proof can be written shorter thanks to tactic 'intros':
 *)
Example ex11: forall A B: Prop, (A -> B) -> A -> B.
Proof.
  intros. (* Introduce all propositions and premises as hypotheses. *)
  apply H.
  assumption. (* Find one of assumptions which coincides with the goal and it. This is sometimes better
               than using particular name of hypothesis in 'exact'. *)
Qed.

Example ex12: forall A B: Prop, (A -> B) -> A -> B.
Proof.
  auto. (* Well, yeah, that's not fair, I know. But try to resist using this tactic until told so. *)
Qed.

(* Now we learn how to deal with disjunctions, conjunctions and negations,
   how to prove them (in goals) and use them (in hypotheses). *)

Example ex2: forall A B: Prop, A -> A \/ B.
Proof.
  intros.
  left. (* To prove disjunction we have to specify which part in particular we want to prove.
           Here we can prove left part. Beware, intuitionistic logic here! *)
  assumption.
Qed.

Example ex3: forall x y z: Prop, (x -> z) -> (y -> z) -> (x \/ y -> z).
Proof.
  intros. (* Look at hypotheses, the main question here is how to use disjunction in H1.
             We have to 'destruct' it, that means exploring two cases: if x holds and if y holds.
             If disjunction in H1 holds then one of its parts is necessarily holds, but we don't
             know which one, so we do really have two cases. *)
  destruct H1. (* H1 becomes 'x', so x holds and we apply implication H. *)
    (* Note indentation here, this is way to mark visually proofs for subgoals arisen after 'destruct'. *)
    apply H. assumption. (* The first case is solved and we move to the second one. *)
    (* H1 becomes 'y', so y holds and we apply implication H0. *)
    apply H0. assumption.
Qed.

Example ex4: forall a b: Prop, a /\ b -> a.
Proof.
  intros.
  destruct H. (* Here we destruct conjunction so evidently we get two hypotheses for the same
                 goal, which are both parts of conjuction. *)
  assumption.
Qed.

Example ex5: forall a b: Prop, a -> b -> a /\ b.
Proof.
  intros. (* How to prove conjunction? Well, we have to prove both parts. *)
  split. (* We use 'split' to literally split conjunction into two parts. So we get two
            subgoals and have to prove them both independently.
            Happily, the proof is straightforward, we just use assumptions in  both cases. *)
  assumption.
  assumption.
Qed.

(* If proofs for several cases are the same we can use 'tactical' ; (semicolon),
   as in example below. *)
Example ex51: forall a b: Prop, a -> b -> a /\ b.
Proof.
  intros.
  split; assumption. (* Tactic 'assumption' is executed for both subgoals arisen after 'split'. *)
Qed.

(* We use negation ~P in the following sense: if we assume P then we come to contradiction (we get False).
   So we can read (and use whenever we like) ~P as implication P->False. *)
Example ex6: forall A: Prop, A -> ~~A.
Proof.
  intros. (* Now we have ~~A in goals, according to our interpretation that means (~A->False), so use
             intro one more time. *)
  intro.  (* We can clearly see contradiction in hypotheses. To prove it we apply H0 (~A === A->False)
             and then provide exact assumption. *)
  apply H0.
  exact H.
  (* The last two steps are not necessary, we can use 'contradiction' tactic instead. The 'contradiction'
     tactic tries to find hypotheses like 'P' and '~P' and finishes the proof if succeeding. *)
Qed.

(* Next example is one direction of De Morgan's Law (the other one can't be proved in intuitionistic logic
  without additional assumptions). To prove it we use plenty of destructions.
  Note also use of ';' tactical. *)
Example ex7: forall A B , A \/ B -> ~ (~ A /\ ~ B ).
Proof.
  intros.
  intro.
  destruct H; destruct H0; contradiction.
Qed.  (* By the way, try to use 'auto' here. Does it work? *)

(* P is predicate in the following Lemma, it takes the value from set T and turns it into proposition. *)
Lemma ex8: forall (T: Set) ( P : T -> Prop ), (~ exists x , P x ) -> forall x , ~ P x .
Proof.
  intros.
  intro.
  apply H.
  exists x. (* We have to provide something to prove 'exists' in goal. Well, we have what we need
               (namely, x: T) in the list of assumptions. *)
  assumption.
Qed.

(* The words Example, Lemma, Theorem or Fact are true synonyms. Use whatever you feel appropriate. *)


Require Import Setoid.
Require Import Coq.Lists.List.
Require Import Coq.Program.Equality.
Import ListNotations.

Require Import Lib.LinearOrder.
Require Import Lib.EqDec.

Inductive Sorted {A: Type} `{LinearOrder A} : list A -> Prop :=
  | SortedNil : Sorted []
  | SortedSing : forall h: A, Sorted [h]
  | SortedCons : forall h h' : A, forall t: list A,
      Sorted (h' :: t) -> ord h h' = true -> Sorted (h :: h' :: t).

Fixpoint count {A: Type} (p: A -> bool) (l: list A): nat :=
  match l with
  | nil => O
  | cons h t => if p h then S (count p t) else count p t
  end.

Definition permutation {A: Type} (a b : list A) :=
  forall p : A -> bool, count p a = count p b.

(* Remove *)
Fixpoint remove {A: Type} `{EqDec A} (x: A) (l: list A) :=
match l with
| []     => []
| (h::t) => if eqf x h then t else h :: remove x t
end.

Lemma remove_count_true {A: Type} `{EqDec A} (h: A) (l: list A) (p: A -> bool) :
  In h l -> p h = true -> count p l = S (count p (remove h l)).
Proof.
  induction l; intros I t; cbn in *; destruct I.
  - subst. rewrite t, eqf_refl. auto.
  - destruct (p a) eqn:e; destruct (eqf h a) eqn:e1; [auto|..].
    + cbn in *. rewrite e, IHl; auto.
    + rewrite <- eqf_iff in e1. subst. rewrite t in e. discriminate.
    + cbn in *. rewrite e, IHl; auto.
Qed.

Lemma remove_count_false {A: Type} `{EqDec A} (h: A) (l: list A) (p: A -> bool) :
  p h = false -> count p l = count p (remove h l).
Proof.
  induction l; intros f; auto. cbn in *.
  destruct (p a) eqn:e; destruct (eqf h a) eqn:e1; [| |auto|].
  - rewrite <- eqf_iff in e1. subst. rewrite f in e. discriminate.
  - cbn. rewrite e. f_equal. apply IHl; auto.
  - cbn. rewrite e, IHl; auto.
Qed.

Lemma in_count_not_O {A: Type} `{EqDec A} (l: list A) (x: A) :
  In x l <-> count (eqf x) l <> O.
Proof.
  split.
  - intros I. induction l; cbn in *; destruct I.
    + subst. rewrite eqf_refl. auto.
    + destruct (eqf x a) eqn: e; auto.
  - intros C. induction l; cbn in *; [contradiction|].
    destruct (eqf x a) eqn: e; auto. rewrite <- eqf_iff in e.
    subst. left. auto.
Qed.

Lemma perm_in {A: Type} `{EqDec A} (l l': list A) (x: A) :
  permutation l l' -> In x l -> In x l'.
Proof.
  intros perm I. rewrite in_count_not_O. rewrite in_count_not_O in I.
  specialize (perm (eqf x)). rewrite <-perm. assumption.
Qed.

Lemma remove_perm {A: Type} `{EqDec A} (h: A) (l l': list A) :
  permutation (h :: l) l' -> permutation l (remove h l').
Proof.
  unfold permutation. revert l'. induction l; intros l' perm p.
  - assert (In h l') by (apply (perm_in [h]); auto; cbn; auto).
    cbn. apply eq_add_S. specialize (perm p). cbn in *. destruct (p h) eqn:e.
    + rewrite <-remove_count_true; auto.
    + rewrite <-remove_count_false; auto.
  - assert (In h l') by (apply (perm_in (h::a::l)); cbn; auto).
    assert (In a l') by (apply (perm_in (h::a::l)); cbn; auto).
    cbn. apply eq_add_S. apply eq_add_S. specialize (perm p). cbn in *.
    destruct (p h) eqn:e.
    + rewrite <-remove_count_true; auto.
    + rewrite <-remove_count_false; auto.
Qed.

Lemma remove_perm' {A: Type} `{EqDec A} (h: A) (l l': list A) :
  In h l' -> permutation l (remove h l') -> permutation (h :: l) l' .
Proof.
  unfold permutation. induction l; intros I perm p.
  - cbn in *. specialize (perm p). destruct (p h) eqn: e.
    + rewrite (remove_count_true h); auto.
    + rewrite (remove_count_false h); auto.
  - cbn in *. specialize (perm p). destruct (p h) eqn: e.
    + rewrite (remove_count_true h l'); auto.
    + rewrite (remove_count_false h l'); auto.
Qed.

(* Sorted lemmas *)
Lemma count_list_concat {A: Type} (l l': list A):
  forall p: A-> bool, count p (l ++ l') = count p l + count p l'.
Proof.
  intros p. induction l; [auto|].
  cbn. destruct (p a); rewrite IHl; auto.
Qed.

Lemma sorted_without_head {A: Type} `{LinearOrder A} : forall l: list A, forall a: A,
  Sorted (a::l) -> Sorted l.
Proof.
  intros l. induction l; intro h.
  - intros _. constructor.
  - intro s. dependent destruction s. assumption.
Qed.

Lemma sorted_with_head {A: Type} `{LinearOrder A} : forall l: list A, forall a h: A,
  Sorted (h::l) -> ord a h = true -> Sorted (a::h::l).
Proof.
  intros l a h sort o. constructor.
  - trivial.
  - assumption.
Qed.

Lemma head_in_sorted {A: Type} `{LinearOrder A} (h: A) (l: list A) : Sorted l ->
  (forall x: A, In x l -> ord h x = true) -> Sorted (h::l).
Proof.
  intros s N. induction l; constructor; [auto|]. apply N. cbn. auto.
Qed.

Lemma concat_sorted {A: Type} `{LinearOrder A} (h: A) (l l': list A) : Sorted l -> Sorted (h :: l') ->
  (forall x: A, In x l -> ord x h = true) -> Sorted (l ++ (h :: l')).
Proof.
  intros s1 s2 N. induction l; [auto | destruct l]; cbn.
  + constructor; [auto | ]. apply (N a). cbn. auto.
  + cbn in *. constructor.
    * apply IHl.
      -- apply (sorted_without_head _ a). assumption.
      -- intros x I. apply N. auto.
    * dependent destruction s1. assumption.
Qed.

Lemma sorted_head_relation {A: Type} `{L: LinearOrder A} :
  forall l: list A, forall h: A, Sorted (h::l) -> forall x: A, In x (h :: l) ->
  ord h x = true.
Proof.
  intros l. induction l; intros h sort x H.
  - cbn in H. destruct H.
    + subst. apply refl.
    + contradiction.
  - cbn in H. destruct H.
    + subst. apply refl.
    + assert (ord a x = true).
      { apply IHl.
        - apply (sorted_without_head _ h). assumption.
        - assumption.
      }
      dependent destruction sort; try discriminate.
      apply (trans h a x); assumption.
Qed.

Theorem perm_sym {A: Type} : forall l l': list A, permutation l l' <-> permutation l' l.
Proof.
  intros l l'. unfold permutation. split; intros H p; symmetry; apply (H p).
Qed.

Theorem perm_trans {A: Type} : forall x y z: list A,
  permutation x y -> permutation y z -> permutation x z.
Proof.
  intros x y z H H0. unfold permutation in *. intro p. specialize (H p). specialize (H0 p).
  transitivity (count p y); assumption.
Qed.

Lemma perm_without_head {A: Type} : forall l l': list A, forall a: A,
  permutation (cons a l) (cons a l') -> permutation l l'.
Proof.
  - intros l l' a H. unfold permutation in *. intro p. specialize (H p). cbn in H.
    destruct (p a).
    + inversion H. reflexivity.
    + assumption.
Qed.

Lemma perm_with_head {A: Type} : forall l l': list A, forall a: A,
  permutation l l' -> permutation (a::l) (a::l').
Proof.
  intros l l' a perm. unfold permutation in *. intro p. specialize (perm p).
  cbn. destruct (p a).
  - destruct perm. trivial.
  - assumption.
Qed.

Theorem perm_for_element {A: Type} : forall l l': list A, forall x: A,
  permutation l l' -> In x l' -> In x l.
Proof.
  unfold permutation. intros l. induction l; intros l' x perm H.
  - destruct l'.
    + cbn in H. destruct H.
    + specialize (perm (fun x => true)). cbn in perm. discriminate.
  - destruct l'.
    + cbn in H. destruct H.
    + cbn. cbn in H. destruct H.
      * subst. left.
Abort.

Lemma singleton_perm {A: Type} `{L: LinearOrder A} (x y: A) :
   x = y <-> permutation [x] [y].
Proof.
  split.
  - intros [] p. auto.
  - intros perm. specialize (perm (eqf x)). cbn [count] in *. rewrite eqf_refl in perm.
    destruct (eqf x y) eqn:e.
    + rewrite <- eqf_iff in e; auto.
    + inversion perm.
Qed.

Lemma week_eqf_in {A: Type} `{L: EqDec A} :
  forall x: A, forall l: list A, In x l <-> count (eqf x) l <> O.
Proof.
  intros x l. split.
  - intros H. induction l.
    + cbn in H. contradiction.
    + cbn. destruct (eqf x a) eqn:eq.
      * apply PeanoNat.Nat.neq_succ_0.
      * apply IHl. destruct H; auto. subst. rewrite eqf_refl in eq.
        inversion eq.
  - intro H. induction l.
    + cbn in H. contradiction.
    + cbn. destruct (eqf x a) eqn:eq.
      * left. apply eqf_iff. rewrite eqf_sym. assumption.
      * right. apply IHl. cbn in H. rewrite eq in H. assumption.
Qed.

Theorem weak_perm_in {A: Type} `{L: EqDec A} : forall l l': list A, forall x: A,
  permutation l l' -> In x l' -> In x l.
Proof.
  unfold permutation. intros l l' x perm H. specialize (perm (eqf x)). cut (count (eqf x) l' <> O).
  - intro H0. rewrite <- perm in H0. rewrite week_eqf_in. assumption.
  - apply week_eqf_in. assumption.
Qed.

Lemma sorted_head_eq {A: Type} `{L: LinearOrder A} : forall l l': list A, forall a a': A,
  permutation (a :: l) (a' :: l') -> Sorted (a :: l) -> Sorted (a' :: l') -> a = a'.
Proof.
  intros l l' h h' perm s1 s2.
  destruct (full h h').
  - assert (In h (h'::l')).
    + apply (weak_perm_in (h'::l') (h :: l) h); try apply perm_sym; auto.
      cbn. left. reflexivity.
    + assert (ord h' h = true) by (apply (sorted_head_relation l' h'); auto).
      apply anti_sym; auto.
  - assert (In h' (h::l)).
    + apply (weak_perm_in (h::l) (h' :: l') h'); auto.
      cbn. left. reflexivity.
    + assert (ord h h' = true) by (apply (sorted_head_relation l h); auto).
      apply anti_sym; auto.
Qed.

(* Unique *)

Theorem sorted_unique_representation {A: Type} `{L: LinearOrder A} :
  forall l l': list A, permutation l l' -> Sorted l -> Sorted l' -> l = l'.
Proof.
  intros l. induction l; intros l' perm sort sort'.
  - destruct l'; auto. specialize (perm (fun _ => true)). cbn in perm. discriminate.
  - destruct l'.
    + specialize (perm (fun _ => true)). cbn in perm. discriminate.
    + assert (a = a0) by (apply (sorted_head_eq l l'); auto). subst.
      f_equal. apply IHl.
      * apply (perm_without_head _ _ a0); auto.
      * apply (sorted_without_head _ a0). auto.
      * apply (sorted_without_head _ a0). auto.
Qed.


Require Import Lia.

Fixpoint log2up (n : nat) : nat :=
  match n with
  | O => 0
  | S O => 0
  | S (S n') => 1 + (log2up n')
  end.
Compute log2up 6. (* 3 *)
Compute log2up 7. (* 3 *)
Compute log2up 8. (* 4 *)

(* Search (nat -> nat -> bool). *)
Compute (Nat.leb 3 2).

(* After the fashion of
   https://coq.inria.fr/library/Coq.Numbers.NatInt.NZLog.html *)
Lemma log2up_nonneg : forall (n : nat), 0 <= (log2up n).
Proof.
  lia.
Qed.

Compute (Nat.pow 2 3).

Lemma log2_lemma : forall (n : nat), n <= (Nat.pow 2 (log2up n)).
(*
Proof.
  intros.
  induction n.
  - lia.
  - simpl.
Qed.
 *)


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (lf1 : natural) (y : natural) (x : natural)
  : natural := mult y x.


Require Import Frap.

(** * Syntax and semantics of a simple imperative language *)

Inductive exp :=
| Const (n : nat)
| Var (x : string)
| Read (e1 : exp)
| Plus (e1 e2 : exp)
| Minus (e1 e2 : exp)
| Mult (e1 e2 : exp).

Inductive bexp :=
| Equal (e1 e2 : exp)
| Less (e1 e2 : exp).

Definition heap := fmap nat nat.
Definition valuation := fmap var nat.
Definition assertion := heap -> valuation -> Prop.

Inductive cmd :=
| Skip
| Assign (x : var) (e : exp)
| Write (e1 e2 : exp)
| Seq (c1 c2 : cmd)
| If_ (be : bexp) (then_ else_ : cmd)
| While_ (inv : assertion) (be : bexp) (body : cmd)

| Assert (a : assertion).

(* Shorthand notation for looking up in a finite map, returning zero if the key
 * is not found *)
Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).

(* Start of expression semantics: meaning of expressions *)
Fixpoint eval (e : exp) (h : heap) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x => v $! x
  | Read e1 => h $! eval e1 h v
  | Plus e1 e2 => eval e1 h v + eval e2 h v
  | Minus e1 e2 => eval e1 h v - eval e2 h v
  | Mult e1 e2 => eval e1 h v * eval e2 h v
  end.

(* Meaning of Boolean expressions *)
Fixpoint beval (b : bexp) (h : heap) (v : valuation) : bool :=
  match b with
  | Equal e1 e2 => if eval e1 h v ==n eval e2 h v then true else false
  | Less e1 e2 => if eval e2 h v <=? eval e1 h v then false else true
  end.

(* A big-step operational semantics for commands *)
Inductive exec : heap -> valuation -> cmd -> heap -> valuation -> Prop :=
| ExSkip : forall h v,
  exec h v Skip h v
| ExAssign : forall h v x e,
  exec h v (Assign x e) h (v $+ (x, eval e h v))
| ExWrite : forall h v e1 e2,
  exec h v (Write e1 e2) (h $+ (eval e1 h v, eval e2 h v)) v
| ExSeq : forall h1 v1 c1 h2 v2 c2 h3 v3,
  exec h1 v1 c1 h2 v2
  -> exec h2 v2 c2 h3 v3
  -> exec h1 v1 (Seq c1 c2) h3 v3
| ExIfTrue : forall h1 v1 b c1 c2 h2 v2,
  beval b h1 v1 = true
  -> exec h1 v1 c1 h2 v2
  -> exec h1 v1 (If_ b c1 c2) h2 v2
| ExIfFalse : forall h1 v1 b c1 c2 h2 v2,
  beval b h1 v1 = false
  -> exec h1 v1 c2 h2 v2
  -> exec h1 v1 (If_ b c1 c2) h2 v2
| ExWhileFalse : forall I h v b c,
  beval b h v = false
  -> exec h v (While_ I b c) h v
| ExWhileTrue : forall I h1 v1 b c h2 v2 h3 v3,
  beval b h1 v1 = true
  -> exec h1 v1 c h2 v2
  -> exec h2 v2 (While_ I b c) h3 v3
  -> exec h1 v1 (While_ I b c) h3 v3

(* Assertions execute only when they are true.  They provide a way to embed
 * proof obligations within programs. *)
| ExAssert : forall h v (a : assertion),
  a h v
  -> exec h v (Assert a) h v.

(** * Hoare logic *)

Inductive hoare_triple : assertion -> cmd -> assertion -> Prop :=
| HtSkip : forall P, hoare_triple P Skip P
| HtAssign : forall (P : assertion) x e,
  hoare_triple P (Assign x e) (fun h v => exists v', P h v' /\ v = v' $+ (x, eval e h v'))
| HtWrite : forall (P : assertion) (e1 e2 : exp),
  hoare_triple P (Write e1 e2) (fun h v => exists h', P h' v /\ h = h' $+ (eval e1 h' v, eval e2 h' v))
| HtSeq : forall (P Q R : assertion) c1 c2,
  hoare_triple P c1 Q
  -> hoare_triple Q c2 R
  -> hoare_triple P (Seq c1 c2) R
| HtIf : forall (P Q1 Q2 : assertion) b c1 c2,
  hoare_triple (fun h v => P h v /\ beval b h v = true) c1 Q1
  -> hoare_triple (fun h v => P h v /\ beval b h v = false) c2 Q2
  -> hoare_triple P (If_ b c1 c2) (fun h v => Q1 h v \/ Q2 h v)
| HtWhile : forall (I P : assertion) b c,
  (forall h v, P h v -> I h v)
  -> hoare_triple (fun h v => I h v /\ beval b h v = true) c I
  -> hoare_triple P (While_ I b c) (fun h v => I h v /\ beval b h v = false)
| HtAssert : forall P I : assertion,
  (forall h v, P h v -> I h v)
  -> hoare_triple P (Assert I) P
| HtConsequence : forall (P Q P' Q' : assertion) c,
  hoare_triple P c Q
  -> (forall h v, P' h v -> P h v)
  -> (forall h v, Q h v -> Q' h v)
  -> hoare_triple P' c Q'.

Lemma hoare_triple_big_step_while: forall (I : assertion) b c,
  (forall h v h' v', exec h v c h' v'
                     -> I h v
                     -> beval b h v = true
                     -> I h' v')
  -> forall h v h' v', exec h v (While_ I b c) h' v'
                       -> I h v
                       -> I h' v' /\ beval b h' v' = false.
Proof.
  induct 2; eauto.
Qed.

Theorem hoare_triple_big_step : forall pre c post,
    hoare_triple pre c post
    -> forall h v h' v', exec h v c h' v'
                         -> pre h v
                         -> post h' v'.
Proof.
  induct 1; eauto; invert 1; eauto.

  simplify.
  eapply hoare_triple_big_step_while; eauto.
Qed.

(* BEGIN syntax macros that won't be explained *)
Coercion Const : nat >-> exp.
Coercion Var : string >-> exp.
Notation "*[ e ]" := (Read e) : cmd_scope.
Infix "+" := Plus : cmd_scope.
Infix "-" := Minus : cmd_scope.
Infix "*" := Mult : cmd_scope.
Infix "=" := Equal : cmd_scope.
Infix "<" := Less : cmd_scope.
Definition set (dst src : exp) : cmd :=
  match dst with
  | Read dst' => Write dst' src
  | Var dst' => Assign dst' src
  | _ => Assign "Bad LHS" 0
  end.
Infix "<-" := set (no associativity, at level 70) : cmd_scope.
Infix ";;" := Seq (right associativity, at level 75) : cmd_scope.
Notation "'when' b 'then' then_ 'else' else_ 'done'" := (If_ b then_ else_) (at level 75, b at level 0).
Notation "{{ I }} 'while' b 'loop' body 'done'" := (While_ I b body) (at level 75).
Notation "'assert' {{ I }}" := (Assert I) (at level 75).
Delimit Scope cmd_scope with cmd.
(* END macros *)

(* We should draw some attention to the next notation, which defines special
 * lambdas for writing assertions. *)
Notation "h & v ~> e" := (fun h v => e%nat%type) (at level 85, v at level 0).

(* And here's the classic notation for Hoare triples. *)
Notation "{{ P }} c {{ Q }}" := (hoare_triple P c%cmd Q) (at level 90, c at next level).

(* Special case of consequence: keeping the precondition; only changing the
 * postcondition. *)
Lemma HtStrengthenPost : forall (P Q Q' : assertion) c,
  hoare_triple P c Q
  -> (forall h v, Q h v -> Q' h v)
  -> hoare_triple P c Q'.
Proof.
  simplify; eapply HtConsequence; eauto.
Qed.

(* Finally, three tactic definitions that we won't explain.  The overall tactic
 * [ht] tries to prove Hoare triples, essentially by rote application of the
 * rules.  Some other obligations are generated, generally of implications
 * between assertions, and [ht] also makes a best effort to solve those. *)

Ltac ht1 :=
  match goal with
  | [  |- {{ _ }} _ {{ ?P }} ] =>
    tryif is_evar P then
      apply HtSkip || apply HtAssign || apply HtWrite || eapply HtSeq
      || eapply HtIf || eapply HtWhile || eapply HtAssert
    else
      eapply HtStrengthenPost
  end.

Ltac t := cbv beta; propositional; subst;
          repeat match goal with
                 | [ H : ex _ |- _ ] => invert H; propositional; subst
                 end;
          simplify;
          repeat match goal with
                 | [ _ : context[?a <=? ?b] |- _ ] => destruct (a <=? b); try discriminate
                 | [ H : ?E = ?E |- _ ] => clear H
                 end; simplify; propositional; auto; try equality; try linear_arithmetic.

Ltac ht := simplify; repeat ht1; t.

(** * Some examples of verified programs *)

(** ** Swapping the values in two variables *)

Theorem swap_ok : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    "tmp" <- "x";;
    "x" <- "y";;
    "y" <- "tmp"
  {{_&v ~> v $! "x" = b /\ v $! "y" = a}}.
Proof.
Admitted.

(** ** Computing the maximum of two variables *)

Theorem max_ok : forall a b,
  {{_&v ~> v $! "x" = a /\ v $! "y" = b}}
    when "x" < "y" then
      "m" <- "y"
    else
      "m" <- "x"
    done
  {{_&v ~> v $! "m" = max a b}}.
Proof.
Admitted.

(** ** Iterative factorial *)

Theorem fact_ok : forall n,
  {{_&v ~> v $! "n" = n}}
    "acc" <- 1;;
    {{_&v ~> True}}
    while 0 < "n" loop
      "acc" <- "acc" * "n";;
      "n" <- "n" - 1
    done
  {{_&v ~> v $! "acc" = fact n}}.
Proof.
Admitted.

(** ** Selection sort *)

(* This is our one example of a program reading/writing memory, which holds the
 * representation of an array that we want to sort in-place. *)

(* One simple lemma turns out to be helpful to guide [eauto] properly. *)
Lemma leq_f : forall A (m : fmap A nat) x y,
  x = y
  -> m $! x <= m $! y.
Proof.
  ht.
Qed.

Local Hint Resolve leq_f : core.
Local Hint Extern 1 (@eq nat _ _) => linear_arithmetic : core.
Local Hint Extern 1 (_ < _) => linear_arithmetic : core.
Local Hint Extern 1 (_ <= _) => linear_arithmetic : core.
(* We also register [linear_arithmetic] as a step to try during proof search. *)

Theorem selectionSort_ok :
  {{_&_ ~> True}}
    "i" <- 0;;
    {{h&v ~> True}}
    while "i" < "n" loop
      "j" <- "i"+1;;
      "best" <- "i";;
      {{h&v ~> True}}
      while "j" < "n" loop
        when *["a" + "j"] < *["a" + "best"] then
          "best" <- "j"
        else
          Skip
        done;;
        "j" <- "j" + 1
      done;;
      "tmp" <- *["a" + "best"];;
      *["a" + "best"] <- *["a" + "i"];;
      *["a" + "i"] <- "tmp";;
      "i" <- "i" + 1
    done
  {{h&v ~> forall i j, i < j < v $! "n" -> h $! (v $! "a" + i) <= h $! (v $! "a" + j)}}.
Proof.
Admitted.

(** * An alternative correctness theorem for Hoare logic, with small-step semantics *)

Inductive step : heap * valuation * cmd -> heap * valuation * cmd -> Prop :=
| StAssign : forall h v x e,
  step (h, v, Assign x e) (h, v $+ (x, eval e h v), Skip)
| StWrite : forall h v e1 e2,
  step (h, v, Write e1 e2) (h $+ (eval e1 h v, eval e2 h v), v, Skip)
| StStepSkip : forall h v c,
  step (h, v, Seq Skip c) (h, v, c)
| StStepRec : forall h1 v1 c1 h2 v2 c1' c2,
  step (h1, v1, c1) (h2, v2, c1')
  -> step (h1, v1, Seq c1 c2) (h2, v2, Seq c1' c2)
| StIfTrue : forall h v b c1 c2,
  beval b h v = true
  -> step (h, v, If_ b c1 c2) (h, v, c1)
| StIfFalse : forall h v b c1 c2,
  beval b h v = false
  -> step (h, v, If_ b c1 c2) (h, v, c2)
| StWhileFalse : forall I h v b c,
  beval b h v = false
  -> step (h, v, While_ I b c) (h, v, Skip)
| StWhileTrue : forall I h v b c,
  beval b h v = true
  -> step (h, v, While_ I b c) (h, v, Seq c (While_ I b c))
| StAssert : forall h v (a : assertion),
  a h v
  -> step (h, v, Assert a) (h, v, Skip).

Local Hint Constructors step : core.

Definition trsys_of (st : heap * valuation * cmd) := {|
  Initial := {st};
  Step := step
|}.

Definition unstuck (st : heap * valuation * cmd) :=
  snd st = Skip
  \/ exists st', step st st'.

Lemma hoare_triple_unstuck : forall P c Q,
  {{P}} c {{Q}}
  -> forall h v, P h v
                 -> unstuck (h, v, c).
Proof.
  induct 1; unfold unstuck; simplify; propositional; eauto.

  apply IHhoare_triple1 in H1.
  unfold unstuck in H1; simplify; first_order; subst; eauto.
  cases x.
  cases p.
  eauto.

  cases (beval b h v); eauto.

  cases (beval b h v); eauto.

  apply H0 in H2.
  apply IHhoare_triple in H2.
  unfold unstuck in H2; simplify; first_order.
Qed.

Lemma hoare_triple_Skip : forall P Q,
  {{P}} Skip {{Q}}
  -> forall h v, P h v -> Q h v.
Proof.
  induct 1; auto.
Qed.

Lemma hoare_triple_step : forall P c Q,
  {{P}} c {{Q}}
  -> forall h v h' v' c',
      step (h, v, c) (h', v', c')
      -> P h v
      -> {{h''&v'' ~> h'' = h' /\ v'' = v'}} c' {{Q}}.
Proof.
  induct 1.

  invert 1.

  invert 1; ht; eauto.

  invert 1; ht; eauto.

  invert 1; simplify.

  eapply HtConsequence; eauto.
  propositional; subst.
  eapply hoare_triple_Skip; eauto.

  econstructor; eauto.

  invert 1; simplify.
  eapply HtConsequence; eauto; equality.
  eapply HtConsequence; eauto; equality.

  invert 1; simplify.
  eapply HtConsequence with (P := h'' & v'' ~> h'' = h' /\ v'' = v').
  apply HtSkip.
  auto.
  simplify; propositional; subst; eauto.

  econstructor.
  eapply HtConsequence; eauto.
  simplify; propositional; subst; eauto.
  econstructor; eauto.

  invert 1; simplify.
  eapply HtConsequence; eauto.
  econstructor.
  simplify; propositional; subst; eauto.

  simplify.
  eapply HtConsequence.
  eapply IHhoare_triple; eauto.
  simplify; propositional; subst; eauto.
  auto.
Qed.

Theorem hoare_triple_invariant : forall P c Q h v,
  {{P}} c {{Q}}
  -> P h v
  -> invariantFor (trsys_of (h, v, c)) unstuck.
Proof.
  simplify.
  apply invariant_weaken with (invariant1 := fun st => {{h&v ~> h = fst (fst st)
                                                           /\ v = snd (fst st)}}
                                                         snd st
                                                       {{_&_ ~> True}}).

  apply invariant_induction; simplify.

  propositional; subst; simplify.
  eapply HtConsequence; eauto.
  equality.

  cases s.
  cases s'.
  cases p.
  cases p0.
  simplify.
  eapply hoare_triple_step; eauto.
  simplify; auto.

  simplify.
  cases s.
  cases p.
  simplify.
  eapply hoare_triple_unstuck; eauto.
  simplify; auto.
Qed.

(* A very simple example, just to show all this in action *)
Definition forever := (
  "i" <- 1;;
  "n" <- 1;;
  {{h&v ~> v $! "i" > 0}}
  while 0 < "i" loop
    "i" <- "i" * 2;;
    "n" <- "n" + "i";;
    assert {{h&v ~> v $! "n" >= 1}}
  done;;

  assert {{_&_ ~> False}}
  (* Note that this last assertion implies that the program never terminates! *)
)%cmd.

Theorem forever_ok : {{_&_ ~> True}} forever {{_&_ ~> False}}.
Proof.
  ht.
Qed.

Theorem forever_invariant : invariantFor (trsys_of ($0, $0, forever)) unstuck.
Proof.
  eapply hoare_triple_invariant.
  apply forever_ok.
  simplify; trivial.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf3 : natural) (lf2 : natural) (lf1 : natural) : natural :=
  plus lf3 lf2.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.

Section Exponentiation.

(* Why3 goal *)
Variable t : Type.
Hypothesis t_WhyType : WhyType t.
Existing Instance t_WhyType.

(* Why3 goal *)
Variable one: t.

(* Why3 goal *)
Variable infix_as: t -> t -> t.

(* Why3 goal *)
Hypothesis Assoc : forall (x:t) (y:t) (z:t), ((infix_as (infix_as x y)
  z) = (infix_as x (infix_as y z))).

(* Why3 goal *)
Hypothesis Unit_def_l : forall (x:t), ((infix_as one x) = x).

(* Why3 goal *)
Hypothesis Unit_def_r : forall (x:t), ((infix_as x one) = x).

(* Why3 goal *)
Hypothesis Comm : forall (x:t) (y:t), ((infix_as x y) = (infix_as y x)).

(* Why3 goal *)
Definition power: t -> Z -> t.
intros x n.
exact (iter_nat (Zabs_nat n) t (fun acc => infix_as x acc) one).
Defined.

(* Why3 goal *)
Lemma Power_0 : forall (x:t), ((power x 0%Z) = one).
Proof.
easy.
Qed.

(* Why3 goal *)
Lemma Power_s : forall (x:t) (n:Z), (0%Z <= n)%Z -> ((power x
  (n + 1%Z)%Z) = (infix_as x (power x n))).
Proof.
intros x n h1.
unfold power.
fold (Zsucc n).
now rewrite Zabs_nat_Zsucc.
Qed.

(* Why3 goal *)
Lemma Power_s_alt : forall (x:t) (n:Z), (0%Z < n)%Z -> ((power x
  n) = (infix_as x (power x (n - 1%Z)%Z))).
intros x n h1.
rewrite <- Power_s; auto with zarith.
f_equal; omega.
Qed.

(* Why3 goal *)
Lemma Power_1 : forall (x:t), ((power x 1%Z) = x).
Proof.
exact Unit_def_r.
Qed.

(* Why3 goal *)
Lemma Power_sum : forall (x:t) (n:Z) (m:Z), (0%Z <= n)%Z -> ((0%Z <= m)%Z ->
  ((power x (n + m)%Z) = (infix_as (power x n) (power x m)))).
Proof.
intros x n m Hn Hm.
revert n Hn.
apply natlike_ind.
apply sym_eq, Unit_def_l.
intros n Hn IHn.
replace (Zsucc n + m)%Z with ((n + m) + 1)%Z by ring.
rewrite Power_s by auto with zarith.
rewrite IHn.
now rewrite <- Assoc, <- Power_s.
Qed.

(* Why3 goal *)
Lemma Power_mult : forall (x:t) (n:Z) (m:Z), (0%Z <= n)%Z -> ((0%Z <= m)%Z ->
  ((power x (n * m)%Z) = (power (power x n) m))).
Proof.
intros x n m Hn Hm.
revert m Hm.
apply natlike_ind.
now rewrite Zmult_0_r, 2!Power_0.
intros m Hm IHm.
replace (n * Zsucc m)%Z with (n * m + n)%Z by ring.
rewrite Power_sum by auto with zarith.
rewrite IHm.
now rewrite Comm, <- Power_s.
Qed.

(* Why3 goal *)
Lemma Power_mult2 : forall (x:t) (y:t) (n:Z), (0%Z <= n)%Z ->
  ((power (infix_as x y) n) = (infix_as (power x n) (power y n))).
Proof.
intros x y.
apply natlike_ind.
apply sym_eq.
rewrite 3!Power_0.
apply Unit_def_r.
intros n Hn IHn.
unfold Zsucc.
rewrite 3!(Power_s _ _ Hn).
rewrite IHn.
now rewrite Assoc, <- (Assoc y), (Comm y), 2!Assoc.
Qed.

End Exponentiation.


Require Import Lists.List.

Fixpoint sum (xs : list nat) : nat :=
match xs with
|nil => 0
| x ::  xs => x + sum xs
end.

Theorem Pigeon_Hole_Principle:
forall (xs : list nat), length xs < sum xs -> (exists x, 1 < x /\ In x xs).
Proof.
intros.
induction xs.
contradict H.
simpl.
apply Lt.lt_irrefl.

Require Import Omega.
assert (a = 0 \/ a = 1 \/ a > 1).
omega.
destruct H0.
destruct IHxs.
replace (sum xs) with (sum (a :: xs)).
apply (Lt.le_lt_trans (length xs) (length (a :: xs)) (sum (a::xs))).
simpl.
apply (Le.le_n_Sn (length xs)).
apply H.
simpl.
replace a with 0.
reflexivity.
exists x.
split.
apply H1.
simpl.
right.
apply H1.
destruct H0.
destruct IHxs.
apply (plus_lt_reg_l (length xs) (sum xs) a).
apply (NPeano.Nat.lt_stepl (length (a :: xs)) (sum (a :: xs)) (a + length xs)).
apply H.
simpl.
replace a with 1.
reflexivity.
exists x.
split.
apply H1.
simpl.
right.
apply H1.
exists a.
split.
apply H0.
simpl.
left.
reflexivity.
Qed.


Require Import List.

Inductive last {A:Type} : A -> list A -> Prop :=
  | last1 : forall a:A, last a (cons a nil)
  | last2 : forall (a x:A)(l:list A), last a l -> last a (cons x l).

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

Lemma last_a_l_not_nil : forall (A:Type)(a:A)(l:list A),
  last a l -> l <> nil.
Proof.
  intros A a l p. generalize p. elim p. intros b H. clear H.
  intro H. apply nil_cons with (x:=b)(l:=nil). auto.
  intros b x l' q H0 H1. clear H0 H1 q b p l a. intro H.
  apply nil_cons with (x:=x)(l:=l'). auto.
Qed.

Lemma not_last_a_nil: forall (A:Type)(a:A),
  ~last a nil.
Proof.
  intros A a H. apply last_a_l_not_nil with (l:=nil)(a:=a).
  exact H. reflexivity.
Qed.

Lemma last_coherence : forall (A:Type)(l:list A)(a:A),
  last a l <-> last_fun l = Some a.
Proof.
  (* -> *)
  intros A l a. split. intro p. generalize p. elim p.
  intros b H0. clear H0. simpl. reflexivity.
  intros b x m. case m. intro H. apply False_ind.
  apply not_last_a_nil with (a:=b). exact H.
  intros c l' H H' H''. simpl. apply H'. exact H.
  (* <- *)
  elim l. simpl. intro H. discriminate H.
  clear l. intros b l. case l. simpl. intros H H'.
  cut(a = b). intro H''. rewrite <- H''. apply last1.
  pose (g:= fun x =>  match x with | None    => a | Some c  => c end).
  change (g (Some a) = g (Some b)). rewrite H'. reflexivity.
  clear l. intros c l H H'. apply last2. apply H. rewrite <- H'.
  simpl. reflexivity.
Qed.

(* last_with_rest a l l' expresses the fact that l = l' ++ [a]
** i.e. that a is the last element of l, and l' is what remains of
** the list after removing the last element 'a'                    *)
Inductive last_with_rest {A:Type} : A -> list A -> list A -> Prop :=
  | last_with_rest1 : forall a:A, last_with_rest a (cons a nil) nil
  | last_with_rest2 : forall (a b:A)(l m:list A),
      last_with_rest a l m -> last_with_rest a (cons b l) (cons b m).

Inductive palindrome {A:Type} : list A -> Prop :=
  | palindrome_nil    : palindrome nil
  | palindrome_single : forall (a:A), palindrome (cons a nil)
  | palindrome_a      : forall (a:A)(l m:list A),
      last_with_rest a l m -> palindrome m -> palindrome (cons a l).

Definition pal_example1 := 1::2::3::4::5::4::3::2::1::nil.
Definition pal_example2 := 1::2::2::1::nil.
Definition pal_example3 := 1::2::nil. (* not a palindrome *)

Lemma palindrome_example2: palindrome pal_example2.
Proof.
  unfold pal_example2. apply palindrome_a with (a:=1)(m:= 2::2::nil).
  repeat apply last_with_rest2. apply last_with_rest1.
  apply palindrome_a with (m:=nil). apply last_with_rest1. apply palindrome_nil.
Qed.

Lemma palindrome_example1: palindrome pal_example1.
Proof.
  unfold pal_example1.
  apply palindrome_a with (m:= 2::3::4::5::4::3::2::nil).
  repeat apply last_with_rest2. apply last_with_rest1.
  apply palindrome_a with (m:= 3::4::5::4::3::nil).
  repeat apply last_with_rest2. apply last_with_rest1.
  apply palindrome_a with (m:= 4::5::4::nil).
  repeat apply last_with_rest2. apply last_with_rest1.
  apply palindrome_a with (m:= 5::nil).
  repeat apply last_with_rest2. apply last_with_rest1.
  apply palindrome_single.
Qed.

Lemma last_with_rest_last: forall (A:Type)(a:A)(l m:list A),
  last_with_rest a l m -> last a l.
Proof.
  intros A a l m H. generalize H. elim H. clear H a m l.
  intros a H. apply last1. clear H m l a. intros a b l m.
  intros H0 H1 H2. apply last2, H1, H0.
Qed.

Lemma last_single: forall (A:Type)(a b:A),
  last a (b::nil) -> a = b.
Proof.
  intros A a b H. rewrite last_coherence in H. simpl in H.
  pose (g:= fun opt => match opt with | None => a | Some x => x end).
  fold (g (Some b)). rewrite H. simpl. reflexivity.
Qed.

Lemma last_unique: forall (A:Type)(a b:A)(l:list A),
  last a l -> last b l -> a = b.
Proof.
  intros A a b l Ha Hb.
  rewrite last_coherence in Ha. rewrite last_coherence in Hb.
  rewrite Ha in Hb.
  pose (g:= fun opt => match opt with | None => a | Some x => x end).
  fold (g (Some b)). rewrite <- Hb. simpl. reflexivity. (* fold trick *)
Qed.

Lemma palindrome_law : forall (A:Type) (a b:A)(l m:list A),
  palindrome l -> l = cons a m-> last b m -> a = b.
Proof.
  intros A a b l m H. generalize H. generalize a b m.
  clear a b m. elim H. intros a b m H0 H1. discriminate H1.
  intros a x b m H0 H1 H2. fold(tl (x::m)) in H2. rewrite <- H1 in H2.
  simpl in H2. apply False_ind. apply not_last_a_nil with (a:=b).
  exact H2. clear H l. intros a l m. intros H0 H1 IH x b l' H2 H3 H4.
  rewrite H3 in H2. cut(last a l). cut (last b l). cut (x = a).
  intros H Hb Ha. rewrite H. apply last_unique with (l:=l).
  exact Ha. exact Hb.
  pose (g:= fun l => match l with | nil => x | (y::l') => y end).
  fold(g (x::l')). rewrite <- H3. simpl. reflexivity.   (* fold trick *)
  fold (tl(a::l)). rewrite H3. simpl. exact H4.         (* fold trick *)
  apply last_with_rest_last with (m:=m). apply H0.
Qed.

Lemma palindrome_example3: ~palindrome pal_example3.
Proof.
  unfold pal_example3. intro pal. cut(1 = 2). intro H.
  discriminate H. apply palindrome_law with (l:= 1::2::nil)(m:=2::nil).
  exact pal. reflexivity. apply last1.
Qed.