(* We hide the implementation of generators behind this interface. The
   rest of the framework and user code are agnostic to the internal
   representation of generators. The proof organization/abstraction
   tries to follow this code organization/abstraction. We need to
   expose quite a bit on the proof side for this to work though. *)

Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".

Require Import ZArith List.
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssrfun ssrbool ssrnat.

From ExtLib.Structures Require Export
     Functor Applicative Monads.
Import MonadNotation.
Open Scope monad_scope.

From QuickChick Require Import
     RandomQC RoseTrees Sets.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Set Bullet Behavior "Strict Subproofs".

Import ListNotations.

Definition isNone {T : Type} (u : option T) :=
  match u with
    | Some _ => false
    | None => true
  end.

Lemma randomSplit_codom : codom randomSplit <--> setT.
Proof.
by apply/subset_eqP; split=> // [[s1 s2]] _; apply: randomSplitAssumption.
Qed.

Module Type Sig.

  (** * Type of generators *)

  Parameter G : Type -> Type.

  (** * Primitive generator combinators *)

  Parameter returnGen  : forall {A : Type}, A -> G A.
  (* TODO: Add dependent combinator *)
  Parameter bindGen :  forall {A B : Type}, G A -> (A -> G B) -> G B.
  Parameter run  : forall {A : Type}, G A -> nat -> RandomSeed -> A.
  Parameter fmap : forall {A B : Type}, (A -> B) -> G A -> G B.
  Parameter apGen : forall {A B : Type}, G (A -> B) -> G A -> G B.
  Parameter sized : forall {A: Type}, (nat -> G A) -> G A.
  Parameter resize : forall {A: Type}, nat -> G A -> G A.
  Parameter promote : forall {A : Type}, Rose (G A) -> G (Rose A).
  Parameter choose : forall {A : Type} `{ChoosableFromInterval A}, (A * A) -> G A.
  Parameter sample : forall {A : Type}, G A -> list A.

  (* LL: The abstraction barrier is annoying :D *)
  Parameter variant : forall {A : Type}, SplitPath -> G A -> G A.
  Parameter reallyUnsafePromote : forall {r A:Type}, (r -> G A) -> G (r -> A).

  Parameter promoteVariant : forall {A B : Type} (a : A) (f : A -> SplitPath) (g : G B) size
                               (r r1 r2 : RandomSeed),
                               randomSplit r = (r1,r2) ->
                               run (reallyUnsafePromote (fun a => variant (f a) g)) size r a =
                               run g size (varySeed (f a) r1).

  (** * Semantics of generators *)

  (* Set of outcomes semantics definitions (repeated below) *)
  Definition semGenSize {A : Type} (g : G A) (size : nat) : set A :=
    codom (run g size).
  Definition semGen {A : Type} (g : G A) : set A :=
    \bigcup_size semGenSize g size.

  (* Set of outcomes semantics for generators that can fail
     (ignoring [None] as a value). *)
  Definition semGenSizeOpt {A : Type} (g : G (option A)) (s : nat) : set A :=
    somes (semGenSize g s).

  Definition semGenOpt {A : Type} (g : G (option A)) : set A :=
    somes (semGen g).

  Parameter semGenOpt_equiv : forall {A} (g : G (option A)),
    semGenOpt g <--> \bigcup_s semGenSizeOpt g s.

  Parameter bindGen' : forall {A B : Type} (g : G A),
                       (forall (a : A), (a \in semGen g) -> G B) -> G B.

  Arguments bindGen' [A] [B] _ _.

  (** * Properties of generators *)

  (** A generator is [Unsized] if its semantics does not depend on the runtime size *)
  (* begin Unsized *)
  Class Unsized {A} (g : G A) :=
    unsized : forall s1 s2, semGenSize g s1 <--> semGenSize g s2.
  (* end Unsized *)

  (** Sized generators monotonic in the size parameter *)
  Class SizedMonotonic {A} (g : nat -> G A) :=
    sizeMonotonic : forall s s1 s2,
      s1 <= s2 ->
      semGenSize (g s1) s \subset semGenSize (g s2) s.

  (** Sized generators of option type monotonic in the size parameter *)
  Class SizedMonotonicOpt {A} (g : nat -> G (option A)) :=
    sizeMonotonicOpt : forall s s1 s2,
      s1 <= s2 ->
      semGenSizeOpt (g s1) s \subset semGenSizeOpt (g s2) s.

  (** Generators monotonic in the runtime size parameter *)
  Class SizeMonotonic {A} (g : G A) :=
    monotonic : forall s1 s2,
      s1 <= s2 ->
      semGenSize g s1 \subset semGenSize g s2.

  (** Generators monotonic in the runtime size parameter *)
  Class SizeMonotonicOpt {A} (g : G (option A)) :=
    monotonicOpt : forall s1 s2,
      s1 <= s2 ->
      semGenSizeOpt g s1 \subset semGenSizeOpt g s2.

  (** Generators monotonic in the runtime size parameter *)
  Class SizeAntiMonotonicNone {A} (g : G (option A)) :=
    monotonicNone : forall s1 s2,
      s1 <= s2 ->
      isNone :&: semGenSize g s2 \subset isNone :&: semGenSize g s1.

  (* CH: Why does Unsized need a _ when A is marked as implict! *)
  Parameter unsized_alt_def :
    forall A (g : G A) `{Unsized _ g},
    forall s, semGenSize g s <--> semGen g.

  (* begin unsizedMonotonic *)
  Declare Instance unsizedMonotonic : forall {A} (g : G A), Unsized g -> SizeMonotonic g.
  (* end unsizedMonotonic *)

  (** *  Semantics of combinators *)

  Parameter semReturn :
    forall A (x : A), semGen (returnGen x) <--> [set x].
  Parameter semReturnSize :
    forall A (x : A) size, semGenSize (returnGen x) size <--> [set x].

  Declare Instance unsizedReturn {A} (x : A) : Unsized (returnGen x).
  Declare Instance returnGenSizeMonotonic {A} (x : A) : SizeMonotonic (returnGen x).
  Declare Instance returnGenSizeMonotonicOpt {A} (x : option A) : SizeMonotonicOpt (returnGen x).

  Parameter semBindSize :
    forall A B (g : G A) (f : A -> G B) (size : nat),
      semGenSize (bindGen g f) size <-->
                 \bigcup_(a in semGenSize g size) semGenSize (f a) size.

  Parameter semBindSize_subset_compat :
    forall {A B : Type} (g g' : G A) (f f' : A -> G B),
      (forall s, semGenSize g s \subset semGenSize g' s) ->
      (forall x s, semGenSize (f x) s \subset semGenSize (f' x) s) ->
      (forall s, semGenSize (bindGen g f) s \subset semGenSize (bindGen g' f') s).

  Parameter semBindSizeOpt_subset_compat :
    forall {A B : Type} (g g' : G A) (f f' : A -> G (option B)),
      (forall s, semGenSize g s \subset semGenSize g' s) ->
      (forall x s, isSome :&: semGenSize (f x) s \subset isSome :&: semGenSize (f' x) s) ->
      (forall s, isSome :&: semGenSize (bindGen g f) s \subset isSome :&: semGenSize (bindGen g' f') s) .

  Parameter monad_leftid :
    forall {A B : Type} (a: A) (f : A -> G B),
      semGen (bindGen (returnGen a) f) <--> semGen (f a).
  Parameter monad_rightid :
    forall {A : Type} (g : G A),
      semGen (bindGen g returnGen) <--> semGen g.
  Parameter monad_assoc:
    forall {A B C : Type} (ga : G A) (fb : A -> G B) (fc : B -> G C),
      semGen (bindGen (bindGen ga fb) fc) <-->
             semGen (bindGen ga (fun a => bindGen (fb a) fc)).

  (* I'm not sure how this universal quantifier will behave *)
  (* begin bindUnsized *)
  Declare Instance bindUnsized {A B} (g : G A) (f : A -> G B)
          `{Unsized _ g} `{forall x, Unsized (f x)} : Unsized (bindGen g f).
  (* end bindUnsized *)

  (* XXX these will always succeed and they have the same priority *)
  Declare Instance bindMonotonic
          {A B} (g : G A) (f : A -> G B)
          `{SizeMonotonic _ g} `{forall x, SizeMonotonic (f x)} :
    SizeMonotonic (bindGen g f).

  Declare Instance bindMonotonicOpt
          {A B} (g : G A) (f : A -> G (option B))
          `{SizeMonotonic _ g} `{forall x, SizeMonotonicOpt (f x)} :
    SizeMonotonicOpt (bindGen g f).

  Declare Instance bindMonotonicStrong
          {A B} (g : G A) (f : A -> G B)
          `{SizeMonotonic _ g} `{forall x, semGen g x -> SizeMonotonic (f x)} :
    SizeMonotonic (bindGen g f).

  Declare Instance bindMonotonicOptStrong
          {A B} (g : G A) (f : A -> G (option B)) `{SizeMonotonic _ g}
          `{forall x, semGen g x -> SizeMonotonicOpt (f x)} :
    SizeMonotonicOpt (bindGen g f).

  Parameter semBindUnsized1 :
    forall A B (g : G A) (f : A -> G B) `{Unsized _ g},
      semGen (bindGen g f) <--> \bigcup_(a in semGen g) semGen (f a).

  Parameter semBindUnsized2 :
    forall A B (g : G A) (f : A -> G B) `{forall a, Unsized (f a)},
      semGen (bindGen g f) <--> \bigcup_(a in semGen g) semGen (f a).

  Parameter semBindSizeMonotonic :
  forall {A B} (g : G A) (f : A -> G B)
         `{SizeMonotonic _ g} `{forall a, SizeMonotonic (f a)},
    semGen (bindGen g f) <--> \bigcup_(a in semGen g) semGen (f a).

  Parameter semBindSizeMonotonicIncl_r :
    forall {A B} (g : G A) (f : A -> G (option B)) (s1 : set A) (s2 : A -> set B),
      semGen g \subset s1 ->
      (forall x, semGen (f x) \subset Some @: (s2 x) :|: [set None]) ->
      semGen (bindGen g f) \subset Some @: (\bigcup_(a in s1) s2 a)  :|: [set None].

  Parameter semBindSizeMonotonicIncl_l :
    forall {A B} (g : G A) (f : A -> G (option B)) (s1 : set A) (fs : A -> set B)
      `{Hg : SizeMonotonic _ g}
      `{Hf : forall a, SizeMonotonicOpt (f a)},
    s1 \subset semGen g ->
    (forall x, Some @: (fs x) \subset semGen (f x)) ->
    (Some @: \bigcup_(a in s1) (fs a)) \subset semGen (bindGen g f).

  Parameter semFmap :
    forall A B (f : A -> B) (g : G A),
      semGen (fmap f g) <--> f @: semGen g.

  Parameter semFmapSize :
    forall A B (f : A -> B) (g : G A) (size : nat),
      semGenSize (fmap f g) size <--> f @: semGenSize g size.

  Declare Instance fmapUnsized {A B} (f : A -> B) (g : G A) `{Unsized _ g} :
    Unsized (fmap f g).

  Declare Instance fmapMonotonic
          {A B} (f : A -> B) (g : G A) `{SizeMonotonic _ g} :
    SizeMonotonic (fmap f g).

  Parameter semChoose :
    forall A `{RandomQC.ChoosableFromInterval A} (a1 a2 : A),
      RandomQC.leq a1 a2 ->
      (semGen (choose (a1,a2)) <--> [set a | RandomQC.leq a1 a && RandomQC.leq a a2]).

  Parameter semChooseSize :
    forall A `{RandomQC.ChoosableFromInterval A} (a1 a2 : A),
      RandomQC.leq a1 a2 ->
      forall size, (semGenSize (choose (a1,a2)) size <-->
              [set a | RandomQC.leq a1 a && RandomQC.leq a a2]).

  Declare Instance chooseUnsized A `{RandomQC.ChoosableFromInterval A} (a1 a2 : A) :
    Unsized (choose (a1, a2)).

  Parameter semSized :
    forall A (f : nat -> G A),
      semGen (sized f) <--> \bigcup_s semGenSize (f s) s.

  Parameter semSizedSize :
    forall A (f : nat -> G A) s,
      semGenSize (sized f) s <--> semGenSize (f s) s.

  (* TODO change name *)

  Parameter semSized_alt :
    forall A (f : nat -> G A) `{forall n, SizeMonotonic (f n)},
      (forall n m s,  n <= m -> semGenSize (f n) s \subset semGenSize (f m) s) ->
      semGen (sized f) <--> \bigcup_n (semGen (f n)).

  Parameter semSized_opt :
    forall A (f : nat -> G (option A)) (H : forall n, SizeMonotonicOpt (f n)) (H' : SizedMonotonicOpt f),
      isSome :&: semGen (sized f) <--> isSome :&: \bigcup_n (semGen (f n)).

  Declare Instance sizedSizeMonotonic
          A (gen : nat -> G A) `{forall n, SizeMonotonic (gen n)} `{SizedMonotonic A gen} :
    SizeMonotonic (sized gen).

  Declare Instance sizedSizeMonotonicOpt
          A (gen : nat -> G (option A)) `{forall n, SizeMonotonic (gen n)} `{SizedMonotonicOpt A gen} :
    SizeMonotonicOpt (sized gen).

  Parameter semResize :
    forall A (n : nat) (g : G A),
      semGen (resize n g) <--> semGenSize g n.

  Parameter semSizeResize :
    forall A (s n : nat) (g : G A),
      semGenSize (resize n g) s <--> semGenSize g n.

  Declare Instance unsizedResize {A} (g : G A) n :
    Unsized (resize n g).

  (* This (very concrete) spec is needed to prove shrinking *)
  Parameter semPromote :
    forall A (m : Rose (G A)),
      semGen (promote m) <-->
      codom2 (fun size seed => fmapRose (fun g => run g size seed) m).

  Parameter semPromoteSize :
    forall (A : Type) (m : Rose (G A)) n,
      semGenSize (promote m) n <-->
      (fun t : Rose A =>
         exists (seed : RandomSeed),
           fmapRose (fun g : G A => run g n seed) m = t).

  (* Those are too concrete, but I need them to prove shrinking.
   Does this reveal a weakness in our framework?
   Should we try to get rid of this?
   This is expected since the spec of promote is too concrete. *)

  Parameter runFmap :
    forall (A B : Type) (f : A -> B) (g : G A) seed size,
      run (fmap f g) seed size = f (run g seed size).

  Parameter runPromote :
    forall A (m : Rose (G A)) seed size,
      run (promote m) seed size = fmapRose (fun (g : G A) => run g seed size) m.

  Parameter semFmapBind :
    forall A B C (g : G A) (f1 : B -> C) (f2 : A -> G B),
      semGen (fmap f1 (bindGen g f2)) <-->
      semGen (bindGen g (fun x => fmap f1 (f2 x))).

  Instance Functor_G : Functor G := {
    fmap A B := fmap;
  }.

  Instance Applicative_G : Applicative G := {
    pure A := returnGen;
    ap A B := apGen;
  }.

  Instance Monad_G : Monad G := {
    ret A := returnGen;
    bind A B := bindGen;
  }.

  (** Delay evaluation of a generator in a CBV language. *)
  Parameter thunkGen : forall {A}, (unit -> G A) -> G A.

  (** [thunkGen] doesn't change semantics. *)
  Parameter semThunkGenSize : forall A (f : unit -> G A) s,
      semGenSize (thunkGen f) s <--> semGenSize (f tt) s.

  Parameter semThunkGen : forall A (f : unit -> G A),
      semGen (thunkGen f) <--> semGen (f tt).

  Declare Instance thunkGenUnsized {A} (f : unit -> G A)
          `{Unsized _ (f tt)} : Unsized (thunkGen f).

  Declare Instance thunkGenSizeMonotonic {A} (f : unit -> G A)
          `{SizeMonotonic _ (f tt)} : SizeMonotonic (thunkGen f).

  Declare Instance thunkGenSizeMonotonicOpt {A} (f : unit -> G (option A))
          `{SizeMonotonicOpt _ (f tt)} : SizeMonotonicOpt (thunkGen f).

  Declare Instance thunkGenSizeAntiMonotonicNone {A} (f : unit -> G (option A))
          `{SizeAntiMonotonicNone _ (f tt)} : SizeAntiMonotonicNone (thunkGen f).

  (** A notation around [thunkGen] for convenience. *)
  Notation etaG g := (thunkGen (fun _ => g)).

End Sig.


Global Generalizable All Variables.

Require Export Morphisms Setoid.
Require Export List.
Export ListNotations.

Require Export structure.

Notation "x .1" := (projT1 x) (at level 3).
Notation "x .2" := (projT2 x) (at level 3).
Notation "( x ; y )" := (existT _ x y).

(*
Redefine some library functions to avoid opacity.
*)
Definition in_app_or : forall {A : Type} (l m : list A) (a : A),
       In a (l ++ m) -> In a l \/ In a m
 := fun (A : Type) (l m : list A) (a : A) =>
list_ind (fun l0 : list A => In a (l0 ++ m) -> In a l0 \/ In a m)
  (fun H : In a m => or_intror H)
  (fun (a0 : A) (y : list A) (H : In a (y ++ m) -> In a y \/ In a m)
     (H0 : a0 = a \/ In a (y ++ m)) =>
   or_ind (fun H1 : a0 = a => or_introl (or_introl H1))
     (fun H1 : In a (y ++ m) =>
      or_ind (fun H2 : In a y => or_introl (or_intror H2))
        (fun H2 : In a m => or_intror H2) (H H1)) H0) l.

Definition in_or_app : forall {A : Type} (l m : list A) (a : A),
       In a l \/ In a m -> In a (l ++ m)
 := fun (A : Type) (l m : list A) (a : A) =>
list_ind (fun l0 : list A => In a l0 \/ In a m -> In a (l0 ++ m))
  (fun H : False \/ In a m =>
   or_ind (fun H0 : False => False_ind (In a m) H0) (fun H0 : In a m => H0) H)
  (fun (H : A) (y : list A) (H0 : In a y \/ In a m -> In a (y ++ m))
     (H1 : (H = a \/ In a y) \/ In a m) =>
   or_ind
     (fun H2 : H = a \/ In a y =>
      or_ind (fun H3 : H = a => or_introl H3)
        (fun H3 : In a y => or_intror (H0 (or_introl H3))) H2)
     (fun H2 : In a m => or_intror (H0 (or_intror H2))) H1) l.

Definition in_app_iff : forall {A : Type} (l l' : list A) (a : A),
       In a (l ++ l') <-> In a l \/ In a l' :=
fun (A : Type) (l l' : list A) (a : A) =>
conj (fun H : In a (l ++ l') => in_app_or l l' a H)
  (fun H : In a l \/ In a l' => in_or_app l l' a H).

(*
Definitions: formulas and judgements.
*)
Class EqDec (A : Type) := eqdec : forall x y : A, {x=y}+{~x=y}.

Axiom atom : Type.
Hypothesis atom_ne : exists a : atom, True.
Hypothesis atom_dec : EqDec atom.

Inductive prop : Type :=
  | Atomic : atom -> prop
  | And : Meet prop
  | Or : Join prop
  | Impl : Imply prop
  | pfalse : Bot prop
  | ptrue : Top prop
.

Existing Instance And.
Existing Instance Or.
Existing Instance Impl.
Existing Instance pfalse.
Existing Instance ptrue.

Definition neg (p : prop) : prop := p __> bot.

Global Instance prop_dec : EqDec prop.
Proof.
red. induction x;destruct y;try solve [right;discriminate].
- destruct (atom_dec a a0). left;f_equal;assumption. right;injection;assumption.
- destruct (IHx1 y1);[destruct (IHx2 y2)|];
  solve [left;f_equal;assumption|right;injection;auto].
- destruct (IHx1 y1);[destruct (IHx2 y2)|];
  solve [left;f_equal;assumption|right;injection;auto].
- destruct (IHx1 y1);[destruct (IHx2 y2)|];
  solve [left;f_equal;assumption|right;injection;auto].
- left;reflexivity.
- left;reflexivity.
Defined.

Section interpSec.

Context (A : Type) `{H : Heyting A}.
Variable (aEval : atom -> A).

Fixpoint interp (p : prop) : A := match p with
  | Atomic a => aEval a
  | And p q => meet (interp p) (interp q)
  | Or p q => join (interp p) (interp q)
  | Impl p q => imply (interp p) (interp q)
  | pfalse => bot
  | ptrue => top
 end.

End interpSec.

Definition context := list prop.
Hint Unfold context.

Definition sub_ctx (G G' : context) := (forall A, In A G -> In A G').
Hint Unfold sub_ctx.

Module NJ.

Reserved Notation "G |- A" (at level 90).
Inductive NJ : context -> prop -> Prop :=
  | NJ_top : forall Gamma, Gamma |- ptrue
  | NJ_inconj : forall Gamma A B, Gamma |- A -> Gamma |- B -> Gamma |- meet A B
  | NJ_inmp : forall Gamma A B, A::Gamma |- B -> Gamma |- A __> B
  | NJ_indisjl : forall Gamma A B, Gamma |- A -> Gamma |- join A B
  | NJ_indisjr : forall Gamma A B, Gamma |- B -> Gamma |- join A B
  | NJ_exmp : forall Gamma A B, Gamma |- A __> B -> Gamma |- A -> Gamma |- B
  | NJ_exdisj : forall Gamma A B, Gamma |- join A B ->
     forall C, A::Gamma |- C -> B::Gamma |- C -> Gamma |- C
  | NJ_exconjl : forall Gamma A B, Gamma |- meet A B -> Gamma |- A
  | NJ_exconjr : forall Gamma A B, Gamma |- meet A B -> Gamma |- B
  | NJ_ax : forall Gamma A {H : In A Gamma}, Gamma |- A
  | NJ_bot : forall Gamma, Gamma |- pfalse -> forall A, Gamma |- A
where "G |- A" := (NJ G A).

Inductive cf : context -> prop -> Prop :=
  | ne_cf : forall G A, ne G A -> cf G A
  | cf_top : forall Gamma, cf Gamma ptrue
  | cf_inconj : forall Gamma A B, cf Gamma A -> cf Gamma B -> cf Gamma (And A B)
  | cf_inmp : forall Gamma A B, cf (A::Gamma) B -> cf Gamma (Impl A B)
  | cf_indisjl : forall Gamma A B, cf Gamma A -> cf Gamma (Or A B)
  | cf_indisjr : forall Gamma A B, cf Gamma B -> cf Gamma (Or A B)
with ne : context -> prop -> Prop :=
  | ne_exmp : forall Gamma A B, ne Gamma (Impl A B) -> cf Gamma A
     -> ne Gamma B
  | ne_exdisj : forall Gamma A B, ne Gamma (Or A B) ->
     forall C, cf (A::Gamma) C -> cf (B::Gamma) C -> ne Gamma C
  | ne_exconjl : forall Gamma A B, ne Gamma (And A B) -> ne Gamma A
  | ne_exconjr : forall Gamma A B, ne Gamma (And A B) -> ne Gamma B
  | ne_ax : forall Gamma A (H : In A Gamma), ne Gamma A
  | ne_bot : forall Gamma, ne Gamma pfalse -> forall A, ne Gamma A
.

(*
Weakening lemmas.
*)
Lemma NJ_generalise : forall Gamma Sigma, (forall A, In A Gamma -> In A Sigma)
 -> forall A, Gamma |- A -> Sigma |- A.
Proof.
intros ? ? Hsub ? d;revert Gamma A d Sigma Hsub.
induction 1;intros.
- constructor.
- constructor;auto.
- constructor. apply IHd. intros.
  simpl;destruct H;auto.
- apply NJ_indisjl. auto.
- apply NJ_indisjr. auto.
- apply NJ_exmp with A;auto.
- apply NJ_exdisj with A B;auto.
  apply IHd2. intros ? [?|?];simpl;auto.
  apply IHd3. intros ? [?|?];simpl;auto.
- apply NJ_exconjl with B. auto.
- apply NJ_exconjr with A. auto.
- apply NJ_ax;auto.
- apply NJ_bot;auto.
Defined.

Lemma cf_NJ : forall G A, cf G A -> G |- A
with ne_NJ : forall G A, ne G A -> G |- A.
Proof.
intros G A d;destruct d.
apply ne_NJ. assumption.
apply NJ_top.
apply NJ_inconj;apply cf_NJ;assumption.
apply NJ_inmp;apply cf_NJ;assumption.
apply NJ_indisjl;apply cf_NJ;assumption.
apply NJ_indisjr;apply cf_NJ;assumption.
intros G A d;destruct d.
apply NJ_exmp with A;[apply ne_NJ|apply cf_NJ];assumption.
apply NJ_exdisj with A B;[apply ne_NJ|apply cf_NJ|apply cf_NJ];assumption.
apply NJ_exconjl with B;apply ne_NJ;assumption.
apply NJ_exconjr with A;apply ne_NJ;assumption.
apply NJ_ax;assumption.
apply NJ_bot;apply ne_NJ;assumption.
Defined.

Lemma cf_gen : forall G A, cf G A -> forall G', sub_ctx G G' -> cf G' A
with ne_gen : forall G A, ne G A -> forall G', sub_ctx G G' -> ne G' A.
Proof.
intros ?? d;destruct d;intros.
apply ne_cf. apply ne_gen with G;assumption.
apply cf_top.
apply cf_inconj;apply cf_gen with Gamma;assumption.
apply cf_inmp;apply cf_gen with (A::Gamma);try assumption.
intros ? [?|?];[left|right];auto.
apply cf_indisjl;apply cf_gen with Gamma;assumption.
apply cf_indisjr;apply cf_gen with Gamma;assumption.
intros ?? d;destruct d;intros.
apply ne_exmp with A;[apply ne_gen with Gamma|apply cf_gen with Gamma];
assumption.
apply ne_exdisj with A B;[apply ne_gen with Gamma|
apply cf_gen with (A::Gamma)|apply cf_gen with (B::Gamma)];try assumption;
(intros ? [?|?];[left|right];auto).
apply ne_exconjl with B;apply ne_gen with Gamma;assumption.
apply ne_exconjr with A;apply ne_gen with Gamma;assumption.
apply ne_ax. apply H0. assumption.
apply ne_bot. apply ne_gen with Gamma;assumption.
Defined.

Fixpoint replace_atom_prop (a : atom) (b : prop) (f : prop) : prop :=
 match f with
  | Atomic x => if atom_dec a x then b else Atomic x
  | And x y => And (replace_atom_prop a b x) (replace_atom_prop a b y)
  | Or x y => Or (replace_atom_prop a b x) (replace_atom_prop a b y)
  | Impl x y => Impl (replace_atom_prop a b x) (replace_atom_prop a b y)
  | pfalse => pfalse
  | ptrue => ptrue
  end.

Definition replace_atom_ctx (a : atom) (b : prop) : context -> context
 := map (replace_atom_prop a b).

Lemma replace_atom_nj (a : atom) (b : prop) : forall G A, G |- A ->
replace_atom_ctx a b G |- replace_atom_prop a b A.
Proof.
intros ?? H;induction H;simpl.
- apply NJ_top.
- apply NJ_inconj;assumption.
- apply NJ_inmp;assumption.
- apply NJ_indisjl;assumption.
- apply NJ_indisjr;assumption.
- eapply NJ_exmp;[|apply IHNJ2]. apply IHNJ1.
- simpl in IHNJ1. eapply NJ_exdisj;[apply IHNJ1| |];assumption.
- eapply NJ_exconjl. apply IHNJ.
- eapply NJ_exconjr. apply IHNJ.
- apply NJ_ax. apply in_map. assumption.
- simpl in IHNJ. apply NJ_bot. assumption.
Defined.

Lemma NJ_strong_weakening : forall G A, G |- A ->
forall D, (forall B, In B G -> D |- B) -> D |- A.
Proof.
induction 1;intros;try solve [constructor;auto].
- constructor. apply IHNJ.
  simpl;intros ? [?|?]. apply NJ_ax;left;auto.
  apply NJ_generalise with D. simpl;auto. auto.
- apply NJ_indisjr. auto.
- apply NJ_exmp with A;auto.
- apply NJ_exdisj with A B;auto.
  apply IHNJ2. intros. destruct H3 as [?|H3].
  constructor;red;auto.
  apply NJ_generalise with D. simpl;auto.
  auto.
  apply IHNJ3. intros. destruct H3 as [?|H3].
  constructor;red;auto.
  apply NJ_generalise with D. simpl;auto.
  auto.
- apply NJ_exconjl with B. auto.
- apply NJ_exconjr with A. auto.
- auto.
- apply NJ_bot. auto.
Defined.

Lemma cf_str : forall G A, cf G A -> forall G', (forall A, In A G -> ne G' A)
-> cf G' A
with ne_str : forall G A, ne G A -> forall G', (forall A, In A G -> ne G' A)
-> ne G' A.
Proof.
intros ?? d;destruct d;intros.
apply ne_cf. apply ne_str with G;assumption.
apply cf_top.
apply cf_inconj;apply cf_str with Gamma;assumption.
apply cf_inmp;apply cf_str with (A::Gamma);try assumption.
intros ? [?|?]. apply ne_ax. left;assumption.
apply ne_gen with G'. apply H. assumption. intro;apply (@or_intror _ _).
apply cf_indisjl;apply cf_str with Gamma;assumption.
apply cf_indisjr;apply cf_str with Gamma;assumption.
intros ?? d;destruct d;intros.
apply ne_exmp with A;[apply ne_str with Gamma|apply cf_str with Gamma];
assumption.
apply ne_exdisj with A B;[apply ne_str with Gamma|
apply cf_str with (A::Gamma)|apply cf_str with (B::Gamma)];try assumption;
(intros ? [?|?];[apply ne_ax;left;assumption|
apply ne_gen with G';[apply H1;assumption|intro;apply or_intror]]).
apply ne_exconjl with B;apply ne_str with Gamma;assumption.
apply ne_exconjr with A;apply ne_str with Gamma;assumption.
apply H0;assumption.
apply ne_bot. apply ne_str with Gamma;assumption.
Defined.

(*
Soundness.
*)

Section NJ_sound_heyting.

Context (T : Type) `{Heyt : Heyting T} (eval : atom -> T).

Lemma NJ_sound_heyting : forall Gamma A, Gamma |- A ->
 fold_right meet top (map (interp _ eval) Gamma) <= interp _ eval A.
Proof.
induction 1;simpl in *;intros.
- apply bounded_top.
- apply meet_glb;assumption.
- apply heyting_imply. simpl in IHNJ.
  eapply transitivity;[|apply IHNJ].
  eapply order_proper. apply (@meet_comm T _ _ ). apply _.
  reflexivity. reflexivity.
- eapply transitivity;[|apply join_ub_l]. assumption.
- eapply transitivity;[|apply join_ub_r]. assumption.
- apply heyting_imply in IHNJ1.
  eapply transitivity;[|apply IHNJ1].
  apply meet_glb. apply reflexivity.
  assumption.
- apply (join_lub _ _ (interp T eval C) IHNJ2) in IHNJ3.
  clear IHNJ2.
  apply transitivity with
 (meet (join (interp T eval A) (interp T eval B))
       (fold_right meet top (map (interp T eval) Gamma))).
  apply meet_glb. assumption. apply reflexivity.
  eapply order_proper;[|reflexivity|apply IHNJ3].
  symmetry. apply meet_distrib_r.
- eapply transitivity. apply IHNJ. apply meet_lb_l.
- eapply transitivity. apply IHNJ. apply meet_lb_r.
- induction Gamma. destruct H.
  simpl. destruct H. destruct H.
  apply meet_lb_l.
  eapply transitivity. apply meet_lb_r. auto.
- apply transitivity with bot. assumption. apply Heyt.
Defined.

End NJ_sound_heyting.

(*
Completeness.
*)

Module NJ_complete.

Definition extract (A : prop) : set context :=
fun G => cf G A.

Notation "|_ A _|" := (extract A) (only parsing).
Notation "⌊ A ⌋" := (extract A). (* u230A and u230B *)

Definition Omega_aux (H : set context) (P : prop -> Prop) : Prop
 := forall G, H G <-> forall A, P A -> |_ A _| G.

Definition Omega : Type
 := sigT (fun H : set context => sigT (fun P : prop -> Prop => Omega_aux H P)).

Definition Omega_set : Omega -> set context := fun omega => projT1 omega.
Coercion Omega_set : Omega >-> set.
Hint Unfold Omega_set.

Lemma Omega_inter : forall P : Omega -> Prop, Omega.
Proof.
intros. exists (fun G => forall omega, P omega -> omega.1 G).
exists (fun A => exists omega, P omega /\ omega .2 .1 A).
red.
split;intros. destruct H0 as [omega [H0 H1]]. apply (omega .2 .2).
 apply H. assumption.
 assumption.
apply (omega .2 .2). intros.
apply H. exists omega. split. assumption. assumption.
Defined.

Instance Omega_eq : Equiv Omega
 := fun H K => Omega_set H == K.

Instance Omega_setoid : Setoid Omega.
Proof.
constructor.
split; reflexivity.
split. apply H. apply H.
split. eapply transitivity. apply H. apply H0.
eapply transitivity. apply H0. apply H.
Defined.

Lemma Omega_sub : forall omega : Omega, forall A : prop, omega .2 .1 A
-> sub omega (extract A).
Proof.
intros ? ? H G HG.
apply (omega .2 .2). assumption. assumption.
Defined.

Lemma Omega_weakening : forall omega : Omega,
forall G, omega.1 G -> forall G', (forall p, In p G -> In p G')
 -> omega.1 G'.
Proof.
intros.
destruct omega as [omega [P HP]]. simpl.
apply HP. intros.
assert (|_ A _| G). apply HP. assumption. assumption.
apply cf_gen with G;assumption.
Defined.

Instance Omega_leq : Leq Omega := fun X Y => X.1 <= Y.1.

Instance Omega_order : @Order Omega _ (<=).
Proof.
split. apply _.
split;
apply set_order;auto. symmetry;assumption. symmetry;assumption.
split. intro;apply set_order.
red. unfold leq;unfold Omega_leq. intros ? ? ?.
apply transitivity.
red. unfold equiv,Omega_eq,leq,Omega_leq. intros ? ?.
apply antisymmetry. apply _.
Defined.

Instance Omega_meet : Meet Omega.
Proof.
intros X Y. exists (fun G => X.1 G /\ Y.1 G).
destruct X as [X [P HP]];destruct Y as [Y [Q HQ]].
exists (fun A => P A \/ Q A). split.
intros H ? [H' | H'].
 simpl in H. apply HP. apply H. apply H'.
 simpl in H. apply HQ. apply H. apply H'.
intros H. split;simpl.
 apply HP;intros;apply H. left;assumption.
 apply HQ;intros;apply H. right;assumption.
Defined.

Lemma Omega_meet_lattice : @MeetSemiLattice Omega _ (<=) _.
Proof.
split. apply _.
repeat intro. hnf in H. apply H.
repeat intro. hnf in H. apply H.
repeat intro. split;
auto.
Defined.

Lemma Omega_extract : prop -> Omega.
Proof.
intro A. exists (extract A).
exists (fun B => A=B). split. intros ? _ []. assumption.
intros. apply H. reflexivity.
Defined.

Instance Omega_top : Top Omega := Omega_extract top.
Instance Omega_bot : Bot Omega := Omega_extract bot.

Lemma Omega_top_pr : forall omega : Omega, omega <= top.
Proof.
intros ? G _.
apply cf_top.
Defined.

Lemma cf_bot_all : forall G, cf G pfalse -> forall B, cf G B.
Proof.
assert (forall G A, cf G A -> pfalse = A -> forall B, cf G B).
intros ?? d;destruct d;intros X C;try discriminate X.
destruct X. apply ne_cf;apply ne_bot;assumption.
intros ??;apply H with pfalse. assumption. reflexivity.
Defined.

Lemma Omega_bot_pr : forall omega : Omega, bot <= omega.
Proof.
intros ? G H.
destruct omega as [E [P HP]].
apply HP. intros.
apply cf_bot_all. assumption.
Defined.

Lemma Omega_extract_incl : forall A : prop, (Omega_extract A).1 [A].
Proof.
intros. unfold Omega_extract. simpl. apply ne_cf;apply ne_ax.
left;auto.
Defined.

Instance Omega_join : Join Omega.
Proof.
intros X Y.
apply (Omega_inter (fun omega => sub X omega /\ sub Y omega)).
Defined.

Lemma Omega_join_pr : forall (a b : Omega) G, (join a b).1 G <->
  forall D : prop, sub a (extract D) -> sub b (extract D) -> (extract D) G.
Proof.
split;intros.
hnf in H. simpl in H. apply (H (Omega_extract D)).
split;assumption.
intros omega [H0 H1].
apply (omega .2 .2). intros.
apply H.
 transitivity (Omega_set omega). assumption.
 apply Omega_sub. assumption.
 transitivity (Omega_set omega). assumption.
 apply Omega_sub. assumption.
Defined.

Instance Omega_imply : Imply Omega := fun X Y =>
  Omega_inter (fun omega => forall Z : Omega, (meet X Z) <= Y -> Z <= omega).

Lemma Omega_imply_pr : forall (a b : Omega) G, (a __> b).1 G <->
  forall D : prop, (forall c : Omega, meet a c <= b -> sub c (extract D))
    -> (extract D) G.
Proof.
split;intros.
apply (H (Omega_extract D)).
assumption.
intros ? ?. apply (omega .2 .2). intros. apply H.
intros. transitivity (Omega_set omega). apply H0. assumption.
apply Omega_sub. assumption.
Defined.

Lemma Omega_join_lattice : @JoinSemiLattice Omega _ (<=) _.
Proof.
split.
apply _.
intros ? ? ? ? ? [H0 _]. apply H0. assumption.
intros ? ? ? ? ? [_ H1]. apply H1. assumption.
intros ? ? ? ? ? ? ?. apply H1;split;assumption.
Defined.

Lemma Omega_imply_left : forall X Y Z, meet X Y <= Z -> X <= Y __> Z.
Proof.
intros ? ? ? ? G ?.
intros d ?. apply H1 with X.
intros ? ?;apply H;split;destruct H2;auto.
assumption.
Defined.

Lemma cf_imply_passes_right : forall G D A, cf (G++D) A ->
 cf D (fold_right imply A G).
Proof.
induction G;intros ? ? d.
assumption.
simpl. apply cf_inmp. apply IHG.
eapply cf_gen. apply d.
red;intros. apply in_app_iff;apply in_app_iff in H. simpl. simpl in H.
tauto.
Defined.

(* CUT *)
Lemma cf_kleene : forall G A B, cf G (A __> B) -> cf (A::G) B.
Proof.
intros. inversion H.
apply ne_cf. apply ne_exmp with A. apply ne_gen with G. assumption.
intro;apply or_intror. apply ne_cf;apply ne_ax;left;reflexivity.
assumption.
Defined.

Lemma cf_imply_passes_left : forall G D A, cf D (fold_right imply A G)
 -> cf (G++D) A.
Proof.
induction G;intros.
assumption.
simpl in H. apply cf_kleene in H. apply IHG in H.
eapply cf_gen. apply H.
simpl;intros ? H0. apply in_app_iff in H0.
simpl;destruct H0;[right;apply in_app_iff;auto|
destruct H0;[auto|right;apply in_app_iff;auto]].
Defined.

Lemma Omega_imply_right : forall X Y Z, X <= Y __> Z -> meet X Y <= Z.
Proof.
intros ? ? ? ? G [HG0 HG1].
apply (Z .2 .2).
intros C HC.
pose (H0 := H _ HG0);clearbody H0.
pose (H1 := match (Omega_imply_pr _ _ _) with | conj H _ => H end H0
  (fold_right imply C G));clearbody H1.
assert (HD: |_ fold_right imply C G _| G). apply H1.
intros E ? D HD. assert (Z.1 (G++D)). apply H2.
split.
apply Omega_weakening with G. assumption.
 intros;apply in_app_iff;auto.
apply Omega_weakening with D. assumption.
 intros;apply in_app_iff;auto.
apply (match Z.2.2 (G++D) with | conj H _ => H end) with C in H3.
apply cf_imply_passes_right in H3.
assumption. assumption.
apply cf_imply_passes_left in HD.
eapply cf_gen. apply HD. intros ? H2;apply in_app_iff in H2;tauto.
Defined.

Instance Omega_heyting : @Heyting Omega _ _ _ _ _ _ _.
Proof.
split;[split;[split| |]|].
apply Omega_meet_lattice.
apply Omega_join_lattice.
apply Omega_top_pr.
apply Omega_bot_pr.
split. apply Omega_imply_right. apply Omega_imply_left.
Defined.

Definition Omega_interp : prop -> Omega
 := interp Omega (fun a : atom => Omega_extract (Atomic a)).

Notation "[| A |]" := (Omega_interp A).

Definition closure (A : prop) : Omega
 := Omega_inter (fun omega => omega.1 [A]).

Lemma closure_pr : forall A G, (closure A).1 G <->
  forall D, (extract D) [A] -> (extract D) G.
Proof.
split;intros.
red in H;red in H. simpl in H.
apply (H (Omega_extract D)). assumption.
intros ? ?. apply (omega.2.2). intros B ?. apply H.
apply (omega.2.2). assumption. assumption.
Defined.

Lemma Omega_strong_weakening : forall (omega : Omega) G, omega.1 G ->
  forall G', (forall p, In p G -> ne G' p) -> omega.1 G'.
Proof.
intros.
apply omega.2.2. intros.
apply cf_str with G.
apply omega.2.2. assumption. assumption.
assumption.
Defined.

Lemma cl_sub_pr : forall A (omega : Omega), omega.1 [A] ->
 sub (closure A) omega.
Proof.
intros ? ? ? G ?.
apply H0. assumption.
Defined.

Lemma Omega_imply_monotonous : forall A A' B B' : Omega,
  A <= A' -> B <= B' -> A' __> B <= A __> B'.
Proof.
intros ? ? ? ? ? ? G ?.
intros ? ?. apply H1. intros.
apply H2. intros ? [? ?]. apply H0. apply H3. split;auto.
Defined.

Lemma cl_extract : forall A, sub (closure A) (extract A).
Proof.
intros A G H. hnf in H;simpl in H. change ((Omega_extract A).1 G). apply H.
apply Omega_extract_incl.
Defined.

Lemma Omega_key_cl (A : prop) :  sub (closure A) (Omega_interp A)
with Omega_key_ex (A : prop) : sub (Omega_interp A) (extract A).
Proof.
destruct A.
(* atom *)
  intros G ?. hnf in H;simpl in H. apply H.
  apply Omega_extract_incl.

(* and *)
  simpl. intros G;unfold incl;intros ?.
  split.
  apply Omega_key_cl. intros ? ?. apply H.
  apply Omega_strong_weakening with [A1]. assumption.
  intros ? [[]|[]].
  apply ne_exconjl with A2. apply ne_ax. left;auto.
  apply Omega_key_cl. intros ? ?. apply H.
  apply Omega_strong_weakening with [A2]. assumption.
  intros ? [[]|[]].
  apply ne_exconjr with A1. apply ne_ax. left;auto.

(* or *)
  intros G H. apply H. clear G H.
  simpl;red. intros omega [? ?].
  apply (omega.2.2). intros C ?.
  assert ((extract C) [A1]).
    apply (omega.2.2);try assumption.
    apply H. apply Omega_key_cl. intros ?;auto.
  assert ((extract C) [A2]).
    apply (omega.2.2);try assumption.
    apply H0. apply Omega_key_cl. intros ?;auto.
  apply ne_cf;apply ne_exdisj with A1 A2.
  apply ne_ax;left;auto.
  apply cf_gen with [A1];auto.
    red;intros. simpl in H4;simpl. tauto.
  apply cf_gen with [A2];auto.
    red;intros. simpl in H4;simpl. tauto.

(* imply *)
  change ((closure (Impl A1 A2)) <= (Omega_interp A1 __> Omega_interp A2)).
  apply Omega_imply_left.
  intros G ?.
  apply Omega_key_cl. destruct H. apply Omega_key_ex in H0.
  apply closure_pr. intros ? H1.
  apply cf_gen with (G++G);[ |
  intros ? H2;apply in_app_or in H2;tauto].
  apply cf_imply_passes_left.
  change ((Omega_extract (fold_right imply D G)).1 G).
  apply H. apply cf_imply_passes_right.
  apply cf_str with [A2].
  assumption.
  intros _ [[]|[]]. apply ne_exmp with A1.
  apply ne_ax. apply in_app_iff. right;left;reflexivity.
  apply cf_gen with G. assumption.
  red;intros. apply in_app_iff;left;assumption.

(* false *)
  intros G ?. apply H.
  red;simpl. apply ne_cf;apply ne_ax;simpl;auto.

(* true *)
  intros ? _. hnf. apply cf_top.

destruct A.
(* atom *)
   intros ?;auto.

(* and *)
  intros G ?. destruct H. apply Omega_key_ex in H;apply Omega_key_ex in H0.
  apply cf_inconj;assumption.

(* or *)
  intros G ?. simpl in H. apply (H (Omega_extract (Or A1 A2))).
  clear G H. split.
  intros G ?. apply Omega_key_ex in H. apply cf_indisjl;assumption.
  intros G ?. apply Omega_key_ex in H. apply cf_indisjr;assumption.

(* imply *)
  apply (sub_trans _ ((closure A1) __> (Omega_extract A2)) _).
  change [| Impl A1 A2 |] with ([|A1|] __> [|A2|]).
  apply Omega_imply_monotonous.
  apply Omega_key_cl. apply Omega_key_ex.
  intros G ?.
  apply (match Omega_imply_pr _ _ _ with | conj H _ => H end H (A1 __> A2)).
  intros o ?. intros S ?.
  assert ((meet (closure A1) o).1 (A1::S)).
  split. unfold closure. simpl. red;intros. apply Omega_weakening with [A1].
  assumption. simpl;left;tauto.
  apply Omega_weakening with S. assumption. simpl;auto.
  apply H0 in H2.
  apply cf_inmp. assumption.

(* false *)
  intros ? H;apply H.

(* true *)
  intros ? H;apply H.
Defined.

Lemma fold_right_closure_interp : forall G,
 sub (fold_right meet top (map closure G))
     (fold_right meet top (map Omega_interp G)).
Proof.
induction G. simpl. reflexivity.
simpl. red;unfold incl. intros ?[??].
split. apply Omega_key_cl. assumption.
apply IHG. assumption.
Defined.

Lemma context_closure : forall G G', (forall x, In x G -> In x G')
-> (fold_right meet top (map closure G)).1 G'.
Proof.
induction G;simpl;unfold incl;intros.
apply cf_top.
split. intros. apply Omega_weakening with [a]. assumption.
intros;apply H. left;destruct H1 as [?|[]]. assumption.
apply IHG. intros;apply H;right;assumption.
Defined.

Lemma Omega_complete : forall {G A},
 fold_right meet top (map Omega_interp G) <= Omega_interp A -> cf G A.
Proof.
intros. change (extract A G). apply Omega_key_ex.
apply H. apply fold_right_closure_interp. apply context_closure. auto.
Defined.

Lemma Omega_sound : forall {G A}, G |- A ->
  fold_right meet top (map Omega_interp G) <= Omega_interp A.
Proof.
eapply NJ_sound_heyting. apply _.
Defined.

Lemma cf_complete : forall G A, (forall T `{Heyting T} eval,
fold_right meet top (map (interp _ eval) G) <= interp _ eval A) -> cf G A.
Proof.
intros.
apply Omega_complete. eapply H. apply _.
Defined.

Lemma remove_cuts : forall {G A}, G |- A -> cf G A.
Proof.
intros. apply Omega_complete. apply Omega_sound. assumption.
Defined.

Definition reduction : forall {G A}, G |- A -> G |- A
 := fun G A d => cf_NJ _ _ (remove_cuts d).

(*
Tests.
*)

Axiom A B : atom.

Definition test : NJ [Atomic A] (Atomic A).
apply NJ_exmp with (Atomic A).
apply NJ_inmp. apply NJ_ax. right;left;reflexivity.
apply NJ_ax;left;reflexivity.
Defined.

Eval compute in (reduction test).
(* x : A |- x : A  ==> x : A |- x : A *)

Definition test' : NJ [Atomic A] (Atomic A).
apply NJ_exmp with (Atomic A).
apply NJ_exdisj with (Atomic A) (Atomic A).
apply NJ_exmp with (meet (Atomic A) (Atomic A)).
apply NJ_inmp.
apply NJ_indisjl. apply NJ_exconjr with (Atomic A).
apply NJ_ax;simpl;auto.
apply NJ_inconj;apply NJ_ax;simpl;auto.
apply NJ_inmp;apply NJ_ax;right;left;auto.
apply NJ_inmp;apply NJ_ax;left;simpl;auto.
apply NJ_ax;simpl;auto.
Defined.

Eval compute in (reduction test').
(*

 x : A |- (match (λz : A/\A. inl z.2) (x,x) with
             | inl (y:A) => λz : A. y
             | inr (y:A) => λz : A. z
          ) x : A
==>
 x : A |- x : A

*)

Definition test0 : NJ [Atomic A; Atomic A] (Atomic A).
apply NJ_exmp with (Atomic A).
apply NJ_exconjl with (Atomic A).
apply NJ_inconj. apply NJ_inmp. apply NJ_ax. right;left;reflexivity.
apply NJ_ax. left;reflexivity.
apply NJ_ax. right;left;reflexivity.
Defined.

Eval compute in (reduction test0).
(*
 x : A, y : A |- (λz : A. y, y).1 x : A
==>
 x : A, y : A |- y : A
*)

Definition test1 : NJ [Atomic A ⊔ Atomic B] (Atomic A ⊔ Atomic B).
apply NJ_ax;left;reflexivity.
Defined.

Eval compute in (Omega_sound test1).

Eval compute in (reduction test1).
Eval compute in (reduction (reduction test1)).
(*
 x : A\/B |- x : A\/B
==>
 x : A\/B |- (match x with
               | inl y => inl y
               | inr z => inr z) : A\/B
==>
 something else
*)

Definition test2 : NJ [meet (Atomic A) (Atomic B)] (meet (Atomic A) (Atomic B)).
Proof.
apply NJ_ax;simpl;auto.
Defined.

Eval compute in (reduction test2).
Eval compute in (reduction (reduction test2)).
(*
 x : A/\B |- x : A/\B
==>
 x : A/\B |- (x.1,x.2) : A/\B
==>
 itself
*)

Definition test3 : NJ [imply (Atomic A) (Atomic B)]
 (imply (Atomic A) (Atomic B)).
Proof.
apply NJ_ax;simpl;auto.
Defined.

Eval compute in (reduction test3).
Eval compute in (reduction (reduction test3)).
(*
 x : A -> B |- x : A -> B
==>
 x : A -> B |- (λy : A. x y) : A -> B
==>
 itself
*)

End NJ_complete.

End NJ.


From Hammer Require Import Hammer.

Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
From PLF Require Import Maps.
From PLF Require Import Types.
From PLF Require Import Smallstep.

Definition manual_grade_for_arrow_sub_wrong : option (nat*string) := None.

Definition manual_grade_for_subtype_order : option (nat*string) := None.

Definition manual_grade_for_subtype_instances_tf_2 : option (nat*string) := None.

Definition manual_grade_for_subtype_concepts_tf : option (nat*string) := None.

Definition manual_grade_for_proper_subtypes : option (nat*string) := None.

Definition manual_grade_for_small_large_1 : option (nat*string) := None.

Definition manual_grade_for_small_large_2 : option (nat*string) := None.

Definition manual_grade_for_small_large_4 : option (nat*string) := None.

Definition manual_grade_for_smallest_1 : option (nat*string) := None.

Definition manual_grade_for_smallest_2 : option (nat*string) := None.

Definition manual_grade_for_pair_permutation : option (nat*string) := None.

Inductive ty : Type :=
| Top   : ty
| Bool  : ty
| Base  : string -> ty
| Arrow : ty -> ty -> ty
| Unit  : ty
.

Inductive tm : Type :=
| var : string -> tm
| app : tm -> tm -> tm
| abs : string -> ty -> tm -> tm
| tru : tm
| fls : tm
| test : tm -> tm -> tm -> tm
| unit : tm
.

Fixpoint subst (x:string) (s:tm)  (t:tm) : tm :=
match t with
| var y =>
if eqb_string x y then s else t
| abs y T t1 =>
abs y T (if eqb_string x y then t1 else (subst x s t1))
| app t1 t2 =>
app (subst x s t1) (subst x s t2)
| tru =>
tru
| fls =>
fls
| test t1 t2 t3 =>
test (subst x s t1) (subst x s t2) (subst x s t3)
| unit =>
unit
end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

Inductive value : tm -> Prop :=
| v_abs : forall x T t,
value (abs x T t)
| v_true :
value tru
| v_false :
value fls
| v_unit :
value unit
.

Hint Constructors value.

Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
| ST_AppAbs : forall x T t12 v2,
value v2 ->
(app (abs x T t12) v2) --> [x:=v2]t12
| ST_App1 : forall t1 t1' t2,
t1 --> t1' ->
(app t1 t2) --> (app t1' t2)
| ST_App2 : forall v1 t2 t2',
value v1 ->
t2 --> t2' ->
(app v1 t2) --> (app v1  t2')
| ST_TestTrue : forall t1 t2,
(test tru t1 t2) --> t1
| ST_TestFalse : forall t1 t2,
(test fls t1 t2) --> t2
| ST_Test : forall t1 t1' t2 t3,
t1 --> t1' ->
(test t1 t2 t3) --> (test t1' t2 t3)
where "t1 '-->' t2" := (step t1 t2).

Hint Constructors step.

Reserved Notation "T '<:' U" (at level 40).

Inductive subtype : ty -> ty -> Prop :=
| S_Refl : forall T,
T <: T
| S_Trans : forall S U T,
S <: U ->
U <: T ->
S <: T
| S_Top : forall S,
S <: Top
| S_Arrow : forall S1 S2 T1 T2,
T1 <: S1 ->
S2 <: T2 ->
(Arrow S1 S2) <: (Arrow T1 T2)
where "T '<:' U" := (subtype T U).

Hint Constructors subtype.

Module Examples.

Open Scope string_scope.
Notation x := "x".
Notation y := "y".
Notation z := "z".

Notation A := (Base "A").
Notation B := (Base "B").
Notation C := (Base "C").

Notation String := (Base "String").
Notation Float := (Base "Float").
Notation Integer := (Base "Integer").

Example subtyping_example_0 :
(Arrow C Bool) <: (Arrow C Top).

Proof. hammer_hook "Sub" "Sub.Examples.subtyping_example_0". auto. Qed.

Definition Person : ty
. Admitted.
Definition Student : ty
. Admitted.
Definition Employee : ty
. Admitted.

Example sub_student_person :
Student <: Person.
Proof. hammer_hook "Sub" "Sub.Examples.sub_student_person".
Admitted.

Example sub_employee_person :
Employee <: Person.
Proof. hammer_hook "Sub" "Sub.Examples.sub_employee_person".
Admitted.

Example subtyping_example_1 :
(Arrow Top Student) <: (Arrow (Arrow C C) Person).

Proof with eauto. hammer_hook "Sub" "Sub.Examples.subtyping_example_1".
Admitted.

Example subtyping_example_2 :
(Arrow Top Person) <: (Arrow Person Top).

Proof with eauto. hammer_hook "Sub" "Sub.Examples.subtyping_example_2".
Admitted.

End Examples.

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=

| T_Var : forall Gamma x T,
Gamma x = Some T ->
Gamma |- var x \in T
| T_Abs : forall Gamma x T11 T12 t12,
(x |-> T11 ; Gamma) |- t12 \in T12 ->
Gamma |- abs x T11 t12 \in Arrow T11 T12
| T_App : forall T1 T2 Gamma t1 t2,
Gamma |- t1 \in Arrow T1 T2 ->
Gamma |- t2 \in T1 ->
Gamma |- app t1 t2 \in T2
| T_True : forall Gamma,
Gamma |- tru \in Bool
| T_False : forall Gamma,
Gamma |- fls \in Bool
| T_Test : forall t1 t2 t3 T Gamma,
Gamma |- t1 \in Bool ->
Gamma |- t2 \in T ->
Gamma |- t3 \in T ->
Gamma |- test t1 t2 t3 \in T
| T_Unit : forall Gamma,
Gamma |- unit \in Unit

| T_Sub : forall Gamma t S T,
Gamma |- t \in S ->
S <: T ->
Gamma |- t \in T

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

Hint Extern 2 (has_type _ (app _ _) _) =>
eapply T_App; auto.
Hint Extern 2 (_ = _) => compute; reflexivity.

Module Examples2.
Import Examples.

End Examples2.

Lemma sub_inversion_Bool : forall U,
U <: Bool ->
U = Bool.
Proof with auto. hammer_hook "Sub" "Sub.sub_inversion_Bool".
intros U Hs.
remember Bool as V.
Admitted.

Lemma sub_inversion_arrow : forall U V1 V2,
U <: Arrow V1 V2 ->
exists U1 U2,
U = Arrow U1 U2 /\ V1 <: U1 /\ U2 <: V2.
Proof with eauto. hammer_hook "Sub" "Sub.sub_inversion_arrow".
intros U V1 V2 Hs.
remember (Arrow V1 V2) as V.
generalize dependent V2. generalize dependent V1.
Admitted.

Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
Gamma |- s \in Arrow T1 T2 ->
value s ->
exists x S1 s2,
s = abs x S1 s2.
Proof with eauto. hammer_hook "Sub" "Sub.canonical_forms_of_arrow_types".
Admitted.

Lemma canonical_forms_of_Bool : forall Gamma s,
Gamma |- s \in Bool ->
value s ->
s = tru \/ s = fls.
Proof with eauto. hammer_hook "Sub" "Sub.canonical_forms_of_Bool".
intros Gamma s Hty Hv.
remember Bool as T.
induction Hty; try solve_by_invert...
-
subst. apply sub_inversion_Bool in H. subst...
Qed.

Theorem progress : forall t T,
empty |- t \in T ->
value t \/ exists t', t --> t'.
Proof with eauto. hammer_hook "Sub" "Sub.progress".
intros t T Ht.
remember empty as Gamma.
revert HeqGamma.
induction Ht;
intros HeqGamma; subst...
-
inversion H.
-
right.
destruct IHHt1; subst...
+
destruct IHHt2; subst...
*
destruct (canonical_forms_of_arrow_types empty t1 T1 T2)
as [x [S1 [t12 Heqt1]]]...
subst. exists ([x:=t2]t12)...
*
inversion H0 as [t2' Hstp]. exists (app t1 t2')...
+
inversion H as [t1' Hstp]. exists (app t1' t2)...
-
right.
destruct IHHt1.
+  eauto.
+ assert (t1 = tru \/ t1 = fls)
by (eapply canonical_forms_of_Bool; eauto).
inversion H0; subst...
+ inversion H. rename x into t1'. eauto.
Qed.

Lemma typing_inversion_abs : forall Gamma x S1 t2 T,
Gamma |- (abs x S1 t2) \in T ->
exists S2,
Arrow S1 S2 <: T
/\ (x |-> S1 ; Gamma) |- t2 \in S2.
Proof with eauto. hammer_hook "Sub" "Sub.typing_inversion_abs".
intros Gamma x S1 t2 T H.
remember (abs x S1 t2) as t.
induction H;
inversion Heqt; subst; intros; try solve_by_invert.
-
exists T12...
-
destruct IHhas_type as [S2 [Hsub Hty]]...
Qed.

Lemma typing_inversion_var : forall Gamma x T,
Gamma |- (var x) \in T ->
exists S,
Gamma x = Some S /\ S <: T.
Proof with eauto. hammer_hook "Sub" "Sub.typing_inversion_var".
intros Gamma x T Hty.
remember (var x) as t.
induction Hty; intros;
inversion Heqt; subst; try solve_by_invert.
-
exists T...
-
destruct IHHty as [U [Hctx HsubU]]... Qed.

Lemma typing_inversion_app : forall Gamma t1 t2 T2,
Gamma |- (app t1 t2) \in T2 ->
exists T1,
Gamma |- t1 \in (Arrow T1 T2) /\
Gamma |- t2 \in T1.
Proof with eauto. hammer_hook "Sub" "Sub.typing_inversion_app".
intros Gamma t1 t2 T2 Hty.
remember (app t1 t2) as t.
induction Hty; intros;
inversion Heqt; subst; try solve_by_invert.
-
exists T1...
-
destruct IHHty as [U1 [Hty1 Hty2]]...
Qed.

Lemma typing_inversion_true : forall Gamma T,
Gamma |- tru \in T ->
Bool <: T.
Proof with eauto. hammer_hook "Sub" "Sub.typing_inversion_true".
intros Gamma T Htyp. remember tru as tu.
induction Htyp;
inversion Heqtu; subst; intros...
Qed.

Lemma typing_inversion_false : forall Gamma T,
Gamma |- fls \in T ->
Bool <: T.
Proof with eauto. hammer_hook "Sub" "Sub.typing_inversion_false".
intros Gamma T Htyp. remember fls as tu.
induction Htyp;
inversion Heqtu; subst; intros...
Qed.

Lemma typing_inversion_if : forall Gamma t1 t2 t3 T,
Gamma |- (test t1 t2 t3) \in T ->
Gamma |- t1 \in Bool
/\ Gamma |- t2 \in T
/\ Gamma |- t3 \in T.
Proof with eauto. hammer_hook "Sub" "Sub.typing_inversion_if".
intros Gamma t1 t2 t3 T Hty.
remember (test t1 t2 t3) as t.
induction Hty; intros;
inversion Heqt; subst; try solve_by_invert.
-
auto.
-
destruct (IHHty H0) as [H1 [H2 H3]]...
Qed.

Lemma typing_inversion_unit : forall Gamma T,
Gamma |- unit \in T ->
Unit <: T.
Proof with eauto. hammer_hook "Sub" "Sub.typing_inversion_unit".
intros Gamma T Htyp. remember unit as tu.
induction Htyp;
inversion Heqtu; subst; intros...
Qed.

Lemma abs_arrow : forall x S1 s2 T1 T2,
empty |- (abs x S1 s2) \in (Arrow T1 T2) ->
T1 <: S1
/\ (x |-> S1 ; empty) |- s2 \in T2.
Proof with eauto. hammer_hook "Sub" "Sub.abs_arrow".
intros x S1 s2 T1 T2 Hty.
apply typing_inversion_abs in Hty.
inversion Hty as [S2 [Hsub Hty1]].
apply sub_inversion_arrow in Hsub.
inversion Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
inversion Heq; subst...  Qed.

Inductive appears_free_in : string -> tm -> Prop :=
| afi_var : forall x,
appears_free_in x (var x)
| afi_app1 : forall x t1 t2,
appears_free_in x t1 -> appears_free_in x (app t1 t2)
| afi_app2 : forall x t1 t2,
appears_free_in x t2 -> appears_free_in x (app t1 t2)
| afi_abs : forall x y T11 t12,
y <> x  ->
appears_free_in x t12 ->
appears_free_in x (abs y T11 t12)
| afi_test1 : forall x t1 t2 t3,
appears_free_in x t1 ->
appears_free_in x (test t1 t2 t3)
| afi_test2 : forall x t1 t2 t3,
appears_free_in x t2 ->
appears_free_in x (test t1 t2 t3)
| afi_test3 : forall x t1 t2 t3,
appears_free_in x t3 ->
appears_free_in x (test t1 t2 t3)
.

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
Gamma |- t \in S  ->
(forall x, appears_free_in x t -> Gamma x = Gamma' x)  ->
Gamma' |- t \in S.
Proof with eauto. hammer_hook "Sub" "Sub.context_invariance".
intros. generalize dependent Gamma'.
induction H;
intros Gamma' Heqv...
-
apply T_Var... rewrite <- Heqv...
-
apply T_Abs... apply IHhas_type. intros x0 Hafi.
unfold update, t_update. destruct (eqb_stringP x x0)...
-
apply T_Test...
Qed.

Lemma free_in_context : forall x t T Gamma,
appears_free_in x t ->
Gamma |- t \in T ->
exists T', Gamma x = Some T'.
Proof with eauto. hammer_hook "Sub" "Sub.free_in_context".
intros x t T Gamma Hafi Htyp.
induction Htyp;
subst; inversion Hafi; subst...
-
destruct (IHHtyp H4) as [T Hctx]. exists T.
unfold update, t_update in Hctx.
rewrite <- eqb_string_false_iff in H2.
rewrite H2 in Hctx... Qed.

Lemma substitution_preserves_typing : forall Gamma x U v t S,
(x |-> U ; Gamma) |- t \in S  ->
empty |- v \in U   ->
Gamma |- [x:=v]t \in S.
Proof with eauto. hammer_hook "Sub" "Sub.substitution_preserves_typing".
intros Gamma x U v t S Htypt Htypv.
generalize dependent S. generalize dependent Gamma.
induction t; intros; simpl.
-
rename s into y.
destruct (typing_inversion_var _ _ _ Htypt)
as [T [Hctx Hsub]].
unfold update, t_update in Hctx.
destruct (eqb_stringP x y) as [Hxy|Hxy]; eauto;
subst.
inversion Hctx; subst. clear Hctx.
apply context_invariance with empty...
intros x Hcontra.
destruct (free_in_context _ _ S empty Hcontra)
as [T' HT']...
inversion HT'.
-
destruct (typing_inversion_app _ _ _ _ Htypt)
as [T1 [Htypt1 Htypt2]].
eapply T_App...
-
rename s into y. rename t into T1.
destruct (typing_inversion_abs _ _ _ _ _ Htypt)
as [T2 [Hsub Htypt2]].
apply T_Sub with (Arrow T1 T2)... apply T_Abs...
destruct (eqb_stringP x y) as [Hxy|Hxy].
+
eapply context_invariance...
subst.
intros x Hafi. unfold update, t_update.
destruct (eqb_string y x)...
+
apply IHt. eapply context_invariance...
intros z Hafi. unfold update, t_update.
destruct (eqb_stringP y z)...
subst.
rewrite <- eqb_string_false_iff in Hxy. rewrite Hxy...
-
assert (Bool <: S)
by apply (typing_inversion_true _ _  Htypt)...
-
assert (Bool <: S)
by apply (typing_inversion_false _ _  Htypt)...
-
assert  ((x |-> U ; Gamma) |- t1 \in Bool
/\  (x |-> U ; Gamma) |- t2 \in S
/\  (x |-> U ; Gamma) |- t3 \in S)
by apply (typing_inversion_if _ _ _ _ _ Htypt).
inversion H as [H1 [H2 H3]].
apply IHt1 in H1. apply IHt2 in H2. apply IHt3 in H3.
auto.
-
assert (Unit <: S)
by apply (typing_inversion_unit _ _  Htypt)...
Qed.

Theorem preservation : forall t t' T,
empty |- t \in T  ->
t --> t'  ->
empty |- t' \in T.
Proof with eauto. hammer_hook "Sub" "Sub.preservation".
intros t t' T HT.
remember empty as Gamma. generalize dependent HeqGamma.
generalize dependent t'.
induction HT;
intros t' HeqGamma HE; subst; inversion HE; subst...
-
inversion HE; subst...
+
destruct (abs_arrow _ _ _ _ _ HT1) as [HA1 HA2].
apply substitution_preserves_typing with T...
Qed.

Definition manual_grade_for_variations : option (nat*string) := None.

Definition manual_grade_for_products : option (nat*string) := None.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal75.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons Zero Nil).
Definition lfind_example_2  := ( Cons Zero Nil).
Definition lfind_example_3  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_4  := ( Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_5  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_6  := ( Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_7  := ( Cons Zero (Cons Zero (Cons Zero Nil))).
Definition lfind_example_8  := ( Cons Zero Nil).
Definition lfind_example_9  := ( Cons (Succ (Succ (Succ Zero)))         (Cons (Succ (Succ (Succ Zero))) (Cons Zero Nil))).
Definition lfind_example_10  := ( Cons Zero Nil).
Definition lfind_example_11  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_12  := ( Cons (Succ Zero) Nil).
Definition lfind_example_13  := ( Cons (Succ Zero) Nil).
Definition lfind_example_14  := ( Cons (Succ Zero) Nil).
Definition lfind_example_15  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_16  := ( Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_17  := ( Cons Zero Nil).
Definition lfind_example_18  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_19  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_20  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).
Definition lfind_example_21  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_22  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_23  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_24  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).
Definition lfind_example_25  := ( Cons Zero Nil).
Definition lfind_example_26  := ( Cons Zero (Cons Zero (Cons Zero Nil))).
Definition lfind_example_27  := ( Cons (Succ Zero) (Cons (Succ Zero) Nil)).
Definition lfind_example_28  := ( Cons (Succ Zero) Nil).
Definition lfind_example_29  := ( Cons (Succ Zero) Nil).
Definition lfind_example_30  := ( Cons (Succ (Succ (Succ (Succ Zero)))) Nil).
Definition lfind_example_31  := ( Cons Zero Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal75_theorem0_41_append_assoc/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 lfind_example_26 lfind_example_27 lfind_example_28 lfind_example_29 lfind_example_30 lfind_example_31 .


(* 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                                                     *)

(** * lin_comb_facts.v *)
Set Implicit Arguments.
Unset Strict Implicit.
Require Export algebraic_span_facts.
Require Export seq_set_seq.

(** - Miscellaneous facts about linear combinations:

 - Suppose $x$ is a linear combination of $W$, and all $w\in W$ are linear combinations
 of $W'$, then $x$ is a linear combination of $W'$ *)

Lemma lin_comb_casting :
 forall (F : field) (V : vectorspace F) (W W' : part_set V) (x : V),
 is_lin_comb x W ->
 (forall w : W, is_lin_comb (subtype_elt w) W') -> is_lin_comb x W'.
intros.
change (in_part x (span W')) in |- *.
elim (span_idempotent W' x).
intros.
apply H2; auto with algebra; clear H1 H2.
simpl in |- *.
assert (forall w : W, in_part (subtype_elt w) (span_set W')).
auto.
clear H0.
inversion_clear H.
inversion_clear H0.
inversion_clear H.
red in |- *.
exists x0.
exists x1.
assert (forall i : fin x0, in_part (Map_embed x2 i) (span_set W')).
intro i.
change (in_part (subtype_elt (x2 i)) (span_set W')) in |- *.
auto.
exists (cast_map_to_subset H).
apply Trans with (sum (mult_by_scalars x1 (Map_embed x2))); auto with algebra.
Qed.

(** - If all $w\in W$ are linear combinations of $W'$ then $span(W)\subset span(W')$ *)

Lemma span_casting :
 forall (F : field) (V : vectorspace F) (W W' : part_set V),
 (forall w : W, is_lin_comb (subtype_elt w) W') ->
 included (span W) (span W').
intros; simpl in |- *.
red in |- *; simpl in |- *.
intros.
apply lin_comb_casting with W; auto with algebra.
Qed.

Lemma lin_comb_scalar_multiplied :
 forall (F : field) (V : vectorspace F) (x : V) (n : Nat)
   (a : seq n F) (v : seq n V) (c : F),
 x =' c mX sum (mult_by_scalars a v) in _ -> is_lin_comb x (seq_set v).
intros.
red in |- *.
exists n.
set (axc_fun := fun i : fin n => c rX a i) in *.
assert (axc_comp : fun_compatible axc_fun).
red in |- *.
intros.
unfold axc_fun in |- *.
apply RING_comp; auto with algebra.
set (axc := Build_Map axc_comp:seq _ _) in *.
exists axc.
exists (seq_set_seq v).
apply Trans with (sum (mult_by_scalars axc v)).
apply Trans with (c mX sum (mult_by_scalars a v)); auto with algebra.
apply
 Trans with (sum (mult_by_scalars (const_seq n c) (mult_by_scalars a v)));
 auto with algebra.
apply sum_comp; auto with algebra.
simpl in |- *.
red in |- *; intros.
unfold mult_by_scalars, axc in |- *.
simpl in |- *.
unfold axc_fun in |- *.
auto with algebra.
apply sum_comp; auto with algebra.
Qed.

Lemma lin_comb_omit :
 forall (F : field) (V : vectorspace F) (x : V) (n : Nat)
   (a : seq n F) (v : seq n V) (i : fin n),
 x =' sum (omit (mult_by_scalars a v) i) in _ -> is_lin_comb x (seq_set v).
intros.
red in |- *.
exists n.
exists (modify_seq a i (zero F)).
exists (seq_set_seq v).
apply Trans with (sum (mult_by_scalars (modify_seq a i (zero F)) v)).
2: apply sum_comp; auto with algebra.
apply Trans with (sum (modify_seq (mult_by_scalars a v) i ((zero F) mX v i))).
2: apply sum_comp; auto with algebra.

apply
 Trans
  with
    (sum (mult_by_scalars a v) +' (min mult_by_scalars a v i) +'
     (zero F) mX v i); auto with algebra.

apply
 Trans
  with (sum (mult_by_scalars a v) +' (min mult_by_scalars a v i) +' (zero V));
 auto with algebra.
apply Trans with (sum (mult_by_scalars a v) +' (min mult_by_scalars a v i));
 auto with algebra.
apply Trans with (sum (omit (mult_by_scalars a v) i)); auto with algebra.
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                                                     *)

(* Like digraph, a graph is a type dependant of a set of vertices and   *)
(* a set of arcs. A graph is inhabited, when the construction is        *)
(* possible.Inversion lemmas are proved.                                *)

(* The following notion are defined :                                   *)
(*      - (Graph v a): dependant of a set of vertices and a set of arcs *)
(*              constructors : G_empty, G_vertex, G_edge, G_eq;         *)
(*      - GV_list : list of vertices in order of construction;          *)
(*      - GA_list : list of arcs containing (xy) and (yx);              *)
(*      - GE_list : list of edge containing (xy) or (yx);               *)
(*      - G_order : number of vertices;                                 *)
(*      - G_size : number of edges.                                     *)

Require Export Digraphs.
Require Export Edges.

Section GRAPH.

Inductive Graph : V_set -> A_set -> Set :=
  | G_empty : Graph V_empty A_empty
  | G_vertex :
      forall (v : V_set) (a : A_set) (d : Graph v a) (x : Vertex),
      ~ v x -> Graph (V_union (V_single x) v) a
  | G_edge :
      forall (v : V_set) (a : A_set) (d : Graph v a) (x y : Vertex),
      v x ->
      v y ->
      x <> y ->
      ~ a (A_ends x y) -> ~ a (A_ends y x) -> Graph v (A_union (E_set x y) a)
  | G_eq :
      forall (v v' : V_set) (a a' : A_set),
      v = v' -> a = a' -> Graph v a -> Graph v' a'.

Fixpoint GV_list (v : V_set) (a : A_set) (g : Graph v a) {struct g} :
 V_list :=
  match g with
  | G_empty => V_nil
  | G_vertex v' a' g' x _ => x :: GV_list v' a' g'
  | G_edge v' a' g' x y _ _ _ _ _ => GV_list v' a' g'
  | G_eq v' _ a' _ _ _ g' => GV_list v' a' g'
  end.

Fixpoint GA_list (v : V_set) (a : A_set) (g : Graph v a) {struct g} :
 A_list :=
  match g with
  | G_empty => A_nil
  | G_vertex v' a' g' x _ => GA_list v' a' g'
  | G_edge v' a' g' x y _ _ _ _ _ =>
      A_ends x y :: A_ends y x :: GA_list v' a' g'
  | G_eq v' _ a' _ _ _ g' => GA_list v' a' g'
  end.

Fixpoint GE_list (v : V_set) (a : A_set) (g : Graph v a) {struct g} :
 E_list :=
  match g with
  | G_empty => E_nil
  | G_vertex v' a' g' x _ => GE_list v' a' g'
  | G_edge v' a' g' x y _ _ _ _ _ => E_ends x y :: GE_list v' a' g'
  | G_eq v' _ a' _ _ _ g' => GE_list v' a' g'
  end.

Definition G_order (v : V_set) (a : A_set) (g : Graph v a) :=
  length (GV_list v a g).

Definition G_size (v : V_set) (a : A_set) (g : Graph v a) :=
  length (GE_list v a g).

Lemma G_v_dec :
 forall (v : V_set) (a : A_set) (g : Graph v a) (x : Vertex), {v x} + {~ v x}.
Proof.
        intros v a g; elim g; intros.
        right; apply V_empty_nothing.

        case (H x0); intros.
        left; apply V_in_right; trivial.

        case (V_eq_dec x x0); intros.
        left; apply V_in_left; rewrite e; apply V_in_single.

        right; red in |- *; intros; inversion H0.
        elim n1; inversion H1; trivial.

        elim n0; trivial.

        auto.

        case (H x); intros.
        left; elim e; trivial.

        right; elim e; trivial.
Qed.

Lemma G_a_dec :
 forall (v : V_set) (a : A_set) (g : Graph v a) (x : Arc), {a x} + {~ a x}.
Proof.
        intros v a g; elim g; intros.
        right; apply A_empty_nothing.

        auto.

        case (H x0); intros.
        left; apply A_in_right; trivial.

        case (A_eq_dec (A_ends x y) x0); intros.
        left; apply A_in_left; rewrite <- e; apply E_right; trivial.

        case (A_eq_dec (A_ends y x) x0); intros.
        left; apply A_in_left; rewrite <- e; apply E_left; trivial.

        right; red in |- *; intros; inversion H0.
        inversion H1.
        elim n3; trivial.

        elim n4; trivial.

        elim n2; trivial.

        case (H x); intros.
        left; elim e0; trivial.

        right; elim e0; trivial.
Qed.

Lemma G_non_directed :
 forall (v : V_set) (a : A_set) (g : Graph v a) (x y : Vertex),
 a (A_ends x y) -> a (A_ends y x).
Proof.
        intros v a g; elim g; intros.
        inversion H.

        auto.

        inversion H0.
        apply A_in_left.
        inversion H1.
        apply E_left.

        apply E_right.

        apply A_in_right; auto.

        generalize H0; elim e0; auto.
Qed.

Lemma G_ina_inv1 :
 forall (v : V_set) (a : A_set) (g : Graph v a) (x y : Vertex),
 a (A_ends x y) -> v x.
Proof.
        intros v a g; elim g; intros.
        inversion H.

        apply V_in_right; apply (H x0 y); trivial.

        inversion H0.
        inversion H1; rewrite <- H4; trivial.

        apply (H x0 y0); trivial.

        rewrite <- e; apply (H x y); rewrite e0; trivial.
Qed.

Lemma G_ina_inv2 :
 forall (v : V_set) (a : A_set) (g : Graph v a) (x y : Vertex),
 a (A_ends x y) -> v y.
Proof.
        intros v a g; elim g; intros.
        inversion H.

        apply V_in_right; apply (H x0 y); trivial.

        inversion H0.
        inversion H1; rewrite <- H5; trivial.

        apply (H x0 y0); trivial.

        rewrite <- e; apply (H x y); rewrite e0; trivial.
Qed.

End GRAPH.

Section GRAPH_TO_DIGRAPH.

Lemma graph_isa_digraph :
 forall (v : V_set) (a : A_set) (d : Graph v a), Digraph v a.
Proof.
        intros v a d; elim d; intros.
        exact D_empty.

        apply D_vertex; auto.

        apply
         (D_eq v0 v0
            (A_union (A_single (A_ends x y))
               (A_union (A_single (A_ends y x)) a0))
            (A_union (E_set x y) a0)).
        trivial.

        symmetry  in |- *; apply E_add_edge.

        apply D_arc.
        apply D_arc; auto.

        trivial.

        trivial.

        red in |- *; intros; inversion_clear H0.
        inversion H1.
        elim n; auto.

        elim n0; auto.

        apply (D_eq v0 v' a0 a'); auto.
Defined.

End GRAPH_TO_DIGRAPH.

Section UNION_GRAPHS.

Lemma G_union :
 forall (v1 v2 : V_set) (a1 a2 : A_set),
 Graph v1 a1 -> Graph v2 a2 -> Graph (V_union v1 v2) (A_union a1 a2).
Proof.
        intros; elim H; intros.
        apply G_eq with (v := v2) (a := a2).
        symmetry  in |- *; apply V_union_neutral.

        symmetry  in |- *; apply A_union_neutral.

        trivial.

        case (G_v_dec v2 a2 H0 x); intros.
        apply G_eq with (v := V_union v v2) (a := A_union a a2).
        rewrite V_union_assoc; rewrite (V_union_absorb (V_single x)); trivial.
        apply V_included_single; apply V_in_right; trivial.

        trivial.

        trivial.

        apply
         G_eq
          with (v := V_union (V_single x) (V_union v v2)) (a := A_union a a2).
        symmetry  in |- *; apply V_union_assoc.

        trivial.

        apply G_vertex.
        trivial.

        apply V_not_union; trivial.

        case (G_a_dec v2 a2 H0 (A_ends x y)); intros.
        apply G_eq with (v := V_union v v2) (a := A_union a a2).
        trivial.

        rewrite A_union_assoc; rewrite (A_union_absorb (E_set x y)); trivial.
        apply E_inclusion.
        apply A_in_right; trivial.

        apply A_in_right; apply (G_non_directed v2 a2 H0); auto.

        trivial.

        apply
         G_eq
          with (v := V_union v v2) (a := A_union (E_set x y) (A_union a a2)).
        trivial.

        symmetry  in |- *; apply A_union_assoc.

        apply G_edge.
        trivial.

        apply V_in_left; trivial.

        apply V_in_left; trivial.

        trivial.

        apply A_not_union; trivial.

        apply A_not_union.
        trivial.

        red in |- *; intro; elim n2; apply (G_non_directed v2 a2 H0); trivial.

        apply G_eq with (v := V_union v v2) (a := A_union a a2).
        elim e; trivial.

        elim e0; trivial.

        trivial.
Qed.

End UNION_GRAPHS.

Section INVERSION_GRAPH.

Lemma G_empty_empty :
 forall (v : V_set) (a : A_set), Graph v a -> v = V_empty -> a = A_empty.
Proof.
        intros v a g; elim g; intros.
        trivial.

        elim (V_empty_nothing x); fold V_empty in |- *; rewrite <- H0;
         apply V_in_left; apply V_in_single.

        elim (V_empty_nothing x); fold V_empty in |- *; rewrite <- H0;
         trivial.

        rewrite <- e0; apply H; rewrite e; trivial.
Qed.

Lemma V_union_single_inter :
 forall (x y : Vertex) (v v' : V_set),
 ~ v x ->
 x <> y ->
 V_union (V_single x) v = V_union (V_single y) v' ->
 V_union (V_single x) (V_inter v v') = v'.
Proof.
        intros; rewrite V_distributivity_union_inter.
        fold V_union in |- *; rewrite H1;
         rewrite (V_union_commut (V_single x));
         rewrite (V_union_commut (V_single y));
         rewrite <- V_distributivity_union_inter.
        rewrite V_single_single_disjoint.
        rewrite V_union_commut; apply V_union_neutral.

        auto.
Qed.

Lemma G_minus_vertex :
 forall (v : V_set) (a : A_set) (g : Graph v a) (x : Vertex),
 v x ->
 (forall y : Vertex, ~ a (A_ends x y)) ->
 forall v' : V_set, ~ v' x -> v = V_union (V_single x) v' -> Graph v' a.
Proof.
intros v a g; elim g; intros.
elim (V_empty_nothing x); trivial.

case (V_union_single_dec x x0 v0 n H0); intros.
apply G_eq with (v := v0) (a := a0).
apply V_union_inversion with (E := V_single x).
apply V_single_disjoint; trivial.

apply V_single_disjoint; rewrite e; trivial.

pattern x at 2 in |- *; rewrite e; trivial.

trivial.

trivial.

generalize (H x0 v1 H1); intros.
apply G_eq with (v := V_union (V_single x) (V_inter v0 v')) (a := a0).
apply (V_union_single_inter x x0).
trivial.

red in |- *; intros Heq; elim n; rewrite Heq; trivial.

trivial.

trivial.

apply G_vertex.
apply H4.
unfold V_inter in |- *.
rewrite (V_inter_commut v0 v'); apply V_not_inter; trivial.

rewrite V_inter_commut; symmetry  in |- *; apply (V_union_single_inter x0 x).
trivial.

red in |- *; intros Heq; elim n; rewrite <- Heq; trivial.

auto.

apply V_not_inter; trivial.

apply G_edge.
apply (H x0).
trivial.

red in |- *; intros; elim (H1 y0).
apply A_in_right; trivial.

trivial.

trivial.

rewrite H3 in v1; inversion v1.
elim (H1 y); inversion H4; apply A_in_left; apply E_right.

trivial.

rewrite H3 in v2; inversion v2.
elim (H1 x); inversion H4; apply A_in_left; apply E_left.

trivial.

trivial.

trivial.

trivial.

apply G_eq with (v := v'0) (a := a0).
trivial.

trivial.

apply (H x).
rewrite e; rewrite H3; apply V_in_left; apply V_in_single.

rewrite e0; trivial.

trivial.

rewrite e; trivial.
Qed.

Lemma A_union_single_inter :
 forall (x y x' y' : Vertex) (a a' : A_set),
 ~ a (A_ends x y) ->
 ~ a (A_ends y x) ->
 E_set x y <> E_set x' y' ->
 A_union (E_set x y) a = A_union (E_set x' y') a' ->
 A_union (E_set x y) (A_inter a a') = a'.
Proof.
        intros; rewrite A_distributivity_union_inter.
        fold A_union in |- *; rewrite H2;
         rewrite (A_union_commut (E_set x y));
         rewrite (A_union_commut (E_set x' y'));
         rewrite <- A_distributivity_union_inter.
        rewrite E_inter_empty.
        rewrite A_union_commut; apply A_union_neutral.

        auto.
Qed.

Lemma G_minus_edge :
 forall (v : V_set) (a : A_set) (g : Graph v a) (x y : Vertex),
 a (A_ends x y) ->
 forall a' : A_set,
 ~ a' (A_ends x y) ->
 ~ a' (A_ends y x) -> a = A_union (E_set x y) a' -> Graph v a'.
Proof.
intros v a g; elim g.
unfold A_empty in |- *; tauto.

intros; apply G_vertex; eauto 2.

intros; case (E_set_eq_dec x x0 y y0); intros.
apply G_eq with (v := v0) (a := a0).
trivial.

apply (A_union_inversion (E_set x y) a0 a').
apply E_set_disjoint; trivial.

rewrite e; apply E_set_disjoint; trivial.

rewrite <- e in H3; trivial.

trivial.

apply G_eq with (v := v0) (a := A_union (E_set x y) (A_inter a0 a')).
trivial.

apply A_union_single_inter with (x' := x0) (y' := y0); trivial.

apply G_edge.
apply (H x0 y0).
inversion H0.
absurd (E_set x y = E_set x0 y0).
trivial.

inversion H4.
trivial.

apply E_set_eq.

trivial.

red in |- *; intros Ha; inversion Ha; elim H1; trivial.

red in |- *; intros Ha; inversion Ha; elim H2; trivial.

rewrite A_inter_commut; symmetry  in |- *;
 apply A_union_single_inter with (x' := x) (y' := y).
trivial.

trivial.

auto.

auto.

trivial.

trivial.

trivial.

red in |- *; intros Ha; inversion Ha; elim n0; trivial.

red in |- *; intros Ha; inversion Ha; elim n1; trivial.

intros.
apply G_eq with (v := v0) (a := a'0).
trivial.

trivial.

apply (H x y).
rewrite e0; trivial.

trivial.

trivial.

rewrite e0; trivial.
Qed.

End INVERSION_GRAPH.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Structure.Cartesian.
Require Export Category.Structure.Initial.
Require Export Category.Construction.Opposite.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

(* To be cocartesian is just to be cartesian in the opposite category; but to
   avoid confusion, we'd like a set of notations specific to categories with
   cocartesian structure. *)

Notation "'Cocartesian' C" := (@Cartesian (C^op))
  (at level 9) : category_theory_scope.
Notation "@Cocartesian C" := (@Cartesian (C^op))
  (at level 9) : category_theory_scope.

Section Cocartesian_.

Context `{O : @Cocartesian C}.

Definition Coprod : C -> C -> C := @product_obj _ O.

Infix "+" := Coprod (at level 50, left associativity) : object_scope.

Global Program Instance coprod_respects_iso {x y z : C} :
  Proper (Isomorphism ==> Isomorphism ==> Isomorphism) Coprod.
Next Obligation.
  proper.
  pose proof (@isomorphism_equivalence (C^op)).
  spose (@prod_respects_iso _ O x y z
           y0 x0 (symmetry (Isomorphism_Opposite X))
           y1 x1 (symmetry (Isomorphism_Opposite X0))) as X2.
  pose proof (@isomorphism_equivalence C).
  apply (symmetry (Isomorphism_Opposite X2)).
Qed.

Definition merge {x y z : C} (f : y ~> x) (g : z ~> x) : y + z ~{C}~> x :=
  @fork _ O _ _ _ f g.

Infix "▽" := merge (at level 26) : morphism_scope.

Global Program Instance merge_respects {x y z} :
  Proper (equiv ==> equiv ==> equiv) (@merge x y z).
Next Obligation. apply (@fork_respects _ O). Qed.

Definition inl {x y : C} : x ~{C}~> x + y := @exl _ O _ _.
Definition inr {x y : C} : y ~{C}~> x + y := @exr _ O _ _.

Definition left  {x y z : C} (f : x ~> y) : x + z ~{C}~> y + z :=
  (inl ∘ f) ▽ inr.

Definition right  {x y z : C} (f : x ~> y) : z + x ~{C}~> z + y :=
  inl ▽ (inr ∘ f).

Definition cover  {x y z w : C} (f : x ~> y) (g : z ~> w) :
  x + z ~{C}~> y + w :=
  (inl ∘ f) ▽ (inr ∘ g).

Global Program Instance parametric_morphism_left {a b c : C} :
  Proper (equiv ==> equiv) (@left a b c).
Next Obligation. apply (@parametric_morphism_first _ O). Qed.

Global Program Instance parametric_morphism_right {a b c : C} :
  Proper (equiv ==> equiv) (@right a b c).
Next Obligation. apply (@parametric_morphism_second _ O). Qed.

Global Program Instance parametric_morphism_cover {a b c d : C} :
  Proper (equiv ==> equiv ==> equiv) (@cover a b c d).
Next Obligation.
  proper.
  unfold cover.
  rewrites.
  reflexivity.
Qed.

Definition paws {x y : C} : x + y ~{C}~> y + x := @swap _ O _ _.

Lemma inl_merge {x z w : C} (f : z ~> x) (g : w ~> x) :
  f ▽ g ∘ inl ≈ f.
Proof. apply (@exl_fork _ O). Qed.

Hint Rewrite @inl_merge : categories.

Lemma inr_merge {x z w : C} (f : z ~> x) (g : w ~> x) :
  f ▽ g ∘ inr ≈ g.
Proof. apply (@exr_fork _ O). Qed.

Hint Rewrite @inr_merge : categories.

Corollary merge_inl_inr {x y : C} :
  inl ▽ inr ≈ @id C (x + y).
Proof. apply (@fork_exl_exr _ O). Qed.

Hint Rewrite @merge_inl_inr : categories.

Corollary merge_inv {x y z : C} (f h : y ~> x) (g i : z ~> x) :
  f ▽ g ≈ h ▽ i ↔ (f ≈ h) * (g ≈ i).
Proof. apply (@fork_inv _ O). Qed.

Corollary merge_comp {x y z w : C} (f : y ~> z) (h : w ~> z) (g : z ~> x) :
  (g ∘ f) ▽ (g ∘ h) ≈ g ∘ f ▽ h.
Proof. apply (@fork_comp _ O). Qed.

Theorem left_comp {x y z w : C} (f : y ~> z) (g : x ~> y) :
  left (z:=w) (f ∘ g) ≈ left f ∘ left g.
Proof. apply (@first_comp _ O). Qed.

Theorem left_fork {x y z w : C} (f : y ~> x) (g : z ~> x) (h : w ~> y) :
  f ▽ g ∘ left h ≈ (f ∘ h) ▽ g.
Proof. apply (@first_fork _ O). Qed.

Theorem right_comp {x y z w : C} (f : y ~> z) (g : x ~> y) :
  right (z:=w) (f ∘ g) ≈ right f ∘ right g.
Proof. apply (@second_comp _ O). Qed.

Theorem right_fork {x y z w : C} (f : y ~> x) (g : z ~> x) (h : w ~> z) :
  f ▽ g ∘ right h ≈ f ▽ (g ∘ h).
Proof. apply (@second_fork _ O). Qed.

Corollary inl_left {x y z : C} (f : x ~> y) :
  left f ∘ @inl x z ≈ inl ∘ f.
Proof. apply (@exl_first _ O). Qed.

Hint Rewrite @inl_left : categories.

Corollary inr_left {x y z : C} (f : x ~> y) :
  left f ∘ @inr x z ≈ inr.
Proof. apply (@exr_first _ O). Qed.

Hint Rewrite @inr_left : categories.

Corollary inl_right {x y z : C} (f : x ~> y) :
  right f ∘ @inl z x ≈ inl.
Proof. apply (@exl_second _ O). Qed.

Hint Rewrite @inl_right : categories.

Corollary inr_right {x y z : C} (f : x ~> y) :
  right f ∘ @inr z x ≈ inr ∘ f.
Proof. apply (@exr_second _ O). Qed.

Hint Rewrite @inr_right : categories.

Theorem paws_left {x y z : C} (f : x ~> y) :
  paws ∘ left (z:=z) f ≈ right f ∘ paws.
Proof. symmetry; apply (@swap_second _ O y x z f). Qed.

Theorem paws_right {x y z : C} (f : x ~> y) :
  paws ∘ right f ≈ left (z:=z) f ∘ paws.
Proof. symmetry; apply (@swap_first _ O y x z f). Qed.

Theorem left_right {x y z w : C} (f : x ~> y) (g : z ~> w) :
  left f ∘ right g ≈ right g ∘ left f.
Proof. symmetry; apply (@first_second _ O). Qed.

Theorem paws_fork {x y z : C} (f : y ~> x) (g : z ~> x) :
  f ▽ g ∘ paws ≈ g ▽ f.
Proof. apply (@swap_fork _ O). Qed.

Definition paws_invol {x y : C} :
  paws ∘ paws ≈ @id C (x + y).
Proof. unfold paws; apply (@swap_invol _ O). Qed.

Hint Rewrite @paws_invol : categories.

Context `{I : @Initial C}.

Global Program Instance coprod_zero_l {x : C} :
  0 + x ≅ x := {
  to   := zero ▽ id;
  from := inr
}.
Next Obligation. apply (@prod_one_l _ _ I). Qed.

Hint Rewrite @coprod_zero_l : isos.

Global Program Instance coprod_zero_r {x : C} :
  x + 0 ≅ x := {
  to   := id ▽ zero;
  from := inl
}.
Next Obligation. apply (@prod_one_r _ _ I). Qed.

Hint Rewrite @coprod_zero_r : isos.

Global Program Instance coprod_comm  {x y : C} :
  x + y ≅ y + x := {
  to   := paws;
  from := paws
}.

Global Program Instance coprod_assoc  {x y z : C} :
  (x + y) + z ≅ x + (y + z) := {
  to   := (inl ▽ (inr ∘ inl)) ▽ (inr ∘ inr);
  from := (inl ∘ inl) ▽ ((inl ∘ inr) ▽ inr)
}.
Next Obligation. apply (@prod_assoc _ O). Qed.
Next Obligation. apply (@prod_assoc _ O). Qed.

End Cocartesian_.

Infix "+" := Coprod (at level 50, left associativity) : object_scope.
Infix "▽" := merge (at level 26) : morphism_scope.

Hint Rewrite @inl_merge : categories.
Hint Rewrite @inr_merge : categories.
Hint Rewrite @merge_inl_inr : categories.
Hint Rewrite @coprod_zero_r : isos.
Hint Rewrite @coprod_zero_l : isos.