(**
 Consequences of classical logic and setoid choice.

 © 2017 Johannes Kloos

 This library requires Coq 8.6. *)

 (*
 This library is free software; you can redistribute it and/or
 modify it under the terms of the GNU Lesser General Public
 License as published by the Free Software Foundation; either
 version 2.1 of the License, or (at your option) any later version.

 This library is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 Lesser General Public License for more details.

 You should have received a copy of the GNU Lesser General Public
 License along with this library; if not, write to the Free Software
 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

 *)
From Coq.Logic Require Import ChoiceFacts.
From Coq.Logic Require Export SetoidChoice.
From Coq.Classes Require Import Equivalence.
From misc Require Import MoreChoice ChoiceResults.
From misc Require Zorn CantorBernsteinSchroeder.

(** * Derived results. *)

Definition gen_setoid_rel_choice A B :=
  gen_setoid_fun_choice_imp_gen_setoid_rel_choice A B (setoid_choice A B).
Definition zorns_lemma {A} R {preR} :=
  Zorn.zorns_lemma classic gen_setoid_rel_choice (A:=A) R (preR := preR).
Definition well_ordering_theorem {A} eqA {equA} :=
  Zorn.well_ordering_theorem classic gen_setoid_rel_choice
    (A:=A) eqA (equA := equA).
Definition setoid_fun_rel_reification A B :=
  setoid_fun_choice_imp_setoid_fun_rel_reification A B
    (setoid_choice A B).
Definition cantor_bernstein_schröder {A} Ae {Aequ: @Equivalence A Ae}
  {B} Be {Bequ: @Equivalence B Be} f f_proper f_inj g g_proper g_inj :=
  @CantorBernsteinSchroeder.cantor_bernstein_schröder A Ae Aequ B Be Bequ
    f f_proper f_inj g g_proper g_inj classic (setoid_fun_rel_reification A B).
Definition dependent_zorn := dependent_zorn (@zorns_lemma).
Definition dependent_nonempty_zorn := dependent_nonempty_zorn classic (@zorns_lemma).
Notation Filter := Filter.
Notation ProperFilter := ProperFilter.
Notation Ultrafilter := Ultrafilter.
Definition ultrafilter {L} Lle := ultrafilter L Lle classic (@zorns_lemma).
Definition ultrafilter_prime {L} Lle {Lpre: PreOrder Lle} := ultrafilter_prime L Lle classic.


From Showtime Require Import Lattice.
Require Import Classes.RelationClasses Setoid SetoidClass.
Require Vectors.Vector.
Import Vectors.Vector.VectorNotations.

Instance JSL_Vec : forall {a n} `{JoinSemiLattice a},
                   JoinSemiLattice (Vector.t a n) := {
  join l1 l2 := Vector.map2 join l1 l2
}.

Definition VecEq {a n} (rel : relation a) : Vector.t a n -> Vector.t a n -> Prop :=
  Vector.rect2 (fun _ _ _ => Prop) True (fun _ v1' v2' r x y => rel x y /\ r).

Instance VecEqReflexive :
  forall {a n} {rel : relation a} `{Reflexive a rel},
  Reflexive (@VecEq a n rel) := {}.
Proof.
  induction x.
  + constructor.
  + split.
    * reflexivity.
    * auto.
Qed.

