From LF Require Export Basics.

Theorem add_0_r: forall n : nat,
    n + 0 = n.
Proof.
    intros n. induction n as [| n' IHn'].
    - reflexivity.
    - simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem minus_n_n: forall n : nat,
    n - n = 0.
Proof.
    intros n. induction n as [|n' IHn'].
    - simpl. reflexivity.
    - simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem mul_0_r : forall n:nat,
    n * 0 = 0.
Proof.
    intros n. induction n as [| n' IHn'].
    - simpl. reflexivity.
    - simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem plus_n_Sm : forall n m : nat,
    S (n + m) = n + (S m).
Proof.
    intros n m. induction n as [| n' IHn'].
    - simpl. reflexivity.
    - simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem add_comm : forall n m : nat,
    n + m = m + n.
Proof.
    intros n m. induction n as [| n' IHn'].
    - simpl. rewrite -> add_0_r. reflexivity.
    - simpl. rewrite -> IHn'. rewrite -> plus_n_Sm. reflexivity.
Qed.

Theorem add_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
    intros n m p. induction n as [| n' IHn'].
    - reflexivity.
    - simpl. rewrite -> IHn'. reflexivity.
Qed.

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

Lemma double_plus: forall n,
    double n = n + n.
Proof.
    intros n. induction n as [| n' IHn'].
    - reflexivity.
    - simpl. rewrite <- plus_n_Sm. rewrite -> IHn'. reflexivity.
Qed.

Theorem even_S: forall n : nat,
    even (S n) = negb (even n).
Proof.
    intros n. induction n as [| n' IHn'].
    - reflexivity.
    - rewrite -> IHn'. rewrite -> negb_involutive. reflexivity.
Qed.

Theorem add_shuffle3: forall n m p : nat, n + (m + p) = m + (n + p).
Proof.
    intros n m p.
    rewrite -> add_assoc.
    rewrite -> add_assoc.
    assert (H: n + m = m + n). {
        rewrite -> add_comm.
        reflexivity.
    }
    rewrite -> H.
    reflexivity.
Qed.

Theorem S_add: forall n m : nat,
    n = m -> S n = S m.
Proof.
    intros n m. induction n as [| n IHn'].
    - intros H. rewrite <- H. reflexivity.
    - intros H. rewrite -> H. reflexivity.
Qed.

Theorem mul_n_Sm: forall n m : nat,
    n + n * m = n * (S m).
Proof.
    intros n m. induction n as [| n' IHn'].
    - reflexivity.
    - simpl. rewrite -> add_shuffle3. rewrite -> IHn'. reflexivity.
Qed.

Theorem mul_comm : forall m n : nat,
    m * n = n * m.
Proof.
    intros m n. induction m as [| m' IHm'].
    - rewrite -> mul_0_r. reflexivity.
    - simpl.
        rewrite -> IHm'.
        rewrite -> mul_n_Sm.
        reflexivity.
Qed.

(* Exercise: 2 stars, standard, optional (eqb_refl) *)
Theorem eqb_refl : forall n : nat,
    (n =? n) = true.
Proof.
    intros n. induction n as [|n' IHn'].
    - reflexivity.
    - simpl. rewrite IHn'. reflexivity.
Qed.

Theorem add_shuffle3': forall n m p : nat,
    n + (m + p) = m + (n + p).
Proof.
    intros n m p.
    rewrite -> add_assoc.
    rewrite -> add_assoc.
    replace (n + m) with (m + n).
    - reflexivity.
    - rewrite -> add_comm. reflexivity.
Qed.

Theorem bin_to_nat_pres_incr: forall b : bin,
    bin_to_nat (incr b) = S (bin_to_nat b).
Proof.
    intros b. induction b as [| b0 IHb0| b1 IHb1].
    - reflexivity.
    - simpl. reflexivity.
    - simpl.
        rewrite -> IHb1.
        rewrite -> add_0_r.
        rewrite -> add_0_r.
        rewrite <- plus_1_l.
        rewrite -> add_shuffle3.
        reflexivity.
Qed.

Fixpoint nat_to_bin (n : nat) : bin :=
    match n with
    | 0 => Z
    | S n' => incr (nat_to_bin n')
    end.

Theorem nat_bin_nat: forall n : nat,
    bin_to_nat (nat_to_bin n) = n.
Proof.
    intros n. induction n as [| n' IHn'].
    - reflexivity.
    - simpl.
        rewrite -> bin_to_nat_pres_incr.
        rewrite -> IHn'.
        reflexivity.
Qed.

