(** * System LJ for first-order intuitionistic logic encoded as an LL theory *)

(** The rule for conjunction in this system is

<<
Gamma , Fi |-- G
----------------------
Gamma , F1/\ F2 |-- G
>>
and hence encoded with the formula [PLUSWITH] (that uses [OPLUS] to choose one of the formulas Fi *)

Require Export FLL.OL.CutCoherence.OLCuti.
Require Import FLL.Misc.Permutations.

Export ListNotations.
Export LLNotations.
Set Implicit Arguments.

(** ** Syntax *)
(** units: true and false *)
Inductive Constants := TT | FF  .
(** conjunction, disjunction and implication *)
Inductive Connectives := AND | OR | IMP  .
(** universal and existential quantifiers *)
Inductive Quantifiers := ALL|SOME .
(* No unary connectives *)
Inductive UConnectives := .

Instance SimpleOLSig : OLSyntax:=
  {|
    OLType := nat;
    constants := Constants ;
    uconnectives := UConnectives;
    connectives := Connectives ;
    quantifiers := Quantifiers
  |}.

(** ** Inference rules *)
(** The following definitions chooses the  LL connectives to encode the LJ rules *)
(** Constants *)
Definition rulesCTE (c:constants) :=
  match c with
  | TT => ZEROTOP
  | FF => TOPZERO
  end.

(** Binary connectives *)
Definition rulesBC (c :connectives) :=
  match c with
  | AND => PLUSWITH
  | OR =>  WITHPLUS
  | IMP => TENSORPAR
  end.

(** Quantifiers *)
Definition rulesQD (q :quantifiers) :=
  match q with
  | ALL => ALLSOME
  | SOME => SOMEALL
  end
.

Instance SimpleOORUles : OORules :=
  {|
    rulesCte := rulesCTE ;
    rulesBin := rulesBC;
    rulesQ := rulesQD
  |}.

(** An inductive definition for LJ. This will be used to prove that
the LL encoding is sound and complete *)

Inductive LJSeq : list uexp -> uexp -> Prop :=
| LJTRUE : forall L, LJSeq L (t_cons TT)
| LJFALSE : forall L G, LJSeq (t_cons FF :: L) G
| LJinit : forall L F,  LJSeq (F:: L) F
| LJAndL1 : forall L F G R, LJSeq (F :: L) R -> LJSeq ( (t_bin AND F G) :: L) R
| LJAndL2 : forall L F G R, LJSeq (G :: L) R -> LJSeq ( (t_bin AND F G) :: L) R
| LJAndR : forall L F G , LJSeq L F -> LJSeq L G -> LJSeq L (t_bin AND F G)
| LJOrL : forall L F G R,  LJSeq (F :: L) R ->  LJSeq (G :: L) R -> LJSeq ( (t_bin OR F G) :: L) R
| LJOrR1 : forall L F G , LJSeq L F -> LJSeq L (t_bin OR F G)
| LJOrR2 : forall L F G , LJSeq L G -> LJSeq L (t_bin OR F G)
| LJImpL : forall L A B G , LJSeq L A -> LJSeq (B:: L) G -> LJSeq (t_bin IMP A B ::L) G
| LJImpR : forall L A B  , LJSeq (A:: L) B ->  LJSeq L (t_bin IMP A B)
| LJAllL : forall L t FX G, uniform FX -> proper t -> LJSeq( FX t :: L) G -> LJSeq (t_quant ALL FX :: L) G
| LJAllR : forall L FX , uniform FX -> (forall x, proper x -> LJSeq L (FX x)) -> LJSeq L (t_quant ALL FX)
| LJEXL : forall L FX G, uniform FX -> (forall x, proper x -> LJSeq (FX x:: L) G) -> LJSeq (t_quant SOME FX :: L) G
| LJEXR : forall L FX t, uniform FX -> proper t -> LJSeq L (FX t)-> LJSeq L (t_quant SOME FX)
| (* contraction is needed *)
LJContr : forall L F G, (LJSeq (F :: F:: L)) G -> (LJSeq (F :: L)) G
| (* Explicit exchange *)
LJEx : forall L L' G, Permutation L L' -> LJSeq L G -> LJSeq L' G
.
Hint Constructors LJSeq : core .
Hint Constructors LJSeq : core .
Hint Constructors OLTheory buildTheory : core.
Hint Constructors  isOLFormula : core.
Hint Unfold IsPositiveLAtomFormulaL : core.
Hint Constructors IsPositiveRAtomFormula : core .

Global Instance LJL_morph :
  Proper ((@Permutation uexp) ==> eq ==> iff) (LJSeq).
Proof.
  unfold Proper; unfold respectful.
  intros.
  split;intros;subst.
  eapply LJEx;eauto.
  apply Permutation_sym in H.
  eapply LJEx;eauto.
Qed.

Ltac solveOLTheory :=
  try
    match goal with
    | [|- OLTheory _] =>
      first [ apply ooth_init ; auto ; SolveIS
            | do 2 constructor;auto ; SolveIS ]
    end.

(** Soundness theorem *)
Theorem Soundeness: forall L F, LJSeq L F ->
                                isOLFormulaL L ->
                                isOLFormula F ->
                                seq OLTheory (LEncode L) (REncode [F]) (> []).
Proof with solveF;solveLL;solveOLTheory;SolveIS;solveOLTheory.
  intros.
  induction H.
  + (* True on the right *)
    decide3 (makeRuleConstant TT Right)...
    tensor (REncode [t_cons TT]) (@nil oo).
  + (* false on the left *)
    decide3 (makeRuleConstant FF Left)...
    tensor (@nil oo) (REncode [G])...
  + (* init *)
    decide3 (RINIT F)...
    tensor (REncode [F]) (@nil oo)...
  + (* ANDL1 *)
    decide3 (makeRuleBin AND Left F G)...
    tensor (@nil oo) (REncode [R])...
    oplus1.
    LLPerm ( d| t_bin AND F G | :: d| F |  :: LEncode L).
    apply weakening.
    apply IHLJSeq...
  +  (* ANDL2 *)
    decide3 (makeRuleBin AND Left F G)...
    tensor (@nil oo) (REncode [R])...
    oplus2.
    LLPerm ( d| t_bin AND F G | :: d| G |  :: LEncode L).
    apply weakening.
    apply IHLJSeq...
  + (* And R *)
    decide3 (makeRuleBin AND Right F G)...
    tensor (REncode [t_bin AND F G]) (@nil oo).
    apply  IHLJSeq1...
    apply  IHLJSeq2...
  + (* Or L *)
    decide3 (makeRuleBin OR Left F G)...
    tensor (@nil oo)  (REncode [R])...

    apply weakening. LLPerm(d| F | :: LEncode L).
    apply IHLJSeq1...

    apply weakening. LLPerm(d| G | :: LEncode L).
    apply IHLJSeq2...
  +  (* OrR1 *)
    decide3 (makeRuleBin OR Right F G)...
    tensor (REncode [t_bin OR F G]) (@nil oo).
    oplus1.
    apply IHLJSeq...
  +  (* OrR2 *)
    decide3 (makeRuleBin OR Right F G)...
    tensor (REncode [t_bin OR F G]) (@nil oo).
    oplus2.
    apply IHLJSeq...
  + (* implication left *)
    decide3 (makeRuleBin IMP Left A B)...
    tensor (@nil oo) (REncode [G])...
    tensor (@nil oo) (REncode [G])...
    apply weakening.
    apply IHLJSeq1...
    apply weakening.
    LLPerm (d| B | :: LEncode L ) .
    apply IHLJSeq2...
  + (* implication right *)
    decide3 (makeRuleBin IMP Right A B)...
    tensor (REncode [t_bin IMP A B]) (@nil oo).

    LLPerm (d| A | :: LEncode L ) .
    apply IHLJSeq...
  + (* forall left *)
    decide3 (makeRuleQ ALL Left FX)...
    tensor (@nil oo) (REncode [G])...
    existential t...
    apply weakening.
    LLPerm(d| FX t |:: LEncode L )...
    apply IHLJSeq...
  + (* forall right *)
    decide3 (makeRuleQ ALL Right FX)...
    tensor (REncode [t_quant ALL FX]) (@nil oo)...
    apply H3...
  + (* existst left *)
    decide3 (makeRuleQ SOME Left FX)...
    tensor (@nil oo) (REncode [G])...
    apply weakening...
    LLPerm(d| FX x |:: LEncode L )...
    apply H3...
  + (* exists right *)
    decide3 (makeRuleQ SOME Right FX)...
    tensor  (REncode [t_quant SOME FX]) (@nil oo)...
    existential t...
    apply IHLJSeq...
  + (* contraction *)
    eapply contractionSet with (L0:=LEncode [F]);[firstorder|]...
    apply IHLJSeq...
  + (* exchange *)
    eapply Permutation_map in  H as H'.
    unfold LEncode; rewrite <- H'...
    apply IHLJSeq...
    rewrite H...
Qed.

Ltac toLJ H :=
  match (type of H) with
  | In (u| _ |)(LEncode _ ++ REncode _) =>
    apply upRight in H; apply OLInPermutation in H;CleanContext
  | In (d| _ |)(LEncode _) =>
    apply OLInPermutationL in H;CleanContext;
    eapply LJEx; [apply Permutation_sym;eauto | ]
  | seqN _ _ (u| ?F | :: LEncode ?L ++ REncode ?R) [] (> []) =>
    apply exchangeCCN with (CC' := LEncode L ++ REncode (F :: R)) in H ;[| simpl; perm]
  | seqN _ _ (u| ?F | :: ?T :: LEncode ?L ++ REncode ?R) [] (> []) =>
    apply exchangeCCN with (CC' := T :: LEncode L ++ REncode (F :: R)) in H ;[| simpl; perm]
  | seqN _ _ (d| ?F | :: LEncode ?L ++ REncode ?R) [] (> []) =>
    apply exchangeCCN with (CC' := LEncode (F :: L) ++ REncode R) in H ;[| simpl; perm]
  | seqN _ _ (d| ?F | :: ?T :: LEncode ?L ++ REncode ?R) [] (> []) =>
    apply exchangeCCN with (CC' := T :: LEncode (F::L) ++ REncode R) in H ;[| simpl; perm]
  end.

(** Completeness theorem *)
Theorem Completeness: forall n L F ,
    isOLFormulaL L ->
    isOLFormula F ->
    seqN OLTheory n (LEncode L)  (REncode [F]) (> []) ->
    LJSeq L F .
Proof with solveF;solveLL;SolveIS;CleanContext.
  induction n using strongind;intros.
  inversion H1.

  inversion H2;subst.
  simpl in H5.
  apply RemoveUnique in H5...
  apply InIsPositiveL in H5;contradiction.
  inversion H4...
  + (* from the theory *)
    inversion H3...
    ++ (* Constant right *)
      apply FocusingRightCte in H6...
      (* by cases on C *)
      destruct C;simpl in H8...
    ++  (* constant left *)
      apply FocusingLeftCte in H6...
      (* by cases on C *)
      destruct C;simpl in H8...
      toLJ H7.
      apply LJFALSE.
    ++ (* binary connective right *)
      apply FocusingRightRule in H6...
      (* by cases on C *)
      destruct C;simpl in H8...
      { (* case AND *)
        apply AppPLUSWITHRight in H8...
        apply LJAndR; apply (H x0)...
      }
      { (*  OR *)
        apply AppWITHPLUSRight in H8...
        destruct H8.
        apply LJOrR1.
        apply (H x0)...
        apply LJOrR2.
        apply (H x0)...
      }
      { (* impl *)
        apply AppTENSORPARRight in H8...
        apply LJImpR.
        apply (H x0)...
      }
    ++  (* binary connective left *)
      apply FocusingLeftRule in H6...
      (* by cases on C *)
      destruct C;simpl in H8...
      { (* case AND *)
        apply AppPLUSWITHLeft in H8...
        destruct H8.
        + toLJ H7.
          apply LJContr.
          apply LJAndL1; rewrite <- H7.
          eapply (H x0)...
        + toLJ H7.
          apply LJContr.
          apply LJAndL2; rewrite <- H7.
          eapply (H x0)...
      }
      { (*  OR *)
        apply AppWITHPLUSLeft in H8...
        toLJ H7.
        apply LJContr.
        apply LJOrL; rewrite <- H6; eapply (H x0)...
      }
      { (* impl *)
        apply AppTENSORPARLeft in H8...
        toLJ H7.
        apply LJContr.
        apply LJImpL; rewrite <- H6; eapply (H x0)...
      }
    ++ (* Quantifier right *)
      apply FocusingRightQ in H6...
      (* by cases on C*)
      destruct C;simpl in H9...
      { (* case ALL *)
        apply AppALLSOMERight in H9...
        apply LJAllR;intros...
        specialize (H8 x H6).
        eapply (H x0)...
      }
      { (* case SOME *)
        apply AppSOMEALLRight in H9...
        apply LJEXR with (t:=x1)...
        eapply (H x0)...
      }
    ++ (* Quantifier left *)
      apply FocusingLeftQ in H6...
      (* by cases on C*)
      destruct C;simpl in H9...
      { (* case ALL *)
        apply AppALLSOMELeft in H9...
        toLJ H8.
        apply LJContr.
        apply LJAllL with (t:= x1)...
        rewrite <- H6; eapply (H x0)...
      }
      { (* case SOME *)
        apply AppSOMEALLLeft in H9...
        toLJ H8.
        apply LJContr.
        rewrite <- H6.
        apply LJEXL;intros...
        specialize (H9 _ H8).
        eapply (H x0)...
      }
  + (* init *)
    apply Init_inversion1 in H6...
    toLJ H6.
    apply LJinit.
Qed.

Theorem Adequacy:  forall L F ,
    isOLFormulaL L ->
    isOLFormula F ->
    (
      seq OLTheory  (LEncode L) (REncode [F]) (> []) <->
      LJSeq L F ).
Proof with solveF;solveLL.
  intros.
  split;intros.
  + apply seqtoSeqN in H1;CleanContext.
    apply  Completeness in H1...
  +  apply Soundeness in H1...
Qed.
(** The cut-elimination theorem instantiated for LJ *)
Check Adequacy .
Check CutElimination.


Require Import
  Coq.Program.Program
  Coq.Unicode.Utf8
  Coq.Classes.Morphisms
  Coq.Lists.List
  Model
  Syntax.

Open Scope program_scope.

CoInductive Machine (a b : Type) :=
  | Step : (a -> Machine a b + b) -> Machine a b.

Arguments Step {a b} _.

CoFixpoint map {a b c : Type} (f : b -> c)
           (p : Machine a b) : Machine a c :=
  match p with
  | Step k => Step (λ x, match k x with
                         | inl m => inl (map f m)
                         | inr r => inr (f r)
                         end)
  end.

Module LTLMachine (S : StreamType).

Module Import LTL := LTL S.

Inductive Failed : Type :=
  | HitBottom
  | Rejected    (x : S.a)
  | BothFailed  (p q : Failed)
  | LeftFailed  (p : Failed)
  | RightFailed (q : Failed).

Inductive Result : Type :=
  | Failure (e : Failed)
  | Success.

Definition LTL := Machine S.a Result.

Definition stop (r : Result) : LTL := Step (λ _, inr r).

Definition true := stop Success.

Definition false := stop (Failure HitBottom).

Definition invert (r : Result) : Result :=
  match r with
  | Failure e => Success
  | Success   => Failure HitBottom
  end.

Definition negate : LTL -> LTL := map invert.

Definition next (p : LTL) : LTL :=
  match p with
  | Step k => Step (λ _, inl (Step k))
  end.

CoFixpoint and (p q : LTL) : LTL :=
  match p with
  | Step k =>
    Step (λ a,
          match k a with
          | inr (Failure e) => inr (Failure (LeftFailed e))
          | inr Success     =>
            match q with
            | Step g => g a
            end
          | inl p' =>
            match q with
            | Step g =>
              match g a with
              | inr (Failure e) => inr (Failure (RightFailed e))
              | inr Success     => inl p'
              | inl q'          => inl (and p' q')
              end
            end
          end)
  end.

Definition andNext (p q : LTL) : LTL :=
  match p with
  | Step k =>
    Step (λ a,
          match k a with
          | inr (Failure e) => inr (Failure (LeftFailed e))
          | inr Success     => inl q
          | inl p'          => inl (and p' q)
          end)
  end.

CoFixpoint or (p q : LTL) : LTL :=
  match p with
  | Step k =>
    Step (λ a,
          match k a with
          | inr Success      => inr Success
          | inr (Failure e1) =>
            match q with
            | Step g =>
              match g a with
              | inr (Failure e2) => inr (Failure (BothFailed e1 e2))
              | q' => q'
              end
            end
          | inl p' =>
            match q with
            | Step g =>
              match g a with
              | inr Success     => inr Success
              | inr (Failure _) => inl p'
              | inl q'          => inl (or p' q')
              end
            end
          end)
  end.

Definition orNext (p q : LTL) : LTL :=
  match p with
  | Step k =>
    Step (λ a,
          match k a with
          | inr Success     => inr Success
          | inr (Failure _) => inl q
          | inl p'          => inl (or p' q)
          end)
  end.

(*
CoFixpoint until (p q : LTL) : LTL :=
  or q (andNext p (until p q)).

CoFixpoint wait (p q : LTL) : LTL :=
  or q (andNext p (wait p q)).

CoFixpoint always (p : LTL) : LTL :=
  andNext p (always p).

CoFixpoint eventually (p : LTL) : LTL :=
  orNext p (eventually p).

CoFixpoint release (p q : LTL) : LTL :=
  and q (orNext p (release p q)).

CoFixpoint strong_release (p q : LTL) : LTL :=
  and q (orNext p (strong_release p q)).
*)

End LTLMachine.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir *)

(** A type class-based library for working with decidable equality. *)

Require Import Coq.Classes.Equivalence.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Logic.Decidable.

(* *********************************************************************** *)
(** * Hints for [equiv] *)

Hint Extern 0 (?x === ?x) => reflexivity : core.
Hint Extern 1 (_ === _) => (symmetry; trivial; fail) : core.
Hint Extern 1 (_ =/= _) => (symmetry; trivial; fail) : core.

(* *********************************************************************** *)
(** * Facts about [EqDec] *)

(** The [EqDec] class is defined in Coq's standard library. *)

Lemma equiv_reflexive' : forall (A : Type) `{EqDec A} (x : A),
  x === x.
Proof. intros. apply equiv_reflexive. Qed.

Lemma equiv_symmetric' : forall (A : Type) `{EqDec A} (x y : A),
  x === y ->
  y === x.
Proof. intros. apply equiv_symmetric; assumption. Qed.

Lemma equiv_transitive' : forall (A : Type) `{EqDec A} (x y z : A),
  x === y ->
  y === z ->
  x === z.
Proof. intros. eapply @equiv_transitive; eassumption. Qed.

Lemma equiv_decidable : forall (A : Type) `{EqDec A} (x y : A),
  decidable (x === y).
Proof. intros. unfold decidable. destruct (x == y); auto. Defined.

(* *********************************************************************** *)
(** * Specializing [EqDec] *)

(** It is convenient to be able to use a single notation for decidable
    equality on types.  This can naturally be done using a type class.
    However, the definition of [EqDec] in the EquivDec library is
    overly general for cases where the equality is [eq]: the extra
    layer of abstraction provided by abstracting over the equivalence
    relation gets in the way of smooth reasoning.  To get around this,
    we define a version of that class where the equivalence relation
    is hard-coded to be [eq].

    Implementation note: One should not declare an instance for
    [EqDec_eq A] directly.  First, declare an instance for [@EqDec A
    eq eq_equivalence].  Second, let class inference build an instance
    for [EqDec_eq A] using the instance declaration below.

    Implementation note (BEA): Specifying [eq_equivalence] explicitly
    is important.  Following Murphy's Law, if type class inference can
    find multiple ways of inferring the [@Equivalence A eq] argument,
    it will do so in the most inconvenient way possible.
    Additionally, I choose to infer [EqDec_eq] instances from [EqDec]
    instances because the standard library already defines instances
    for [EqDec]. *)

Class EqDec_eq (A : Type) :=
  eq_dec : forall (x y : A), {x = y} + {x <> y}.

Instance EqDec_eq_of_EqDec (A : Type) `(@EqDec A eq eq_equivalence) : EqDec_eq A.
Proof. trivial. Defined.

(** We can also provide a reflexivity theorem for rewriting with, since types
    with decidable equality satisfy UIP/Axiom K and so we know that we can
    rewrite the equality proof to `eq_refl`. *)

Theorem eq_dec_refl {A : Type} `{EqDec_eq A} (x : A) : eq_dec x x = left eq_refl.
Proof.
  destruct (eq_dec x x); [|contradiction].
  f_equal; apply (Eqdep_dec.UIP_dec eq_dec).
Qed.

(* ********************************************************************** *)
(** * Decidable equality *)

(** We prefer that "==" refer to decidable equality at [eq], as
    defined by the [EqDec_eq] class from the CoqEqDec library. *)

Declare Scope coqeqdec_scope.

Notation " x  == y " := (eq_dec x y) (at level 70) : coqeqdec_scope.

Open Scope coqeqdec_scope.


(* -*- mode: coq; mode: visual-line -*- *)
Require Import HoTT.Basics.
Require Import HoTT.Types.
Require Import HSet TruncType.
Require Export HIT.Coeq.
Local Open Scope path_scope.

(** * Homotopy Pushouts *)

(** We define pushouts in terms of coproducts and coequalizers. *)

Definition Pushout@{i j k l} {A : Type@{i}} {B : Type@{j}} {C : Type@{k}}
  (f : A -> B) (g : A -> C) : Type@{l}
  := Coeq@{l l} (inl o f) (inr o g).

Definition push {A B C : Type} {f : A -> B} {g : A -> C}
 : B+C -> Pushout f g
  := @coeq _ _ (inl o f) (inr o g).

Definition pushl {A B C} {f : A -> B} {g : A -> C} (b : B)
  : Pushout f g := push (inl b).
Definition pushr {A B C} {f : A -> B} {g : A -> C} (c : C)
  : Pushout f g := push (inr c).

Definition pglue {A B C : Type} {f : A -> B} {g : A -> C} (a : A)
  : pushl (f a) = pushr (g a)
  := @cglue A (B+C) (inl o f) (inr o g) a.

(* Some versions with explicit parameters. *)
Definition pushl' {A B C} (f : A -> B) (g : A -> C) (b : B) : Pushout f g := pushl b.
Definition pushr' {A B C} (f : A -> B) (g : A -> C) (c : C) : Pushout f g := pushr c.
Definition pglue' {A B C : Type} (f : A -> B) (g : A -> C) (a : A) : pushl (f a) = pushr (g a)
  := pglue a.

Section PushoutInd.

  Context {A B C : Type} {f : A -> B} {g : A -> C}
    (P : Pushout f g -> Type)
    (pushb : forall b : B, P (pushl b))
    (pushc : forall c : C, P (pushr c))
    (pusha : forall a : A, (pglue a) # (pushb (f a)) = pushc (g a)).

  Definition Pushout_ind
    : forall (w : Pushout f g), P w
    := Coeq_ind P (fun bc =>
      match bc with
        | inl b => pushb b
        | inr c => pushc c
      end) pusha.

  Definition Pushout_ind_beta_pushl (b:B) : Pushout_ind (pushl b) = pushb b
    := 1.
  Definition Pushout_ind_beta_pushr (c:C) : Pushout_ind (pushr c) = pushc c
    := 1.

  Definition Pushout_ind_beta_pglue (a:A)
    : apD Pushout_ind (pglue a) = pusha a
    := Coeq_ind_beta_cglue P (fun bc => match bc with inl b => pushb b | inr c => pushc c end) pusha a.

End PushoutInd.

(** But we want to allow the user to forget that we've defined pushouts in terms of coequalizers. *)
Arguments Pushout : simpl never.
Arguments push : simpl never.
Arguments pglue : simpl never.
Arguments Pushout_ind : simpl never.
Arguments Pushout_ind_beta_pglue : simpl never.

Definition Pushout_rec {A B C} {f : A -> B} {g : A -> C} (P : Type)
  (pushb : B -> P)
  (pushc : C -> P)
  (pusha : forall a : A, pushb (f a) = pushc (g a))
  : @Pushout A B C f g -> P
  := Pushout_ind (fun _ => P) pushb pushc (fun a => transport_const _ _ @ pusha a).

Definition Pushout_rec_beta_pglue {A B C f g} (P : Type)
  (pushb : B -> P)
  (pushc : C -> P)
  (pusha : forall a : A, pushb (f a) = pushc (g a))
  (a : A)
  : ap (Pushout_rec P pushb pushc pusha) (pglue a) = pusha a.
Proof.
  unfold Pushout_rec.
  eapply (cancelL (transport_const (pglue a) _)).
  refine ((apD_const (@Pushout_ind A B C f g (fun _ => P) pushb pushc _) (pglue a))^ @ _).
  refine (Pushout_ind_beta_pglue (fun _ => P) _ _ _ _).
Defined.

(** ** Universal property *)

Definition pushout_unrec {A B C P} (f : A -> B) (g : A -> C)
           (h : Pushout f g -> P)
  : {psh : (B -> P) * (C -> P) &
           forall a, fst psh (f a) = snd psh (g a)}.
Proof.
  exists (h o pushl , h o pushr).
  intros a; cbn.
  exact (ap h (pglue a)).
Defined.

Definition isequiv_Pushout_rec `{Funext} {A B C} (f : A -> B) (g : A -> C) P
  : IsEquiv (fun p : {psh : (B -> P) * (C -> P) &
                            forall a, fst psh (f a) = snd psh (g a) }
             => Pushout_rec P (fst p.1) (snd p.1) p.2).
Proof.
  srefine (isequiv_adjointify _ (pushout_unrec f g) _ _).
  - intros h.
    apply path_arrow; intros x.
    srefine (Pushout_ind (fun x => Pushout_rec P (fst (pushout_unrec f g h).1) (snd (pushout_unrec f g h).1) (pushout_unrec f g h).2 x = h x) _ _ _ x).
    + intros b; reflexivity.
    + intros c; reflexivity.
    + intros a; cbn.
      abstract (rewrite transport_paths_FlFr, Pushout_rec_beta_pglue;
                rewrite concat_p1; apply concat_Vp).
  - intros [[pushb pushc] pusha]; unfold pushout_unrec; cbn.
    srefine (path_sigma' _ _ _).
    + srefine (path_prod' _ _); reflexivity.
    + apply path_forall; intros a.
      abstract (rewrite transport_forall_constant, Pushout_rec_beta_pglue;
                reflexivity).
Defined.

Definition equiv_Pushout_rec `{Funext} {A B C} (f : A -> B) (g : A -> C) P
  : {psh : (B -> P) * (C -> P) &
           forall a, fst psh (f a) = snd psh (g a) }
      <~> (Pushout f g -> P)
  := Build_Equiv _ _ _ (isequiv_Pushout_rec f g P).

Definition equiv_pushout_unrec `{Funext} {A B C} (f : A -> B) (g : A -> C) P
  : (Pushout f g -> P)
      <~> {psh : (B -> P) * (C -> P) &
                 forall a, fst psh (f a) = snd psh (g a) }
  := equiv_inverse (equiv_Pushout_rec f g P).

(** ** Symmetry *)

Definition pushout_sym_map {A B C} {f : A -> B} {g : A -> C}
  : Pushout f g -> Pushout g f
  := Pushout_rec (Pushout g f) pushr pushl (fun a : A => (pglue a)^).

Lemma sect_pushout_sym_map {A B C f g} : Sect (@pushout_sym_map A C B g f) (@pushout_sym_map A B C f g).
Proof.
  unfold Sect. srapply @Pushout_ind.
  - intros; reflexivity.
  - intros; reflexivity.
  - intro a.
    abstract (rewrite transport_paths_FFlr, Pushout_rec_beta_pglue, ap_V, Pushout_rec_beta_pglue; hott_simpl).
Defined.

Definition pushout_sym {A B C} {f : A -> B} {g : A -> C}
  : Pushout f g <~> Pushout g f :=
equiv_adjointify pushout_sym_map pushout_sym_map sect_pushout_sym_map sect_pushout_sym_map.

(** ** Functoriality *)

Definition functor_pushout
           {A B C} (f : A -> B) (g : A -> C)
           {A' B' C'} (f' : A' -> B') (g' : A' -> C')
           (h : A -> A') (k : B -> B') (l : C -> C')
           (p : k o f == f' o h) (q : l o g == g' o h)
  : Pushout f g -> Pushout f' g'.
Proof.
  unfold Pushout; serapply functor_coeq.
  - exact h.
  - exact (functor_sum k l).
  - intros a; cbn.
    apply ap, p.
  - intros a; cbn.
    apply ap, q.
Defined.

(** ** Equivalences *)

(** Pushouts preserve equivalences. *)

Section EquivPushout.
  Context {A B C f g A' B' C' f' g'}
          (eA : A <~> A') (eB : B <~> B') (eC : C <~> C')
          (p : eB o f == f' o eA) (q : eC o g == g' o eA).

  Lemma equiv_pushout
    : Pushout f g <~> Pushout f' g'.
  Proof.
    refine (equiv_functor_coeq' eA (equiv_functor_sum' eB eC) _ _).
    all:unfold pointwise_paths.
    all:intro; simpl; apply ap.
    + apply p.
    + apply q.
  Defined.

  Lemma equiv_pushout_pglue (a : A)
    : ap equiv_pushout (pglue a)
      = ap pushl (p a) @ pglue (eA a) @ ap pushr (q a)^.
  Proof.
    refine (functor_coeq_beta_cglue _ _ _ _ a @ _).
    refine (_ @@ 1 @@ _).
    - symmetry; refine (ap_compose inl coeq _).
    - refine (ap (ap coeq) (ap_V _ _)^ @ _).
      symmetry; refine (ap_compose inr coeq _).
  Defined.

End EquivPushout.

(** ** Contractibility *)

(** The pushout of a span of contractible types is contractible *)

Global Instance contr_pushout {A B C : Type} `{Contr A, Contr B, Contr C}
       (f : A -> B) (g : A -> C)
  : Contr (Pushout f g).
Proof.
  exists (pushl (center B)).
  serapply Pushout_ind.
  - intros b; apply ap, path_contr.
  - intros c.
    refine (_ @ pglue (center A) @ _).
    + apply ap, path_contr.
    + apply ap, path_contr.
  - intros a.
    rewrite transport_paths_r.
    assert (p := path_contr (center A) a).
    destruct p.
    refine ((concat_p1 _)^ @ _).
    apply whiskerL.
    change 1 with (ap (@pushr A B C f g) (idpath (g (center A)))).
    apply (ap (ap pushr)).
    apply path_contr.
Defined.

(** ** Sigmas *)

(** Pushouts commute with sigmas *)

Section EquivSigmaPushout.

  Context {X : Type}
          (A : X -> Type) (B : X -> Type) (C : X -> Type)
          (f : forall x, A x -> B x) (g : forall x, A x -> C x).

  Let esp1 : { x : X & Pushout (f x) (g x) }
             -> Pushout (functor_sigma idmap f) (functor_sigma idmap g).
  Proof.
    intros [x p].
    srefine (Pushout_rec _ _ _ _ p).
    + intros b. exact (pushl (x;b)).
    + intros c. exact (pushr (x;c)).
    + intros a; cbn. exact (pglue (x;a)).
  Defined.

  Let esp1_beta_pglue (x : X) (a : A x)
    : ap esp1 (path_sigma' (fun x => Pushout (f x) (g x)) 1 (pglue a))
      = pglue (x;a).
  Proof.
    rewrite (ap_path_sigma (fun x => Pushout (f x) (g x))
                           (fun x a => esp1 (x;a)) 1 (pglue a)); cbn.
    rewrite !concat_p1.
    unfold esp1; rewrite Pushout_rec_beta_pglue.
    reflexivity.
  Qed.

  Let esp2 : Pushout (functor_sigma idmap f) (functor_sigma idmap g)
             -> { x : X & Pushout (f x) (g x) }.
  Proof.
    srefine (Pushout_rec _ _ _ _).
    + exact (functor_sigma idmap (fun x => @pushl _ _ _ (f x) (g x))).
    + exact (functor_sigma idmap (fun x => @pushr _ _ _ (f x) (g x))).
    + intros [x a]; unfold functor_sigma; cbn.
      srefine (path_sigma' _ 1 _); cbn.
      apply pglue.
  Defined.

  Let esp2_beta_pglue (x : X) (a : A x)
    : ap esp2 (pglue (x;a)) = path_sigma' (fun x:X => Pushout (f x) (g x)) 1 (pglue a).
  Proof.
    unfold esp2.
    rewrite Pushout_rec_beta_pglue.
    reflexivity.
  Qed.

  Definition equiv_sigma_pushout
    : { x : X & Pushout (f x) (g x) }
        <~> Pushout (functor_sigma idmap f) (functor_sigma idmap g).
  Proof.
    srefine (equiv_adjointify esp1 esp2 _ _).
    - srefine (Pushout_ind _ _ _ _); cbn.
      + reflexivity.
      + reflexivity.
      + intros [x a].
        rewrite transport_paths_FlFr.
        rewrite ap_idmap, concat_p1.
        apply moveR_Vp. rewrite concat_p1.
        rewrite ap_compose.
        rewrite esp2_beta_pglue, esp1_beta_pglue.
        reflexivity.
    - intros [x a]; revert a.
      srefine (Pushout_ind _ _ _ _); cbn.
      + reflexivity.
      + reflexivity.
      + intros a.
        rewrite transport_paths_FlFr.
        rewrite concat_p1; apply moveR_Vp; rewrite concat_p1.
        rewrite (ap_compose (exist _ x) (esp2 o esp1)).
        rewrite (ap_compose esp1 esp2).
        rewrite (ap_existT (fun x => Pushout (f x) (g x)) x _ _ (pglue a)).
        rewrite esp1_beta_pglue, esp2_beta_pglue.
        reflexivity.
  Defined.

End EquivSigmaPushout.

(** ** Pushouts are associative *)

Section PushoutAssoc.

  Context {A1 A2 B C D : Type}
          (f1 : A1 -> B) (g1 : A1 -> C) (f2 : A2 -> C) (g2 : A2 -> D).

  Definition pushout_assoc_left := Pushout (pushr' f1 g1 o f2) g2.
  Let pushll : B -> pushout_assoc_left
    := pushl' (pushr' f1 g1 o f2) g2 o pushl' f1 g1.
  Let pushlm : C -> pushout_assoc_left
    := pushl' (pushr' f1 g1 o f2) g2 o pushr' f1 g1.
  Let pushlr : D -> pushout_assoc_left
    := pushr' (pushr' f1 g1 o f2) g2.
  Let pgluell : forall a1, pushll (f1 a1) = pushlm (g1 a1)
    := fun a1 => ap (pushl' (pushr' f1 g1 o f2) g2) (pglue' f1 g1 a1).
  Let pgluelr : forall a2, pushlm (f2 a2) = pushlr (g2 a2)
    := fun a2 => pglue' (pushr' f1 g1 o f2) g2 a2.

  Definition pushout_assoc_left_ind
             (P : pushout_assoc_left -> Type)
             (pushb : forall b, P (pushll b))
             (pushc : forall c, P (pushlm c))
             (pushd : forall d, P (pushlr d))
             (pusha1 : forall a1, (pgluell a1) # pushb (f1 a1) = pushc (g1 a1))
             (pusha2 : forall a2, (pgluelr a2) # pushc (f2 a2) = pushd (g2 a2))
    : forall x, P x.
  Proof.
    srefine (Pushout_ind _ _ pushd _).
    - srefine (Pushout_ind _ pushb pushc _).
      intros a1.
      exact (transport_compose P pushl _ _ @ pusha1 a1).
    - exact pusha2.
  Defined.

  Section Pushout_Assoc_Left_Rec.

    Context (P : Type)
            (pushb : B -> P)
            (pushc : C -> P)
            (pushd : D -> P)
            (pusha1 : forall a1, pushb (f1 a1) = pushc (g1 a1))
            (pusha2 : forall a2, pushc (f2 a2) = pushd (g2 a2)).

    Definition pushout_assoc_left_rec
      : pushout_assoc_left -> P.
    Proof.
      srefine (Pushout_rec _ _ pushd _).
      - srefine (Pushout_rec _ pushb pushc pusha1).
      - exact pusha2.
    Defined.

    Definition pushout_assoc_left_rec_beta_pgluell a1
      : ap pushout_assoc_left_rec (pgluell a1) = pusha1 a1.
    Proof.
      unfold pgluell.
      rewrite <- (ap_compose (pushl' (pushr' f1 g1 o f2) g2)
                             pushout_assoc_left_rec).
      change (ap (Pushout_rec P pushb pushc pusha1) (pglue' f1 g1 a1) = pusha1 a1).
      apply Pushout_rec_beta_pglue.
    Defined.

    Definition pushout_assoc_left_rec_beta_pgluelr a2
      : ap pushout_assoc_left_rec (pgluelr a2) = pusha2 a2.
    Proof.
      unfold pushout_assoc_left_rec, pgluelr.
      apply (Pushout_rec_beta_pglue (f := pushr' f1 g1 o f2) (g := g2)).
    Defined.

  End Pushout_Assoc_Left_Rec.

  Definition pushout_assoc_right := Pushout f1 (pushl' f2 g2 o g1).
  Let pushrl : B -> pushout_assoc_right
    := pushl' f1 (pushl' f2 g2 o g1).
  Let pushrm : C -> pushout_assoc_right
    := pushr' f1 (pushl' f2 g2 o g1) o pushl' f2 g2.
  Let pushrr : D -> pushout_assoc_right
    := pushr' f1 (pushl' f2 g2 o g1) o pushr' f2 g2.
  Let pgluerl : forall a1, pushrl (f1 a1) = pushrm (g1 a1)
    := fun a1 => pglue' f1 (pushl' f2 g2 o g1) a1.
  Let pgluerr : forall a2, pushrm (f2 a2) = pushrr (g2 a2)
    := fun a2 => ap (pushr' f1 (pushl' f2 g2 o g1)) (pglue' f2 g2 a2).

  Definition pushout_assoc_right_ind
             (P : pushout_assoc_right -> Type)
             (pushb : forall b, P (pushrl b))
             (pushc : forall c, P (pushrm c))
             (pushd : forall d, P (pushrr d))
             (pusha1 : forall a1, (pgluerl a1) # pushb (f1 a1) = pushc (g1 a1))
             (pusha2 : forall a2, (pgluerr a2) # pushc (f2 a2) = pushd (g2 a2))
    : forall x, P x.
  Proof.
    srefine (Pushout_ind _ pushb _ _).
    - srefine (Pushout_ind _ pushc pushd _).
      intros a2.
      exact (transport_compose P pushr _ _ @ pusha2 a2).
    - exact pusha1.
  Defined.

  Section Pushout_Assoc_Right_Rec.

    Context (P : Type)
            (pushb : B -> P)
            (pushc : C -> P)
            (pushd : D -> P)
            (pusha1 : forall a1, pushb (f1 a1) = pushc (g1 a1))
            (pusha2 : forall a2, pushc (f2 a2) = pushd (g2 a2)).

    Definition pushout_assoc_right_rec
      : pushout_assoc_right -> P.
    Proof.
      srefine (Pushout_rec _ pushb _ _).
      - srefine (Pushout_rec _ pushc pushd pusha2).
      - exact pusha1.
    Defined.

    Definition pushout_assoc_right_rec_beta_pgluerl a1
      : ap pushout_assoc_right_rec (pgluerl a1) = pusha1 a1.
    Proof.
      unfold pushout_assoc_right_rec, pgluerl.
      apply (Pushout_rec_beta_pglue (f := f1) (g := pushl' f2 g2 o g1)).
    Defined.

    Definition pushout_assoc_right_rec_beta_pgluerr a2
      : ap pushout_assoc_right_rec (pgluerr a2) = pusha2 a2.
    Proof.
      unfold pgluerr.
      rewrite <- (ap_compose (pushr' f1 (pushl' f2 g2 o g1))
                             pushout_assoc_right_rec).
      change (ap (Pushout_rec P pushc pushd pusha2) (pglue' f2 g2 a2) = pusha2 a2).
      apply Pushout_rec_beta_pglue.
    Defined.

  End Pushout_Assoc_Right_Rec.

  Definition equiv_pushout_assoc
    : Pushout (pushr' f1 g1 o f2) g2 <~> Pushout f1 (pushl' f2 g2 o g1).
  Proof.
    srefine (equiv_adjointify _ _ _ _).
    - exact (pushout_assoc_left_rec _ pushrl pushrm pushrr pgluerl pgluerr).
    - exact (pushout_assoc_right_rec _ pushll pushlm pushlr pgluell pgluelr).
    - abstract (
      srefine (pushout_assoc_right_ind
                 _ (fun _ => 1) (fun _ => 1) (fun _ => 1) _ _);
        intros; rewrite transport_paths_FlFr, ap_compose;
      [ rewrite pushout_assoc_right_rec_beta_pgluerl,
        pushout_assoc_left_rec_beta_pgluell
      | rewrite pushout_assoc_right_rec_beta_pgluerr,
        pushout_assoc_left_rec_beta_pgluelr ];
      rewrite concat_p1, ap_idmap; apply concat_Vp ).
    - abstract (
      srefine (pushout_assoc_left_ind
                 _ (fun _ => 1) (fun _ => 1) (fun _ => 1) _ _);
        intros; rewrite transport_paths_FlFr, ap_compose;
      [ rewrite pushout_assoc_left_rec_beta_pgluell,
        pushout_assoc_right_rec_beta_pgluerl
      | rewrite pushout_assoc_left_rec_beta_pgluelr,
        pushout_assoc_right_rec_beta_pgluerr ];
      rewrite concat_p1, ap_idmap; apply concat_Vp ).
  Defined.

End PushoutAssoc.

(** ** Pushouts of equvialences are equivalences *)

Global Instance isequiv_pushout_isequiv {A B C} (f : A -> B) (g : A -> C)
       `{IsEquiv _ _ f} : IsEquiv (pushr' f g).
Proof.
  srefine (isequiv_adjointify _ _ _ _).
  - srefine (Pushout_rec C (g o f^-1) idmap _).
    intros a; cbn; apply ap, eissect.
  - srefine (Pushout_ind _ _ _ _); cbn.
    + intros b; change (pushr' f g (g (f^-1 b)) = pushl b).
      transitivity (pushl' f g (f (f^-1 b))).
      * symmetry; apply pglue.
      * apply ap, eisretr.
    + intros c; reflexivity.
    + intros a.
      abstract (
      rewrite transport_paths_FlFr, ap_compose, !concat_pp_p;
      apply moveR_Vp; apply moveR_Vp;
      rewrite Pushout_rec_beta_pglue, eisadj, ap_idmap, concat_p1;
      rewrite <- ap_compose, <- (ap_compose g (pushr' f g));
      exact (concat_Ap (pglue' f g) (eissect f a)) ).
  - intros c; reflexivity.
Defined.

Global Instance isequiv_pushout_isequiv' {A B C} (f : A -> B) (g : A -> C)
       `{IsEquiv _ _ g} : IsEquiv (pushl' f g).
Proof.
  srefine (isequiv_adjointify _ _ _ _).
  - srefine (Pushout_rec B idmap (f o g^-1) _).
    intros a; cbn. symmetry; apply ap, eissect.
  - srefine (Pushout_ind _ _ _ _); cbn.
    + intros b; reflexivity.
    + intros c; change (pushl' f g (f (g^-1 c)) = pushr c).
      transitivity (pushr' f g (g (g^-1 c))).
      * apply pglue.
      * apply ap, eisretr.
    + intros a.
      abstract (
      rewrite transport_paths_FlFr, ap_compose, !concat_pp_p;
      apply moveR_Vp;
      rewrite Pushout_rec_beta_pglue, eisadj, ap_idmap, concat_1p, ap_V;
      apply moveL_Vp;
      rewrite <- !ap_compose;
      exact (concat_Ap (pglue' f g) (eissect g a)) ).
  - intros c; reflexivity.
Defined.


From Hammer Require Import Hammer.

Require Import Arith_base.
Require Import BinPos.
Require Import BinInt.
Require Import Zcompare.
Require Import Zorder.
Require Import Znat.
Require Import ZArith_dec.

Local Open Scope Z_scope.

Lemma Zabs_ind :
forall (P:Z -> Prop) (n:Z),
(n >= 0 -> P n) -> (n <= 0 -> P (- n)) -> P (Z.abs n).
Proof. hammer_hook "Zabs" "Zabs.Zabs_ind".
intros. apply Z.abs_case_strong; Z.swap_greater; trivial.
intros x y Hx; now subst.
Qed.

Theorem Zabs_intro : forall P (n:Z), P (- n) -> P n -> P (Z.abs n).
Proof. hammer_hook "Zabs" "Zabs.Zabs_intro".
now destruct n.
Qed.

Definition Zabs_dec : forall x:Z, {x = Z.abs x} + {x = - Z.abs x}.
Proof. hammer_hook "Zabs" "Zabs.Zabs_dec".
destruct x; auto.
Defined.

Lemma Zabs_spec x :
0 <= x /\ Z.abs x = x \/
0 > x /\ Z.abs x = -x.
Proof. hammer_hook "Zabs" "Zabs.Zabs_spec".
Z.swap_greater. apply Z.abs_spec.
Qed.

Lemma Zsgn_spec x :
0 < x /\ Z.sgn x = 1 \/
0 = x /\ Z.sgn x = 0 \/
0 > x /\ Z.sgn x = -1.
Proof. hammer_hook "Zabs" "Zabs.Zsgn_spec".
intros. Z.swap_greater. apply Z.sgn_spec.
Qed.

Lemma Zabs_nat_le n m : 0 <= n <= m -> (Z.abs_nat n <= Z.abs_nat m)%nat.
Proof. hammer_hook "Zabs" "Zabs.Zabs_nat_le".
intros (H,H'). apply Zabs2Nat.inj_le; trivial. now transitivity n.
Qed.

Lemma Zabs_nat_lt n m : 0 <= n < m -> (Z.abs_nat n < Z.abs_nat m)%nat.
Proof. hammer_hook "Zabs" "Zabs.Zabs_nat_lt".
intros (H,H'). apply Zabs2Nat.inj_lt; trivial.
transitivity n; trivial. now apply Z.lt_le_incl.
Qed.