Instance VecEqSymmetric :
  forall {a n} {rel : relation a} `{Symmetric a rel},
  Symmetric (@VecEq a n rel) := {}.
Proof.
  apply (Vector.rect2 (fun _ x y => VecEq rel x y -> VecEq rel y x)); simpl.
  - auto.
  - intros. destruct H1. split.
    + symmetry. auto.
    + auto.
  Qed.

Definition zip {A B} {n : nat} : Vector.t A n -> Vector.t B n -> Vector.t (A * B) n :=
  Vector.rect2 (fun n _ _ => Vector.t (A * B) n) [] (fun _ _ _ H a b => (a, b) :: H).

Definition unzip {A B} : forall {n : nat}, Vector.t (A * B) n -> (Vector.t A n * Vector.t B n) :=
  fix unzip_fix {n : nat} (v : Vector.t (A * B) n) : (Vector.t A n * Vector.t B n) :=
    match v with
    | []          => ([], [])
    | (a,b) :: v' => let (av, bv) := unzip_fix v'
                     in (a::av, b::bv)
    end.

Lemma unzip_zip :
  forall {A B n} (v1 : Vector.t A n) (v2 : Vector.t B n),
  unzip (zip v1 v2) = (v1, v2).
Proof.
  intros A B. apply Vector.rect2; simpl.
  - auto.
  - intros. rewrite H. auto.
Defined.

Definition rect3_P {A B C}
  (P : forall (n : nat), Vector.t A n -> Vector.t B n -> Vector.t C n -> Type) :
  forall (n : nat), Vector.t A n -> Vector.t (B * C) n -> Type :=
    fun n v1 v2bc =>
      let (v2b, v2c) := unzip v2bc
      in P n v1 v2b v2c.

Lemma rect3_P_zip :
  forall {A B C}
         (P : forall (n : nat), Vector.t A n -> Vector.t B n -> Vector.t C n -> Type)
         (n : nat) (v1 : Vector.t A n) (v2 : Vector.t B n) (v3 : Vector.t C n),
  P n v1 v2 v3 = rect3_P P n v1 (zip v2 v3).
Proof. intros. unfold rect3_P. rewrite unzip_zip. auto. Defined.

Lemma rect3 {A B C}
  (P : forall (n : nat), Vector.t A n -> Vector.t B n -> Vector.t C n -> Type)
  (bas : P 0 [] [] [])
  (rect : forall n v1 v2 v3, P n v1 v2 v3 ->
    forall a b c, P (S n) (a :: v1) (b :: v2) (c :: v3)) :
      forall (n : nat) (v1 : Vector.t A n) (v2 : Vector.t B n) (v3 : Vector.t C n), P n v1 v2 v3.
Proof.
  intros. rewrite rect3_P_zip. apply Vector.rect2.
  - auto.
  - unfold rect3_P. intros. destruct b. simpl.
    destruct (unzip v4). auto.
Defined.

Instance VecEqTransitive :
  forall {a n} {rel : relation a} `{Transitive a rel},
  Transitive (@VecEq a n rel) := {}.
Proof.
  apply (rect3 (fun _ x y z => VecEq rel x y -> VecEq rel y z -> VecEq rel x z)); simpl.
  - auto.
  - intros. destruct H1, H2. split.
    + rewrite H1. auto.
    + auto.
Qed.

Instance VecEqEquivalence :
  forall {a n} {rel : relation a} `{Equivalence a rel},
  Equivalence (@VecEq a n rel) := {}.

Instance VecSetoid :
  forall {a n} `{Setoid a}, Setoid (Vector.t a n) := {
  equiv := @VecEq a n equiv
}.

Instance VJSL_Vec : forall {a n} `{VJoinSemiLattice a},
                     VJoinSemiLattice (Vector.t a n) := {}.
Proof.
- revert n. apply rect3; simpl.
  + auto.
  + intros. split; auto. apply (jslAssociativity a0 b c).
- revert n. apply Vector.rect2; simpl.
  + auto.
  + intros. split; auto. apply (jslCommutativity a0 b).
- intros. induction x; simpl.
  + auto.
  + split; auto. apply (jslIdempotency h).
Qed.

Instance BJSL_Vec : forall {a n} `{BoundedJoinSemiLattice a},
                     BoundedJoinSemiLattice (Vector.t a n) := {
  bottom := Vector.const bottom n
}.

