(** * The category ω of (ℕ, ≤), and the chain categories [[n]] *)
Require Import Category.Subcategory.Full.
Require Import Category.Sigma.Univalent.
Require Import Category.Morphisms Category.Univalent Category.Strict.
Require Import HoTT.Basics HoTT.Types HoTT.Spaces.Nat.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope nat_scope.

(** ** Definitions *)
(** Quoting Wikipedia (http://en.wikipedia.org/wiki/Total_order##Chains):

    While chain is sometimes merely a synonym for totally ordered set,
    it can also refer to a totally ordered subset of some partially
    ordered set. The latter definition has a crucial role in Zorn's
    lemma. *)
(** We take the convention that a "chain" is a totally ordered or
    linearly ordered set; the corresponding category on that set has,
    as morphisms, the order relation. *)
(* N.B. The notation here (including that [[n]] have as objects the
   set [{0, 1, ..., n}]) was originally suggested by David Spivak.
   It's possible that we should pick a different or more common
   terminology. *)

Module Export Core.
  (** *** [[ω]], the linear order on ℕ *)
  Definition omega : PreCategory
    := @Build_PreCategory
         nat
         leq
         leq_refl
         (fun x y z p q => leq_trans q p)
         (fun _ _ _ _ _ _ _ => path_ishprop _ _)
         (fun _ _ _ => path_ishprop _ _)
         (fun _ _ _ => path_ishprop _ _)
         _.

  (** *** [[n]], a linear order on a finite set with [n + 1] elements *)
  (** Using [n + 1] elements allows us to agree with the common
      definition of an [n]-simplex, where a 0-simplex is a point, and
      a 1-simplex has two end-points, etc. *)
  Definition chain (n : nat) : PreCategory
    := { m : omega | m <= n }%category.

  (** TODO: Possibly generalize this to arbitrary sets with arbitrary
      (total?) orders on them? *)

  Module Export ChainCategoryCoreNotations.
    Notation "[ n ]" := (chain n) : category_scope.
  End ChainCategoryCoreNotations.
End Core.

Module Export Notations.
  Include ChainCategoryCoreNotations.
End Notations.

Module Utf8.
  Export Notations.

  Notation "[ ∞ ]" := omega : category_scope.
  Notation "[ 'ω' ]" := omega : category_scope.
End Utf8.

Module Export Strict.
  Definition isstrict_omega : IsStrictCategory omega.
  Proof.
    exact _.
  Defined.

  Definition isstrict_chain {n} : IsStrictCategory [n].
  Proof.
    exact _.
  Defined.
End Strict.

Module Export Univalent.
  Global Instance iscategory_omega : IsCategory omega.
  Proof.
    intros s d.
    refine (isequiv_iff_hprop _ _).
    { refine (istrunc_equiv_istrunc _ (issig_isomorphic _ _ _)); simpl; refine _. }
    { intro m; apply leq_antisym; apply m. }
  Defined.

  Definition iscategory_chain {n} : IsCategory [n].
  Proof.
    exact _.
  Defined.
End Univalent.


Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        Infrastructure.

Lemma disjoint_commute : forall A B,
    disjoint A B -> disjoint B A.
Proof.
  introv H.
  induction* H.
Qed.

Lemma disjoint_and : forall A B C,
    disjoint A (styp_and B C) <->
    disjoint A B /\ disjoint A C.
Proof.
  intros.
  splits.
  introv H.
  inductions H; auto_star.
  forwards * (? & ?): IHdisjoint1 B C.
  forwards * (? & ?): IHdisjoint2 B C.

  introv H.
  destruct* H.
Qed.

Lemma co_sound : forall A1 A2 c,
    A1 ≺: A2 ⇝ c ->
    c |= | A1 | ~> | A2 |.
Proof.
  introv Sub.
  induction Sub; simpls*.
Qed.

Lemma elab_sound : forall Γ E A d t,
    has_type Γ E d A t ->
    ∥ Γ ∥ |= t ~: | A |.
Proof.
  introv Typ.
  induction Typ; simpls*.

  lets* : co_sound H.
Qed.

Lemma inference_unique : forall Γ E A1 A2 t1 t2,
    Γ ⊢ E ⇒ A1 ⇝ t1 ->
    Γ ⊢ E ⇒ A2 ⇝ t2 ->
    A1 = A2.
Proof.
  introv Ty1.
  gen_eq Dir : Inf.
  gen A2 t2.
  induction Ty1; introv Eq Ty2; try (inverts* Eq); try (inverts* Ty2).
  - (* t_var *)
    forwards * : binds_unique H0 H4.
  - (* t_app *)
    forwards * : IHTy1_1 H2.
    inverts* H.
  - (* t_and *)
    forwards * : IHTy1_1 H2.
    substs.
    forwards * : IHTy1_2 H4.
    substs*.
  - Case "t_rcd".
    forwards * : IHTy1 H1.
    substs*.
  - Case "t_proj".
    forwards * : IHTy1 H1.
    inverts~ H.
Qed.


(**
Signature of integers modulo 2
 *)
Require Import prelude.all.
Require Import syntax.hit_signature.
Require Import syntax.hit.
Require Import syntax.hit_properties.
Require Import algebras.set_algebra.
Require Import existence.hit_existence.
Require Import displayed_algebras.displayed_algebra.

Open Scope cat.
Opaque HIT_exists hit_ind hit_ind_prop hit_rec.

(** Operations *)
Definition mod2_operations
  : poly_code
  := I + C unitset.

(** Labels of axioms *)
Inductive mod2_ax : Type :=
| mod2_paths : mod2_ax.

(** Arguments for each label *)
Definition mod2_arg
  : mod2_ax → poly_code
  := fun j => I.

(** Some convenient notation for the constructor terms. These represent the operations *)
Definition S
           {P : poly_code}
           (e : endpoint mod2_operations P I)
  : endpoint mod2_operations P I
  := comp (comp e (ι₁ _ _)) constr.

Definition Z
           {P : poly_code}
  : endpoint mod2_operations P I.
Proof.
  refine (comp _ constr).
  refine (comp _ (ι₂ _ _)).
  apply c.
  exact tt.
Defined.

(** The left hand side of each equation *)
Definition mod2_lhs
  : ∏ (j : mod2_ax), endpoint mod2_operations (mod2_arg j) I
  := λ j, S(S(id_e _ I)).

(** The right hand side of each equation *)
Definition mod2_rhs
  : ∏ (j : mod2_ax), endpoint mod2_operations (mod2_arg j) I
  := λ j, id_e _ I.

(** The signature of the integers modulo 2 *)
Definition mod2_signature
  : hit_signature.
Proof.
  use tpair.
  - exact mod2_operations.
  - use tpair.
    + exact mod2_ax.
    + use tpair.
      * exact mod2_arg.
      * split.
        ** exact mod2_lhs.
        ** exact mod2_rhs.
Defined.

(** Integers modulo 2 *)
Definition mod2_HIT
  : HIT mod2_signature
  := HIT_exists mod2_signature.

Definition mod2
  : hSet
  := alg_carrier mod2_HIT.

Definition mod2_S
  : mod2 → mod2
  := λ x, alg_operation mod2_HIT (inl x).

Definition mod2_Z
  : mod2
  := alg_operation mod2_HIT (inr tt).

Definition mod2_mod
  : ∏ (n : mod2), mod2_S (mod2_S n) = n
  := alg_paths mod2_HIT mod2_paths.

(** Induction for integers modulo 2 *)
Section Mod2Ind.
  Context {Y : mod2 → UU}.
  Variable (YZ : Y mod2_Z)
           (YS : ∏ (x : mod2), Y x → Y (mod2_S x))
           (Ymod : ∏ (x : mod2) (y : Y x),
                   transportf Y (mod2_mod x) (YS (mod2_S x) (YS x y)) = y)
           (Yset : ∏ (x : mod2), isaset (Y x)).

  Definition mod2_ind_disp_alg
    : disp_algebra mod2_HIT.
  Proof.
    use make_disp_algebra.
    - intro x.
      use make_hSet.
      + exact (Y x).
      + exact (Yset x).
    - intros x.
      induction x as [x | x].
      + exact (YS x).
      + induction x.
        exact (λ _, YZ).
    - intros j.
      induction j.
      exact Ymod.
  Defined.

  Definition mod2_ind_help
    : disp_algebra_map mod2_ind_disp_alg
    := pr2 mod2_HIT mod2_ind_disp_alg.

  Definition mod2_ind
    : ∏ (x : mod2), Y x
    := pr1 mod2_ind_help.

  Definition mod2_ind_S
    : ∏ (x : mod2), mod2_ind (mod2_S x) = YS x (mod2_ind x).
  Proof.
    intro x.
    apply mod2_ind_help.
  Qed.

  Definition mod2_ind_Z
    : mod2_ind mod2_Z = YZ.
  Proof.
    apply mod2_ind_help.
  Qed.
End Mod2Ind.

(** Induction on propositions for integers modulo 2 *)
Section Mod2IndProp.
  Context {Y : mod2 → UU}.
  Variable (YZ : Y mod2_Z)
           (YS : ∏ (x : mod2), Y x → Y (mod2_S x))
           (Yprop : ∏ (x : mod2), isaprop (Y x)).

  Definition mod2_ind_prop
    : ∏ (x : mod2), Y x.
  Proof.
    use mod2_ind.
    - exact YZ.
    - exact YS.
    - intros x y ; apply Yprop.
    - intro.
      apply isasetaprop.
      apply Yprop.
  Defined.
End Mod2IndProp.

(** Recursion on integers modulo 2 *)
Section Mod2Rec.
  Context {Y : UU}.
  Variable (YZ : Y)
           (YS : Y → Y)
           (Ymod : ∏ (y : Y), YS(YS y) = y)
           (Yset : isaset Y).

  Definition mod2_rec_alg
    : set_algebra mod2_signature.
  Proof.
    use make_algebra.
    - use make_hSet.
      + exact Y.
      + exact Yset.
    - intros x.
      induction x as [x | x].
      + exact (YS x).
      + exact YZ.
    - intros j.
      induction j.
      exact Ymod.
  Defined.

  Definition mod2_rec_help
    : mod2_HIT --> mod2_rec_alg
    := hit_rec mod2_HIT mod2_rec_alg.

  Definition mod2_rec
    : mod2 → Y
    := alg_map_carrier mod2_rec_help.

  Definition mod2_rec_S
    : ∏ (x : mod2), mod2_rec (mod2_S x) = YS (mod2_rec x).
  Proof.
    intro x.
    apply (eqtohomot (pr21 mod2_rec_help)).
  Qed.

  Definition mod2_rec_Z
    : mod2_rec mod2_Z = YZ.
  Proof.
    apply (eqtohomot (pr21 mod2_rec_help)).
  Qed.
End Mod2Rec.

(** Integers modulo 2 are bool *)
Definition bool_to_mod2 : bool → mod2.
Proof.
  intro b.
  induction b.
  - exact (mod2_S mod2_Z).
  - exact mod2_Z.
Defined.

Definition bool_to_mod2_negb
  : ∏ (b : bool), bool_to_mod2 (negb b) = mod2_S (bool_to_mod2 b).
Proof.
  intro b.
  induction b ; cbn.
  - rewrite mod2_mod.
    reflexivity.
  - reflexivity.
Qed.

Lemma negbnegb : ∏ (b : bool), negb(negb b) = b.
Proof.
  induction b ; reflexivity.
Qed.

Definition mod2_to_bool : mod2 → bool
  := mod2_rec false negb negbnegb isasetbool.

Definition bool_to_mod2_to_bool
  : ∏ (b : bool), mod2_to_bool(bool_to_mod2 b) = b.
Proof.
  induction b ; cbn ; unfold mod2_to_bool.
  - rewrite mod2_rec_S, mod2_rec_Z.
    reflexivity.
  - rewrite mod2_rec_Z.
    reflexivity.
Qed.

Definition mod2_to_bool_to_mod2
  : ∏ (x : mod2), bool_to_mod2(mod2_to_bool x) = x.
Proof.
  use mod2_ind_prop.
  - cbn ; unfold mod2_to_bool.
    rewrite mod2_rec_Z.
    reflexivity.
  - cbn ; unfold mod2_to_bool.
    intros x IH.
    rewrite mod2_rec_S.
    rewrite bool_to_mod2_negb.
    rewrite IH.
    reflexivity.
  - intro ; apply mod2.
Qed.

Definition mod2_equiv_bool
  : mod2 ≃ bool.
Proof.
  use make_weq.
  - exact mod2_to_bool.
  - use isweq_iso.
    + exact bool_to_mod2.
    + exact mod2_to_bool_to_mod2.
    + exact bool_to_mod2_to_bool.
Defined.

Definition mod2_is_bool
  : mod2 = boolset.
Proof.
  apply hSet_univalence.
  exact mod2_equiv_bool.
Defined.


Require Export Base.
Require Import Classes.Galois Classes.Monad.

Class Joinable (A B : Type) : Type := join_op : A → A → B.

Arguments join_op : simpl never.
Infix "⊔" := join_op (at level 40).

Class JoinableIdem {A} (J : Joinable A A) : Prop :=
  joinable_idem : ∀ a : A, a ⊔ a = a.

Class JoinableSound {A B A' : Type} {GA : Galois A A'} {GB : Galois B A'}
  (JA : Joinable A B)  : Prop :=
  join_sound : ∀ x y : A, γ x ∪ γ y ⊆ γ (x ⊔ y).

Class joinsecondable M `{MM : Monad M} : Type := {
  joinsecond : ∀ {A : Type}, (A → A) → M A → M A;
  joinsecond_return : ∀ {A} (f : A → A) (x : A),
    joinsecond f (returnM x) =
    returnM (f x);
  joinsecond_bind : ∀ {A B} (f : A → A) (g : B → B)
    (m : M A) (k : A → M B),
    (∀ a, k (f a) = joinsecond g (k a)) →
    joinsecond f m >>= k =
    joinsecond g (m >>= k);
  joinsecond_compose : ∀ {A} (f g : A → A) (m : M A),
   joinsecond (g ∘ f) m = joinsecond f (joinsecond g m);
}.

Class joinsecondable_sound
  (M M' : Type → Type) `{MM : Monad M} `{MM' : Monad M'}
  {JM : joinsecondable M} {GM : ∀ A A', Galois A A' → Galois (M A) (M' A')}
  : Type := {
    joinsecond_sound : ∀ {A A'} {GA : Galois A A'}
      (f : A → A) (m : M A) (m' : M' A'),
      (∀ a a', γ a a' → γ (f a) a') →
      γ m m' → γ (joinsecond f m) m';
}.

Instance functions_joinable {A B C} {JB : Joinable B C} :
Joinable (A → B) (A → C) := λ f, λ g, λ a : A, (f a) ⊔ (g a).

Instance functions_joinable_idem {A} {JA : Joinable A A} :
  JoinableIdem JA → JoinableIdem (functions_joinable (A:=A)).
Proof.
  intros JAI a. unfold join_op, functions_joinable. ext.
  rewrite JAI. reflexivity.
Qed.

Instance functions_joinable_sound {A A' B' B C} {JB : Joinable B C}
  {GA : Galois A A'} {GB : Galois B B'} {GC : Galois C B'} :
  JoinableSound JB →
  JoinableSound (functions_joinable (A:=A) (B:=B) (C:=C)).
Proof.
  Set Printing Implicit.
  intro JS. intros f g f' [Hf | Hf] a a' Ha; apply JS; [left | right]; auto.
Qed.
Hint Resolve functions_joinable_sound : soundness.

Instance top_joinable_r {A B} (JA : Joinable A B) : Joinable A (B+⊤) :=
  λ a : A, λ a' : A, NotTop (a ⊔ a').

Instance top_joinable_r_sound {A A' B} {JA : Joinable A B}
  {GA : Galois A A'} {GB : Galois B A'}:
  JoinableSound JA →
  JoinableSound (top_joinable_r JA).
Proof.
  intros JS a1 a2 a' Hgamma. unfold γ, galois_top, gamma_top.
  apply JS in Hgamma. unfold "⊔", top_joinable_r.
  assumption.
Qed.

Instance top_joinable_l {A B} (JA : Joinable A (B+⊤)) : Joinable (A+⊤) (B+⊤) :=
  λ a, λ a',
    match a, a' with
    | NotTop x, NotTop y => x ⊔ y
    | _, _ => Top
    end.

Instance top_joinable_l_sound {A A' B} {JA : Joinable A (B+⊤)}
  {GA : Galois A A'} {GB : Galois B A'} :
  JoinableSound JA →
  JoinableSound (top_joinable_l JA).
Proof.
  intros JS a1 a2 a' Hgamma.
  destruct a1, a2; try constructor. apply JS in Hgamma. apply Hgamma.
Qed.

Instance unit_joinable : Joinable unit unit := λ _, λ _,  tt.

Instance unit_joinable_idem : JoinableIdem unit_joinable.
Proof.
  intro. destruct a; reflexivity.
Qed.

Instance unit_joinable_sound : JoinableSound unit_joinable.
Proof.
  constructor.
Qed.
Hint Resolve unit_joinable_sound : soundness.

Instance identity_joinable {A B} `{Joinable A B} : Joinable (Identity A) (Identity B) :=
  λ i, λ j,
    match i, j with
    | identity a, identity a' => identity (a ⊔ a')
    end.

Instance identity_joinable_idem {A} {JA : Joinable A A} :
  JoinableIdem JA → JoinableIdem (@identity_joinable A A JA).
Proof.
  intros JAI a. destruct a. cbv. rewrite JAI. reflexivity.
Qed.

Instance pair_joinable {A B C D} {JA : Joinable A C} {JB : Joinable B D} :
  Joinable (A*B)%type (C*D)%type :=
  λ p, λ q, ((fst p) ⊔ (fst q), (snd p) ⊔ (snd q)).

Instance pair_joinable_idem {A A'} {JA : Joinable A A} {JA' : Joinable A' A'} :
  JoinableIdem JA →
  JoinableIdem JA' →
  JoinableIdem (@pair_joinable A A' A A' JA JA').
Proof.
  intros JAI JAI' p. destruct p; cbv.  rewrite JAI, JAI'. reflexivity.
Qed.

Instance pair_joinable_sound {A B C D A' B'}
  {JA : Joinable A C} {JB: Joinable B D}
  {GA : Galois A A'} {GC : Galois C A'}
  {GB : Galois B B'} {GD : Galois D B'} :
  JoinableSound JA →
  JoinableSound JB →
  JoinableSound (@pair_joinable A B C D JA JB).
Proof.
  intros JAS JBS p q p' Hgamma. destruct p, q, p'; simpl.
  constructor; simpl; [apply JAS | apply JBS].
  all: inversion Hgamma; [left | right]; inversion H; subst; assumption.
Qed.
Hint Resolve pair_joinable_sound : soundness.

Instance sum_joinable {A B C D} (JA : Joinable A C) (JB : Joinable B D) :
  Joinable (A+B) ((C+D)+⊤) :=
  λ s1, λ s2,
    match s1, s2 with
    | inl x, inl y => NotTop (inl (x ⊔ y))
    | inr x, inr y => NotTop (inr (x ⊔ y))
    | _, _ => Top
    end.

Instance sum_joinable_idem {A A'} {JA : Joinable A A} {JA' : Joinable A' A'} :
  JoinableIdem JA →
  JoinableIdem JA' →
  JoinableIdem (@top_joinable_l (A+A') (A+A') (sum_joinable JA JA')).
Proof.
  intros JAI JAI' a. destruct a.
  - constructor.
  - unfold join_op. unfold top_joinable_l. destruct s.
    + unfold join_op. unfold sum_joinable. rewrite JAI. reflexivity.
    + unfold join_op. unfold sum_joinable. rewrite JAI'. reflexivity.
Qed.

Instance sum_joinable_sound {A A' B B' C D}
  {JA : Joinable A C} {JB : Joinable B D}
  {GA : Galois A A'} {GB : Galois B B'}
  {GC : Galois C A'} {GD : Galois D B'} :
  JoinableSound JA →
  JoinableSound JB →
  JoinableSound (sum_joinable JA JB).
Proof.
  intros JAS JBS.
  intros s1 s2 s' Hgamma. destruct s1, s2, s'; cbv in *; auto; inversion
  Hgamma as [contra | contra]; inversion contra.
Qed.


(* Revision of my Documents/2012/divalg.v
   Aaron Mansheim
   2013-05-30
   2013-08-22
*)

(*
(* The following commented-out code shows
   how to recreate the standard definitions
   that we use. *)

(* Just enough theory of functions. *)
(* The standard name for this is [f_equal]. *)
Theorem functionality :
  forall {X Y: Type} (f : X -> Y) (x1 x2 : X),
  x1 = x2 -> f x1 = f x2.
Proof. intros X Y f x1 x2 H. rewrite H. reflexivity.
Qed.

(* Just enough propositional logic. *)
Inductive False : Prop := .
Definition not (P:Prop) := P -> False.
Notation "~ x" := (not x) : type_scope.

Inductive and (P Q : Prop) : Prop :=
  conj : P -> Q -> (and P Q).
Notation "P /\ Q" := (and P Q) : type_scope.

Inductive or (P Q : Prop) : Prop :=
  | or_introl : P -> or P Q
  | or_intror : Q -> or P Q.
Notation "P \/ Q" := (or P Q) : type_scope.

(* Just enough digital logic. *)
Inductive bool : Type :=
| true : bool
| false : bool.

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

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

(*
(* "God made the integers. All the rest is the
work of Man." *)
Inductive nat : Type :=
| O : nat
| S : nat -> nat.
*)

(* Just enough order theory. *)
Fixpoint ble_nat (n m : nat) : bool :=
match n with
| O => true
| S n' => match m with
  | O => false
  | S m' => ble_nat n' m'
  end
end.

Definition beq_nat (n m : nat) : bool :=
andb (ble_nat n m) (ble_nat m n).

Theorem beq_nat__eq : forall (n m : nat),
true = beq_nat n m -> n = m.
Proof. intros n. induction n as [|n'].
(* Case n = O. *) intros m. destruct m.
  (* Case m = O. *) intros H. reflexivity.
  (* Case m = S m'. *) intros H. inversion H.
(* Case n = S n'. *) intros m. induction m as [|m'].
  (* Case m = O. *) intros H. inversion H.
  (* Case m = S m'. *) simpl. intros H.
    apply (f_equal S).
    apply (IHn' m'). unfold beq_nat in H.
    simpl in H. unfold beq_nat.
    apply H. Qed.

Fixpoint blt_nat (n m : nat) : bool :=
andb (ble_nat n m) (negb (ble_nat m n)).

(*
(* Just enough arithmetic. *)

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

(* Notation "n + m" := (plus n m) : type_scope. *)

Theorem plus_0_r : forall n : nat,
plus n O = n.
Proof. intros n. induction n as [|n'].
(* Case n = O. *) reflexivity.
(* Case n = S n'. *) simpl. rewrite IHn'.
  reflexivity. Qed.

Theorem plus_n_Sm : forall n m : nat,
S (plus n m) = plus n (S m).
Proof. intros n. induction n as [|n'].
(* Case n = O. *) reflexivity.
(* Case n = S n'. *) simpl. intros m.
  rewrite <- IHn'. reflexivity. Qed.

Theorem plus_comm : forall n m : nat,
plus n m = plus m n.
Proof. intros n. induction n as [|n'].
(* Case n = O. *) intros m. rewrite plus_0_r.
  reflexivity.
(* Case n = S n'. *) intros m. simpl.
  rewrite <- plus_n_Sm. rewrite IHn'.
  reflexivity. Qed.

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

(* Notation "n * m" := (mult n m) : type_scope. *)
*)

Require Import Coq.Arith.Plus.

(* Division. Hooray! *)
Theorem divalg : forall m n : nat, exists q : nat,
  exists r : nat, n = plus (mult q m) r.
Proof. intros m. destruct m as [|m'].
(* Case m = O. *) intros n. exists O. exists n.
  reflexivity.
(* Case m = S m'. *) intros n. induction n as [|n'].
  (* Case n = O. *) exists O. exists O. reflexivity.
  (* Case n = S n'. *) inversion IHn' as [q' Hq'].
    inversion Hq' as [r' Hr'].
    remember (beq_nat r' m') as K.
    destruct K.
    (* Case r' = m'. *) exists (S q'). exists O.
      simpl. rewrite plus_0_r. rewrite plus_comm.
      apply beq_nat__eq in HeqK.
      rewrite HeqK in Hr'. rewrite <- Hr'.
      reflexivity.
    (* Case r' != m'. *) exists q'. exists (S r').
      rewrite <- plus_n_Sm. rewrite <- Hr'.
      reflexivity.
Qed.

Theorem divalgT : forall m n : nat,
(*  {q : nat & {r : nat & n = plus (mult q m) r}}. *)
  {p : nat * nat & n = plus (mult (fst p) m) (snd p)}.
Proof. intros m. destruct m as [|m'].
(* Case m = O. *) intros n. exists (O, n). reflexivity.
(* Case m = S m'. *) intros n. induction n as [|n'].
  (* Case n = O. *) exists (O, O). reflexivity.
  (* Case n = S n'. *) inversion IHn' as [p' Hp'].
    remember (beq_nat (snd p') m') as K.
    destruct K.
    (* Case r' = m'. *) exists (S (fst p'), O).
      simpl. rewrite plus_0_r. rewrite plus_comm.
      apply beq_nat__eq in HeqK.
      rewrite HeqK in Hp'. rewrite <- Hp'.
      reflexivity.
    (* Case r' != m'. *) exists (fst p', S (snd p')). simpl.
      rewrite <- plus_n_Sm. rewrite <- Hp'.
      reflexivity.
Qed.

Extraction Language Haskell.
Set Extraction AccessOpaque. (* Extraneous before or after Coq 8.4pl2 *)
(*
Extract Inductive nat => "Prelude.Integer" ["0" "Prelude.succ"]
  "(\fO fS n -> if n Prelude.== 0 then fO () else fS (n Prelude.- 1))".
Extract Inductive bool => "Prelude.Bool" ["Prelude.True" "Prelude.False"].
*)
Extraction "/Users/aaron/divalgT.hs" divalgT.


(*
 * Copyright (c) 2009-2011, Andrew Appel, Robert Dockins and Aquinas Hobor.
 *
 *)

(** This module defines the standard operators on separation algebras, including
    the operators over pairs, disjoint sums, function spaces, dependent products,
    dependent sums, sub-separation algebras, the discrete separation algebra,
    the trivial unit and void separation algrbras.
*)

Require Import msl.base.
Require Import msl.sepalg.

(** The trivial separation algebra over the unit type.  This SA
    is the identity of the product SA operator, up to isomorphism.
*)

  Instance Join_unit : Join unit := fun x y z => True.

  Instance Perm_unit : Perm_alg unit.
  Proof.
  constructor; auto with typeclass_instances; try firstorder.
  destruct z; destruct z'; auto.
  destruct a; destruct b; auto.
  Qed.

  Instance Sep_unit: Sep_alg unit.
  Proof. apply mkSep with (fun _ => tt); intros;  hnf; auto with typeclass_instances. Qed.

  Instance Sing_unit: Sing_alg unit.
  Proof. apply (mkSing tt); intros; hnf; simpl.
        destruct (core a); destruct tt; auto.
 Qed.

  Instance Canc_unit: Canc_alg unit.
  Proof. repeat intro. auto. hnf; destruct a1; destruct a2; auto. Qed.

  Instance Disj_unit: Disj_alg unit.
  Proof. repeat intro. hnf; destruct a; destruct b;  auto. Qed.

  Instance Cross_unit: Cross_alg unit.
  Proof. repeat intro. exists (tt,tt,tt,tt). repeat split; constructor. Qed.

(** The trivial separation algebra over the void type. This SA
    is the identity of the coproduct (disjoint sum) SA operator, up to isomorphism.
*)

  Inductive Void : Type :=.

  Instance Join_void : Join Void := fun x y z => False.

  Instance Perm_void : Perm_alg Void.
  Proof. constructor; intuition.  Qed.
  Instance Sep_void: Sep_alg Void.
  Proof. apply mkSep with (fun x => x); intros.
      auto with typeclass_instances. destruct t. destruct a.
  Qed.
  Instance Canc_void: Canc_alg Void.
  Proof. repeat intro. destruct b. Qed.
  Instance Disj_void: Disj_alg Void.
  Proof. repeat intro. destruct a. Qed.
  Instance Cross_void: Cross_alg Void.
  Proof. repeat intro. destruct z. Qed.

(** The separation algebra over booleans, e.g. Z/2 with bounded addition *)

  Inductive join_bool : bool -> bool -> bool -> Prop :=
  | jb_fff: join_bool false false false
  | jb_tft: join_bool true false true
  | jb_ftt: join_bool false true true.

  Instance Join_bool : Join bool := join_bool.

  Instance Perm_bool: Perm_alg bool.
  Proof.
    constructor. auto with typeclass_instances.
    intros; inv H; inv H0; hnf; auto.
    repeat intro; hnf in *; subst; auto.
    intros. icase a; icase b; icase d; try solve [elimtype False; (inv H || inv H0)].
    exists c; inv H0; split; constructor.
    exists true; inv H0; split; constructor.
    exists c; inv H0; split; constructor.
    intros; inv H; constructor; auto.
    intros. inv H; inv H0; hnf; auto.
  Qed.

  Instance Sep_bool: Sep_alg bool.
  Proof. apply mkSep with (fun t => false); intros; hnf; auto with typeclass_instances.
     icase t; constructor.
  Defined.

  Instance Sing_bool: Sing_alg bool.
  Proof. apply (mkSing false). intros; simpl; reflexivity.
  Defined.

  Instance Canc_bool: Canc_alg bool.
  Proof. repeat intro. inv H; inv H0; hnf; auto. Qed.

  Instance Disj_bool: Disj_alg bool.
  Proof. repeat intro. inv H; hnf; auto. Qed.

  Instance Cross_bool: Cross_alg bool.
  Proof. repeat intro.
     icase a; icase b; try solve [elimtype False; (try inv H; inv H0)];
    icase z; icase c; icase d; try solve [elimtype False; (try inv H; inv H0)].
     exists (true,false,false,false); repeat split; constructor.
     exists (false,true,false,false); repeat split; constructor.
     exists (false,false,true,false); repeat split; constructor.
     exists (false,false,false,true); repeat split; constructor.
     exists (false,false,false,false); repeat split; constructor.
  Qed.

Section JOIN_EQUIV.
(** The "equivalance" or discrete SA.  In this SA, every element of an arbitrary
    set is made an idempotent element.  We do not add this as a global
    Instance, because it is too widely applicable in cases where we do not
    desire it.
*)

  Instance Join_equiv (A: Type) : Join A := fun x y z => x=y/\y=z.

  Instance Perm_equiv (A: Type) :  @Perm_alg A (Join_equiv A).
  Proof. constructor; intros.
     destruct H; destruct H0; unfold equiv in *; subst; auto.
     destruct H; destruct H0; subst. exists e; split; split; auto.
     destruct H; split; subst; auto.
     destruct H; subst; reflexivity.
  Qed.

  Instance Sep_equiv (A: Type): Sep_alg A.
  Proof. apply mkSep with (fun a => a); intros.
            apply Perm_equiv.
            split; reflexivity.
            destruct H; subst; reflexivity.
  Defined.

  Instance Canc_equiv (A: Type): Canc_alg A.
  Proof. repeat intro. destruct H; destruct H0; subst; reflexivity. Qed.

  Instance Disj_equiv (A: Type): Disj_alg A.
  Proof. repeat intro. destruct H; subst; reflexivity. Qed.

  Instance Cross_equiv (A: Type): Cross_alg A.
  Proof. repeat intro. destruct H; destruct H0; subst.
   exists (z,z,z,z); repeat split; reflexivity.
  Qed.

Lemma join_equiv_refl: forall A (v: A), @join A (Join_equiv A) v v v.
Proof. split; auto. Qed.
End JOIN_EQUIV.

(* WARNING: DO NOT DO    [EXisting Instance Join_equiv]   BECAUSE
   IT WILL MATCH IN UNINTENDED PLACES.  But I think it will do no harm
  to do the following EXisting Instances: *)
Existing Instance Perm_equiv.
Existing Instance Sep_equiv.
Existing Instance Canc_equiv.
Existing Instance Disj_equiv.
Existing Instance Cross_equiv.

Hint Extern 1 (@join _ _ _ _ _) =>
   match goal with |- @join _ (@Join_equiv _) _ _ _ => apply join_equiv_refl end.
(* Hint Resolve @join_equiv_refl. *)

Section SepAlgProp.
  Variable A:Type.
  Variable JOIN: Join A.
  Variable PA: Perm_alg A.
  Variable P:A -> Prop.

  Variable HPjoin : forall x y z, join x y z -> P x -> P y -> P z.

  Instance Join_prop : Join (sig P) :=
                 fun x y z: (sig P) => join (proj1_sig x) (proj1_sig y) (proj1_sig z).

  Instance Perm_prop : Perm_alg (sig P).
  Proof.
   constructor; intros.
    destruct z; destruct z'. apply exist_ext. do 2 red in H,H0; eapply join_eq; eauto.
    do 2 red in H,H0.
    destruct (join_assoc H H0) as [f [? ?]].
     assert (P f) by (apply (HPjoin _ _ _ H1); auto; apply proj2_sig; auto).
     exists (exist P f H3).
     split; auto.
     do 2 red in H; apply join_comm in H; auto.
     do 2 red in H,H0. simpl in H,H0.
     destruct a, b; simpl; apply exist_ext; eapply join_positivity; eauto.
 Qed.

  Instance Sep_prop (SA: Sep_alg A)(HPcore : forall x, P x -> P (core x)): Sep_alg (sig P).
  Proof. repeat intro.
     apply mkSep with (fun a : sig P => exist P (core (proj1_sig a)) (HPcore _ (proj2_sig a)));
      intros. apply Perm_prop.
      do 2 red. destruct t; simpl. apply join_comm; apply core_unit.
      apply exist_ext.
      do 2 red in H. apply join_core in H. apply H.
  Defined.

 Instance Sing_prop  (SA: Sep_alg A)(Sing_A: Sing_alg A)
               (HPcore : forall x, P x -> P (core x)): P the_unit ->
    @Sing_alg (sig P) Join_prop (Sep_prop _ HPcore).
 Proof. intros.
  apply (mkSing (exist P the_unit H)).
  intros. destruct a as  [a Ha]. simpl. apply exist_ext.
  rewrite <- (the_unit_core a).
  apply core_uniq.
 Defined.

  Instance Canc_prop  {CA: Canc_alg A}:  Canc_alg (sig P).
  Proof.
   intros [a Ha] [b Hb] [c1 Hc1] [c2 Hc2].
    unfold join, Join_prop; simpl; intros. apply exist_ext.
  eapply join_canc; eauto.
  Qed.

  Instance Disj_prop {DA: Disj_alg A}: Disj_alg (sig P).
  Proof. intros [a Ha][b Hb].
    unfold join, Join_prop; simpl; intros.
    apply exist_ext. apply join_self; auto.
  Qed.

(*  Instance CS_prop {CS: Cross_alg A}: Cross_alg (sig P). ... not true ...
  Proof. intros [a Ha][b Hb][c Hc][d Hd][z Hz].
    unfold join, Join_prop, equiv, Equiv_prop; simpl; intros.
   destruct (cross_split _ _ _ _ _ H H0) as [[[[ac ad] bc] bd][? [? [? ?]]]].
*)

End SepAlgProp.
Existing Instance Join_prop.
Existing Instance Perm_prop.
Existing Instance Sep_prop.
Existing Instance Sing_prop.
Existing Instance Canc_prop.
Existing Instance Disj_prop.

(** The function space operator from a key type [key] to
    a separation algebra on type [t'].
*)
Section SepAlgFun.
  Variable key: Type.
  Variable t' : Type.
  Variable JOIN: Join t'.
  Variable Pt': Perm_alg t'.

  Instance Join_fun: Join (key -> t') :=
                  fun a b c : key -> t' => forall x, join (a x) (b x) (c x).

  Instance Perm_fun : Perm_alg (key -> t').
  Proof.
   constructor; intros.
   extensionality k.
   apply (join_eq (H k) (H0 k)).
  exists (fun x => projT1 (join_assoc (H x) (H0 x))).
  split; intro k; destruct (join_assoc (H k) (H0 k)) as [f [? ?]]; auto.
  intro k; apply join_comm; apply H.
  extensionality k; specialize (H k); specialize (H0 k).
  apply (join_positivity H H0).
 Qed.

  Instance Sep_fun (SA: Sep_alg t'): Sep_alg (key -> t').
  Proof. apply mkSep with (fun a k => core (a k)); intros.
   intro k; apply core_unit.
   extensionality k; apply @join_core with (b k); auto.
 Defined.

 Instance Sing_fun (SA: Sep_alg t'): Sing_alg t' -> Sing_alg (key -> t').
 Proof.
 intros. apply (mkSing (fun _: key => the_unit)).
 intro a; extensionality k.
 rewrite <- (the_unit_core (a k)).
  unfold core. simpl. auto.
 Defined.

 Instance Canc_fun: Canc_alg t' -> Canc_alg (key -> t').
 Proof. repeat intro. extensionality x; apply (join_canc (H0 x) (H1 x)). Qed.

 Instance Disj_fun: Disj_alg t' -> Disj_alg (key -> t').
 Proof.  repeat intro. extensionality x;  apply H. apply H0. Qed.
End SepAlgFun.

Existing Instance Join_fun.
Existing Instance Perm_fun.
Existing Instance Sep_fun.
Existing Instance Sing_fun.
Existing Instance Canc_fun.
Existing Instance Disj_fun.

(** The dependent product SA operator from an index set [I] into
    a SA indexed by [Pi_j].  The construction of this
    operator either requires constructive witnesses for the unit
    and associativity axioms or some form of the axiom of choice.
    We have chosen to have explicitly constructive witnesses
    and avoid the use of choice.
*)

Section SepAlgPi.
  Variable I:Type.
  Variable Pi: I -> Type.
  Variable pi_J: forall i, Join (Pi i).
  Variable PA:  forall i, Perm_alg (Pi i).

  Let P := forall i:I, Pi i.

  Instance Join_pi: Join P := fun x y z => forall i:I, join (x i) (y i) (z i).

  Instance Perm_pi  : Perm_alg P.
  Proof.
   constructor; intros.
   extensionality i. apply (join_eq (H i) (H0 i)).
   exists (fun i => projT1 (join_assoc (H i) (H0 i))).
   split; intro i; destruct (join_assoc (H i) (H0 i)) as [f [? ?]]; auto.
   intro i; apply join_comm; auto.
   extensionality i. specialize (H i); specialize (H0 i).
   apply (join_positivity H H0).
 Qed.

  Instance Sep_pi (SA : forall i:I, Sep_alg (Pi i)): Sep_alg P.
  Proof. apply mkSep with (fun a i => core (a i)); intros.
   intro i; apply core_unit.
   extensionality i; apply @join_core with (b i); auto.
 Defined.

  Instance Canc_pi: (forall i, Canc_alg (Pi i)) -> Canc_alg P.
  Proof. repeat intro. extensionality i; apply (join_canc (H0 i) (H1 i)). Qed.

  Instance Disj_pi: (forall i, Disj_alg (Pi i)) -> Disj_alg P.
  Proof. repeat intro. extensionality i; apply (join_self (H0 i)). Qed.

End SepAlgPi.
Existing Instance Join_pi.
Existing Instance Perm_pi.
Existing Instance Sep_pi.
Existing Instance Canc_pi.
Existing Instance Disj_pi.

(** The dependent sum operator on SAs.

   Here we have defined the operator under the hypothesis
   that dependent pairs are injective.  This property can
   be proved without axioms provided that
   the index type [I] enjoys decidable equality.

   The property for all types follows as a corollary of
   Streicher's K axiom (or one of its equivalants).
   The K axiom, in turn, follows from the classical axiom.
   Users who are willing to assume K can then use this
   construction at any index type.

   However, in this version, we use inj_pair2, which comes from
   msl.EXtensionality; the proof there relies on
   proof-irrelevance (but not on stronger forms of extensionality).
*)
Section SepAlgSigma.
  Variable I:Type.
  Variable Sigma: I -> Type.
  Variable JOIN: forall i, Join (Sigma i).
  Variable PA: forall i, Perm_alg (Sigma i).
  Let S := sigT Sigma.

  Inductive join_sigma : S -> S -> S -> Prop :=
    j_sig_def : forall (i:I) (a b c:Sigma i),
      join a b c ->
      join_sigma (existT Sigma i a) (existT Sigma i b) (existT Sigma i c).

  Instance Join_sigma: Join S := join_sigma.

  Instance Perm_sigma: Perm_alg S.
  Proof.  constructor; intros.

    (* join_eq *)
    destruct z as [z Hz]. destruct z' as [z' Hz'].
    destruct x as [x Hx]; destruct y as [y Hy].
    assert (z=z').
    inv H. subst.
    apply inj_pair2 in H3; subst.  apply inj_pair2 in H5; subst.
    apply inj_pair2 in H7; subst.
    inv H0; subst; auto. subst z'.
    f_equal.
    inv H; subst.
   apply inj_pair2 in H3; subst.
    apply inj_pair2 in H5; subst.  apply inj_pair2 in H7;  subst.
    inv H0; subst.
   apply inj_pair2 in H3; subst.
    apply inj_pair2 in H4; subst.  apply inj_pair2 in H5;  subst.
    eapply join_eq; eauto.

    (* join_assoc *)
    destruct a as [ai a]; destruct b as [bi b]; destruct c as [ci c];
    destruct d as [di d]; destruct e as [ei e].
    assert (ai = bi /\ bi = ci /\ ci = di /\ di = ei).
    inv H; inv H0; simpl; auto.
    decompose [and] H1; subst; clear H1.
    rename ei into i.
    assert (join a b d).
    inversion H. apply inj_pair2 in H3. apply inj_pair2 in H4. apply inj_pair2 in H5.
    subst; auto.
    assert (join d c e).
    inversion H0. apply inj_pair2 in H4. apply inj_pair2 in H5. apply inj_pair2 in H6.
    subst; auto.
    destruct (join_assoc H1 H2) as [f [? ?]].
    exists (existT Sigma i f).
    split; constructor; auto.

    (* join_comm *)
    inv H; subst.
    constructor.
    apply join_comm; auto.

    (* join_positivity *)
    inv H; inv H0.  apply inj_pair2 in H3.  apply inj_pair2 in H5.  subst.
    f_equal.
    eapply join_positivity; eauto.
 Qed.

  Instance Sep_sigma (SA : forall i:I, Sep_alg (Sigma i)) : Sep_alg S.
  Proof. apply mkSep with
      (fun (a : S) => existT Sigma (projT1 a) (core (projT2 a))).
   intros [i a]. constructor. apply core_unit.
   intros. inv H. f_equal. apply (join_core H0).
 Defined.

  Instance Canc_sigma: (forall i, Canc_alg (Sigma i)) -> Canc_alg S.
  Proof. repeat intro.
       destruct a1; destruct a2; destruct b; destruct c;
       inv H0; inv H1; subst.
     apply inj_pair2 in H5; apply inj_pair2 in H10; apply inj_pair2 in H12;
     apply inj_pair2 in H4; apply inj_pair2 in H6; apply inj_pair2 in H8;
     subst.
    f_equal. apply (join_canc H3 H2).
  Qed.

  Instance Disj_sigma: (forall i, Disj_alg (Sigma i)) -> Disj_alg S.
  Proof. repeat intro.
    destruct a as [ia a]; destruct b as [ib b].
  (* Some weird bug in Coq requires this two-stage inversion process *)
    red in H0. generalize H0; intro. inv H1.
     apply inj_pair2 in H7; apply inj_pair2 in H4; apply inj_pair2 in H5;
     subst. inv H0.
     apply inj_pair2 in H4; apply inj_pair2 in H5; apply inj_pair2 in H6;
     subst.
    f_equal;  apply (join_self H2).
 Qed.
End SepAlgSigma.

Existing Instance Join_sigma.
Existing Instance Perm_sigma.
Existing Instance Sep_sigma.
Existing Instance Canc_sigma.
Existing Instance Disj_sigma.

(** The SA operator on cartesian products. *)
Section SepAlgProd.

  Variables (A: Type) (Ja: Join A).
  Variables (B: Type) (Jb: Join B) .
  Variables (PAa: Perm_alg A)(PAb: Perm_alg B).

  Instance Join_prod : Join (A*B) :=
               fun (x y z:A*B) =>  join (fst x) (fst y) (fst z) /\ join (snd x) (snd y) (snd z).

  Instance Perm_prod  : Perm_alg (A*B).
  Proof.
    constructor.

    (* join_eq *)
    intros [? ?] [? ?] [? ?] [? ?] [? ?] [? ?]; simpl in *.
    f_equal; simpl; eapply join_eq; eauto.

    (* join_assoc *)
    intros [? ?] [? ?] [? ?] [? ?] [? ?] [? ?] [? ?]; simpl in *.
    destruct (join_assoc H H1) as [x [? ?]].
    destruct (join_assoc H0 H2) as [y [? ?]].
    exists (x,y); simpl; repeat split; auto.

    (* join_comm *)
    intros [? ?] [? ?] [? ?] [? ?]; repeat split; simpl in *; apply join_comm; auto.

    (* join_positivity *)
    intros [? ?] [? ?] [? ?] [? ?] [? ?] [? ?]; simpl in *.
    f_equal; simpl; eapply join_positivity; eauto.
 Qed.

  Instance Sep_prod (SAa: Sep_alg A) (SAb: Sep_alg B) : Sep_alg (A*B).
  Proof.
    apply mkSep with (fun a => (core (fst a), core (snd a))).
    intros [? ?]; split; apply core_unit; auto.
    intros [? ?] [? ?] [? ?] [? ?]; f_equal; simpl; eapply join_core; eauto.
  Defined.

  Instance Sing_prod {SAa: Sep_alg A} {SAb: Sep_alg B} {SingA: Sing_alg A}{SingB: Sing_alg B}: Sing_alg (A*B).
  Proof. apply (mkSing  (the_unit, the_unit)).
     intros [? ?].  f_equal; simpl; f_equal; apply the_unit_core.
  Defined.

  Instance Canc_prod {CAa: Canc_alg A} {CAb:  Canc_alg B}: Canc_alg (A*B).
  Proof. intros  [? ?] [? ?] [? ?] [? ?] [? ?] [? ?].
   f_equal; simpl in *; eapply join_canc;eauto.
  Qed.

  Instance Disj_prod {DAa: Disj_alg A} {DAb:  Disj_alg B}: Disj_alg (A*B).
  Proof. intros  [? ?]  [? ?] [? ?].
   f_equal; simpl in *; eapply join_self;eauto.
  Qed.

End SepAlgProd.

Implicit Arguments Perm_prod [[A][Ja][B][Jb]].
Implicit Arguments Sep_prod [[A][Ja][B][Jb]].
Existing Instance Join_prod.
Existing Instance Perm_prod.
Existing Instance Sep_prod.
Existing Instance Canc_prod.
Existing Instance Disj_prod.

(** The SA operator on disjoint sums. *)
Section SepAlgSum.

  Variables (A: Type) (Ja: Join A) .
  Variables (B: Type) (Jb: Join B) .
  Variables (PAa: Perm_alg A) (PAb: Perm_alg B).
  Instance Join_sum : Join (A+B) :=
    (fun (x y z: A+B) =>
    match x, y, z with
    | inl xa, inl ya, inl za => join xa ya za
    | inr xb, inr yb, inr zb => join xb yb zb
    | _, _, _ => False
    end).

  Instance Perm_sum: Perm_alg (A+B).
  Proof.
    constructor.

    intros. icase x; icase y; icase z; icase z'; simpl in *; hnf; simpl;
    f_equal; eapply join_eq; eauto.

    (* join_assoc *)
    intros; destruct e,a,b,c,d; try contradiction; hnf in H,H0;
    destruct (join_assoc H H0) as [f [? ?]].
    exists (inl B f); simpl; auto.
    exists (inr A f); simpl; auto.

    (* join_comm *)
    intros; destruct a; destruct b; destruct c; hnf in H|-*; try contradiction;
    apply join_comm; auto.

    (* join_positivity *)
    intros; hnf in H,H0|-*; destruct a; destruct a'; destruct b; destruct b'; try contradiction;
    f_equal; eapply join_positivity; eauto.
 Qed.

  Instance Sep_sum (SAa: Sep_alg A) (SAb: Sep_alg B): Sep_alg (A+B).
  Proof.
    apply mkSep
      with (fun ab : A+B =>
              match ab with
              | inl a => inl _ (core a)
              | inr b => inr _ (core b)
              end).
    intro a; icase a; hnf; apply core_unit; auto.
    intros; icase a; icase b; icase c; hnf in *; f_equal; eapply join_core; eauto.
  Defined.

  Instance Canc_sum {CAa: Canc_alg A} {CAb:  Canc_alg B}: Canc_alg (A+B).
  Proof. repeat intro. icase a1; icase a2; icase b; icase c; hnf;
    f_equal; eapply join_canc; hnf in *; eauto.
  Qed.

  Instance Disj_sum {DAa: Disj_alg A} {DAb:  Disj_alg B}: Disj_alg (A+B).
  Proof. repeat intro.  hnf in H|-*; icase a; icase b; simpl; f_equal; eapply join_self;eauto.
  Qed.

End SepAlgSum.
Existing Instance Join_sum.
Existing Instance Perm_sum.
Existing Instance Sep_sum.
Existing Instance Canc_sum.
Existing Instance Disj_sum.

(** The SA operator on lists.  Lists are joined componentwise.
 *)
Section sa_list.

  Variables (A: Type) (Ja: Join A)  (PAa: Perm_alg A).

  Inductive list_join : list A -> list A -> list A -> Prop :=
  | lj_nil : list_join nil nil nil
  | lj_cons : forall x y z xs ys zs,
      join x y z ->
      list_join xs ys zs ->
      list_join (x::xs) (y::ys) (z::zs).

  Instance Join_list: Join (list A) := list_join.

  Instance Perm_list: Perm_alg (list A).
  Proof.
    constructor.

    induction x; intros; inv H; inv H0; auto; try constructor.
    f_equal. eapply join_eq; eauto. eapply IHx; eauto.

    induction a; intros;
    destruct b; destruct d; try (elimtype False; inv H; fail);
    destruct c; destruct e; try (elimtype False; inv H0; fail).
    exists nil. split; constructor.
    assert (join a a1 a2) by (inv H; auto).
    assert (join a2 a3 a4) by (inv H0; auto).
    assert (list_join a0 b d) by (inv H; auto).
    assert (list_join d c e) by (inv H0; auto).
    destruct (join_assoc H1 H2) as [z [? ?]].
    destruct (IHa _ _ _ _ H3 H4) as [zs [? ?]].
    exists (z::zs); split; constructor; auto.
    induction a; intros; inv H; constructor; auto.
    apply IHa; auto.

    induction a; intros.
    inv H; inv H0; auto.
    inv H0; inv H.
    f_equal.  eapply join_positivity; eauto.
    eapply IHa; eauto.
 Qed.

  Instance Sep_list (SAa: Sep_alg A) : Sep_alg (list A).
  Proof.
    apply mkSep with (map core).
    induction t; constructor; auto; apply core_unit.
    induction a; intros; inv H; auto. simpl.
    f_equal.  eapply join_core; eauto. eapply IHa; eauto.
 Defined.

  Instance Canc_list {CA: Canc_alg A}: Canc_alg (list A).
  Proof.
   intro. induction a1; intros; inv H; inv H0; auto.
    f_equal.
     eapply join_canc;eauto.
   eapply IHa1; eauto.
  Qed.

  Instance Disj_list {DAa: Disj_alg A} : Disj_alg (list A).
  Proof. intro. induction a; intros; inv H; auto.
    f_equal; auto.
  Qed.

End sa_list.
Existing Instance Join_list.
Existing Instance Perm_list.
Existing Instance Sep_list.
Existing Instance Canc_list.
Existing Instance Disj_list.

Definition raw_join_hom A B (j1: A -> A -> A -> Prop) (j2: B -> B -> B -> Prop) (f:A ->B) :=
  forall x y z,
    j1 x y z ->
    j2 (f x) (f y) (f z).
Implicit Arguments raw_join_hom.

(** The SA induced by the preimage of a section
    in a section-retraction pair.

    This SA construction is used to generate
    a separation algebra over "knots".
 *)
Section sa_preimage.
  Variables A B:Type.
  Variable B_J: Join B.
   Variable PA: Perm_alg B.

  Variable f:A -> B.
  Variable f':B -> A.

  Hypothesis Hf'_f : forall x, f' (f x) = x.
  Hypothesis Hf_f' : join_hom (f oo f').

  Lemma f_inj : forall x y : A,  f x = f y -> x = y.
  Proof.
    intros.
    rewrite <- (Hf'_f x).
    rewrite <- (Hf'_f y).
    rewrite H; auto.
  Qed.

  Instance Join_preimage: Join A :=
          fun a b c => join (f a) (f b) (f c).

  Instance Perm_preimage  : @Perm_alg _  Join_preimage.
  Proof.
    constructor; simpl; intros.
   do 2 red in H,H0.
   apply f_inj.
   apply (join_eq H H0).

    do 2 red in H,H0.
    destruct (join_assoc H H0) as [z [? ?]].
    exists (f' z).
    split;
     [ do 2 red; rewrite <- (Hf'_f b); rewrite <- (Hf'_f c)
     | do 2 red; rewrite <- (Hf'_f a); rewrite <- (Hf'_f e)];
    apply Hf_f'; auto.

    do 2 red in H|-*; auto.

    apply f_inj; eapply join_positivity; eauto.
 Qed.

  Instance Sep_preimage {SAb: Sep_alg B}: Sep_alg A.
  Proof.
    apply mkSep with (fun x : A => f' (core (f x))); intros.

    do 3 red.
   generalize (@Hf_f' (@core B B_J SAb (f t)) (f t) (f t) (core_unit _)); intro.
   unfold compose in H. rewrite Hf'_f in H. auto.
   do 2 red in H.
   f_equal; apply (join_core H).
 Defined.

 Instance Sing_preimage {SAb: Sep_alg B}{Sing_b: Sing_alg B}: Sing_alg A.
 Proof.
 apply (mkSing (f' the_unit)).
 intro.
 simpl. rewrite <- (the_unit_core (f a)). f_equal; apply core_uniq.
 Defined.

 Instance Canc_preimage {SAb: Sep_alg B}{CAb: Canc_alg B} : Canc_alg A.
 Proof. intros ? ? ? ? ? ?. do 2 red in H,H0.
  generalize (join_canc H H0); intro.
  apply f_inj; auto.
 Qed.

 Instance Disj_preimage {SAb: Sep_alg B}{DAb: Disj_alg B} : Disj_alg A.
  Proof. repeat intro. do 2 red in H. apply join_self in H. apply f_inj; auto.
  Qed.

End sa_preimage.

Existing Instance Join_preimage.
Existing Instance Perm_preimage.
Existing Instance Sep_preimage.
Existing Instance Sing_preimage.
Existing Instance Canc_preimage.
Existing Instance Disj_preimage.

Section SepAlgBijection.
  Variables (A: Type) (Ja: Join A)(PAa: Perm_alg A).
  Variable B:Type .

  Variable bij : bijection A B.
  Instance Join_bij: Join B := fun (x y z : B) => join (bij_g _ _ bij x) (bij_g _ _ bij y) (bij_g _ _ bij z).

  Lemma Perm_bij  : Perm_alg B.
  Proof.
    constructor; intros.

    do 2 red in H,H0.
    generalize (join_eq H H0); clear H H0; intro.
    rewrite <- (bij_fg _ _ bij z). rewrite <- (bij_fg _ _ bij z'). f_equal; auto.

    do 2 red in H,H0.
   destruct (join_assoc H H0) as [m [? ?]]; exists (bij_f _ _ bij m); split;
   do 2 red; rewrite bij_gf; auto.

    do 2 red in H|-*. apply join_comm; auto.

    do 2 red in H,H0. rewrite <- (bij_fg _ _ bij a); rewrite <- (bij_fg _ _ bij b).
    f_equal. eapply join_positivity; eauto.
   Qed.

  Instance Sep_bij {SAa: Sep_alg A} : Sep_alg B.
  Proof.
   apply mkSep with (fun b => bij_f _ _ bij (core (bij_g _ _ bij b))); intros.
   do 3 red.
   repeat rewrite bij_gf. simpl. apply core_unit.
   do 2 red in H. f_equal. apply (join_core H).
 Defined.

 Lemma Sing_bij {SAa: Sep_alg A}{SingA: Sing_alg A} : Sing_alg B.
  Proof.
   apply (mkSing (bij_f _ _ bij the_unit)); intros.
   simpl. f_equal. apply  (the_unit_core (bij_g _ _ bij a)).
  Defined.

 Instance Canc_bij {SAa: Canc_alg A} : Canc_alg B.
  Proof. repeat intro.
    do 2 red in H,H0.
    generalize (join_canc H H0);intro.
    rewrite <- (bij_fg _ _ bij a1). rewrite <- (bij_fg _ _ bij a2). rewrite H1; auto.
  Qed.

  Instance  Disj_bij {DAa: Disj_alg A} : Disj_alg B.
  Proof. repeat intro. do 2 red in H.
    apply join_self in H.
   rewrite <- (bij_fg _ _ bij a). rewrite <- (bij_fg _ _ bij b). rewrite H; auto.
  Qed.

End SepAlgBijection.
Existing Instance Join_bij.
Existing Instance Perm_bij.
Existing Instance Sep_bij.
Existing Instance Sing_bij.
Existing Instance Canc_bij.
Existing Instance Disj_bij.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Reflection : Basic Operations on Booleans                               *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibOperation.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Boolean type *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Definition *)

(** From the Prelude:

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

*)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Inhabited *)

Instance Inhab_bool : Inhab bool.
Proof using. constructor. apply (Inhab_of_val true). Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Extensionality *)

(** See [LibReflect] for extensionality of booleans. *)

(* ********************************************************************** *)
(* ################################################################# *)
(** * Boolean Operations *)

(* ================================================================= *)
(** ** Comparison *)

Definition eqb (x y:bool) : bool :=
  match x, y with
  | true, true => true
  | false, false => true
  | _, _ => false
  end.

(** Negation *)

Definition neg (x:bool) : bool :=
  match x with
  | true => false
  | false => true
  end.

(** Conjunction *)

Definition and (x y:bool) : bool :=
  match x, y with
  | true, true => true
  | _, _ => false
  end.

(** Disjunction *)

Definition or (x y:bool) : bool :=
  match x, y with
  | false, false => false
  | _, _ => true
  end.

(** Implication *)

Definition impl (x y:bool) : bool :=
  or x (neg y).

(** Exclusive or *)

Definition xor (x y:bool) : bool :=
  neg (eqb x y).

(** Notations *)

Bind Scope Bool_scope with bool.
Open Scope Bool_scope.

Notation "! x" := (neg x)
  (at level 35, right associativity) : Bool_scope.
Infix "&&" := and
  (at level 40, left associativity) : Bool_scope.
Infix "||" := or
  (at level 50, left associativity) : Bool_scope.

Notation "! x" := (neg x)
  (at level 35, right associativity) : Bool_scope.
Infix "&&" := and
  (at level 40, left associativity) : Bool_scope.
Infix "||" := or
  (at level 50, left associativity) : Bool_scope.

(* ********************************************************************** *)
(** * Boolean Decision Procedure : tactic working by exponential case
      analysis on all variables of type bool. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactic [tautob] *)

(** [tautob] introduces all variables that it can, performs a
    case analysis on all the boolean variables, then splits
    all subgoals and attempts resolution using intuition *)

Ltac tautob_post tt :=
  simpls; try split; intros; try discriminate;
  try solve [ intuition auto_false ].

Ltac tautob_core tt :=
  let rec aux tt :=
    (try intros_all); match goal with
    | b : bool |- _ => destruct b; clear b; aux tt
    | _ => tautob_post tt
    end in
  aux tt.

Tactic Notation "tautob" :=
  tautob_core tt.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Properties of boolean operators *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of [eqb] *)

Lemma eqb_same : forall x,
  eqb x x = true.
Proof using. tautob. Qed.

Lemma eqb_true_l : neutral_l eqb true.
(* forall x, eqb true x = x. *)
Proof using. tautob. Qed.

Lemma eqb_true_r : neutral_r eqb true.
Proof using. tautob. Qed.

Lemma eqb_false_l : forall x,
  eqb false x = neg x.
Proof using. tautob. Qed.

Lemma eqb_false_r : forall x,
  eqb x false = neg x.
Proof using. tautob. Qed.

Lemma eqb_comm : comm eqb.
Proof using. tautob. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of [and] *)

Lemma and_same : idempotent2 and.
Proof using. tautob. Qed.

Lemma and_true_l : neutral_l and true.
Proof using. tautob. Qed.

Lemma and_true_r : neutral_r and true.
Proof using. tautob. Qed.

Lemma and_false_l : absorb_l and false.
Proof using. tautob. Qed.

Lemma and_false_r : absorb_r and false.
Proof using. tautob. Qed.

Lemma and_comm : comm and.
Proof using. tautob. Qed.

Lemma and_assoc : assoc and.
Proof using. tautob. Qed.

Lemma and_or_l : distrib_r and or.
(* forall x y z, (x || y) && z = x && z ||| y && z. *)
Proof using. tautob. Qed.

Lemma and_or_r : distrib_l and or.
(* forall x y z, x && (y ||| z) = x && y ||| x && z. *)
Proof using. tautob. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of [or] *)

Lemma or_same : idempotent2 or.
Proof using. tautob. Qed.

Lemma or_false_l : neutral_l or false.
Proof using. tautob. Qed.

Lemma or_false_r : neutral_r or false.
Proof using. tautob. Qed.

Lemma or_true_l : absorb_l or true.
Proof using. tautob. Qed.

Lemma or_true_r : absorb_r or true.
Proof using. tautob. Qed.

Lemma or_comm : comm or.
Proof using. tautob. Qed.

Lemma or_assoc : assoc or.
Proof using. tautob. Qed.

Lemma or_and_l : distrib_r or and.
(* forall x y z, (x && y) || z = (x || z) && (y || z). *)
Proof using. tautob. Qed.

Lemma or_and_r : distrib_l or and.
(* forall x y z, x || (y && z) = (x || y) && (x || z). *)
Proof using. tautob. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of [neg] *)

Lemma neg_false : ! false = true.
Proof using. auto. Qed.

Lemma neg_true : ! true = false.
Proof using. auto. Qed.

(* --LATER: fix coq display of goals below *)

Lemma neg_and : automorphism neg and or.
(* forall x y, ! (x && y) = (! x) || (! y) *)
Proof using. tautob. Qed.

Lemma neg_or : automorphism neg or and.
(* forall x y, ! (x || y) = (! x) && (! y) *)
Proof using. tautob. Qed.

Lemma neg_neg : involutive neg.
(* forall x, ! (! b) = b *)
Proof using. tautob. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of [if then else] *)

Section PropertiesIf.
Implicit Types x y z : bool.

Lemma if_true : forall x y,
  (if true then x else y) = x.
Proof using. auto. Qed.

Lemma if_false : forall x y,
  (if false then x else y) = y.
Proof using. auto. Qed.

Lemma if_then_else_same : forall x y,
  (if x then y else y) = y.
Proof using. tautob. Qed.

Lemma if_then_true_else_false : forall x,
  (if x then true else false) = x.
Proof using. tautob. Qed.

Lemma if_then_false_else_true : forall x,
  (if x then false else true) = !x.
Proof using. tautob. Qed.

Lemma if_then_true : forall x y,
  (if x then true else y) = x || y.
Proof using. tautob. Qed.

Lemma if_then_false : forall x y,
  (if x then false else y) = (!x) && y.
Proof using. tautob. Qed.

Lemma if_else_false : forall x y,
  (if x then y else false) = x && y.
Proof using. tautob. Qed.

Lemma if_else_true : forall x y,
  (if x then y else true) = (!x) || y.
Proof using. tautob. Qed.

End PropertiesIf.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Properties of [impl] and [xor] *)

(** We do not provide lemmas for [impl] and [xor]
   because these functions can be easily expressed
   in terms of the other operators. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Opacity *)

Opaque eqb neg and or.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Tactics *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactic [rew_neg_neg] *)

(** [rew_neg_neg] is a tactic that simplifies all double negations
    of booleans, i.e. replaces [!!b] with [b]. *)

Hint Rewrite neg_neg : rew_neg_neg.

Tactic Notation "rew_neg_neg" :=
  autorewrite with rew_neg_neg.
Tactic Notation "rew_neg_neg" "~" :=
  rew_neg_neg; auto_tilde.
Tactic Notation "rew_neg_neg" "*" :=
  rew_neg_neg; auto_star.
Tactic Notation "rew_neg_neg" "in" hyp(H) :=
  autorewrite with rew_neg_neg in H.
Tactic Notation "rew_neg_neg" "~" "in" hyp(H) :=
  rew_neg_neg in H; auto_tilde.
Tactic Notation "rew_neg_neg" "*" "in" hyp(H) :=
  rew_neg_neg in H; auto_star.
Tactic Notation "rew_neg_neg" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_neg_neg).
  (* autorewrite with rew_neg_neg in *. *)
Tactic Notation "rew_neg_neg" "~" "in" "*" :=
  rew_neg_neg in *; auto_tilde.
Tactic Notation "rew_neg_neg" "*" "in" "*" :=
  rew_neg_neg in *; auto_star.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactic [rew_bool] *)

(** [rew_bool] simplifies boolean expressions, using rewriting
    lemmas in the database [rew_bool] defined below. *)

Hint Rewrite
  eqb_same eqb_true_l eqb_true_r eqb_false_l eqb_false_r
  neg_false neg_true neg_neg neg_and neg_or
  and_true_l and_true_r and_false_l and_false_r
  or_false_l or_false_r or_true_l or_true_r
  if_true if_false if_then_else_same
  if_then_true_else_false if_then_false_else_true
  if_then_true if_else_false
  if_then_false if_else_true
  : rew_bool.

Tactic Notation "rew_bool" :=
  autorewrite with rew_bool.
Tactic Notation "rew_bool" "~" :=
  rew_bool; auto_tilde.
Tactic Notation "rew_bool" "*" :=
  rew_bool; auto_star.
Tactic Notation "rew_bool" "in" hyp(H) :=
  autorewrite with rew_bool in H.
Tactic Notation "rew_bool" "~" "in" hyp(H) :=
  rew_bool in H; auto_tilde.
Tactic Notation "rew_bool" "*" "in" hyp(H) :=
  rew_bool in H; auto_star.
Tactic Notation "rew_bool" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_bool).
  (* autorewrite with rew_bool in *. *)
Tactic Notation "rew_bool" "~" "in" "*" :=
  rew_bool in *; auto_tilde.
Tactic Notation "rew_bool" "*" "in" "*" :=
  rew_bool in *; auto_star.


Require Import MyTactics.
Require Import DCSyntax.
Require Import DCValues.
Require Import DCReduction.

Require Import LibTactics.
(*|

-----
Types
-----

Here is the syntax of simple types:

|*)

Inductive ty :=
| TyVar (x : var)
| TyBool
| TyFun (A B : ty).

(*|

A type environment is viewed as a total function of variables to types.

In principle, an environment should be modeled as a list of types, which
represents a partial function of variables to types. This introduces a few
complications, and is left as an exercise for the reader.

|*)

Definition tyenv := var -> ty.

(*|

--------------------
The typing judgement
--------------------

The simply-typed lambda-calculus is defined by the following three
typing rules.

|*)

Inductive jt : tyenv -> term -> ty -> Prop :=
| JTVar:
    forall Gamma x T,
    Gamma x = T ->
    jt Gamma (Var x) T
| JTLam:
    forall Gamma t T U,
    jt (T .: Gamma) t U ->
    jt Gamma (Lam t) (TyFun T U)
| JTApp:
    forall Gamma t1 t2 T U,
    jt Gamma t1 (TyFun T U) ->
    jt Gamma t2 T ->
    jt Gamma (App t1 t2) U
| JTDefault:
    forall Gamma ts tj tc T,
    List.Forall (fun ti => jt Gamma ti T) ts ->
    jt Gamma tj TyBool ->
    jt Gamma tc T ->
    jt Gamma (Default ts tj tc) T
| JTConfict:
  forall Gamma T,
  jt Gamma Conflict T
| JTEmpty:
  forall Gamma T,
  jt Gamma Empty T
| JTConst:
  forall Gamma b,
  jt Gamma (Const b) TyBool
.

Theorem jt_ind'
: forall P : tyenv -> term -> ty -> Prop,
    (forall (Gamma : var -> ty) (x : var) (T : ty),
     Gamma x = T -> P Gamma (Var x) T) ->
    (forall (Gamma : var -> ty) (t : term) (T U : ty),
     jt (T .: Gamma) t U ->
     P (T .: Gamma) t U -> P Gamma (Lam t) (TyFun T U)) ->
    (forall (Gamma : tyenv) (t1 t2 : term) (T U : ty),
     jt Gamma t1 (TyFun T U) ->
     P Gamma t1 (TyFun T U) ->
     jt Gamma t2 T -> P Gamma t2 T -> P Gamma (App t1 t2) U) ->
    (forall (Gamma : tyenv) (ts : list term) (tj tc : term) (T : ty),
     List.Forall (fun ti : term => jt Gamma ti T) ts ->
     List.Forall (fun ti : term => P Gamma ti T) ts ->
     jt Gamma tj TyBool ->
     P Gamma tj TyBool ->
     jt Gamma tc T -> P Gamma tc T -> P Gamma (Default ts tj tc) T) ->
    (forall (Gamma: tyenv) (T: ty), P Gamma Conflict T) ->
    (forall (Gamma: tyenv) (T: ty), P Gamma Empty T) ->
    (forall (Gamma: tyenv) (b: bool), P Gamma (Const b) TyBool) ->
    forall (Gamma : tyenv) (t : term) (T : ty), jt Gamma t T -> P Gamma t T.
Proof.
  introv HVar HLam HApp HDefault HConflict HEmpty HConst.
  fix IH 4.
  introv Hjt; case Hjt.
  * now eapply HVar.
  * intros; eapply HLam; try eassumption; now eapply IH.
  * intros; eapply HApp; try eassumption; now eapply IH.
  * intros; eapply HDefault; try solve [try eapply IH; eassumption].
    - (* we make an induction direclty on the Forall, else coq generate a wrongly typed term. *)
      induction H; econstructor.
      { now eapply IH. }
      { now eapply IHForall. }
  * apply HConflict.
  * apply HEmpty.
  * apply HConst.
Qed.

(*|

The tactic [pick_jt t] picks a hypothesis [h] whose statement is a typing
judgement about the term [t], and passes [h] to the Ltac continuation [k].

Thus, for instance, [pick_jt t invert] selects a typing judgement that is
at hand for the term [t] and inverts it.

|*)

Ltac pick_jt t k :=
  match goal with h: jt _ t _ |- _ => k h end.

(*|

The following hint allows `eauto with jt` to apply the above typing rules.

|*)

Global Hint Constructors jt : jt.


Ltac basic :=
    match goal with
    |           |- True => trivial
    | _ : False |- _    => contradiction
    | _ : ?A    |- ?A   => assumption
    end.

Lemma L1 : forall (A:Prop), A -> A.
Proof. intros A p. basic. Qed.

Lemma L2 : True.
Proof. basic. Qed.

Lemma L3 : forall (A:Prop), False -> A.
Proof. intros A H. basic. Qed.

Lemma L4 : forall (A:Prop), ~A -> True.
Proof. intros A H. red in H. trivial. Qed.

Ltac simplify :=
    repeat (intros;
        match goal with
        | H : ~ _               |- _    => red in H
        | H : _ /\ _            |- _    => elim H; do 2 intro; clear H
        | H : _ \/ _            |- _    => elim H; intro; clear H
        | H : ?A /\ ?B -> ?C    |- _    =>
            cut (A -> B -> C);
                [ intro; clear H
                | intros; apply H; split; assumption]
        | H : ?A \/ ?B -> ?C    |- _    =>
            cut (B -> C);
                [ intro; cut (A -> C);
                    [ intro; clear H
                    | intro; apply H; left; assumption ]
                | intro; apply H; right; assumption]
        | H0 : ?A -> ?B, H1 : ?A |- _   =>
            cut B;
                [ intro; clear H0
                | apply H0; assumption
                ]
        end).

Ltac my_auto :=
    simplify; basic ||
    match goal with
    | H : (?A -> ?B) -> ?C |- _     =>
        cut (B -> C);
            [ intro; cut (A -> B);
                [ intro; cut C;
                    [intro; clear H | apply H; assumption ]
                | clear H ]
            | intro; apply H; intro; assumption ]; my_auto
    | H : ~ ?A -> ?B |- _    =>
        cut (False -> B);
            [ intro; cut (A -> False);
                [ intro; cut B;
                    [intro; clear H | apply H; assumption ]
                | clear H ]
            | intro; apply H; red; intro; assumption ]; my_auto
    | |- _ \/ _ => (left; my_auto) || (right; my_auto)
    end.

Lemma L5 : forall (A:Prop), ~A -> True.
Proof. simplify. trivial. Qed.

Lemma L6 : forall (A B:Prop), A /\ B -> True.
Proof. simplify. trivial. Qed.

Lemma L7 : forall (A B:Prop), A \/ B -> True.
Proof. simplify; trivial. Qed.

Lemma L8 : forall (A B C:Prop), (A /\ B -> C) -> True.
Proof. simplify. trivial. Qed.

Lemma L9 : forall (A B C:Prop), (A \/ B -> C) -> True.
Proof.
    intros. cut (B -> C);
        [ intro; cut (A -> C);
            [ intro; clear H
            | intro; apply H; left; assumption ]
        | intro; apply H; right; assumption].
    trivial.
Qed.

Lemma L9' : forall (A B C:Prop), (A \/ B -> C) -> True.
Proof. intros. simplify. trivial. Qed.

Lemma L10 : forall (A B:Prop), (A -> B) -> A -> True.
Proof.
    intros A B H0 H1. cut B;
        [ intro; clear H0
        | apply H0; assumption ].
    trivial.
Qed.

Lemma L10' : forall (A B:Prop), (A -> B) -> A -> True.
Proof. intros. simplify. trivial. Qed.

Lemma L11 : forall (A B C:Prop), ((A -> B) -> C) -> True.
Proof.
    intros A B C H.
    cut (B -> C);
        [ intro; cut (A -> B);
            [ intro; cut C;
                [ intro; clear H
                | apply H; assumption ]
            | clear H]
        | intro; apply H; intro; assumption].
    - trivial.
    - Abort.

Lemma L12 : forall (A B:Prop), (~A -> B) -> True.
Proof.
    intros A B H.
        cut (False -> B);
            [ intro; cut (A -> False);
                [ intro; cut B;
                    [ intro; clear H
                    | apply H; assumption ]
                | clear H]
            | intro; apply H; red; intro; assumption ].
    - trivial.
    - Abort.

Lemma L13 : forall (A B:Prop), A /\ B -> A \/ B.
Proof. my_auto. Qed.

Lemma L14 : forall (A B:Prop), (~ ~ B -> B) -> (A -> B) -> ~ ~ A -> B.
Proof. my_auto. Qed.


Set Implicit Arguments.

Set Default Proof Using "Type".

Class Dec (P: Prop) := dec: {P} + {~P}.
Arguments dec _ {_}.

Class Dec1 {X} (p: X -> Prop) := dec1: forall x, Dec (p x).
Arguments dec1 {_} _ {_}.

Class Dec2 {X Y} (p: X -> Y -> Prop) :=  dec2: forall x, Dec1 (p x).
Arguments dec2 {_} {_} _ {_}.

#[global]
Instance dec_conj P Q: Dec P -> Dec Q -> Dec (P /\ Q).
Proof.
  intros [p|np] [q|nq]; firstorder.
Qed.

#[global]
Instance dec_disj P Q: Dec P -> Dec Q -> Dec (P \/ Q).
Proof.
  intros [p|np] [q|nq]; firstorder.
Qed.

#[global]
Instance dec_imp P Q: Dec P -> Dec Q -> Dec (P -> Q).
Proof.
  intros [p|np] [q|nq]; firstorder.
Qed.

#[global]
Instance dec_iff P Q: Dec P -> Dec Q -> Dec (P <-> Q).
Proof.
  intros; unfold iff; typeclasses eauto.
Qed.

#[global]
Instance dec_neg P: Dec P -> Dec (~ P).
Proof.
  intros [p|np]; firstorder.
Qed.

Lemma iff_dec P Q: Q <-> P -> Dec P -> Dec Q.
Proof. firstorder. Qed.

#[global]
Instance dec1_dec X P (x: X): Dec1 P -> (Dec (P x)).
Proof. intros H; apply H. Qed.

#[global]
Instance dec1_conj X (P: X -> Prop) (Q: X -> Prop): Dec1 P -> Dec1 Q -> Dec1 (fun x => P x /\ Q x).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[global]
Instance dec1_disj X (P: X -> Prop) (Q: X -> Prop): Dec1 P -> Dec1 Q -> Dec1 (fun x => P x \/ Q x).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[global]
Instance dec1_imp X (P: X -> Prop) (Q: X -> Prop): Dec1 P -> Dec1 Q -> Dec1 (fun x => P x -> Q x).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[global]
Instance dec1_iff X (P: X -> Prop) (Q: X -> Prop): Dec1 P -> Dec1 Q -> Dec1 (fun x => P x <-> Q x).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[global]
Instance dec1_neg X (P: X -> Prop): Dec1 P ->  Dec1 (fun x => ~ P x).
Proof.
  intros Hq x; typeclasses eauto.
Qed.

#[global]
Instance dec2_dec1 X Y (P: X -> Y -> Prop)  x: Dec2 P -> Dec1 (P x).
Proof. intros H; apply H. Qed.

#[global]
Instance dec2_dec1' X Y (P: X -> Y -> Prop) y: Dec2 P -> Dec1 (fun x => P x y).
Proof. intros H x; apply H. Qed.

#[global]
Instance dec2_conj X Y (P: X -> Y -> Prop) (Q: X -> Y -> Prop): Dec2 P -> Dec2 Q -> Dec2 (fun x y => P x y /\ Q x y).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[global]
Instance dec2_disj X Y (P: X -> Y -> Prop) (Q: X -> Y -> Prop): Dec2 P -> Dec2 Q -> Dec2 (fun x y => P x y \/ Q x y).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[global]
Instance dec2_imp X Y (P: X -> Y -> Prop) (Q: X -> Y -> Prop): Dec2 P -> Dec2 Q -> Dec2 (fun x y => P x y -> Q x y).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[global]
Instance dec2_iff X Y (P: X -> Y -> Prop) (Q: X -> Y -> Prop): Dec2 P -> Dec2 Q -> Dec2 (fun x y => P x y <-> Q x y).
Proof.
  intros Hp Hq x; typeclasses eauto.
Qed.

#[global]
Instance dec2_neg X Y (P: X -> Y -> Prop): Dec2 P ->  Dec2 (fun x y => ~ P x y).
Proof.
  intros Hq x; typeclasses eauto.
Qed.

Section DecBool.
  Definition decb P {D: Dec P} := if dec P then true else false.
  Arguments decb _ {_}.

  Definition decb1 {X: Type} (Q: X -> Prop) {D: Dec1 Q} x := decb (Q x).
  Arguments decb1 {_} _ {_} _.

  Definition decb2 {X Y: Type} (R: X -> Y -> Prop) {D: Dec2 R} x := decb1 (R x).
  Arguments decb2 {_} {_} _ {_} _.

  Lemma dec_decb (P: Prop) {D: Dec P}: P -> decb P = true.
  Proof.
    unfold decb; destruct (dec P); intuition; discriminate.
  Qed.

  Lemma decb_dec (P: Prop) {D: Dec P}: decb P = true -> P.
  Proof.
    unfold decb; destruct (dec P); intuition; discriminate.
  Qed.

End DecBool.

#[export] Hint Resolve dec_decb : core.
Arguments decb _ {_}.
Arguments decb1 {_} _ {_} _.
Arguments decb2 {_} {_} _ {_} _.

(* Discreteness *)

Class Dis (X: Type) := eq_dec: Dec2 (@eq X).

Notation "a == b" := (eq_dec a b) (at level 60).

#[global]
Instance dis_dec X (D: Dis X): Dec2 (@eq X).
Proof. firstorder. Qed.

#[global]
Instance discrete_False: Dis False.
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
Qed.

#[global]
Instance discrete_unit: Dis unit.
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
Qed.

#[global]
Instance discrete_nat: Dis nat.
Proof.
   unfold Dis, Dec2, Dec1, Dec; decide equality.
Qed.

#[global]
Instance discrete_bool: Dis bool.
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
Qed.

#[global]
Instance discrete_option (X: Type) {D: Dis X}: Dis (option X).
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
  eapply eq_dec.
Qed.

#[global]
Instance discrete_sum (X Y: Type) {D1: Dis X} {D2: Dis Y}: Dis (X + Y).
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
  all: eapply eq_dec.
Qed.

#[global]
Instance discrete_prod (X Y: Type) {D1: Dis X} {D2: Dis Y}: Dis (X * Y).
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
  all: eapply eq_dec.
Qed.

#[global]
Instance discrete_list (X: Type) {D: Dis X}: Dis (list X).
Proof.
  unfold Dis, Dec2, Dec1, Dec; decide equality.
  eapply eq_dec.
Qed.

Require Import List Arith Lia.

#[global]
Instance In_dec (X: Type) {D: Dis X}: Dec2 (@In X).
Proof.
  intros ??; eapply in_dec, eq_dec.
Qed.

Definition dec_in {X: Type} {D: Dis X} (x: X) (A: list X) :=
  dec2 (@In X) x A.

Notation "x 'el' A" := (dec_in x A) (at level 60).

#[global]
Instance lt_dec : Dec2 lt.
Proof.
  intros ??; eapply lt_dec.
Qed.

#[global]
Instance le_dec : Dec2 le.
Proof.
  intros ??; eapply le_dec.
Qed.

#[global]
Instance gt_dec : Dec2 gt.
Proof.
  intros ??; eapply lt_dec.
Qed.

#[global]
Instance ge_dec : Dec2 ge.
Proof.
  intros ??; eapply le_dec.
Qed.

#[global]
Instance dec_all Y (P: Y -> Prop) (D: Dec1 P):
  Dec1 (fun A => forall x, In x A -> P x).
Proof.
  intros A. eapply iff_dec; [symmetry; eapply Forall_forall|].
  unfold Dec; eapply Forall_dec; eauto.
Qed.