(* No idea what is going on here. :(

Theorem bin_nat_bin: forall b : bin,
    nat_to_bin (bin_to_nat b) = b.
Proof.
    intros b. induction b as [| b0 IHb0 | b1 IHb1].
    - reflexivity.
    - simpl. rewrite -> add_0_r.
Qed.

Fixpoint normalize (b : bin) : bin :=
    match b with
    | Z => .
*)


From mathcomp
 Require Import ssreflect.

Section ModusPonens.
Variable X Y : Prop.

Hypothesis XtoY_is_true : X -> Y.
Hypothesis X_is_true : X.

Theorem MP : Y.
Proof.

move: X_is_true.
by [].
Qed.

End ModusPonens.

Section HilbertSAxiom.
Variables A B C : Prop.

Theorem HS1 : (A -> (B -> C)) -> ((A -> B) -> (A -> C)).
Proof.
move=> AtoBtoC_is_true.
move=> AtoB_is_true.
move=> A_is_true.

apply: (MP B C).

apply: (MP A (B -> C)).
by [].
by [].

apply: (MP A B).
by [].
by [].
Qed.

End HilbertSAxiom.


Require Export Relations.

(*
Inductive nat : Set :=
  | zero : nat
  | succ : nat -> nat.
*)

Inductive succR : nat -> nat -> Prop :=
  | s1 : (forall a b : nat, S a = b -> succR a b).

Inductive immediatePredR : nat -> nat -> Prop :=
  | p0 : (forall a b, succR a b -> immediatePredR b a)
  | pi : (forall a b, forall c, immediatePredR b c -> succR a c
                                -> immediatePredR b a).

Example ex1 : immediatePredR 5 3.
Proof.
  apply pi with (c:=4).
  apply p0.
  apply s1.
  reflexivity.
  apply s1.
  reflexivity.
Qed.

(* Peano's Axioms *)

Theorem thm3 : forall a b, S a = S b -> a = b.
Proof.
  intros.
  inversion H.
  reflexivity.
Qed.

Theorem thm4 : forall a, ~(S a = 0).
Proof.
  intros. intro.
  inversion H.
Qed.

Theorem thm5 : forall (p : nat -> Prop), p 0
                                         -> (forall n, p n -> p (S n))
                                         -> (forall n, p n).
Proof.
  intros.
  induction n.
  (* n = 0 *)
  assumption.
  (* n = S n *)
  apply H0.
  assumption.
Qed.
(* Prooving inductivity with inductive assumption is actually meaningless.
   So they're just demonstrations *)

(* page 25:
A property is called “R-hereditary” when, if it belongs to a term x, and x
has the relation R to y, then it belongs to y.
*)
Definition r_hereditary {X} (R : relation X) (p : X -> Prop) : Prop :=
  forall x y, p x -> R x y -> p y.

(*
A term x is said to be an “R-ancestor” of the term y if y has every
R-hereditary property that x has, provided x is a term which has the
relation R to something or to which something has the relation R.
(This is only to exclude trivial cases.)
*)

Definition r_ancestor {X} (R : relation X) (x : X) (y : X) :=
  forall (p : X -> Prop), r_hereditary R p -> p x -> p y.

(* My own understandings *)
Example __ex1 : r_hereditary lt (fun x => x > 0).
Proof.
  unfold r_hereditary.
  unfold lt.
  intros.
  induction H0.
  induction H. constructor. constructor.
  constructor. apply IHle.
  constructor. apply IHle.
Qed.

Example __ex2 : r_ancestor lt 3 5.
Proof.
  unfold r_ancestor.
  unfold r_hereditary.
  intros.
  apply H with 3.
  assumption. auto.
Qed.

(* page 26:
The “R-posterity” of x is all the terms of which x is an R-ancestor.
*)

Definition r_posterity {X} (R : relation X) (x : X) (y : X) := r_ancestor R y x.


Require Import ZArith List.
Require Import Lia.
Open Scope Z_scope.
Open Scope list_scope.

Inductive ext_Z :Type :=
  cZ : Z -> ext_Z | minfty : ext_Z | pinfty : ext_Z.

Definition bot := (minfty, pinfty).
Definition comp_add (x y:ext_Z) : ext_Z :=
  match x,y with
    minfty, _ => minfty
  | _, minfty => minfty
  | pinfty, _ => pinfty
  | _, pinfty => pinfty
  | cZ x, cZ y => cZ(x+y)
  end.

Definition plus (i1 i2:ext_Z*ext_Z) : ext_Z*ext_Z :=
  let (l1,u1) := i1 in  let (l2,u2) := i2 in (comp_add l1 l2, comp_add u1 u2).

Definition of_int (x:Z) := (cZ x, cZ x).

(* compute the minimum of two ext_Z *)
Definition cp_min (n1 n2:ext_Z) : ext_Z :=
  match n1, n2 with
    minfty, a => minfty
  | cZ n1, cZ n2 => cZ (Z.min n1 n2)
  | _, minfty => minfty
  | a, pinfty => a
  | pinfty, a => a
  end.

(* compute the maximum of two ext_Z *)
Definition cp_max (n1 n2:ext_Z) : ext_Z :=
  match n1, n2 with
    minfty, a => a
  | cZ n1, cZ n2 => cZ (Z.max n1 n2)
  | a, minfty => a
  | pinfty, _ => pinfty
  | a, pinfty => pinfty
  end.

Lemma Zle_to_Zmin : forall n m, n <= m -> Z.min n m = n.
intros n n'; unfold Z.min, Z.le.
case (n?=n'); intuition.
Qed.

Lemma Zle_to_Zmax : forall n m, m <= n -> Z.max n m = n.
intros n n'; unfold Z.max.
intros Hle; cut (n >= n').
unfold Z.ge.
case_eq (n ?= n'); intros Heq H; try (elim H; auto; fail).
rewrite Zcompare_Eq_eq with (1:=Heq); auto.
auto.
lia.
Qed.

Lemma cp_min_assoc :
  forall a b c, cp_min (cp_min a b) c = cp_min a (cp_min b c).
intros [a | | ]; simpl; auto; intros [b | |]; simpl; auto; intros [c| |]; simpl; auto.
rewrite Z.min_assoc; auto.
Qed.

Lemma cp_max_assoc :
  forall a b c, cp_max (cp_max a b) c = cp_max a (cp_max b c).
intros [a | | ]; simpl; auto; intros [b | |]; simpl; auto; intros [c| |]; simpl; auto.
rewrite Z.max_assoc; auto.
Qed.

Lemma cp_max_r_cp_min_l :
  forall a b, cp_max a b = b -> cp_min a b = a.
intros [a | | ][b | | ]; simpl; auto.
intros H; injection H; intros H1.
assert (a <= b) by (rewrite <- H1; apply Z.le_max_l).
rewrite Zle_to_Zmin; auto.
Qed.

Lemma cp_min_r_cp_max_l :
  forall a b, cp_min a b = b -> cp_max a b = a.
intros [a | | ][b | | ]; simpl; auto.
intros H; injection H; intros H1.
assert (b <= a) by (rewrite <- H1; apply Z.le_min_l).
rewrite Zle_to_Zmax; auto.
Qed.

Definition join (i1 i2:ext_Z*ext_Z) : ext_Z*ext_Z :=
  let (l1, u1):= i1 in let (l2, u2) := i2 in (cp_min l1 l2, cp_max u1 u2).

Definition ext_eq : forall a b:ext_Z, {a=b}+{a<>b}.
intros a b; destruct a as [na | | ]; destruct b as [nb | | ];
try (left; apply refl_equal); try (right; discriminate).
case (Z.eq_dec na nb); intros Heq; (left; rewrite Heq; apply refl_equal) ||
 (right; intros H'; elim Heq; injection H'; auto).
Defined.

Definition add_test_constraint_right (d:bool) (i j:ext_Z*ext_Z) : option (ext_Z*ext_Z) :=
  let (bi, ui):=i in let (bj, uj):=j in
  (if d then
    let ujm1 := comp_add uj (cZ (-1)) in
    if ext_eq bi (cp_max bi uj) then None
    else Some (bi, cp_min ui ujm1)
  else
    let v := cp_max ui bj in
    if ext_eq bj v then
      if ext_eq ui v then Some(cp_max bi bj,ui)
      else None
    else Some (cp_max bi bj, ui)).

Definition add_test_constraint_left (d:bool) (i j:ext_Z*ext_Z) : option (ext_Z*ext_Z) :=
  let (bi, ui):=i in let (bj, uj):=j in
  (if d then
    let bip1 := comp_add bi (cZ 1) in
    if ext_eq uj (cp_min bi uj) then None
    else Some (cp_max bip1 bj, uj)
  else
    let v := cp_max ui bj in
    if ext_eq bj v then
      if ext_eq ui v then Some(bj,cp_min ui uj)
      else None
    else Some (bj, cp_min ui uj)).

Definition widen (i j:ext_Z*ext_Z) :=
  let (bi, ui) := i in let (bj, uj) := j in
  let b :=
    if ext_eq (cp_min bi bj) bi then bi
    else minfty in
  let u :=
    if ext_eq (cp_max ui uj) ui then ui
    else pinfty in
    (b,u).

Definition eq (i j:ext_Z*ext_Z) : bool :=
  let (bi,ui) := i in let (bj,uj) := j in
  if ext_eq bi bj then if ext_eq ui uj then true else false else false.

Definition thinner (i j : ext_Z*ext_Z) : Prop :=
   let (bi,ui) := i in let (bj,uj) := j in
   cp_min bi bj = bj /\ cp_max ui uj = uj.

Lemma cp_min_comm : forall i j, cp_min i j = cp_min j i.
intros [ni | | ] [nj | | ];simpl; auto.
rewrite Z.min_comm; auto.
Qed.

Lemma cp_max_comm :
   forall x y, cp_max x y = cp_max y x.
Proof.
intros [x | | ] [y | | ]; simpl; auto.
rewrite Z.max_comm; auto.
Qed.

Lemma thinner_refl : forall v, thinner v v.
intros [[b | | ] [u| |]]; simpl; auto;
  try rewrite Zmax_idempotent; try rewrite Zmin_idempotent; auto.
Qed.

Lemma cp_min_trans :
  forall x y z, cp_min x y = x -> cp_min y z = y -> cp_min x z = x.
intros [x | | ] [y| |]; try (simpl; intros; discriminate);
intros [z | | ]; try(simpl; intros; discriminate); simpl; auto.
intros H1 H2; injection H1; injection H2; intros H3 H4.
rewrite Zle_to_Zmin; auto.
apply Z.le_trans with y.
rewrite <-H4; auto with zarith.
rewrite <- H3; auto with zarith.
Qed.

Lemma cp_max_trans :
  forall x y z, cp_max x y = x -> cp_max y z = y -> cp_max x z = x.
intros [x | | ] [y| |]; try (simpl; intros; discriminate);
intros [z | | ]; try(simpl; intros; discriminate); simpl; auto.
intros H1 H2; injection H1; injection H2; intros H3 H4.
rewrite Zle_to_Zmax; auto.
apply Z.le_trans with y.
rewrite <- H3; apply Z.le_max_r.
rewrite <-H4; apply Z.le_max_r.
Qed.

Lemma thinner_trans : forall v1 v2 v3, thinner v1 v2 ->
 thinner v2 v3 -> thinner v1 v3.
unfold thinner; intros [b1 u1] [b2 u2] [b3 u3] [H1 H2] [H3 H4].
split.
rewrite cp_min_comm; apply cp_min_trans with b2; rewrite cp_min_comm; auto.
rewrite cp_max_comm; apply cp_max_trans with u2; rewrite cp_max_comm; auto.
Qed.

Lemma thinner_bot : forall v, thinner v bot.
unfold bot; intros [[a | | ][b | | ]]; unfold thinner; simpl; auto.
Qed.

Lemma cp_min_plus :
  forall x y z t,
    cp_min x y = x -> cp_min z t = z ->
    cp_min (comp_add x z)(comp_add y t)= comp_add x z.
intros [x | | ] [y | | ];simpl;try (intros;discriminate);
intros [z | | ] [t' | | ];simpl; try (intros; discriminate); auto.
intros H1 H2; injection H1; injection H2; intros H4 H3.
apply f_equal with (f:=cZ); apply Zle_to_Zmin.
apply Z.le_trans with (x + t').
apply Zplus_le_compat_l; rewrite <- H4; apply Z.le_min_r.
apply Zplus_le_compat_r; rewrite <- H3; apply Z.le_min_r.
Qed.

Lemma cp_max_plus :
  forall x y z t,
    cp_max x y = x -> cp_max z t = z ->
    cp_max (comp_add x z)(comp_add y t)= comp_add x z.
intros [x | | ] [y | | ];simpl;try (intros;discriminate);
intros [z | | ] [t' | | ];simpl; try (intros; discriminate); auto.
intros H1 H2; injection H1; injection H2; intros H4 H3.
apply f_equal with (f:=cZ); apply Zle_to_Zmax.
apply Z.le_trans with (x + t').
apply Zplus_le_compat_r; rewrite <- H3; apply Z.le_max_r.
apply Zplus_le_compat_l; rewrite <- H4; apply Z.le_max_r.
Qed.

Lemma thinner_plus :
   forall x y z t, thinner x y -> thinner z t ->
     thinner (plus x z)(plus y t).
intros [lx ux] [ly uy] [lz uz] [lt' ut] [H1 H2][H3 H4]; split; simpl.
rewrite cp_min_comm; apply cp_min_plus; rewrite cp_min_comm; auto.
rewrite cp_max_comm; apply cp_max_plus; rewrite cp_max_comm; auto.
Qed.

Lemma cp_max_refl : forall x, cp_max x x = x.
intros [x | | ]; simpl; unfold Z.max; auto.
rewrite Z.compare_refl; auto.
Qed.

Lemma cp_min_refl : forall x, cp_min x x = x.
intros [x | | ]; simpl; unfold Z.min; auto.
rewrite Z.compare_refl; auto.
Qed.

Lemma eq_sound : forall x y, eq x y = true -> x = y.
intros [b1 u1][b2 u2]; unfold eq; case (ext_eq b1 b2); case (ext_eq u1 u2);
 try (intros; discriminate).
intros; subst; auto.
Qed.

Lemma eq_complete : forall x, eq x x = true.
intros [[l | |][u| |]]; simpl; auto;
try case (Z.eq_dec l l); try case (Z.eq_dec u u); intros; auto;
try match goal with id :~_ |- _ => case id; apply refl_equal end.
Qed.

Lemma join_bot : forall i, join i bot = bot.
intros [[b | |]  [u | | ]]; unfold bot; simpl; auto.
Qed.

Lemma thinner_join :
  forall e1 e2 e3 e4, thinner e1 e2 -> thinner e3 e4 ->
  thinner (join e1 e3)(join e2 e4).
intros [l1 u1] [l2 u2] [l3 u3][l4 u4]; unfold thinner; simpl;
 intros [H1 H2][H3 H4]; unfold join; split; simpl.
destruct l1 as [l1 | | ]; destruct  l2 as [l2 | | ];
 simpl in H1, H2, H3, H4 |- *; try discriminate; auto;
destruct l3 as [l3 | | ]; simpl in H1, H2, H3, H4 |- *; try discriminate; auto;
destruct l4 as [l4 | | ]; simpl in H1, H2, H3, H4 |- *; try discriminate; auto.
rewrite Z.min_assoc; rewrite <- (Z.min_assoc l1 l3 l2); rewrite (Z.min_comm l3 l2).
injection H1; injection H3; clear H1 H3; intros H3 H1.
rewrite Z.min_assoc; rewrite H1; rewrite <- Z.min_assoc; rewrite H3; auto.
injection H1; clear H1; intros H1; rewrite Z.min_assoc; rewrite H1; auto.
injection H3; clear H3; intros H3; rewrite Z.min_assoc; rewrite (Z.min_comm l3).
rewrite <- Z.min_assoc; rewrite H3; auto.

destruct u1 as [u1 | | ]; destruct  u2 as [u2 | | ];
 simpl in H1, H2, H3, H4 |- *; try discriminate; auto;
destruct u3 as [u3 | | ]; simpl in H1, H2, H3, H4 |- *; try discriminate; auto;
destruct u4 as [u4 | | ]; simpl in H1, H2, H3, H4 |- *; try discriminate; auto.
injection H2; injection H4; clear H2 H4; intros H4 H2.
rewrite Z.max_assoc; rewrite <- (Z.max_assoc u1); rewrite (Z.max_comm u3).
rewrite Z.max_assoc; rewrite H2; rewrite <- Z.max_assoc; rewrite H4; auto.
injection H2; clear H2; intros H2; rewrite Z.max_assoc; rewrite H2; auto.
injection H4; clear H4; intros H4; rewrite Z.max_assoc; rewrite (Z.max_comm u3).
rewrite <- Z.max_assoc; rewrite H4; auto.
Qed.

Lemma thinner_join_left :  forall i i', thinner i (join i i').
intros [b1 u1] [b2 u2]; split.
destruct b1 as [l | | ]; destruct b2 as [l' | | ]; simpl; auto.
rewrite Z.min_assoc; rewrite Zmin_idempotent; auto.
rewrite Zmin_idempotent; auto.
destruct u1 as [l | | ]; destruct u2 as [l' | | ]; simpl; auto.
rewrite Z.max_assoc; rewrite Zmax_idempotent; auto.
rewrite Zmax_idempotent; auto.
Qed.

Lemma join_comm : forall i i', join i i' = join i' i.
intros [u l] [u' l']; unfold join.
 rewrite cp_min_comm; rewrite cp_max_comm; auto.
Qed.

Lemma join_assoc : forall i i' i'', join (join i i') i'' = join i (join i' i'').
intros [l u][l' u'][l'' u'']; unfold join; rewrite cp_min_assoc; rewrite cp_max_assoc.
auto.
Qed.

Lemma join_involutive : forall i, join i i = i.
intros [l u]; unfold join; rewrite cp_min_refl; rewrite cp_max_refl; auto.
Qed.

Ltac Zmin_max_to_le :=
 match goal with id : cZ (Z.min ?a ?b) = cZ ?a |- _ =>
  assert (Dummy := id); clear id;
  assert (id : a <= b) by
    (injection Dummy; clear Dummy; intros Dummy; rewrite <- Dummy;
     apply Z.le_min_r); clear Dummy
| id : cZ (Z.min ?a ?b) = cZ ?b |- _ =>
  assert (Dummy:= id); clear id;
  assert (id : b <= a) by
    (injection Dummy; clear Dummy; intros Dummy; rewrite <- Dummy;
        apply Z.le_min_l); clear Dummy
| id : cZ (Z.max ?a ?b) = cZ ?a |- _ =>
  assert (Dummy := id); clear id;
  assert (id : b <= a) by
    (injection Dummy; clear Dummy; intros Dummy; rewrite <- Dummy;
     apply Z.le_max_r); clear Dummy
| id : cZ (Z.max ?a ?b) = cZ ?b |- _ =>
  assert (Dummy:= id); clear id;
  assert (id : a <= b) by
    (injection Dummy; clear Dummy; intros Dummy; rewrite <- Dummy;
        apply Z.le_max_l); clear Dummy
 end.

Ltac cp_max_min_diff :=
  match goal with
  | id : cZ ?a <> cp_max (cZ ?a) (cZ ?b) |- _ =>
    assert (Dummy:=id); clear id ;
    assert (id : a <> b) by
      (intros Dummy';case Dummy; rewrite Dummy'; rewrite cp_max_refl; auto);
    clear Dummy
  | id : cZ ?a <> cp_max (cZ ?b) (cZ ?a) |- _ =>
    assert (Dummy:=id); clear id;
    assert (id : a <> b) by
      (intros Dummy';case Dummy; rewrite Dummy'; rewrite cp_max_refl; auto)
  | id : cZ ?a <> cp_min ?a ?b |- _ =>
    assert (Dummy:=id); clear id;
    assert (id : a <> b) by
      (intros Dummy';case Dummy; rewrite Dummy'; rewrite cp_min_refl; auto)
  | id : cZ ?a <> cp_min (cZ ?b) (cZ ?a) |- _ =>
    assert (Dummy:=id); clear id;
    assert (id : a <> b) by
      (intros Dummy';case Dummy; rewrite Dummy'; rewrite cp_min_refl; auto)
  end.

Lemma Zmax_le_compat :
  forall a b c d, a <= b -> c <= d -> Z.max a c <= Z.max b d.
intros; apply Z.max_lub.
apply Z.le_trans with b; auto; apply Z.le_max_l.
apply Z.le_trans with d; auto; apply Z.le_max_r.
Qed.

Lemma Zmin_le_compat :
  forall a b c d, a <= b -> c <= d -> Z.min a c <= Z.min b d.
intros; apply Z.min_glb.
apply Z.le_trans with a; auto; apply Z.le_min_l.
apply Z.le_trans with c; auto; apply Z.le_min_r.
Qed.

Lemma thinner_widen : forall v1 v2, thinner v1 (widen v1 v2).
intros [[l1 | | ][u1 | | ]]
  [[l2 | | ][u2 | | ]]; try (unfold thinner, widen; intuition; fail);
match goal with |- thinner (?x, ?y) (widen _ (?z, ?t)) =>
  unfold thinner, widen;
  case (ext_eq (cp_min x z) x);case (ext_eq (cp_max y t) y);
  try rewrite cp_max_refl; try rewrite cp_min_refl; try (intuition; fail)
end.
Qed.

Definition to_p (v:ext_Z*ext_Z)(x:Z) : Prop :=
  match v with
    (minfty,pinfty) => True
  | (minfty,cZ u) => x <= u
  | (cZ l, cZ u) => l <= x <= u
  | (cZ l, pinfty) => l <= x
  | _ => False
  end.

Lemma to_p_thinner : forall l u x, to_p (l,u) x ->
    thinner (l, cZ x) (l, u)/\ thinner (cZ x, u)(l,u).
intros [l | |] [u | |] x ;unfold to_p, thinner; simpl; try(intuition;fail);
repeat rewrite Zmin_idempotent; repeat rewrite Zmax_idempotent.
intros; rewrite Z.max_comm; rewrite Zle_to_Zmax; try lia;
 rewrite Z.min_comm; rewrite Zle_to_Zmin; auto; lia.
intros; rewrite Z.min_comm; rewrite Zle_to_Zmin; auto.
intros; rewrite Z.max_comm; rewrite Zle_to_Zmax; auto.
Qed.

Lemma plus_correct :
  forall i1 i2 x1 x2, to_p i1 x1 -> to_p i2 x2 -> to_p (plus i1 i2) (x1+x2).
Proof.
intros i1 i2 x1 x2 H1 H2.
destruct i1 as [[l1 | | ][u1 | | ]]; generalize H1; simpl;
 clear H1; intros H1; contradiction || auto;
destruct i2 as [[l2 | | ][u2 | | ]]; generalize H2; simpl;
 intros; contradiction || auto; try lia.
Qed.

Lemma of_int_correct : forall n, to_p (of_int n) n.
intros; simpl; auto with zarith.
Qed.

Lemma to_p_cp_max_min :
   forall l u x, to_p (l,u) x -> cp_max l (cZ x) = cZ x /\
                  cp_min (cZ x) u = cZ x.
intros [l | | ][u | | ]; unfold to_p; simpl; try(intuition; fail).
intros; rewrite Z.max_comm; rewrite Zle_to_Zmax;try rewrite Zle_to_Zmin;
 intuition.
intros; rewrite Z.max_comm; rewrite Zle_to_Zmax; intuition.
intros; rewrite Zle_to_Zmin; intuition.
Qed.

Lemma cp_max_min_to_p :
  forall l u x, cp_max l (cZ x) = cZ x -> cp_min (cZ x) u = cZ x-> to_p (l,u) x.
intros [l | | ][u | | ]; unfold to_p; simpl; try(intros; auto; discriminate).
intros x H1 H2; injection H1; injection H2; intros H3 H4;split;
 [rewrite <- H4; apply Z.le_max_l | rewrite <- H3; apply Z.le_min_r].
intros x H1 _ ; injection H1; intros H3;rewrite <- H3; apply Z.le_max_l.
intros x _ H1; injection H1; intros H3; rewrite <- H3; apply Z.le_min_r.
Qed.

Lemma thinner_prop :
  forall i1 i2 x, thinner i1 i2 -> to_p i1 x -> to_p i2 x.
intros [l1 u1][l2 u2] x [H1 H2] H3.
destruct (to_p_cp_max_min _ _ _ H3).
apply cp_max_min_to_p.
rewrite cp_max_comm; apply cp_max_trans with l1.
rewrite cp_max_comm; auto.
apply cp_min_r_cp_max_l; auto.
apply cp_min_trans with u1; auto.
apply cp_max_r_cp_min_l; auto.
Qed.

Lemma bot_semantics : forall x, to_p bot x.
simpl; intuition.
Qed.

Lemma add_test_constraint_right_true_none :
   forall v1 v2, add_test_constraint_right true v1 v2 = None ->
     forall x1 x2, to_p v1 x1 ->
     to_p v2 x2 -> ~x1 < x2.
Proof.
intros [b1 u1] [b2 u2]; unfold add_test_constraint_right.
case (ext_eq b1 (cp_max b1 u2)); intros Heq.
intros _; destruct b1 as [b1 | | ]; destruct u2 as [u2 | | ];
try (assert (H' : u2 <= b1) by(injection Heq;
            intros h; rewrite h; apply Z.le_max_r));
 destruct u1 as [u1 | | ]; simpl in Heq;
 try discriminate heq; simpl; intros e1 e2 g; simpl;
  try(intuition;fail); try discriminate;
destruct b2 as [b2 | | ]; simpl; try(intuition;fail).
intros; discriminate.
Qed.

Lemma add_test_constraint_left_true_none :
   forall v1 v2, add_test_constraint_left true v1 v2 = None ->
     forall x1 x2, to_p v1 x1 -> to_p v2 x2 -> ~x1 < x2.
Proof.
intros [b1 u1] [b2 u2]; unfold add_test_constraint_left.
case (ext_eq b1 (cp_max b1 u2)); intros Heq.
intros _; destruct b1 as [b1 | | ]; destruct u2 as [u2 | | ];
try (assert (H' : u2 <= b1) by(injection Heq;
            intros h; rewrite h; apply Z.le_max_r));
 destruct u1 as [u1 | | ]; simpl in Heq;
 try discriminate heq; simpl; intros e1 e2 g; simpl;
 try(intuition;fail); try discriminate;
destruct b2 as [b2 | | ]; simpl; try(intuition;fail).
case (ext_eq u2 (cp_min b1 u2)).
intros Heq' _;destruct b1 as [b1 | | ];destruct u2 as [u2 | | ]; simpl in Heq';
try (assert (H' : u2 <= b1) by(injection Heq';
            intros h; rewrite h; apply Z.le_min_l));
 destruct u1 as [u1 | | ]; simpl in Heq;
 try discriminate heq; simpl; intros e1 e2 g;  simpl;
 try(intuition;fail); try discriminate;
destruct b2 as [b2 | | ]; simpl; try(intuition;fail).
intros; discriminate.
Qed.

Lemma add_test_constraint_right_false_none :
  forall v1 v2, add_test_constraint_right false v1 v2 = None ->
     forall x1 x2, to_p v1 x1 -> to_p v2 x2 -> x1 < x2.
Proof.
intros [b1 u1] [b2 u2]; unfold add_test_constraint_right.
case (ext_eq b2 (cp_max u1 b2)); intros Heq;
case (ext_eq u1 (cp_max u1 b2)); intros Heq'; try (intros; discriminate).
intros _; destruct b2 as [b2 | | ]; destruct u1 as [u1 | | ];
try (assert (H' : u1 <= b2) by
 (injection Heq; intros h; rewrite h; apply Z.le_max_l));
try (assert (H'' : ~u1 = b2)
  by (intros h; subst u1; elim Heq'; rewrite cp_max_refl; auto));
  simpl; try (intuition; fail);
destruct u2 as [u2 | | ];
 try discriminate Heq; simpl; intros e1 e2 g;  simpl;
 try(intuition;fail); try discriminate;
destruct b1 as [b1 | | ]; simpl; try(intuition;fail).
Qed.

Lemma add_test_constraint_left_false_none :
   forall v1 v2, add_test_constraint_left false v1 v2 = None ->
     forall x1 x2, to_p v1 x1 -> to_p v2 x2 -> x1 < x2.
Proof.
intros [b1 u1] [b2 u2]; unfold add_test_constraint_left.
case (ext_eq b2 (cp_max u1 b2)); intros Heq;
case (ext_eq u1 (cp_max u1 b2)); intros Heq'; try (intros; discriminate).
intros _; destruct b2 as [b2 | | ]; destruct u1 as [u1 | | ];
try (assert (H' : u1 <= b2) by
 (injection Heq; intros h; rewrite h; apply Z.le_max_l));
try (assert (H'' : ~u1 = b2)
  by (intros h; subst u1; elim Heq'; rewrite cp_max_refl; auto));
  simpl; try (intuition; fail);
destruct u2 as [u2 | | ];
 try discriminate Heq; simpl; intros e1 e2 g;  simpl;
 try(intuition;fail); try discriminate;
destruct b1 as [b1 | | ]; simpl; try(intuition;fail).
Qed.

Lemma add_test_constraint_right_true_sound :
  forall v1 v2 v x1 x2,
     add_test_constraint_right true v1 v2 = Some v ->
     to_p v1 x1 -> to_p v2 x2 -> x1 < x2 -> to_p v x1.
Proof.
intros [b1 u1][b2 u2] v x1 x2; unfold add_test_constraint_right.
case (ext_eq b1 (cp_max b1 u2)); intros Heq; try (intros; discriminate).
intros Hres; injection Hres; intro; subst v.
intros H1 H2 H'; destruct (to_p_cp_max_min _ _ _ H1) as [H3 H4].
destruct (to_p_cp_max_min _ _ _ H2) as [H5 H6].
apply cp_max_min_to_p; auto.
destruct u1 as [u1 | | ]; try (simpl; intuition;fail);
destruct u2 as [u2 | | ]; try (simpl; intuition; fail); simpl;
 try (intros; discriminate).
assert (x1 <= u1) by (simpl in H4; injection H4; intros H7; rewrite <- H7;
                      apply Z.le_min_r).
assert (x2 <= u2) by (simpl in H6; injection H6; intros H7; rewrite <- H7;
                      apply Z.le_min_r).
destruct (Zle_or_lt u1 (u2+ -1)).
rewrite (Zle_to_Zmin u1); try lia.
rewrite Zle_to_Zmin; auto.
rewrite (Z.min_comm u1); rewrite (Zle_to_Zmin (u2+ -1)); try lia.
rewrite Zle_to_Zmin; auto; lia.
assert (x2 <= u2) by (simpl in H6; injection H6; intros H7; rewrite <- H7;
                      apply Z.le_min_r).
rewrite Zle_to_Zmin; auto; lia.
Qed.

(* The next proof should be about the same, but is a textually shorter
proof that was designed before (maybe longer in time.) *)

Lemma add_test_constraint_left_true_sound :
  forall v1 v2 v x1 x2,
     add_test_constraint_left true v1 v2 = Some v ->
     to_p v1 x1 -> to_p v2 x2 -> x1 < x2 -> to_p v x2.
Proof.
intros [b1 u1][b2 u2] v x1 x2; unfold add_test_constraint_left.
case (ext_eq u2 (cp_min b1 u2)); intros Heq; try (intros; discriminate).
intros Hres; injection Hres; intro; subst v.
destruct b1 as [b1 | | ]; try (simpl; intuition;fail);
destruct u1 as [u1 | | ]; try (simpl; intuition;fail);
destruct b2 as [b2 | | ]; try (simpl; intuition;fail);
destruct u2 as [u2 | | ]; try (simpl; intuition; fail); simpl;
 try (assert (b1 <> u2) by
     (intros h;subst u2; elim Heq; rewrite cp_min_refl; auto));
   try (case (Zmax_irreducible_inf (b1+1) b2);(intros; lia));
   try (intros; lia).
Qed.

Lemma add_test_constraint_right_false_sound :
  forall v1 v2 v x1 x2,
     add_test_constraint_right false v1 v2 = Some v ->
     to_p v1 x1 -> to_p v2 x2 -> ~x1 < x2 -> to_p v x1.
Proof.
intros [b1 u1][b2 u2] v x1 x2; unfold add_test_constraint_right.
case (ext_eq b2 (cp_max u1 b2)); intros Heq.
case (ext_eq u1 (cp_max u1 b2)); intros Heq'; try (intros; discriminate);
intros H'; injection H'; intro ; subst v; clear H';
destruct b1 as [b1 | | ]; destruct u1 as [u1 | | ];
 simpl; try (simpl;intuition;fail);
destruct b2 as [b2 | | ]; destruct u2 as [u2 | | ];
 simpl; try (simpl;intuition;fail); try (intros;discriminate);
try (case (Zmax_irreducible_inf b1 b2); intros; lia).
intros H'; injection H'; intro; subst v; clear H'.
destruct b1 as [b1 | | ]; destruct u1 as [u1 | | ];
 simpl; try (simpl;intuition;fail);
destruct b2 as [b2 | | ];
 try (assert (H': b2 <> u1)
        by (intro; elim Heq; subst b2; rewrite cp_max_refl; auto));
destruct u2 as [u2 | | ];
 try case (Zmax_irreducible_inf b1 b2);
 simpl; try (simpl;intuition;fail); try (intros;discriminate).
Qed.

Lemma add_test_constraint_left_false_sound :
  forall v1 v2 v x1 x2,
     add_test_constraint_left false v1 v2 = Some v ->
     to_p v1 x1 -> to_p v2 x2 -> ~ x1 < x2 -> to_p v x2.
Proof.
intros [b1 u1][b2 u2] v x1 x2; unfold add_test_constraint_left.
case (ext_eq b2 (cp_max u1 b2)); intros Heq.
case (ext_eq u1 (cp_max u1 b2)); intros Heq'; try (intros; discriminate);
intros H'; injection H'; intro ; subst v; clear H';
destruct b1 as [b1 | | ]; destruct u1 as [u1 | | ];
 simpl; try (simpl;intuition;fail);
destruct b2 as [b2 | | ]; destruct u2 as [u2 | | ];
 simpl; try (simpl;intuition;fail); try (intros;discriminate);
try (case (Zmin_irreducible u1 u2); lia).
intros H'; injection H'; intro; subst v; clear H'.
destruct b1 as [b1 | | ]; destruct u1 as [u1 | | ];
 simpl; try (simpl;intuition;fail);
destruct b2 as [b2 | | ];
 try (assert (H': b2 <> u1)
        by (intro; elim Heq; subst b2; rewrite cp_max_refl; auto));
destruct u2 as [u2 | | ];
 try case (Zmin_irreducible_inf u1 u2);
 simpl; try (simpl;intuition;fail); try (intros;discriminate).
Qed.

Lemma add_test_constraint_right_true_lb :
  forall l1 u1 l2 u2 l u,
    add_test_constraint_right true (l1, u1) (l2, u2) = Some (l, u) ->
    l = l1.
intros [l1 | | ] [u1 | | ] [l2 | | ] [u2 | | ] l u;
  unfold add_test_constraint_right;
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq
       end);
  try (simpl; intros; intuition; discriminate);
  try (intros H'; injection H'; intros; subst l; auto;fail).
Qed.

Lemma add_test_constraint_right_false_ub :
  forall l1 u1 l2 u2 l u,
    add_test_constraint_right false (l1, u1) (l2, u2) = Some (l, u) ->
    u = u1.
intros [l1 | | ] [u1 | | ] [l2 | | ] [u2 | | ] l u;
  unfold add_test_constraint_right;
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq
       end);
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq'
       end);
  try (simpl; intros; intuition; discriminate);
  try (intros H'; injection H'; intros; subst l; auto;fail).
Qed.

Lemma add_test_constraint_right_true_ub_no_cut :
  forall l1 u1 l2 u2 l u,
    add_test_constraint_right true (l1, u1) (l2, u2) = Some (l, u) ->
    cp_min u1 (comp_add u2 (cZ (-1))) = u1 ->
    u = u1.
intros [l1 | | ] [u1 | | ] [l2 | | ] [u2 | | ] l u;
  unfold add_test_constraint_right;
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq
       end);
  try (simpl; intros; intuition; discriminate);
  try (intros H'; injection H'; intros; subst u; auto;fail).
Qed.

Lemma add_test_constraint_right_false_lb_no_cut :
  forall l1 u1 l2 u2 l u,
    add_test_constraint_right false (l1, u1) (l2, u2) = Some (l, u) ->
    cp_max l1 l2 = l1 -> l = l1.
intros [l1 | | ] [u1 | | ] [l2 | | ] [u2 | | ] l u;
  unfold add_test_constraint_right;
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq
       end);
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq'
       end);
  try (simpl; intros; intuition; discriminate);
  try (intros H'; injection H'; intros; subst u; auto;fail);
  try (intros H1 H2; rewrite H2 in H1; injection H1; auto).
Qed.

Lemma add_test_constraint_right_true_ub_cut :
  forall l1 u1 l2 u2 l u,
    add_test_constraint_right true (l1, u1) (l2, u2) = Some (l, u) ->
    u1 <> cp_min u1 (comp_add u2 (cZ (-1))) ->
    u = comp_add u2 (cZ (-1)).
intros [l1 | | ] [u1 | | ] [l2 | | ] [u2 | | ] l u;
  unfold add_test_constraint_right;
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq
       end);
  try (simpl; intros; intuition; discriminate);
  try (intros H'; injection H'; do 2 intro; subst u; clear H');
  try (simpl; intro Hneq;
    destruct (Zmin_irreducible  u1 (u2+ -1)) as [H|H];
    try (rewrite H in Hneq;case Hneq; auto;fail); rewrite H; auto; fail);
  simpl; auto.
Qed.

Lemma add_test_constraint_right_false_lb_cut :
  forall l1 u1 l2 u2 l u,
    add_test_constraint_right false (l1, u1) (l2, u2) = Some (l, u) ->
    l1 <> cp_max l1 l2 -> l = l2.
intros [l1 | | ] [u1 | | ] [l2 | | ] [u2 | | ] l u;
  unfold add_test_constraint_right;
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq
       end);
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq'
       end);
  try (simpl; intros; intuition; discriminate);
  try (intros H'; injection H'; do 2 intro; subst u; clear H');
  try (simpl; intro Hneq;
    destruct (Zmax_irreducible_inf l1 l2) as [H|H];
    try (rewrite H in Hneq;case Hneq; auto;fail); subst l;
        rewrite H; auto; fail);
  simpl; auto.
Qed.

Lemma not_cp_min_cp_max :
  forall a b, ~cp_min a b = b->cp_max a b = b.
intros [a | | ][b | | ]; simpl; try (intuition; fail).
destruct (Zle_or_lt a b).
rewrite Z.max_comm; rewrite Zle_to_Zmax; auto.
rewrite Z.min_comm; rewrite Zle_to_Zmin; auto with zarith.
intros Hn; elim Hn; auto.
Qed.

Lemma add_test_constraint_right_true_monotonic :
  forall v1 v2 v1' v2' v v',
    add_test_constraint_right true v1 v2 = Some v ->
    add_test_constraint_right true v1' v2' = Some v' ->
    thinner v1 v1' -> thinner v2 v2' -> thinner v v'.
intros [l1 u1][l2 u2][l1' u1'][l2' u2'][l u][l' u'] H H'.
rewrite add_test_constraint_right_true_lb with (1:=H).
rewrite add_test_constraint_right_true_lb with (1:=H').
destruct (ext_eq u1 (cp_min u1 (comp_add u2 (cZ (-1))))).
rewrite add_test_constraint_right_true_ub_no_cut with (1:=H); auto.
destruct (ext_eq u1' (cp_min u1' (comp_add u2' (cZ (-1))))).
rewrite add_test_constraint_right_true_ub_no_cut with (1:=H'); auto.
rewrite add_test_constraint_right_true_ub_cut with (1:=H'); auto.
intros [H1 H2][H3 H4]; split; auto.
rewrite cp_max_comm; apply cp_max_trans with (comp_add u2 (cZ (-1))).
destruct u2 as [u2 | | ]; destruct u2' as [u2' | | ]; simpl in *;
  try discriminate; auto.
assert (u2 <= u2') by (injection H4; intros a; rewrite <- a; apply Z.le_max_l).
rewrite Zle_to_Zmax; auto; try lia.
apply cp_min_r_cp_max_l; rewrite cp_min_comm; auto.
rewrite add_test_constraint_right_true_ub_cut with (1:=H); auto.
destruct (ext_eq u1' (cp_min u1' (comp_add u2' (cZ (-1))))).
rewrite add_test_constraint_right_true_ub_no_cut with (1:=H'); auto.
intros [H1 H2][H3 H4]; split; auto.
rewrite cp_max_comm; apply cp_max_trans with u1.
rewrite cp_max_comm; auto.
rewrite cp_max_comm; apply not_cp_min_cp_max; rewrite cp_min_comm; auto.
rewrite add_test_constraint_right_true_ub_cut with (1:=H'); auto.
intros [H1 H2][H3 H4]; split; auto.
rewrite cp_max_comm; rewrite cp_max_plus; auto.
rewrite cp_max_comm; auto.
Qed.

Lemma cp_max_irreducible :
  forall a b, cp_max a b = a \/ cp_max a b = b.
intros [a | | ][b | | ];try (intuition; fail).
simpl; case (Zmax_irreducible_inf a b); intros H; rewrite H; auto.
Qed.

Lemma cp_min_irreducible :
  forall a b, cp_min a b = a \/ cp_min a b = b.
intros [a | | ][b | | ]; try (intuition;fail).
simpl; case (Zmin_irreducible a b); intros H; rewrite H; auto.
Qed.

Lemma add_test_constraint_right_false_monotonic :
  forall v1 v2 v1' v2' v v',
    add_test_constraint_right false v1 v2 = Some v ->
    add_test_constraint_right false v1' v2' = Some v' ->
    thinner v1 v1' -> thinner v2 v2' -> thinner v v'.
intros [l1 u1][l2 u2][l1' u1'][l2' u2'][l u][l' u'] H H'.
rewrite add_test_constraint_right_false_ub with (1:=H).
rewrite add_test_constraint_right_false_ub with (1:=H').
destruct (ext_eq l1 (cp_max l1 l2)) as [Hl1l2 | Hl1l2].
rewrite add_test_constraint_right_false_lb_no_cut with (1:=H); auto.
destruct (ext_eq l1' (cp_max l1' l2')).
rewrite add_test_constraint_right_false_lb_no_cut with (1:=H'); auto.
rewrite add_test_constraint_right_false_lb_cut with (1:=H'); auto.
intros [H1 H2][H3 H4]; split; auto.
rewrite cp_min_comm; apply cp_min_trans with l2.
rewrite cp_min_comm; auto.
apply cp_max_r_cp_min_l; rewrite cp_max_comm; auto.
rewrite add_test_constraint_right_false_lb_cut with (1:=H); auto.
destruct (ext_eq l1' (cp_max l1' l2')).
rewrite add_test_constraint_right_false_lb_no_cut with (1:=H'); auto.
intros [H1 H2][H3 H4]; split; auto.
rewrite cp_min_comm; apply cp_min_trans with l1.
rewrite cp_min_comm; auto.
apply cp_max_r_cp_min_l.
case (cp_max_irreducible l1 l2); auto; intros; case Hl1l2; auto.
rewrite add_test_constraint_right_false_lb_cut with (1:=H'); auto.
intros [H1 H2][H3 H4];split; auto.
Qed.

Lemma add_test_constraint_right_monotonic :
  forall neg v1 v2 v1' v2' v v',
    add_test_constraint_right neg v1 v2 = Some v ->
    add_test_constraint_right neg v1' v2' = Some v' ->
    thinner v1 v1' -> thinner v2 v2' -> thinner v v'.
intros [|].
apply add_test_constraint_right_true_monotonic.
apply add_test_constraint_right_false_monotonic.
Qed.

Lemma add_test_constraint_left_true_ub :
  forall l1 u1 l2 u2 l u,
    add_test_constraint_left true (l1, u1) (l2, u2) = Some (l, u) ->
    u = u2.
intros [l1 | | ] [u1 | | ] [l2 | | ] [u2 | | ] l u;
  unfold add_test_constraint_left;
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq
       end);
  try (simpl; intros; intuition; discriminate);
  try (intros H'; injection H'; intros; subst u; auto;fail).
Qed.

Lemma add_test_constraint_left_false_lb :
  forall l1 u1 l2 u2 l u,
    add_test_constraint_left false (l1, u1) (l2, u2) = Some (l, u) ->
    l = l2.
intros [l1 | | ] [u1 | | ] [l2 | | ] [u2 | | ] l u;
  unfold add_test_constraint_left;
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq
       end);
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq'
       end);
  try (simpl; intros; intuition; discriminate);
  try (intros H'; injection H'; intros; subst l; auto;fail).
Qed.

Lemma add_test_constraint_left_true_lb_no_cut :
  forall l1 u1 l2 u2 l u,
    add_test_constraint_left true (l1, u1) (l2, u2) = Some (l, u) ->
    cp_max (comp_add l1 (cZ 1)) l2 = l2 ->
    l = l2.
intros [l1 | | ] [u1 | | ] [l2 | | ] [u2 | | ] l u;
  unfold add_test_constraint_left;
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq
       end);
  try (simpl; intros; intuition; discriminate);
  try (intros H'; injection H'; intros; subst l; auto;fail).
Qed.

Lemma add_test_constraint_left_false_lb_no_cut :
  forall l1 u1 l2 u2 l u,
    add_test_constraint_left false (l1, u1) (l2, u2) = Some (l, u) ->
    cp_min u1 u2 = u2 -> u = u2.
intros [l1 | | ] [u1 | | ] [l2 | | ] [u2 | | ] l u;
  unfold add_test_constraint_left;
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq
       end);
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq'
       end);
  try (simpl; intros; intuition; discriminate);
  try (intros H'; injection H'; intros; subst u; auto;fail).
Qed.

Lemma add_test_constraint_left_true_lb_cut :
  forall l1 u1 l2 u2 l u,
    add_test_constraint_left true (l1, u1) (l2, u2) = Some (l, u) ->
    l2 <> cp_max (comp_add l1 (cZ 1)) l2 ->
    l = comp_add l1 (cZ 1).
intros [l1 | | ] [u1 | | ] [l2 | | ] [u2 | | ] l u;
  unfold add_test_constraint_left;
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq
       end);
  try (simpl; intros; intuition; discriminate);
  try (intros H'; injection H'; do 2 intro; subst l u; clear H'); simpl; auto;
 (simpl; intro Hneq;
    destruct (Zmax_irreducible_inf  (l1 + 1) l2) as [Hl1l2|Hl1l2];
    try (rewrite Hl1l2 in Hneq;case Hneq; auto;fail); rewrite Hl1l2; auto; fail).
Qed.

Lemma add_test_constraint_left_false_lb_cut :
  forall l1 u1 l2 u2 l u,
    add_test_constraint_left false (l1, u1) (l2, u2) = Some (l, u) ->
    u2 <> cp_min u1 u2 -> u = u1.
intros [l1 | | ] [u1 | | ] [l2 | | ] [u2 | | ] l u;
  unfold add_test_constraint_left;
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq
       end);
  try (match goal with |- context[ext_eq ?a ?b] =>
         case (ext_eq a b); intros Heq'
       end);
  try (simpl; intros; intuition; discriminate);
  try (intros H'; injection H'; do 2 intro; subst u l; clear H'); simpl; auto;
  (simpl; intro Hneq;
    destruct (Zmin_irreducible u1 u2) as [H|H];
    try (rewrite H in Hneq;case Hneq; auto;fail);
        rewrite H; auto; fail);
  simpl; auto.
Qed.

Lemma add_test_constraint_left_true_monotonic :
  forall v1 v2 v1' v2' v v',
    add_test_constraint_left true v1 v2 = Some v ->
    add_test_constraint_left true v1' v2' = Some v' ->
    thinner v1 v1' -> thinner v2 v2' -> thinner v v'.
intros [l1 u1][l2 u2][l1' u1'][l2' u2'][l u][l' u'] H H'.
rewrite add_test_constraint_left_true_ub with (1:=H).
rewrite add_test_constraint_left_true_ub with (1:=H').
destruct (ext_eq l2 (cp_max (comp_add l1 (cZ 1)) l2)) as [Hl2l1 | Hl2l1].
rewrite add_test_constraint_left_true_lb_no_cut with (1:=H); auto.
destruct (ext_eq l2' (cp_max (comp_add l1' (cZ 1)) l2')).
rewrite add_test_constraint_left_true_lb_no_cut with (1:=H'); auto.
rewrite add_test_constraint_left_true_lb_cut with (1:=H'); auto.
intros [H1 H2][H3 H4]; split; auto.
rewrite cp_min_comm; apply cp_min_trans with (comp_add l1 (cZ 1)).
destruct l1 as [l1 | | ]; destruct l1' as [l1' | | ]; simpl in *;
  try discriminate; auto.
assert (l1' <= l1) by (injection H1; intros a; rewrite <- a; apply Z.le_min_l).
rewrite Zle_to_Zmin; auto; try lia.
apply cp_max_r_cp_min_l; auto.
rewrite add_test_constraint_left_true_lb_cut with (1:=H); auto.
destruct (ext_eq l2' (cp_max (comp_add l1' (cZ 1)) l2')).
rewrite add_test_constraint_left_true_lb_no_cut with (1:=H'); auto.
intros [H1 H2][H3 H4]; split; auto.
rewrite cp_min_comm; apply cp_min_trans with l2.
rewrite cp_min_comm; auto.
apply cp_max_r_cp_min_l; rewrite cp_max_comm;
 case (cp_max_irreducible (comp_add l1 (cZ 1)) l2);
 try (intros; case Hl2l1; auto; fail); auto.
rewrite add_test_constraint_left_true_lb_cut with (1:=H'); auto.
intros [H1 H2][H3 H4]; split; auto.
rewrite cp_min_comm; rewrite cp_min_plus; auto.
rewrite cp_min_comm; auto.
Qed.

Lemma add_test_constraint_left_false_monotonic :
  forall v1 v2 v1' v2' v v',
    add_test_constraint_left false v1 v2 = Some v ->
    add_test_constraint_left false v1' v2' = Some v' ->
    thinner v1 v1' -> thinner v2 v2' -> thinner v v'.
intros [l1 u1][l2 u2][l1' u1'][l2' u2'][l u][l' u'] H H'.
rewrite add_test_constraint_left_false_lb with (1:=H).
rewrite add_test_constraint_left_false_lb with (1:=H').
destruct (ext_eq u2 (cp_min u1 u2)) as [Hl1l2 | Hl1l2].
rewrite add_test_constraint_left_false_lb_no_cut with (1:=H); auto.
destruct (ext_eq u2' (cp_min u1' u2')).
rewrite add_test_constraint_left_false_lb_no_cut with (1:=H'); auto.
rewrite add_test_constraint_left_false_lb_cut with (1:=H'); auto.
intros [H1 H2][H3 H4]; split; auto.
rewrite cp_max_comm; apply cp_max_trans with u1.
rewrite cp_max_comm; auto.
apply cp_min_r_cp_max_l; auto.
rewrite add_test_constraint_left_false_lb_cut with (1:=H); auto.
destruct (ext_eq u2' (cp_min u1' u2')).
rewrite add_test_constraint_left_false_lb_no_cut with (1:=H'); auto.
intros [H1 H2][H3 H4]; split; auto.
rewrite cp_max_comm; apply cp_max_trans with u2.
rewrite cp_max_comm; auto.
apply cp_min_r_cp_max_l.
rewrite cp_min_comm.
case (cp_min_irreducible u1 u2); auto; intros; case Hl1l2; auto.
rewrite add_test_constraint_left_false_lb_cut with (1:=H'); auto.
intros [H1 H2][H3 H4];split; auto.
Qed.

Lemma add_test_constraint_left_monotonic :
  forall neg v1 v2 v1' v2' v v',
    add_test_constraint_left neg v1 v2 = Some v ->
    add_test_constraint_left neg v1' v2' = Some v' ->
    thinner v1 v1' -> thinner v2 v2' -> thinner v v'.
intros [|].
apply add_test_constraint_left_true_monotonic.
apply add_test_constraint_left_false_monotonic.
Qed.

Lemma add_test_constraint_right_monotonic_none :
  forall neg v1 v2 v1' v2' v,
    add_test_constraint_right neg v1 v2 = Some v ->
    thinner v1 v1' -> thinner v2 v2' ->
    ~add_test_constraint_right neg v1' v2' = None.
unfold add_test_constraint_right;
intros [|] [l1 u1][l2 u2][l1' u1'][l2' u2'] [l u] Hadd [H1 H2][H3 H4].
destruct (ext_eq l1' (cp_max l1' u2')).
destruct (ext_eq l1 (cp_max l1 u2)) as [A | B]; try discriminate.
destruct B; symmetry.
apply cp_max_trans with l1'.
apply cp_min_r_cp_max_l; auto.
apply cp_max_trans with u2'; auto.
rewrite cp_max_comm; auto.
discriminate.
destruct (ext_eq l2' (cp_max u1' l2')) as [C | D]; try discriminate.
destruct (ext_eq u1' (cp_max u1' l2')) as [A | B]; try discriminate.
destruct B; symmetry.
destruct (ext_eq l2 (cp_max u1 l2)) as [A | B]; try discriminate.
destruct (ext_eq u1 (cp_max u1 l2)); try discriminate.
apply cp_max_trans with u1.
rewrite cp_max_comm; auto.
apply cp_max_trans with l2; auto.
apply cp_min_r_cp_max_l; auto.
apply cp_max_trans with u1.
rewrite cp_max_comm; auto.
apply cp_max_trans with l2.
case (cp_max_irreducible u1 l2); auto; intros; case B; auto.
apply cp_min_r_cp_max_l; auto.
Qed.

Lemma add_test_constraint_left_monotonic_none :
  forall neg v1 v2 v1' v2' v,
    add_test_constraint_left neg v1 v2 = Some v ->
    thinner v1 v1' -> thinner v2 v2' ->
    ~add_test_constraint_left neg v1' v2' = None.
unfold add_test_constraint_left;
intros [|] [l1 u1][l2 u2][l1' u1'][l2' u2'] [l u] Hadd [H1 H2][H3 H4].
destruct (ext_eq u2' (cp_min l1' u2')).
destruct (ext_eq u2 (cp_min l1 u2)) as [A | B]; try discriminate.
destruct B; symmetry.
rewrite cp_min_comm; apply cp_min_trans with l1'; auto.
apply cp_min_trans with u2'; auto.
apply cp_max_r_cp_min_l; auto.
rewrite cp_min_comm; auto.
rewrite cp_min_comm; auto.
discriminate.
destruct (ext_eq l2' (cp_max u1' l2')) as [C | D]; try discriminate.
destruct (ext_eq u1' (cp_max u1' l2')) as [A | B]; try discriminate.
destruct B; symmetry.
destruct (ext_eq l2 (cp_max u1 l2)) as [A | B]; try discriminate.
destruct (ext_eq u1 (cp_max u1 l2)); try discriminate.
apply cp_max_trans with u1.
rewrite cp_max_comm; auto.
apply cp_max_trans with l2; auto.
apply cp_min_r_cp_max_l; auto.
apply cp_max_trans with u1.
rewrite cp_max_comm; auto.
apply cp_max_trans with l2.
case (cp_max_irreducible u1 l2); auto; intros; case B; auto.
apply cp_min_r_cp_max_l; auto.
Qed.


(* Exercise 67 *)

Require Import BenB.

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

Theorem exercise_067 : (forall x : D, ~ P x) -> ~ exists x : D, P x.
Proof.
imp_i a1.
neg_i (1=1) a2.
exi_e (exists x:D, P x) a a3.
hyp a2.
neg_e (P a).
all_e (forall x:D, ~P x) a.
hyp a1.
hyp a3.
lin_solve.
Qed.


(* Exercise 26 *)

Require Import BenB.

Variables A B C D : Prop.

Theorem exercise_026 : (~A /\ ~B) -> ~(A \/ (~A /\ B)).
Proof.
imp_i a1.
neg_i (1=1) a2.
dis_e (A \/ ~A /\ B) a3 a3.
hyp a2.
neg_e A.
con_e1 (~B).
hyp a1.
hyp a3.
neg_e B.
con_e2 (~A).
hyp a1.
con_e2 (~A).
hyp a3.
lin_solve.
Qed.


Require Import List.
Import ListNotations.

Set Implicit Arguments.

Section list_util.
  Variables A : Type.

  Lemma in_firstn : forall n (x : A) xs,
      In x (firstn n xs) -> In x xs.
  Proof using.
    induction n; simpl; intuition.
    destruct xs;simpl in *; intuition.
  Qed.

  Lemma firstn_NoDup : forall n (xs : list A),
    NoDup xs ->
    NoDup (firstn n xs).
  Proof using.
    induction n; intros; simpl; destruct xs; auto.
    - apply NoDup_nil.
    - inversion H; subst.
      apply NoDup_cons.
      * eauto 6 using in_firstn.
      * apply IHn; auto.
  Qed.
End list_util.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
Require Import Functor.Main.

Local Open Scope morphism_scope.

(**
Given two objects a and b, their product a×b is an object such that there are
two projections from it to a and b:

#

                    π₁        π₂
                a <—–——– a×b ———–—> b

#
such that for any object z with two projections to a and b, there is a unique
arrow h that makes the following diagram commute:

#

                    π₁        π₂
                a <—–——–– a×b –———–—> b
                 ↖         ↑        ↗
                  \        |       /
                   \       |      /
                    \      |∃!h  /
                     \     |    /
                      \    |   /
                       \   |  /
                           z

#
*)
Record Product {C : Category} (c d : C) : Type :=
{
  product : C;

  Pi_1 : product –≻ c;

  Pi_2 : product –≻ d;

  Prod_morph_ex : ∀ (p' : Obj) (r1 : p' –≻ c) (r2 : p' –≻ d), p' –≻ product;

  Prod_morph_com_1 : ∀ (p' : Obj) (r1 : p' –≻ c) (r2 : p' –≻ d),
      (Pi_1 ∘ (Prod_morph_ex p' r1 r2))%morphism = r1;

  Prod_morph_com_2 : ∀ (p' : Obj) (r1 : p' –≻ c) (r2 : p' –≻ d),
      (Pi_2 ∘ (Prod_morph_ex p' r1 r2))%morphism = r2;

  Prod_morph_unique :
    ∀ (p' : Obj) (r1 : p' –≻ c) (r2 : p' –≻ d) (f g : p' –≻ product),
      Pi_1 ∘ f = r1
      → Pi_2 ∘ f = r2
      → Pi_1 ∘ g = r1
      → Pi_2 ∘ g = r2
      → f = g
}.

Arguments Product _ _ _, {_} _ _.

Arguments Pi_1 {_ _ _ _}, {_ _ _} _.
Arguments Pi_2 {_ _ _ _}, {_ _ _} _.
Arguments Prod_morph_ex {_ _ _} _ _ _ _.
Arguments Prod_morph_com_1 {_ _ _} _ _ _ _.
Arguments Prod_morph_com_2 {_ _ _} _ _ _ _.
Arguments Prod_morph_unique {_ _ _} _ _ _ _ _ _ _ _ _ _.

Coercion product : Product >-> Obj.

Notation "a × b" := (Product a b) : object_scope.

Local Open Scope object_scope.

(** for any pair of objects, their product is unique up to isomorphism. *)
Theorem Product_iso {C : Category} (c d : Obj) (P : c × d) (P' : c × d)
  : (P ≃ P')%isomorphism.
Proof.
  eapply (Build_Isomorphism _ _ _
                            (Prod_morph_ex P' P Pi_1 Pi_2)
                            (Prod_morph_ex P P' Pi_1 Pi_2));
  eapply Prod_morph_unique; eauto;
  rewrite <- assoc;
  repeat (rewrite Prod_morph_com_1 || rewrite Prod_morph_com_2); auto.
Qed.

Definition Has_Products (C : Category) : Type := ∀ a b, a × b.

Existing Class Has_Products.

(**
The product functor maps each pair of objects (an object of the product
category C×C) to their product in C.
*)
Program Definition Prod_Func (C : Category) {HP : Has_Products C}
  : ((C × C) –≻ C)%functor :=
{|
  FO := fun x => HP (fst x) (snd x);
  FA := fun a b f => Prod_morph_ex _ _ ((fst f) ∘ Pi_1) ((snd f) ∘ Pi_2)
|}.

Next Obligation. (* F_id *)
Proof.
  eapply Prod_morph_unique;
  try reflexivity; [rewrite Prod_morph_com_1|rewrite Prod_morph_com_2]; auto.
Qed.

Next Obligation. (* F_compose *)
Proof.
  eapply Prod_morph_unique;
  try ((rewrite Prod_morph_com_1 || rewrite Prod_morph_com_2); reflexivity);
  repeat rewrite <- assoc; (rewrite Prod_morph_com_1 || rewrite Prod_morph_com_2);
  rewrite assoc; (rewrite Prod_morph_com_1 || rewrite Prod_morph_com_2); auto.
Qed.

Arguments Prod_Func _ _, _ {_}.

Notation "×ᶠⁿᶜ" := Prod_Func : functor_scope.

(** Sum is the dual of product *)
Definition Sum (C : Category) := @Product (C^op).

Arguments Sum _ _ _, {_} _ _.

Notation "a + b" := (Sum a b) : object_scope.

Definition Has_Sums (C : Category) : Type :=  ∀ (a b : C), (a + b)%object.

Existing Class Has_Sums.

(**
The sum functor maps each pair of objects (an object of the product category
C×C) to their sum in C.
*)
Definition Sum_Func {C : Category} {HS : Has_Sums C} : ((C × C) –≻ C)%functor :=
  (×ᶠⁿᶜ (C^op) HS)^op.

Arguments Sum_Func _ _, _ {_}.

Notation "+ᶠⁿᶜ" := Sum_Func : functor_scope.


Require Import ZArith FSets FSetAVL.

Module M := FSetAVL.Make(Z_as_OT).

Open Scope Z_scope.

Definition ens1 := M.add 3 (M.add 0 (M.add 2 (M.empty))).
Definition ens2 := M.add 0 (M.add 2 (M.add 4 (M.empty))).
Definition ens3 := M.inter ens1 ens2.
Definition ens4 := M.union ens1 ens2.

Eval vm_compute in (M.mem 2 ens3).
Eval vm_compute in (M.elements ens3).
Eval vm_compute in (M.elements ens4).
Eval vm_compute in
 match (M.compare ens3 ens4) with EQ _ => 0 | LT _ => -1 | GT _ => 1 end.

(* Sets by themselves are ugly (proof parts), but who cares *)
Eval vm_compute in ens1.
Eval vm_compute in ens3.
Eval vm_compute in ens4.

(** Some more intense tests. *)

Fixpoint multiples (m:Z)(start:Z)(n:nat) {struct n} : list Z :=
  match n with
   | O => nil
   | S n => start::(multiples m (m+start) n)
  end.

Eval vm_compute in (multiples 2 0 200%nat).

Definition bigens1 := fold_right M.add M.empty (multiples 2 0 400%nat).
Definition bigens2 := fold_right M.add M.empty (multiples 3 0 400%nat).
Time Eval vm_compute in (M.elements (M.inter bigens1 bigens2)).
Time Eval vm_compute in (M.elements (M.union bigens1 bigens2)).

Definition bigens3 := fold_right M.add M.empty (multiples 2 0 (100*100)%nat).
Definition bigens4 := fold_right M.add M.empty (multiples 3 0 (100*100)%nat).
Time Eval vm_compute in (M.cardinal bigens3). (* computation of bigens3 done once and forall *)
Time Eval vm_compute in (M.cardinal bigens4). (* computation of bigens4 done once and forall *)
Time Eval vm_compute in (M.cardinal (M.inter bigens3 bigens4)).
Time Eval vm_compute in (M.cardinal (M.union bigens3 bigens4)).

(* Experimental illustration of the cardinal law: |AUB|+|A^B|=|A|+|B| *)
Time Eval vm_compute in (M.cardinal (M.union bigens3 bigens4)
                                         +M.cardinal (M.inter bigens3 bigens4))%nat.
(*   = 20000%nat
     : nat
*)


Require Import Kami.Syntax.

Section nat_string.
  Unset Implicit Arguments.

  (*
    Accepts two arguments: radix and ns; and returns: ns[0] + radix *
    ns[1] + radix^2 * ns[2] + ... radix^n * ns[n]

    Ex: nat_decomp_nat 2 [1; 0; 1; 1] = 13.
  *)
  Local Fixpoint nat_decomp_nat (radix : nat) (ns : list nat) : nat
    := match ns with
       | [] => 0
       | m :: ms => (radix * nat_decomp_nat radix ms) + m
       end.

  Local Fixpoint nat_decomp_prod (x : nat) (ns : list nat) : list nat
    := match ns with
       | [] => []
       | m :: ms => x * m :: nat_decomp_prod x ms
       end.

  (* 0 = Nat.div x y ==> x < y ==> x = x mod y *)
  Lemma div0_mod : forall x y : nat, y <> 0 -> 0 = Nat.div x y -> x = x mod y.
  Proof.
    exact
      (fun x y H H0
        => eq_sym (Nat.mod_small x y
             (proj1 (Nat.div_small_iff x y H)
               (eq_sym H0)))).
  Qed.

  Local Definition nat_decomp
    (radix : nat) (* radix minus 2 *)
    (n : nat)
    :  {ms : list nat |
         Forall (fun m => m < (S (S radix))) ms /\
         n = nat_decomp_nat (S (S radix)) ms}
    := Fix_F
         (fun n
           => {ms : list nat |
                Forall (fun m => m < (S (S radix))) ms /\
                n = nat_decomp_nat (S (S radix)) ms})
         (fun n (F : forall r, r < n -> {ms : list nat | Forall (fun m => m < (S (S radix))) ms /\ r = nat_decomp_nat (S (S radix)) ms})
           => nat_rec
                (fun q
                  => q = Nat.div n (S (S radix)) ->
                     {ms : list nat |
                       Forall (fun m => m < (S (S radix))) ms /\
                       n = nat_decomp_nat (S (S radix)) ms})
                (fun H : 0 = Nat.div n (S (S radix))
                  => let H0 : n = nat_decomp_nat (S (S radix)) [n mod (S (S radix))]
                       := ltac:(
                            lazy [nat_decomp_nat list_rec list_rect];
                            rewrite (Nat.mul_0_r (S (S radix)));
                            rewrite (Nat.add_0_l _);
                            apply (div0_mod n (S (S radix)) (Nat.neq_succ_0 (S radix)) H)) in
                     exist
                       (fun ms
                         => Forall (fun m => m < (S (S radix))) ms /\
                            n = nat_decomp_nat (S (S radix)) ms)
                       [n mod (S (S radix))]
                       (conj
                         (Forall_cons (n mod (S (S radix)))
                           (Nat.mod_upper_bound n (S (S radix)) (Nat.neq_succ_0 (S radix)))
                           (Forall_nil (fun m => m < S (S radix))))
                         H0))
                (fun q _ (H : S q = Nat.div n (S (S radix)))
                  => let (ms, H0)
                       := F (S q)
                            (eq_ind_r
                              (fun x => x < n)
                              (Nat.div_lt n (S (S radix))
                                (or_ind
                                  (fun H0 : 0 < n => H0)
                                  (fun H0 : 0 = n
                                    => False_ind (0 < n)
                                         (let H2 : Nat.div n (S (S radix)) = 0
                                            := eq_ind
                                                 0
                                                 (fun x => Nat.div x (S (S radix)) = 0)
                                                 (Nat.div_0_l (S (S radix)) (Nat.neq_succ_0 (S radix)))
                                                 n
                                                 H0 in
                                          let H1 : S q = 0
                                            := eq_ind_r (fun x => x = 0) H2 H in
                                          Nat.neq_succ_0 q H1))
                                  ((proj1 (Nat.lt_eq_cases 0 n))
                                    (Nat.le_0_l n)))
                                (le_n_S 1 (S radix) (le_n_S 0 radix (Nat.le_0_l radix))))
                              H) in
                     let xs := n mod (S (S radix)) :: ms in
                     let H1 : n = nat_decomp_nat (S (S radix)) xs
                       := ltac:(
                            unfold xs;
                            lazy [nat_decomp_nat list_rec list_rect];
                            fold (nat_decomp_nat (S (S radix)));
                            rewrite <- (proj2 H0);
                            rewrite H;
                            rewrite <- (Nat.div_mod n (S (S radix)) (Nat.neq_succ_0 (S radix)));
                            reflexivity) in
                     let H2 : Forall (fun m => m < S (S radix)) xs
                       := Forall_cons (n mod S (S radix))
                           (Nat.mod_upper_bound n (S (S radix)) (Nat.neq_succ_0 (S radix)))
                           (proj1 H0) in
                     exist _ xs (conj H2 H1))
                (Nat.div n (S (S radix)))
                eq_refl)%nat
         (lt_wf n).

  (* Every function that has an inverse is injective. *)
  Local Theorem inv_inj
    : forall (A B : Type) (f : A -> B) (g : B -> A),
        (forall x : A, g (f x) = x) ->
        (forall x y : A, f x = f y -> x = y).
  Proof.
    intros A b f g Hg x y Hxy.
    rewrite <- (Hg x).
    rewrite <- (Hg y).
    rewrite Hxy.
    reflexivity.
  Qed.

  Local Theorem nat_decomp_inj
    (radix : nat) (* radix minus 2 *)
    :  forall n m : nat, proj1_sig (nat_decomp radix n) = proj1_sig (nat_decomp radix m) -> n = m.
  Proof.
    exact
      (inv_inj _ _
        (fun x => proj1_sig (nat_decomp radix x))
        (nat_decomp_nat (S (S radix)))
        (fun x => eq_sym (proj2 (proj2_sig (nat_decomp radix x))))).
  Qed.

  Local Open Scope char_scope.

  Local Fixpoint nat_decomp_chars
    (radix : nat) (* radix minus 2 *)
    (encoding : forall n, n < S (S radix) -> ascii)
    (ns : list nat)
    :  Forall (fun n => n < S (S radix)) ns -> list ascii
    := match ns with
       | [] => fun _ => []
       | m :: ms
         => fun H : Forall (fun n => n < S (S radix)) (m :: ms)
              => nat_decomp_chars radix encoding ms (Forall_inv_tail H) ++
                 [encoding m (Forall_inv H)]
       end.

  Local Theorem nat_decomp_chars_inj
    (radix : nat)
    (encoding : forall n, n < S (S radix) -> ascii)
    (encoding_inj : forall n m (Hn : n < S (S radix)) (Hm : m < S (S radix)), encoding n Hn = encoding m Hm -> n = m)
    : forall
         (ns : list nat)
         (ms : list nat)
         (Hns : Forall (fun n => n < S (S radix)) ns)
         (Hms : Forall (fun m => m < S (S radix)) ms),
         nat_decomp_chars radix encoding ns Hns =
         nat_decomp_chars radix encoding ms Hms ->
         ns = ms.
  Proof.
    exact
      (list_ind
        (fun ns
          => forall
               (ms : list nat)
               (Hns : Forall (fun n => n < S (S radix)) ns)
               (Hms : Forall (fun m => m < S (S radix)) ms),
               nat_decomp_chars radix encoding ns Hns =
               nat_decomp_chars radix encoding ms Hms ->
               ns = ms)
        (list_ind
          (fun ms
            => forall
                 (Hns : Forall (fun n => n < S (S radix)) [])
                 (Hms : Forall (fun m => m < S (S radix)) ms),
                 nat_decomp_chars radix encoding [] Hns =
                 nat_decomp_chars radix encoding ms Hms ->
                 [] = ms)
          (fun _ _ _ => ltac:(reflexivity))
          (fun _ _ _ _ _ H => False_ind _ (app_cons_not_nil _ _ _ H)))
        (fun n ns F
          => list_ind
               (fun ms
                 => forall
                      (Hns : Forall (fun n => n < S (S radix)) (n :: ns))
                      (Hms : Forall (fun m => m < S (S radix)) ms),
                      nat_decomp_chars radix encoding (n :: ns) Hns =
                      nat_decomp_chars radix encoding ms Hms ->
                      (n :: ns) = ms)
               (fun _ _ H => False_ind _ (app_cons_not_nil _ _ _ (eq_sym H)))
               (fun m ms G Hns Hms H
                 => let H0
                      :  ns = ms
                      := F ms
                           (Forall_inv_tail Hns)
                           (Forall_inv_tail Hms)
                           (proj1 (app_inj_tail
                             (nat_decomp_chars radix encoding ns (Forall_inv_tail Hns))
                             (nat_decomp_chars radix encoding ms (Forall_inv_tail Hms))
                             (encoding n (Forall_inv Hns))
                             (encoding m (Forall_inv Hms))
                             H)) in
                    sumbool_ind
                      (fun _ => _)
                      (fun H1 : n = m
                        => ltac:(rewrite H0; rewrite H1; reflexivity) : (n :: ns) = (m :: ms))
                      (fun H1 : n <> m
                        => let H2
                             :  encoding n (Forall_inv Hns) = encoding m (Forall_inv Hms)
                             := proj2 (app_inj_tail
                                  (nat_decomp_chars radix encoding ns (Forall_inv_tail Hns))
                                  (nat_decomp_chars radix encoding ms (Forall_inv_tail Hms))
                                  (encoding n (Forall_inv Hns))
                                  (encoding m (Forall_inv Hms))
                                  H) in
                           False_ind _
                             (H1 (encoding_inj n m (Forall_inv Hns) (Forall_inv Hms) H2)))
                       (Nat.eq_dec n m)))).
  Qed.

  Local Definition nat_chars
    (radix : nat)
    (encoding : forall n, n < S (S radix) -> ascii)
    (n : nat)
    :  list ascii
    := nat_decomp_chars radix encoding
         (proj1_sig (nat_decomp radix n))
         (proj1 (proj2_sig (nat_decomp radix n))).

  Local Theorem nat_chars_inj
    (radix : nat)
    (encoding : forall n, n < S (S radix) -> ascii)
    (encoding_inj : forall n m (Hn : n < S (S radix)) (Hm : m < S (S radix)), encoding n Hn = encoding m Hm -> n = m)
    :  forall n m : nat, nat_chars radix encoding n = nat_chars radix encoding m -> n = m.
  Proof.
    intros n m H.
    assert ((proj1_sig (nat_decomp radix n)) = (proj1_sig (nat_decomp radix m))).
    apply (nat_decomp_chars_inj radix encoding encoding_inj
            (proj1_sig (nat_decomp radix n))
            (proj1_sig (nat_decomp radix m))
            (proj1 (proj2_sig (nat_decomp radix n)))
            (proj1 (proj2_sig (nat_decomp radix m)))
            H).
    apply (nat_decomp_inj radix n m H0).
  Qed.

  Local Definition nat_string
    (radix : nat)
    (encoding : forall n, n < S (S radix) -> ascii)
    (n : nat)
    :  string
    := string_of_list_ascii (nat_chars radix encoding n).

  Local Lemma string_of_list_ascii_inj
    : forall xs ys : list ascii, string_of_list_ascii xs = string_of_list_ascii ys -> xs = ys.
  Proof.
    exact
      (inv_inj _ _
        string_of_list_ascii
        list_ascii_of_string
        list_ascii_of_string_of_list_ascii).
  Qed.

  Local Theorem nat_string_inj
    (radix : nat)
    (encoding : forall n, n < S (S radix) -> ascii)
    (encoding_inj : forall n m (Hn : n < S (S radix)) (Hm : m < S (S radix)), encoding n Hn = encoding m Hm -> n = m)
    :  forall n m : nat, nat_string radix encoding n = nat_string radix encoding m -> n = m.
  Proof.
    intros n m H.
    assert (nat_chars radix encoding n = nat_chars radix encoding m).
    apply (string_of_list_ascii_inj _ _ H).
    assert ((proj1_sig (nat_decomp radix n)) = (proj1_sig (nat_decomp radix m))).
    apply (nat_decomp_chars_inj radix encoding encoding_inj
            (proj1_sig (nat_decomp radix n))
            (proj1_sig (nat_decomp radix m))
            (proj1 (proj2_sig (nat_decomp radix n)))
            (proj1 (proj2_sig (nat_decomp radix m)))
            H0).
    apply (nat_decomp_inj radix n m H1).
  Qed.

  Local Ltac notIn H (* In x xs *) := repeat (destruct H; repeat (discriminate; assumption)).

  Local Ltac encoding_NoDup xs
    := lazymatch xs with
       | nil => exact (NoDup_nil ascii)
       | (cons ?X ?XS)%list
         => exact
              (NoDup_cons X
                (fun H : In X XS => ltac:(notIn H))
                (ltac:(encoding_NoDup XS)))
       end.

  Local Definition decode (encoding : list ascii) (n : nat) : ascii
    := List.nth n encoding " ".

  Local Definition decode_safe (encoding : list ascii) (n : nat) (_ : n < List.length encoding)
    := decode encoding n.

  Local Ltac digit_encoding_inj encoding
    := exact
         (proj1 (NoDup_nth encoding " ")
            ltac:(encoding_NoDup encoding)
           : forall n m : nat,
               n < List.length encoding ->
               m < List.length encoding ->
               decode encoding n = decode encoding m ->
               n = m).

  Local Ltac encoding_inj radix encoding (* radix = encoding - 2 *)
    := exact
         (nat_string_inj
           radix
           (decode_safe encoding)
           (ltac:(digit_encoding_inj encoding))).

  Local Definition binary_encoding_list : list ascii := ["0"; "1"].

  Definition natToBinStr : nat -> string
    := nat_string 0 (decode_safe binary_encoding_list).

  Definition natToBinStr_inj
    :  forall n m, natToBinStr n = natToBinStr m -> n = m
    := ltac:(encoding_inj 0 ["0"; "1"]%list).

  Local Definition decimal_encoding_list : list ascii
    := ["0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"].

  Definition natToDecStr : nat -> string
    := nat_string 8 (decode_safe decimal_encoding_list).

  Definition natToDecStr_inj
    :  forall n m, natToDecStr n = natToDecStr m -> n = m
    := ltac:(encoding_inj 8 ["0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"]%list).

  Local Definition hex_encoding_list : list ascii
    := ["0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; "A"; "B"; "C"; "D"; "E"; "F"].

  Definition natToHexStr : nat -> string
    := nat_string 14 (decode_safe hex_encoding_list).

  Definition natToHexStr_inj
    :  forall n m, natToHexStr n = natToHexStr m -> n = m
    := ltac:(encoding_inj 14 ["0"; "1"; "2"; "3"; "4"; "5"; "6"; "7"; "8"; "9"; "A"; "B"; "C"; "D"; "E"; "F"]%list).

  Local Close Scope char_scope.

  Local Open Scope string_scope.

  (* Goal (natToHexStr 179 = "B3"). Proof. reflexivity. Qed. *)
  Goal (natToDecStr 179 = "179"). Proof. reflexivity. Qed.
  Goal (natToBinStr 179 = "10110011"). Proof. reflexivity. Qed.

  Local Close Scope string_scope.

  Local Close Scope list.

  Set Implicit Arguments.

End nat_string.


Require Import Nat Arith.

Inductive Nat : Type := zero : Nat | succ : Nat -> Nat.

Inductive Lst : Type := cons : Nat -> Lst -> Lst |  nil : Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint plus (plus_arg0 : Nat) (plus_arg1 : Nat) : Nat
           := match plus_arg0, plus_arg1 with
              | zero, n => n
              | succ n, m => succ (plus n m)
              end.

Theorem theorem0 : forall (x : Nat) (y : Nat) (z : Nat), eq (plus (plus x y) z) (plus x (plus y z)).
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.


Require Import Arith.
Open Scope nat_scope.

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

Eval vm_compute in fact 8.