Instance VBJSL_Vec :
  forall {a n} `{VBoundedJoinSemiLattice a},
  VBoundedJoinSemiLattice (Vector.t a n) := {}.
Proof.
  intros. induction x.
  - constructor.
  - destruct H. split; auto.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(***********************************************************************
    Proof of Bertrand's conjecture: Prime.v
                                         Laurent.Thery@inria.fr (2002)
  *********************************************************************)
From Coq Require Import Arith ArithRing Wf_nat.
From Bertrand Require Export Divides.
From Bertrand Require Import Div.

(** Definition of the prime predicate *)
Definition prime (a : nat) : Prop :=
  a <> 1 /\ (forall b : nat, divides b a -> b <> 1 -> a = b).

Lemma not_prime_O : ~ prime 0.
Proof.
red in |- *; intros (H1, H2).
absurd (0 = 2); auto with arith.
apply H2; auto.
apply all_divides_O.
Qed.

Lemma not_prime_1 : ~ prime 1.
Proof.
red in |- *; intros (H1, H2); auto.
Qed.
#[export] Hint Resolve div_ref all_divides_O SO_divides_all not_prime_O not_prime_1 : core.

Lemma lt_prime : forall p : nat, prime p -> 1 < p.
Proof.
intros p; case p.
intros H1; Contradict H1; auto.
intros n; case n; auto with arith.
intros H1; Contradict H1; auto.
Qed.

Lemma prime_2_or_more : forall p : nat, prime p -> p = 2 \/ 2 < p.
Proof.
intros p H; case (lt_prime p H); auto with arith.
Qed.

(** Find the maximal divisor of n *)
Definition max_div (n : nat) :=
  match n with
  | O => 1
  | S O => 1
  | S (S n1) =>
      max_such (fun x => divides x n) (fun x => divides1_dec x n) (S n1)
  end.

Theorem max_div_prop1 : forall n : nat, divides (max_div n) n.
Proof.
intros n; case n.
exists 0; ring.
intros n1; case n1.
exists 1; simpl; ring.
intros n2; unfold max_div in |- *;
 case
  (max_such_prop (fun x : nat => divides x (S (S n2)))
     (fun x : nat => divides1_dec x (S (S n2))) (S n2));
 auto.
exists 1; split; auto with arith.
intros H (H0, H1); auto.
Qed.

Theorem max_div_prop2 :
 forall n p : nat, max_div n < p -> p < n -> ~ divides p n.
Proof.
intros n; case n.
intros p H1 H2; inversion H2.
intros n1; case n1.
intros p H1 H2; inversion H2.
red in |- *; intros (x, H3).
rewrite Nat.mul_comm in H3; discriminate.
inversion H0.
intros n2; unfold max_div in |- *;
 case
  (max_such_prop (fun x : nat => divides x (S (S n2)))
     (fun x : nat => divides1_dec x (S (S n2))) (S n2));
 auto.
exists 1; split; auto with arith.
intros H (H0, H'0) p H1 H2; apply H'0; auto with arith.
Qed.

Theorem max_div_prop3 : forall n : nat, 1 < n -> max_div n < n.
Proof.
intros n; case n.
intros H1; inversion H1.
intros n1; case n1.
simpl in |- *; auto with arith.
intros n2; unfold max_div in |- *;
 case
  (max_such_prop (fun x : nat => divides x (S (S n2)))
     (fun x : nat => divides1_dec x (S (S n2))) (S n2));
 auto.
exists 1; split; auto with arith.
intros H H0 H1; auto with arith.
Qed.

(** Check if a number is prime *)

Definition primeb (n : nat) : bool :=
  match n with
  | O => false
  | S O => false
  | S (S n1) => match max_div n with
                | S O => true
                | _ => false
                end
  end.

Theorem primeb_correct :
 forall n : nat, if primeb n then prime n else ~ prime n.
Proof.
intros n; case n; auto with arith.
simpl in |- *; auto with arith.
intros n1; case n1; auto with arith.
simpl in |- *; auto with arith.
intros n2; generalize (max_div_prop1 (S (S n2)));
 generalize (max_div_prop2 (S (S n2))); generalize (max_div_prop3 (S (S n2)));
 unfold primeb in |- *; case (max_div (S (S n2))).
intros H' H (x, H0); rewrite Nat.mul_comm in H0; discriminate.
intros n3; case n3.
intros H' H H0; split; auto with arith.
intros b; case b.
intros (x, H1); rewrite Nat.mul_comm in H1; discriminate.
intros n0 H1 H2; case (proj1 (Nat.lt_eq_cases (S n0) (S (S n2)))); auto.
apply divides_le; auto with arith.
intros H3; case (H (S n0)); auto with arith.
generalize H2; case n0; simpl in |- *; auto with arith.
intros H4; case H4; auto.
intros n0 H H0 H1; red in |- *; intros (H2, H4).
absurd (S (S n2) <= S (S n0)); auto with arith.
rewrite (H4 (S (S n0))); auto.
Qed.

Definition prime_dec : forall n : nat, {prime n} + {~ prime n}.
Proof.
intros n; generalize (primeb_correct n); case (primeb n).
intros H1; left; auto.
intros H1; right; auto.
Defined.

Theorem divides_prime_divides :
 forall n : nat, 1 < n -> exists p : nat, prime p /\ divides p n.
Proof.
intros n; pattern n in |- *; apply lt_wf_ind.
clear n; intros n Rec H1.
case (Nat.le_gt_cases (max_div n) 1); intros H2.
exists n; split; auto with arith.
split; auto with arith.
contradict H1; rewrite H1; auto with arith.
intros b H H0.
cut (0 <> b); [ intros H4 | idtac ].
case (proj1 (Nat.lt_eq_cases b n)); auto with arith.
apply divides_le; auto with arith.
contradict H1; rewrite H1; auto with arith.
intros H3; contradict H.
apply max_div_prop2; auto with arith.
apply Nat.le_lt_trans with (1 := H2); auto with arith.
generalize H0 H4; case b; auto with arith.
intros HH1 HH2; case HH2; auto.
intros n1; case n1; auto with arith.
intros HH1; case HH1; auto with arith.
contradict H1; case H; intros x H3; rewrite H3; rewrite <- H1;
 rewrite Nat.mul_comm; auto with arith.
case (Rec (max_div n)); auto with arith.
apply max_div_prop3; auto with arith.
intros x (H3, H4); exists x; split; auto.
apply divides_trans with (1 := H4).
apply max_div_prop1; auto with arith.
Qed.

Theorem prime_def1 :
 forall n : nat,
 1 < n -> (forall p : nat, prime p -> p * p <= n -> ~ divides p n) -> prime n.
Proof.
intros n H H0; split; auto with arith.
contradict H; rewrite H; auto with arith.
intros b (x, H1) H2.
case (Nat.le_gt_cases x b); intros H3.
case (Nat.le_gt_cases x 1); intros H4.
case (proj1 (Nat.lt_eq_cases _ _) H4); intros H5.
case (proj1 (Nat.lt_eq_cases x 0)); auto with arith; intros H6.
inversion H6.
contradict H; rewrite H1; rewrite H6; auto with arith.
rewrite H1; rewrite H5; auto with arith.
case (divides_prime_divides x); auto with arith.
intros y (H5, H6); case (H0 y); auto with arith.
cut (y <= x); [ intros H7 | apply divides_le ]; auto.
apply Nat.le_trans with (x * y); auto with arith.
apply le_mult; auto with arith.
rewrite H1; auto with arith.
apply le_mult; auto with arith.
apply Nat.le_trans with (1 := H7); auto.
contradict H4; rewrite H4; auto with arith.
apply divides_trans with (1 := H6); exists b; auto with arith.
rewrite Nat.mul_comm; auto.
case (divides_prime_divides b); auto with arith.
generalize H2 H; rewrite H1; case b; auto with arith.
intros H4; rewrite Nat.mul_comm; intros H5; contradict H5; auto with arith.
intros n1; case n1; auto with arith.
intros H4; case H4; auto with arith.
intros y (H5, H6); case (H0 y); auto with arith.
cut (y <= b); [ intros H7 | apply divides_le ]; auto.
apply Nat.le_trans with (x * y); auto with arith.
apply le_mult; auto with arith.
apply Nat.le_trans with (1 := H7); auto with arith.
rewrite H1; auto with arith.
contradict H; rewrite H1; rewrite H; rewrite Nat.mul_comm; auto with arith.
apply divides_trans with (1 := H6).
exists x; auto with arith.
Qed.

Theorem prime_div_prime :
 forall p n : nat, p < n -> prime p -> divides p n -> ~ prime n.
Proof.
intros p n H1 H2 H3; red in |- *; intros (H4, H5).
Contradict H1; rewrite (H5 p); auto with arith.
Contradict H2; rewrite H2; auto with arith.
Qed.


From Coq Require Import Bool.Bool.
From Coq Require Import Init.Nat.
From Coq Require Import Lists.List.
Require Import Omega.

Record regMem (X : Type) := mkMem
{
    address : nat;
    key : nat;
    value : X
}.

Definition isDesc {X: Type} (a k: nat) (r : regMem X): bool :=
match r with
| {| address := a'; key := k'|} => (eqb a' a) && (eqb k' k)
end.

Definition getAddr {X: Type} (r : regMem X) : nat :=
match r with
| {| address := a'; key := _|} => a'
end.

Definition getKey {X: Type} (r : regMem X) : nat :=
match r with
| {| address := _; key := k'|} => k'
end.

Definition getValue {X: Type} (r : regMem X) : X :=
match r with
| {| value := v|} => v
end.

Definition setValue {X : Type} (v : X) (r : regMem X) : regMem X :=
match r with
| {| address := a; key := k; value := v'|} => mkMem X a k v
end.

Record node (X : Type) := mkNode
{
    crashed : bool;
    regions : list (regMem X);
    regionUnique : forall (r r' : regMem X) regions,
        In r regions /\ In r' regions -> (getAddr r = getAddr r' <-> getKey r = getKey r')
}.

Fixpoint inRegMem {X: Type} (a k : nat) (l : list (regMem X)) : option X :=
match l with
| cons x l' => match isDesc a k x with
               | true => Some (getValue x)
               | false => inRegMem a k l'
               end
| nil => None
end.

Fixpoint setRegMem {X: Type} (a k : nat) (v : X) (prev : list (regMem X)) (l : list (regMem X)) : prod (bool) (list (regMem X)) :=
match l with
| cons x l' => match isDesc a k x with
               | true => pair true (prev ++ (cons (setValue v x) l'))
               | false => setRegMem a k v (prev ++ cons x nil) l'
               end
| nil => pair false prev
end.

Definition frst {X Y : Type} (p : prod X Y) : X :=
match p with
| pair x y => x
end.

Definition scnd {X Y : Type} (p : prod X Y) : Y :=
match p with
| pair x y => y
end.

Definition optionToPair {X : Type} (o : option X) (default : X) : prod bool X :=
match o with
| Some x => pair true x
| None => pair false default
end.

Lemma someEq : forall (X: Type) (a b : X), Some a = Some b <-> a = b.
Proof.
    intros; split; intros.
    - injection H. auto.
    - rewrite H. reflexivity.
Qed.

Lemma someNeq : forall (X: Type) (a b : X), Some a <> Some b <-> a <> b.
Proof.
    intros; split; intros; unfold not; intros.
    - intuition. apply H. rewrite H0. reflexivity.
    - intuition. apply H. apply -> someEq in H0. apply H0.
Qed.

Lemma someEq2 : forall (X: Type) (a : X) (o : option X), Some a = o -> (exists b, o = Some b /\ a = b).
Proof.
    intros.
    exists a.
    rewrite H.
    auto.
Qed.

Lemma inRegMemLemma1 : forall (X: Type) (a k: nat) (r : regMem X) (l : list (regMem X)), inRegMem a k (r :: l) = None -> isDesc a k r = false /\ inRegMem a k l = None.
Proof.
    intros.
    split; simpl in H; destruct (isDesc a k r); auto.
    - discriminate H.
    - discriminate H.
Qed.

Lemma applyList : forall (X : Type) (l l' : list X) (x : X),
l ++ x :: l' = l ++ (cons x nil) ++ l'.
Proof.
    intros.
    induction l.
    - simpl. reflexivity.
    - simpl. reflexivity.
Qed.

Lemma setRegMemLemma : forall (X: Type) (a k: nat) (v : X) (l l' : list (regMem X)),
setRegMem a k v l' l = pair (frst (setRegMem a k v nil l)) (l' ++ scnd (setRegMem a k v nil l)).
Proof.
    intros.
    generalize l'.
    induction l.
    - simpl. intros. rewrite app_nil_r. reflexivity.
    - simpl. destruct (isDesc a k a0).
      + simpl. reflexivity.
      + simpl. intros.
        assert(setRegMem a k v (a0 :: nil) l =
        pair (frst (setRegMem a k v (nil) l))
        ((cons a0 nil) ++ scnd (setRegMem a k v (nil) l))
        ). {
            auto.
        }
        rewrite H.
        simpl.
        assert(l'0 ++ a0 :: scnd (setRegMem a k v nil l) =
        l'0 ++ (a0 :: nil) ++ scnd (setRegMem a k v nil l)).
        {
            apply applyList.
        }
        rewrite H0.
        rewrite app_assoc.
        apply IHl.
Qed.

Lemma setGetNexistRegMem : forall (X: Type) (a k: nat) (v : X) (l l' : list (regMem X)),
inRegMem a k l = None -> setRegMem a k v nil l = pair false l.
Proof.
    intros.
    induction l.
    - simpl. reflexivity.
    - apply inRegMemLemma1 in H. destruct H. simpl. rewrite H.
      apply IHl in H0. rewrite setRegMemLemma. rewrite H0. simpl. reflexivity.
Qed.

Definition qualifiedOption {X: Type} (o : option X) (b: bool) : option X :=
match b with
| true => o
| false => None
end.

Definition read {X: Type} (address key : nat) (n : node X)
: prod (option X) (node X) :=
match n with
| {| regions := l; crashed := c |} => pair (qualifiedOption (inRegMem address key l) (negb c)) n
end.

Definition write {X: Type} (address key : nat) (n : node X)
: option X :=
match n with
| {| regions := l; crashed := c |} => qualifiedOption (inRegMem address key l) (negb c)
end.

Definition isCrashed {X: Type} (node : node X)  : bool :=
match node with
| {|crashed := c|} => c
end.

Definition send {X: Type} (node : node X)  : bool := negb (isCrashed node).
Definition recv {X: Type} (node : node X) : bool := negb (isCrashed node).


Require Export Base.
Require Import Classes.Galois.

Class plus_op (A B : Type) := plus : A → A → B.
Infix "+" := plus.
Class plus_op_sound {A A' : Type} {B B' : Type}
  {GA : Galois A A'} {GB : Galois B B'}
  (PO : plus_op A B) (PO' : plus_op A' B') : Prop :=
  plus_sound : ∀ (a1 a2 : A) (a1' a2' : A'),
  γ a1 a1' →
  γ a2 a2' →
  γ (a1 + a2) (a1' + a2').

Instance nat_plus_op : plus_op nat nat := Nat.add.

Instance top_plus_op_r {A B : Type} (PO : plus_op A B) : plus_op A (B+⊤) :=
  λ a1 : A, λ a2 : A, NotTop (a1 + a2).

Instance top_plus_op_r_sound {A A' B B' : Type}
  {PO : plus_op A B} {PO' : plus_op A' B'}
  {GA : Galois A A'} {GB : Galois B B'} :
  plus_op_sound PO PO' → plus_op_sound (top_plus_op_r PO) PO'.
Proof.
  intro PS. intros a1 a2 a1' a2' Ha Ha'. unfold plus. unfold top_plus_op_r.
  unfold γ; simpl. apply PS; assumption.
Qed.
Hint Resolve top_plus_op_r_sound : soundness.

Instance top_plus_op_l {A B : Type} (PO : plus_op A (B+⊤)) : plus_op (A+⊤) (B+⊤) :=
  λ a1, λ a2, match a1, a2 with
              | Top, _ | _, Top => Top
              | NotTop x, NotTop y => x + y
              end.

Instance top_plus_op_l_sound {A A' B B' : Type}
  {PO : plus_op A (B+⊤)} {PO' : plus_op A' B'}
  {GA : Galois A A'} {GB : Galois B B'} :
  plus_op_sound PO PO' → plus_op_sound (top_plus_op_l PO) PO'.
Proof.
  intro PS. intros a1 a2 a1' a2' Ha Ha'; destruct a1, a2;
  eauto with soundness.
Qed.
Hint Resolve top_plus_op_l_sound : soundness.

Class mult_op (A B : Type) := mult : A → A → B.
Infix "*" := mult.
Class mult_op_sound {A A' B B' : Type} {GA : Galois A A'} {GB : Galois B B'}
  (MO : mult_op A B) (MO' : mult_op A' B') : Prop :=
  mult_sound : ∀ (a1 a2 : A) (a1' a2' : A'),
  γ a1 a1' →
  γ a2 a2' →
  γ (a1 * a2) (a1' * a2').

Instance nat_mult_op : mult_op nat nat := Nat.mul.

Instance top_mult_op_r {A B : Type} (MO : mult_op A B) : mult_op A (B+⊤) :=
  λ a1 : A, λ a2 : A, NotTop (a1 * a2).

Instance top_mult_op_r_sound {A A' B B' : Type}
  {GA : Galois A A'} {GB : Galois B B'}
  {MO : mult_op A B} {MO' : mult_op A' B'} :
  mult_op_sound MO MO' → mult_op_sound (top_mult_op_r MO) MO'.
Proof.
  intro MS. intros a1 a2 a1' a2' Ha Ha'. unfold mult. unfold top_mult_op_r.
  unfold γ; simpl. apply MS; assumption.
Qed.
Hint Resolve top_mult_op_r_sound : soundness.

Instance top_mult_op_l {A B : Type} (MO : mult_op A (B+⊤)) : mult_op (A+⊤) (B+⊤) :=
  λ a1, λ a2, match a1, a2 with
              | Top, _ | _, Top => Top
              | NotTop x, NotTop y => x * y
              end.

Instance top_mult_op_l_sound {A A' B B'} {GA : Galois A A'} {GB : Galois B B'}
  (MO : mult_op A (B+⊤)) (MO' : mult_op A' B') :
  mult_op_sound MO MO' → mult_op_sound (top_mult_op_l MO) MO'.
Proof.
  intro MS. intros a1 a1' a2 a2' Ha Ha'. destruct a1, a1';
  eauto with soundness.
Qed.
Hint Resolve top_mult_op_l_sound : soundness.

Class eq_op (A B : Type) := eq : A → A → B.
Infix "=" := eq.
Class eq_op_sound {A A' B B' : Type} {GA : Galois A A'} {GB : Galois B B'}
  (EO : eq_op A B) (EO' : eq_op A' B') : Prop :=
  eq_sound : ∀ (a1 a2 : A) (a1' a2' : A'),
  γ a1 a1' →
  γ a2 a2' →
  γ (a1 = a2) (a1' = a2').

Instance nat_eq_op : eq_op nat bool := Nat.eqb.

Instance top_eq_op_r {A B : Type} (EO : eq_op A B) : eq_op A (B+⊤) :=
  λ a1 : A, λ a2 : A, NotTop (a1 = a2).

Instance top_eq_op_r_sound {A A' B B'} {GA : Galois A A'} {GB : Galois B B'}
  (EO : eq_op A B) (EO' : eq_op A' B') :
  eq_op_sound EO EO' → eq_op_sound (top_eq_op_r EO) EO'.
Proof.
  intro ES. intros a1 a2 a1' a2' Ha Ha'. unfold eq, top_eq_op_r.
  unfold γ; simpl. eauto with soundness.
Qed.
Hint Resolve top_eq_op_r_sound : soundness.

Instance top_eq_op_l {A B : Type} (EO : eq_op A (B+⊤)) : eq_op (A+⊤) (B+⊤) :=
  λ a1, λ a2, match a1, a2 with
              | Top, _ | _, Top => Top
              | NotTop x, NotTop y => x = y
              end.

Instance top_eq_op_l_sound {A A' B B'} {GA : Galois A A'} {GB : Galois B B'}
  (EO : eq_op A (B+⊤)) (EO' : eq_op A' B') :
  eq_op_sound EO EO' → eq_op_sound (top_eq_op_l EO) EO'.
Proof.
  intro ES. intros a1 a2 a1' a2' Ha Ha'. destruct a1; simpl.
  - reflexivity.
  - destruct a2; try reflexivity. apply ES; assumption.
Qed.
Hint Resolve top_eq_op_l_sound : soundness.

Class leb_op (A B : Type) := leb : A → A → B.
Class leb_op_sound {A A' B B'} `{Galois A A', Galois B B'}
  (LO : leb_op A B) (LO' : leb_op A' B') : Prop :=
  leb_sound : ∀ (a1 a2 : A) (a1' a2' : A'),
  γ a1 a1' →
  γ a2 a2' →
  γ (leb a1 a2) (leb a1' a2').

Instance nat_leb_op : leb_op nat bool := Nat.leb.

Instance top_leb_op_r {A B : Type} (LO : leb_op A B) : leb_op A (B+⊤) :=
  λ a1, λ a2, NotTop (leb a1 a2).

Instance top_leb_op_r_sound {A A' B B'} {GA : Galois A A'} {GB : Galois B B'}
  (LO : leb_op A B) (LO' : leb_op A' B') :
  leb_op_sound LO LO' → leb_op_sound (top_leb_op_r LO) LO'.
Proof.
  intro LS. intros a1 a2 a1' a2' Ha Ha'. unfold leb, top_leb_op_r.
  unfold γ;simpl. apply LS; assumption.
Qed.
Hint Resolve top_leb_op_r_sound : soundness.

Instance top_leb_op_l {A B : Type} (LO : leb_op A (B+⊤)) : leb_op (A+⊤) (B+⊤) :=
  λ a1, λ a2, match a1, a2 with
              | Top, _ | _, Top => Top
              | NotTop x, NotTop y => leb x y
              end.

Instance top_leb_op_l_sound {A A' B B'} {GA : Galois A A'} {GB : Galois B B'}
  (LO : leb_op A (B+⊤)) (LO' : leb_op A' B') :
  leb_op_sound LO LO' → leb_op_sound (top_leb_op_l LO) LO'.
Proof.
  intro LS. intros a1 a2 a1' a2' Ha Ha'. destruct a1, a2; simpl; eauto with
    soundness.
Qed.
Hint Resolve top_leb_op_l_sound : soundness.