Require Export PredMonad.TypeReflection.OrderedType.

(***
 *** Ordered Type Expressions
 ***)

Inductive OTypeExprInd : forall A {RA:OTRelation A}, Type :=
| OTpUnit : OTypeExprInd unit
| OTpEmbed A `{OType A} : OTypeExprInd A
| OTpPair {A} {RA:OTRelation A} {B} {RB:OTRelation B}
          (tp1: OTypeExprInd A) (tp2: OTypeExprInd B) : OTypeExprInd (A * B)
| OTpSum {A} {RA:OTRelation A} {B} {RB:OTRelation B}
         (tp1: OTypeExprInd A) (tp2: OTypeExprInd B) : OTypeExprInd (A + B)
| OTpArrow {A} {RA:OTRelation A} {B} {RB:OTRelation B}
           (tp1: OTypeExprInd A) (tp2: OTypeExprInd B) : OTypeExprInd (A -o> B)
| OTpApply {arity} F `{OTypeF1 arity F} As (tps:OTypeExprInds As) :
    OTypeExprInd (OTFunctorApply arity F As)
with
OTypeExprInds : OTArgs -> Type :=
| OTpNil : OTypeExprInds ArgsNil
| OTpCons {A} {RA:OTRelation A} {As} (tp: OTypeExprInd A) (tps:OTypeExprInds As) :
    OTypeExprInds (ArgsCons A As)
.

(* Define the mutual recursion / induction schemes for OTypeExprInd *)
Scheme OTypeExpr_OTypeExprs_rec := Induction for OTypeExprInd Sort Type
  with OTypeExprs_OTypeExpr_rec := Induction for OTypeExprInds Sort Type.

(* Apply a predicate to all OTypeExprs in an OTypeExprs list *)
Fixpoint forall_OTypeExprInds (P: forall A RA, @OTypeExprInd A RA -> Type)
         args (tps:OTypeExprInds args) : Type :=
  match tps with
  | OTpNil => True
  | OTpCons tp tps => P _ _ tp * forall_OTypeExprInds P _ tps
  end.

(* Mutual induction scheme for OTypeExprInd *)
Definition OTypeExprInd_rect' P f1 f2 f3 f4 f5 f6 :=
  OTypeExpr_OTypeExprs_rec P (forall_OTypeExprInds P)
                           f1 f2 f3 f4 f5 f6 I
                           (fun _ _ _ _ x _ xs => (x,xs)).

(* Typeclass version of OTypeExprInd *)
Class OTypeExpr A {RA:OTRelation A} : Type :=
  otypeExpr : @OTypeExprInd A RA.

(* Instances for building OTypeExprs *)
(*
Instance OTypeExpr_unit : OTypeExpr unit := OTpUnit.
Instance OTypeExpr_pair A RA (tpA:@OTypeExpr A RA) B RB (tpB:@OTypeExpr B RB) :
  OTypeExpr (A*B) | 1 := OTpPair tpA tpB.
Instance OTypeExpr_sum A RA (tpA:@OTypeExpr A RA) B RB (tpB:@OTypeExpr B RB) :
  OTypeExpr (A+B) | 1 := OTpSum tpA tpB.
Instance OTypeExpr_arrow A RA (tpA:@OTypeExpr A RA) B RB (tpB:@OTypeExpr B RB) :
  OTypeExpr (A -o> B) | 1 := OTpArrow tpA tpB.
Instance OTypeExpr_embed A `{OType A} : OTypeExpr A | 2 := OTpEmbed A.
 *)

Ltac prove_OTypeExpr :=
  match goal with
  | |- OTypeExprInd _ => assumption
  | |- @OTypeExprInd ?A ?RA => change (@OTypeExpr A RA); try prove_OTypeExpr
  | |- OTypeExpr _ => assumption
  | |- OTypeExpr unit => apply OTpUnit
  | |- OTypeExpr (_ * _) => apply OTpPair; try prove_OTypeExpr
  | |- OTypeExpr (_ + _) => apply OTpSum; try prove_OTypeExpr
  | |- OTypeExpr (_ -o> _) => apply OTpArrow; try prove_OTypeExpr
  | |- OTypeExpr (?F _ _) =>
    refine (OTpApply F (OTpCons _ OTpNil)); try prove_OTypeExpr
  | |- OTypeExpr _ => apply OTpEmbed; try prove_OTypeExpr
  end.

Hint Extern 1 (OTypeExpr _) => prove_OTypeExpr : typeclass_instances.
Hint Extern 1 (OTypeExprInd _) => prove_OTypeExpr : typeclass_instances.

(* Any type + relation with an OTypeExpr representation is valid *)
Lemma OType_OTypeExpr A (RA:OTRelation A) (tp:OTypeExpr A) : OType A.
Proof.
  apply
    (OTypeExpr_OTypeExprs_rec (fun A RA _ => @OType A RA)
                              (fun As _ => OTArgsValid As));
    try typeclasses eauto.
Qed.

(* Only apply OType_OTypeExpr when there are OTypeExprs in the context *)
Hint Immediate OType_OTypeExpr : typeclass_instances.

(***
 *** Ordered Type Contexts
 ***)

(* A context here is just a list of type expressions *)
Inductive Ctx : Type :=
| CtxNil
| CtxCons {A RA} (tp:@OTypeExpr A RA) (ctx:Ctx)
.

(* An element of a context is a nested tuple of elements of its types *)
Fixpoint CtxElem (ctx:Ctx) : Type :=
  match ctx with
  | CtxNil => unit
  | @CtxCons A _ tp ctx' => CtxElem ctx' * A
  end.

(* OTRelation instance for any CtxElem type *)
Instance OTRelation_CtxElem ctx : OTRelation (CtxElem ctx).
Proof.
  induction ctx; typeclasses eauto.
Defined.

Instance OType_CtxElem ctx : OType (CtxElem ctx).
Proof.
  induction ctx; simpl; [ typeclasses eauto | ].
  apply OTpair; [ typeclasses eauto | ]. apply OType_OTypeExpr. assumption.
Qed.

(* Map from an element of a context to an element of its head. This is just
fst_pfun, but writing it this way helps the Coq unifier. *)
Definition ctx_head_pfun {ctx A RA} {tp:@OTypeExpr A RA} :
  CtxElem (CtxCons tp ctx) -o> A :=
  snd_pfun.

(* Map from an element of a context to an element of its tail. This is just
fst_pfun, but writing it this way helps the Coq unifier. *)
Definition ctx_tail_pfun {ctx A RA} {tp:@OTypeExpr A RA} :
  CtxElem (CtxCons tp ctx) -o> CtxElem ctx :=
  fst_pfun.

(* Look up the nth type in a Ctx, returning the unit type as a default *)
Fixpoint ctxNth n ctx {struct ctx} : Type :=
  match ctx with
  | CtxNil => unit
  | @CtxCons A _ _ ctx' =>
    match n with
    | 0 => A
    | S n' => ctxNth n' ctx'
    end
  end.
Arguments ctxNth !n !ctx.

Instance OTRelation_ctxNth n ctx : OTRelation (ctxNth n ctx).
Proof.
  revert n; induction ctx; [ | destruct n ]; intros; typeclasses eauto.
Defined.

(* Look up the nth OTypeExpr in a Ctx *)
Fixpoint ctxNthExpr n ctx {struct ctx} : OTypeExpr (ctxNth n ctx) :=
  match ctx with
  | CtxNil => OTpUnit
  | CtxCons tp ctx' =>
    match n with
    | 0 => tp
    | S n' => ctxNthExpr n' ctx'
    end
  end.
Arguments ctxNthExpr !n !ctx.

(* Pfun to extract the nth element of a context *)
Fixpoint nth_pfun ctx n : CtxElem ctx -o> ctxNth n ctx :=
  match ctx return CtxElem ctx -o> ctxNth n ctx with
  | CtxNil => const_pfun tt
  | CtxCons tp ctx' =>
    match n return CtxElem (CtxCons tp ctx') -o> ctxNth n (CtxCons tp ctx') with
    | 0 => ctx_head_pfun
    | S n' =>
      compose_pfun ctx_tail_pfun (nth_pfun ctx' n')
    end
  end.
Arguments nth_pfun ctx n : simpl nomatch.

(* Weaken a context by inserting a type at point w *)
Fixpoint ctxInsert w {W RW} (tpW:@OTypeExpr W RW) ctx {struct w} : Ctx :=
  match w with
  | 0 => CtxCons tpW ctx
  | S w' =>
    match ctx with
    | CtxNil => CtxCons OTpUnit (ctxInsert w' tpW CtxNil)
    | CtxCons tp ctx' => CtxCons tp (ctxInsert w' tpW ctx')
    end
  end.
Arguments ctxInsert w {W RW} tpW ctx : simpl nomatch.

(* Map from a weaker to a stronger context, by dropping the new element *)
Fixpoint weaken_pfun w {W RW} tpW ctx :
  CtxElem (@ctxInsert w W RW tpW ctx) -o> CtxElem ctx :=
  match w return CtxElem (ctxInsert w tpW ctx) -o> CtxElem ctx with
  | 0 => ctx_tail_pfun
  | S w' =>
    match ctx return CtxElem (ctxInsert (S w') tpW ctx) -o> CtxElem ctx with
    | CtxNil => const_pfun tt
    | CtxCons tpB ctx' =>
      pair_pfun (compose_pfun ctx_tail_pfun (weaken_pfun w' tpW ctx'))
                ctx_head_pfun
    end
  end.
Arguments weaken_pfun !w {W RW} tpW !ctx.

(* Delete the nth element of a context *)
Fixpoint ctxDelete n ctx {struct ctx} : Ctx :=
  match ctx with
  | CtxNil => CtxNil
  | CtxCons tp ctx' =>
    match n with
    | 0 => ctx'
    | S n' => CtxCons tp (ctxDelete n' ctx')
    end
  end.
Arguments ctxDelete n ctx : simpl nomatch.

(* The the n+1-th suffix of a context *)
Fixpoint ctxSuffix n ctx {struct ctx} : Ctx :=
  match ctx with
  | CtxNil => CtxNil
  | CtxCons tp ctx' =>
    match n with
    | 0 => ctx'
    | S n' => ctxSuffix n' ctx'
    end
  end.
Arguments ctxSuffix n ctx : simpl nomatch.

(* Substitute into a context by providing a pfun for the nth value *)
Fixpoint subst_pfun ctx n :
  (CtxElem (ctxSuffix n ctx) -o> ctxNth n ctx) ->
  CtxElem (ctxDelete n ctx) -o> CtxElem ctx :=
  match ctx return
        (CtxElem (ctxSuffix n ctx) -o> ctxNth n ctx) ->
        CtxElem (ctxDelete n ctx) -o> CtxElem ctx with
  | CtxNil => fun s => const_pfun tt
  | CtxCons A ctx' =>
    match n return
        (CtxElem (ctxSuffix n (CtxCons A ctx')) -o> ctxNth n (CtxCons A ctx')) ->
        CtxElem (ctxDelete n (CtxCons A ctx')) -o> CtxElem (CtxCons A ctx')
    with
    | 0 => fun s => pair_pfun id_pfun s
    | S n' =>
      fun s =>
        pair_pfun (compose_pfun fst_pfun (subst_pfun ctx' n' s)) snd_pfun
    end
  end.
Arguments subst_pfun ctx n : simpl nomatch.

(* Proper-ness of subst_pfun *)
Instance Proper_subst_pfun ctx n : Proper (ot_R ==> ot_R) (subst_pfun ctx n).
Proof.
  revert n; induction ctx; intros; [ | destruct n ]; simpl; intros s1 s2 Rs.
  - reflexivity.
  - intros c1 c2 Rc; simpl. split; [ | apply Rs ]; assumption.
  - intros c1 c2 Rc; simpl.
    split; destruct Rc; [ apply IHctx | ]; assumption.
Qed.

(* Proper-ness of subst_pfun w.r.t equivalence *)
Instance Proper_subst_pfun_equiv ctx n :
  Proper (ot_equiv ==> ot_equiv) (subst_pfun ctx n).
Proof.
  intros s1 s2 Rs; destruct Rs; split; apply Proper_subst_pfun; assumption.
Qed.


(* (c) Copyright Christian Doczkal, Saarland University                   *)
(* Distributed under the terms of the CeCILL-B license                    *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice fintype finset bigop.

Require Import edone base fset induced_sym.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import Setoid Morphisms.
Require Import Relation_Definitions.

(** * A Modular Library for Reasoing in Hilbert Systems

We build a modular library for reasoning in Hilbert systems for
classical modal logics. The Hilbert systems for these logics often
just extend the Hilbert system for a weaker logic with additonal rules
and axioms.

We define abstractly what it means for a Hilbert system to implement
minimal logic, propositional logic, K, and CTL. The main part is the
development for propositional logic, where we define the remaining
logical connecitves and use big conjunctions to simulate ND-style
reasoing in our assumption free Hilbert systems.  *)

(** ** Minimal Logic

We start with a number of Lemmas for minimal logic. This is mostly
the very basic combinator infrasutructure a a few tactic definitions. *)

Record mSystem := MSystem {
                      T :> choiceType;
                      mprv : T -> Prop;
                      Imp : T -> T -> T;
                      rMP' s t : mprv (Imp s t) -> mprv s -> mprv t;
                      axK' s t : mprv (Imp s (Imp t s));
                      axS' s t u : mprv (Imp (Imp u (Imp s t)) (Imp (Imp u s) (Imp u t)))
                    }.

Arguments mprv [m] H.

(** This is reqired to preserve the notation for instances under simplification *)
Definition Imp_op := nosimpl Imp.
Notation "s ---> t" := (@Imp_op _ s t) (at level 35, right associativity).

Lemma rMP (mS : mSystem) (s t : mS) : mprv (s ---> t) -> mprv s -> mprv t.
Proof. exact: rMP'. Qed.

Lemma axS (mS : mSystem) (s t u : mS) : mprv ((u ---> s ---> t) ---> (u ---> s) ---> u ---> t).
Proof. exact: axS'. Qed.

Lemma axK (mS : mSystem) (s t : mS) : mprv (s ---> t ---> s).
Proof. exact: axK'. Qed.

Ltac mp := eapply rMP.
Ltac S := eapply axS.
Ltac K := eapply axK.

(** Tactic to treat axioms as rules *)
Ltac rule H := first [ mp; first eapply H | mp; first mp; first eapply H ].

Section MTheory0.
  Variable (mS : mSystem).
  Implicit Types s t : mS.

  Lemma axI s : mprv (s ---> s).
  Proof. rule (axS (s ---> s) s s); K. Qed.

  Lemma axC s t u : mprv ((s ---> t ---> u) ---> t ---> s ---> u).
  Proof. (* (S (S (K (S (K S) K)) S)) (K K) *)
    mp. mp. S. mp. mp. S. mp. K. mp. mp. S. mp. K. S. K. S. mp. K. K.
  Qed.

  Lemma axB u s t : mprv ((u ---> t) ---> (s ---> u) ---> (s ---> t)).
  Proof. mp. mp. S. mp. K. S. K. Qed.

  Lemma axDup s t : mprv ((s ---> s ---> t) ---> s ---> t).
  Proof. rule axS. rule axC. exact: axI. Qed.

  Definition mImpPrv s t := mprv (s ---> t).

  Definition mImpPrv_refl s : mImpPrv s s := axI s.
  Lemma mImpPrv_trans s t u : mImpPrv s t -> mImpPrv t u -> mImpPrv s u.
  Proof. move => H1 H2. rule axB; eassumption. Qed.

  Lemma mp2 s t u :
  mprv (s ---> t ---> u) -> mprv s -> mprv t -> mprv u.
Proof. move => ax A B. by [mp; first mp; first apply ax]. Qed.
End MTheory0.

Hint Resolve axI : core.

Ltac C := eapply axC.
Ltac B := eapply axB.
Ltac drop := rule axK.

Ltac Cut u := apply (mp2 (axB u _ _)); last first.
Ltac Have u := apply (mp2 (axS u _ _)); last first.
Ltac Suff u := apply (mp2 (axS u _ _)).

(** Enable Setoid rewriting for with provable implications *)

Instance mImpPrv_rel (mS : mSystem) : PreOrder (@mImpPrv mS).
Proof. split. exact: axI. exact: mImpPrv_trans. Qed.

Instance mprv_mor (mS : mSystem) :
  Proper ((@mImpPrv mS) ++> Basics.impl) (@mprv mS).
Proof. move => x y H H'. mp; eassumption. Qed.

Instance Imp_mor (mS : mSystem) :
  Proper ((@mImpPrv mS) --> (@mImpPrv mS) ++> (@mImpPrv mS)) (@Imp mS).
Proof.
  move => x' x X y y' Y. rewrite /mImpPrv in X Y *.
  (* Abs "f" (Abs "x" (A (V "Y") (A f (A (V "X") x)))) *)
  mp. mp. B. mp. B. apply Y. mp. mp. C. B. apply X.
Qed.

(** ** Propositional Logic

In the presence of [Bot] and double negation, we can define the
remaining propositional connectives and prove the corresponding
lemmas. We also define morphisms for these connectives to enable
Setoid rewriting. *)

Record pSystem := PSystem {
                      msort :> mSystem;
                      Bot' : msort;
                      axDN' s : mprv (Imp (Imp (Imp s Bot') Bot') s)
                    }.

(** Avoid simplifictation of [Bot] fo concrete instances to avoid breaking
notations based on [Bot] *)

Definition Bot := nosimpl Bot'.
Arguments Bot {p}.

(** Notations for derived logical opertions *)

Definition Top {pS : pSystem} := @Bot pS ---> Bot.

Definition Neg (pS : pSystem) (s : pS) := (s ---> Bot).
Notation "~~: s" := (Neg s) (at level 25).

Definition And (pS : pSystem) (s t : pS) := ~~: (s ---> ~~: t).
Notation "s :/\: t" := (And s t) (at level 30, right associativity).
Arguments And {pS} s t.

Definition Or (pS : pSystem) (s t : pS) := (~~: s ---> t).
Notation "s :\/: t" := (Or s t) (at level 33, right associativity).
Arguments Or {pS} s t.

Lemma axDN (pS : pSystem) (s:pS) : mprv ((~~: ~~: s) ---> s).
Proof. exact: axDN'. Qed.

(** *** Basic Propositional Logic Facts

We prove some basic propositonal lemmas which we need to set up the
ND-style reasoning. *)

Section PTheoryBase.
  Variable pS : pSystem.
  Implicit Types s t u : pS.

  Lemma axT : mprv (@Top pS).
  Proof. exact: axI. Qed.

  Lemma axsT s : mprv (s ---> Top).
  Proof. drop. exact: axI. Qed.

  Lemma axBE s : mprv (Bot ---> s).
  Proof. rewrite <- (axDN s). K. Qed.

  Lemma axContra s t : mprv (s ---> (~~: s) ---> t).
  Proof. rewrite /Neg. rewrite -> (axBE t). by rule axC.  Qed.

  Lemma axDNI s : mprv (s ---> (~~: ~~: s)).
  Proof. exact: axContra. Qed.

  Lemma axW s t u : mprv ((s ---> t) ---> ((t ---> u) ---> s ---> u)).
  Proof. rule axC. B. Qed.

  Lemma axAEl s t : mprv (s :/\: t ---> s).
  Proof.
    rewrite /And /Neg. rewrite <- (axDN s) at 2. rule axW.
    rule axC. exact: axContra.
  Qed.

  Lemma axAEr s t : mprv (s :/\: t ---> t).
  Proof.
    rewrite /And /Neg. rewrite <- (axDN t) at 2. rule axW.
    rule axC. by drop.
  Qed.

  Lemma axAI s t : mprv (s ---> t ---> s :/\: t).
  Proof. rewrite /And /Neg. mp. mp. B. C. mp. C. done. Qed.

  Lemma axAC s t : mprv (s :/\: t ---> t :/\: s).
  Proof.
    rule axS; last apply axAEl. rule axS; last apply axAEr.
    drop. exact: axAI.
  Qed.

End PTheoryBase.

Hint Resolve axT axAEl axAEr : core.

(** Morphisms for defined locial operators *)

Instance Neg_mor (pS : pSystem) :
  Proper ((@mImpPrv pS) --> (@mImpPrv pS))(@Neg pS).
Proof. rewrite /Neg; solve_proper. Qed.

Instance And_mor (pS : pSystem) :
  Proper ((@mImpPrv pS) ==> (@mImpPrv pS) ==> (@mImpPrv pS)) (@And pS).
Proof. by rewrite /And; solve_proper. Qed.

Instance Or_mor (pS : pSystem) :
  Proper ((@mImpPrv pS) ==> (@mImpPrv pS) ==> (@mImpPrv pS)) (@Or pS).
Proof. by rewrite /Or; solve_proper. Qed.

(** *** Equivalence (Experimental)

We extend rewriting from the preorder of imlications to rewriting with
equivalences. *)

Definition Eqi (pS : pSystem) (s t : pS) := (s ---> t) :/\: (t ---> s).
Notation "s <--> t" := (Eqi s t) (at level 40, no associativity).

Definition EqiPrv (pS : pSystem) (s t : pS) := mprv (Eqi s t).

Section EqiTheoryBase.
  Variable (pS : pSystem) (s t : pS).

  Lemma axEEl : mprv ((s <--> t) ---> (s ---> t)).
  Proof. exact: axAEl. Qed.

  Lemma axEEr : mprv ((s <--> t) ---> (t ---> s)).
  Proof. exact: axAEr. Qed.

  Lemma axEI : mprv ((s ---> t) ---> (t ---> s) ---> (s <--> t) ).
  Proof. exact: axAI. Qed.
End EqiTheoryBase.

Instance eqi_induced_symmety (pS : pSystem) : InducedSym (@mImpPrv pS) (@EqiPrv pS).
Proof.
  move => s t. split => [H | [H1 H2]].
  split. by rule axEEl. by rule axEEr. by rule axEI.
Qed.

Instance induced_eqi (pS : pSystem) : Equivalence (@EqiPrv pS).
Proof. apply: induced_eqi. Qed.

(** Short cut morphisms for faster equivalence rewrites *)
Instance mprv_eqi_mor (pS : pSystem) :
  Proper (@EqiPrv pS ==> iff) (@mprv pS).
Proof. move => s t H. split. by rewrite -> H. by rewrite <- H. Qed.

Instance Neg_Eqi_mor (pS : pSystem) :
  Proper ((@EqiPrv pS) ==> (@EqiPrv pS))(@Neg pS).
Proof. rewrite /Neg; solve_proper. Qed.

Instance And_Eqi_mor (pS : pSystem) :
  Proper ((@EqiPrv pS) ==> (@EqiPrv pS) ==> (@EqiPrv pS)) (@And pS).
Proof. by rewrite /And; solve_proper. Qed.

Instance Or_Eqi_mor (pS : pSystem) :
  Proper ((@EqiPrv pS) ==> (@EqiPrv pS) ==> (@EqiPrv pS)) (@Or pS).
Proof. by rewrite /Or; solve_proper. Qed.

(** Rewriting below Equivalences *)

Instance Eqi_mor (pS : pSystem) :
  Proper ((@EqiPrv pS) ==> (@EqiPrv pS) ==> (@EqiPrv pS)) (@Eqi pS).
Proof. rewrite /Eqi. solve_proper. Qed.

Lemma ax_eq_refl (pS : pSystem)(s : pS) : mprv (s <--> s).
Proof. rule axEI; exact: axI. Qed.
Hint Resolve ax_eq_refl : core.

(** *** Big Boolean Operators *)

Notation "\and_ ( i <- r ) F" := (\big [And/Top]_(i <- r)  F)
  (at level 41, F at level 41, i at level 0,
    format "'[' \and_ ( i <- r ) '/ '  F ']'").

Notation "\and_ ( <- r )" := (\and_(i <- r) i)
  (at level 41, format "'[' \and_ ( <- r ) ']'").

Notation "\and_ ( i \in A ) F" := (\big [And/Top]_(i <- enum A)  F)
 (at level 41, F at level 41, i at level 0,
 format "'[' \and_ ( i  \in  A ) '/ '  F ']'").

Notation "\or_ ( i <- r ) F" := (\big [Or/Bot]_(i <- r)  F)
  (at level 42, F at level 42, i at level 0,
    format "'[' \or_ ( i <- r ) '/ '  F ']'").

Notation "\or_ ( <- r )" := (\or_(i <- r) i)
  (at level 42, format "'[' \or_ ( <- r ) ']'").

Notation "\or_ ( i \in A ) F" := (\big [Or/Bot]_(i <- enum A)  F)
  (at level 42, F at level 42, i at level 0,
    format "'[' \or_ ( i  \in  A ) '/ '  F ']'").

Section BigAnd.
  Variable pS : pSystem.
  Implicit Types s t : pS.

  Lemma rAI s t u : mprv (s ---> t) -> mprv (s ---> u) -> mprv (s ---> t :/\: u).
  Proof. move => H1 H2. rewrite <- H1, <- H2. rule axDup. exact: axAI. Qed.

  Lemma rAIL s t u : mprv (s :/\: t ---> u) -> mprv (s ---> t ---> u).
  Proof. move => H. rewrite <- H. exact: axAI. Qed.

  (** Introduction and eliminiation for big conjunctions *)

  Lemma bigAE (T:eqType) (F : T -> pS) (xs : seq T) (s:T) :
    s \in xs -> mprv ((\and_(x <- xs) F x) ---> F s).
  Proof.
    elim: xs; first by rewrite in_nil. move => t xs IH. rewrite inE big_cons.
    case/orP; first by move/eqP->. move/IH => E. by rewrite <- E.
  Qed.

  Lemma bigAI (T : eqType) s (r : seq T) F :
    (forall i, i \in r -> mprv (s ---> F i)) -> mprv (s ---> \and_(i <- r) F i).
  Proof.
    elim: r => [ _ |x r IH H]; first by rewrite big_nil; mp; [K|].
    rewrite big_cons. apply: rAI; first by apply: H; rewrite mem_head.
    apply: IH => i Hi. apply: H. by rewrite inE Hi orbT.
  Qed.

  Lemma and_sub (T : eqType) (xs ys : seq T) (F : T -> pS) :
    {subset xs <= ys} -> mprv ((\and_(i <- ys) F i) ---> \and_(j <- xs) F j).
  Proof. move => H. apply: bigAI => s /H. exact: bigAE. Qed.

  Lemma bigAdup s xs : mprv (\and_(<- s :: xs) ---> \and_(<-[:: s, s & xs])).
  Proof. apply: and_sub => x. by rewrite !inE orbA Bool.orb_diag. Qed.

  Lemma bigAdrop s xs : mprv (\and_(<- s :: xs) ---> \and_(<- xs)).
  Proof. apply: and_sub => x. by rewrite !inE => ->. Qed.

  Lemma bigA1E s : mprv (\and_(<- [:: s]) ---> s).
  Proof. by rewrite -> big_cons, big_nil. Qed.

  (** We use big conjuctions for assumption management to allow for ND-style reasoning *)

  Lemma rIntro s t xs : mprv ((\and_(<- s :: xs) ---> t)) -> mprv (\and_(<- xs) ---> s ---> t).
  Proof. rewrite big_cons => H. rewrite <- H, <- axAC. exact: axAI. Qed.

  Lemma rHyp s : mprv (\and_(<- [::]) ---> s) -> mprv s.
  Proof. move => H. by rewrite <- H, big_nil. Qed.

  Lemma rHyp1 s t : mprv (\and_(<- [:: s]) ---> t) -> mprv (s ---> t).
  Proof. move => H. by apply rHyp,rIntro. Qed.

  Lemma rDup s xs t : mprv (\and_(<-[:: s, s & xs]) ---> t) -> mprv (\and_(<- s :: xs) ---> t).
  Proof. move => H. by rewrite -> bigAdup. Qed.

  Lemma axRot s xs : mprv (\and_(<- s :: xs) ---> \and_(<- rcons xs s)).
  Proof. apply: and_sub => x. by rewrite mem_rcons. Qed.

  Lemma rRot s xs t : mprv (\and_(<- rcons xs s) ---> t) -> mprv (\and_(<- s :: xs) ---> t).
  Proof. move => H. by rewrite -> axRot. Qed.

  Lemma rApply s xs t : mprv (\and_(<-xs) ---> s) -> mprv (\and_(<- s ---> t :: xs) ---> t).
  Proof. move => H. rewrite -> big_cons, H. by rule (axS s). Qed.

  Lemma rApply2 s0 s1 xs t :
    mprv (\and_(<-xs) ---> s0) -> mprv (\and_(<-xs) ---> s1)  ->
    mprv (\and_(<- s0 ---> s1 ---> t :: xs) ---> t).
  Proof. move => *. rule (axS s1). by apply rApply. by rewrite -> bigAdrop. Qed.

  Lemma rApply3 s0 s1 s2 xs t :
    mprv (\and_(<-xs) ---> s0) -> mprv (\and_(<-xs) ---> s1)  -> mprv (\and_(<-xs) ---> s2) ->
    mprv (\and_(<- s0 ---> s1 ---> s2 ---> t :: xs) ---> t).
  Proof. move => *. rule (axS s2). by apply rApply2. by rewrite -> bigAdrop. Qed.

End BigAnd.

Ltac Asm := by apply: bigAE; rewrite !inE !eqxx.
Ltac Intro := first [apply rIntro | apply rHyp1].
Ltac Apply := first [eapply rApply | eapply rApply2 | eapply rApply3 ]; try Asm.
Tactic Notation "Apply*" integer(n) := (do n apply rRot); Apply.

Lemma axAcase (pS : pSystem) (u s t : pS) : mprv ((u ---> s ---> t) ---> (u :/\: s ---> t)).
Proof. do 2 Intro. Apply* 1; by rewrite -> bigA1E. Qed.

Lemma rRev (pS : pSystem) (s t : pS) xs : mprv (\and_(<- xs) ---> s ---> t) -> mprv ((\and_(<- s :: xs) ---> t)).
Proof. rewrite big_cons => H. rewrite -> axAC. by rule axAcase. Qed.

Lemma rRev1 (pS : pSystem) (s t : pS) : mprv (s ---> t) -> mprv ((\and_(<- [:: s]) ---> t)).
Proof. rewrite big_cons => H. by rewrite -> axAEl. Qed.

Ltac Rev := first [eapply rRev1 | eapply rRev].

Ltac ApplyH H := first [ drop; by apply H
                       | rule axS; first (drop; by apply H)
                       | rule axS; first (rule axS; first (drop; by apply H))
                       | rule axS; first (rule axS; first (rule axS ; first (drop; by apply H))) ]; try Asm.

Ltac Rot n := do n (apply rRot).
Tactic Notation "Rev*" integer(n) := (do n apply rRot); Rev.

(** *** Remaining Propostional Logic Facts *)

Section PTheory.
  Variable pS : pSystem.
  Implicit Types s t u : pS.

  Lemma axDNE s : mprv ((~~: ~~: s) <--> s).
  Proof. rule axAI. exact: axDN. exact: axDNI. Qed.

  Lemma ax_case s t : mprv ((s ---> t) ---> (Neg s ---> t) ---> t).
  Proof.
    rewrite <- (axDN t) at 3. do 3 Intro. apply rDup; Apply.
    Apply* 1. Intro. Apply* 2. by Apply* 1.
  Qed.

  Lemma ax_contra s t : mprv ((~~:t ---> ~~: s) ---> (s ---> t)).
  Proof. do 2 Intro. ApplyH axDN. Intro. by Apply* 2. Qed.

  Lemma ax_contraNN s t : mprv ((s ---> t) ---> ~~:t ---> ~~: s).
  Proof. do 3 Intro. Apply* 1. Apply. Qed.

  Lemma axA2 s : mprv (s <--> s :/\: s).
  Proof. rule axEI; last exact: axAEl. Intro. ApplyH axAI. Qed.

  Lemma axAsT s : mprv (s <--> s :/\: Top).
  Proof. rule axEI. by rewrite <- axAC, <- axAI. exact: axAEl. Qed.

  Lemma axOIl s t : mprv (s ---> s :\/: t).
  Proof. exact: axContra. Qed.

  Lemma axOIr s t : mprv (t ---> s :\/: t).
  Proof. exact: axK. Qed.

  Lemma axOE s t u : mprv ((s ---> u) ---> (t ---> u) ---> (s :\/: t ---> u)).
  Proof. rewrite /Or. do 3 Intro. ApplyH (ax_case s u). Intro. do 2 Apply* 2. Qed.

  Lemma axOC s t : mprv (s :\/: t ---> t :\/: s).
  Proof. rule axOE; auto using axOIl, axOIr. Qed.

  Lemma axOF s : mprv (Bot :\/: s ---> s).
  Proof. rule axOE => //. exact: axBE. Qed.

  Lemma bigOE (T : eqType) F (xs :seq T) (s : pS) :
    (forall j, j \in xs -> mprv (F j ---> s)) -> mprv ((\or_(i <- xs) F i) ---> s).
  Proof.
    elim: xs. move => _. rewrite big_nil. exact: axBE.
    move => t xs IH H. rewrite big_cons. rule axOE. exact: H (mem_head _ _).
    apply: IH => j in_xs. apply: H. by rewrite inE in_xs.
  Qed.

  Lemma bigOI (T : eqType) (xs :seq T) j (F : T -> pS) :
     j \in xs -> mprv (F j ---> \or_(i <- xs) F i).
  Proof.
    elim: xs => //= t xs IH.
    rewrite inE big_cons => /orP [/eqP -> |]. exact: axOIl.
    move => in_xs. rewrite -> IH => //. exact: axOIr.
  Qed.

  Lemma or_sub (T : eqType) (xs ys :seq T) (F : T -> pS) :
    {subset xs <= ys} -> mprv ((\or_(i<-xs) F i) ---> (\or_(j<-ys) F j)).
  Proof. move => H. apply: bigOE => s /H. exact: bigOI. Qed.

  Lemma axIO s t : mprv ((s ---> t) ---> (~~: s :\/: t)).
  Proof. rewrite /Or. by rewrite -> axDN. Qed.

  Lemma axAODr s t u : mprv (u :/\: (s :\/: t) <--> u :/\: s :\/: u :/\: t).
  Proof. rule axEI.
    rule axAcase. rule axC. rule axOE; rule axC; [rewrite <- axOIl|rewrite <- axOIr];exact: axAI.
    rule axOE;[rewrite <- axOIl|rewrite <- axOIr]; exact: axI.
  Qed.

  Lemma bigODr (T:eqType) (xs : seq T) (t : pS) (F : T -> pS) :
    mprv ((\or_(i <- xs) F i) :/\: t <--> (\or_(i <- xs) F i :/\: t)).
  Proof. rule axEI.
    - rule axAcase. apply: bigOE => j Hj. apply: rAIL. rewrite <- (bigOI _ Hj). exact: axI.
    - apply: bigOE => j Hj. rule axAcase. do 2 Intro. ApplyH axAI. Rev* 1. drop. exact: bigOI.
  Qed.

  Lemma dmO s t : mprv (~~: (s :\/: t) <--> (~~: s) :/\: (~~: t)).
  Proof. rewrite /Or /And. rule axAI; by rewrite -> axDNE. Qed.

  Lemma dmA s t : mprv (~~: (s :/\: t) <--> (~~: s) :\/: (~~: t)).
  Proof. rewrite /Or /And. rule axAI; by do ! rewrite -> axDNE. Qed.

  Lemma dmI s t : mprv (~~: (s ---> t) <-->  s :/\: ~~: t).
  Proof. rewrite /And. rule axAI; by do ! rewrite -> axDNE. Qed.

End PTheory.

Lemma axADr (pS : pSystem) (s t u : pS) :
  mprv ((s :\/: t) :/\: u <--> s :/\: u :\/: t :/\: u).
Proof. rule axAI.
  - rule axAcase. rule axOE. rewrite <- axOIl. exact: axAI.
    rewrite <- axOIr. exact: axAI.
  - rule axOE; rule axAcase. rewrite <- axOIl. exact: axAI.
    rewrite <- axOIr. exact: axAI.
Qed.

Lemma axAA (pS : pSystem) (s t u : pS) : mprv ((s :/\: t) :/\: u <--> s :/\: t :/\: u).
Proof. rule axAI.
  - do 2 rule axAcase. do 3 Intro. ApplyH axAI. ApplyH axAI.
  - rule axAcase; Intro. ApplyH axAcase; do 2 Intro. ApplyH axAI. ApplyH axAI.
Qed.

(** ** Basic Modal Logic *)

Record kSystem := KSystem { psort   :> pSystem;
                            AX     : psort -> psort;
                            rNec s  : mprv s -> mprv (AX s);
                            axN s t: mprv (AX (s ---> t) ---> AX s ---> AX t) }.

Lemma rNorm (kS : kSystem) (s t : kS) : mprv (s ---> t) -> mprv (AX s ---> AX t).
Proof. move => H. rule axN. exact: rNec. Qed.

Instance AX_mor (kS : kSystem) : Proper ((@mImpPrv kS) ==> (@mImpPrv kS)) (@AX kS).
Proof. exact: rNorm. Qed.

Definition EX (kS : kSystem) (s : kS) := ~~: AX (~~: s).

Instance EX_mor (kS : kSystem) : Proper ((@mImpPrv kS) ==> (@mImpPrv kS)) (@EX kS).
Proof. move => x y H. rewrite /EX /mImpPrv. by rewrite -> H. Qed.

(** Redundant Morphisms for Equivalence *)

Instance AX_Eqi_mor (kS : kSystem) : Proper ((@EqiPrv kS) ==> (@EqiPrv kS)) (@AX kS).
Proof. move => s t H. rewrite -> H. reflexivity. Qed.

Instance EX_Eqi_mor (kS : kSystem) : Proper ((@EqiPrv kS) ==> (@EqiPrv kS)) (@EX kS).
Proof. move => s t H. rewrite -> H. reflexivity. Qed.

Section KTheory.
  Variable kS : kSystem.
  Implicit Types s t u : kS.

  Lemma axBT : mprv (@AX kS Top).
  Proof. exact: rNec. Qed.
  Hint Resolve axBT : core.

  Lemma axDF : mprv (@EX kS Bot ---> Bot).
  Proof. rewrite /EX. Intro; Apply. drop. exact: axBT. Qed.

  Lemma axABBA s t : mprv (AX s :/\: AX t <--> AX (s :/\: t)).
  Proof. rule axEI.
    - rule axAcase. rewrite <- axN. apply rNorm. exact: axAI.
    - Intro. ApplyH axAI; Rev; by apply rNorm.
  Qed.

  Lemma bigABBA (T : eqType) (xs : seq T) (F : T -> kS) :
    mprv ((\and_(s <- xs) AX (F s)) ---> AX (\and_(s <- xs) F s)).
  Proof.
    elim: xs; first by drop; rewrite big_nil.
    move => t xs IH. rewrite !big_cons. by rewrite -> IH, axABBA.
  Qed.

  Lemma axDBD s t : mprv (EX s ---> AX t ---> EX (s :/\: t)).
  Proof.
    rewrite /EX. do 3 Intro. Apply* 2. do 2 Rev. rewrite <- axN.
    apply: rNorm. do 3 Intro. Apply* 1. ApplyH axAI.
  Qed.

  Lemma rEXn s t : mprv (s ---> t) -> mprv (EX s ---> EX t).
  Proof. rewrite /EX => H. by rewrite -> H. Qed.

  Lemma dmAX s : mprv (~~: AX s <--> EX (~~: s)).
  Proof. rewrite /EX. by rewrite -> axDNE. Qed.

End KTheory.

(** ** K* *)

Record ksSystem :=
  KSSystem { ksort'       :> kSystem;
             AG          : ksort' -> ksort';
             axAGEl s    : mprv (AG s ---> s) ;
             axAGEr s    : mprv (AG s ---> AX (AG s)) ;
             rAG_ind u s : mprv (u ---> AX u) -> mprv (u ---> s) -> mprv (u ---> AG s)
           }.

Definition EF {ksS : ksSystem} (s : ksS) := ~~: AG (~~: s).

Section KStarTheory.
  Variables (ksS : ksSystem).
  Implicit Types s t u : ksS.

  Lemma rNecS s : mprv s -> mprv (AG s).
  Proof. move => H. apply: rMP (H). apply: rAG_ind => //. drop. exact: rNec. Qed.

  Lemma axAGN s t : mprv (AG (s ---> t) ---> AG s ---> AG t).
  Proof.
    apply: rAIL. apply: rAG_ind.
    - rewrite -> axAGEr at 1. by rewrite -> (axAGEr s),axABBA at 1.
    - rule axAcase. by do 2 rewrite -> axAGEl.
  Qed.

  Lemma axAGE s : mprv (AG s <--> s :/\: AX (AG s)).
  Proof.
    have S: mprv (AG s ---> s :/\: AX (AG s)).
      rewrite -> (axA2 (AG s)) at 1. by rewrite -> axAGEl,axAGEr at 1.
    rule axEI => //. apply: rAG_ind; last exact: axAEl.
    rule axAcase. drop. exact: rNorm.
  Qed.

  Lemma rNormS s t : mprv (s ---> t) -> mprv (AG s ---> AG t).
  Proof. move/rNecS. apply: rMP. exact: axAGN. Qed.

  Instance AG_mor : Proper ((@mImpPrv ksS) ==> (@mImpPrv ksS)) (@AG ksS).
  Proof. exact: rNormS. Qed.

  Lemma axAGEn s : mprv (~~: AG s ---> ~~: s :\/: ~~: AX (AG s)).
  Proof. rewrite -> axAGE at 1. by rewrite -> dmA. Qed.

  Lemma rAGp_ind (k : ksSystem) (u s : k) : mprv (u ---> AX (u :/\: s)) -> mprv (u ---> AX (AG s)).
  Proof.
    move => H /=. rewrite -> H. apply: rNorm. apply: rAG_ind; last exact: axAEr.
    rewrite <- H. exact: axAEl.
  Qed.

  Lemma segerberg s : mprv (AG (s ---> AX s) ---> s ---> AG s).
  Proof.
    apply: rAIL. apply: rAG_ind; last exact: axAEr.
    rewrite -> axAGE at 1. do 2 rule axAcase.
    do 3 Intro. rewrite <- axABBA. ApplyH axAI. by Apply* 2.
  Qed.

End KStarTheory.

(** ** CTL *)

Record ctlSystem :=
  CTLSystem { ksort         :> kSystem;
              AU            : ksort -> ksort -> ksort;
              AR            : ksort -> ksort -> ksort;
              rAU_ind s t u : mprv (t ---> u) -> mprv (s ---> AX u ---> u) -> mprv ((AU s t) ---> u);
              axAUI s t     : mprv (t ---> AU s t);
              axAUf s t     : mprv (s ---> AX (AU s t) ---> AU s t);
              rAR_ind s t u :
                mprv (u ---> t) -> mprv (u ---> (s ---> Bot) ---> AX u) -> mprv (u ---> AR s t);
              axARE s t    : mprv (AR s t ---> t);
              axARu s t    : mprv (AR s t ---> (s ---> Bot) ---> AX (AR s t))
            }.

Definition ER {cS : ctlSystem} (s t : cS) := ~~: AU (~~: s) (~~: t).
Definition EU {cS : ctlSystem} (s t : cS) := ~~: AR (~~: s) (~~: t).
Notation "'EG' s" := (ER Bot s) (at level 8).

Instance AU_mor (cS : ctlSystem) :
  Proper ((@mImpPrv cS) ==> (@mImpPrv cS) ==> (@mImpPrv cS))(@AU cS).
Proof.
  move => x x' X y y' Y. rewrite /mImpPrv in X Y *.
  apply: rAU_ind. rewrite -> Y. exact: axAUI. rewrite -> X. exact: axAUf.
Qed.

Instance ER_mor (cS : ctlSystem) :
  Proper ((@mImpPrv cS) ==> (@mImpPrv cS) ==> (@mImpPrv cS))(@ER cS).
Proof. rewrite /ER. solve_proper. Qed.

Instance AR_mor (cS : ctlSystem) :
  Proper ((@mImpPrv cS) ==> (@mImpPrv cS) ==> (@mImpPrv cS))(@AR cS).
Proof.
  move => x x' X y y' Y. rewrite /mImpPrv in X Y *.
  apply: rAR_ind. rewrite <- Y. exact: axARE. rewrite <- X. exact: axARu.
Qed.

Instance EU_mor (cS : ctlSystem) :
  Proper ((@mImpPrv cS) ==> (@mImpPrv cS) ==> (@mImpPrv cS))(@EU cS).
Proof. rewrite /EU. solve_proper. Qed.

Section CTLTheory.
  Variable cS : ctlSystem.
  Implicit Types s t u : cS.

  Lemma axAUeq s t : mprv (AU s t <--> t :\/: s :/\: AX (AU s t)).
  Proof.
    rule axAI.
    - apply: rAU_ind; first exact: axOIl.
      rewrite /Or. do 3 Intro. ApplyH axAI. apply: rRot => /=. Rev. drop.
      apply: rNorm. Intro. ApplyH (ax_case t); Intro; first by ApplyH axAUI.
      ApplyH axAUf; [ApplyH axAEl|ApplyH axAEr]; Apply* 1.
    - rule axOE; first exact: axAUI. rule axAcase. exact: axAUf.
  Qed.

  Lemma rER_ind u s t : mprv (u ---> t) -> mprv (u ---> ~~: s ---> EX u) -> mprv (u ---> ER s t).
  Proof.
    move => H0 H1. rewrite /ER. rule ax_contra. rewrite -> axDN.
    apply: rAU_ind. by rewrite -> H0. do 3 Intro. by ApplyH H1.
  Qed.

  Lemma axAUEGF s t : mprv (AU s t ---> EG (~~: t) ---> Bot).
  Proof. rewrite /ER. do 2 Intro. Apply. Rev. by rewrite -> (axsT s), <-(axDNI t). Qed.

  (** de Morgan Lemmas *)

  Lemma dmAR s t : mprv (~~: (AR s t) <--> EU (~~: s) (~~: t)).
  Proof. rewrite /EU. by rule axEI; do ! rewrite -> axDNE. Qed.

  Lemma dmAU s t : mprv ((~~: AU s t) <--> ER (~~: s) (~~: t)).
  Proof. rewrite /ER. rule axAI; by do ! rewrite -> axDNE. Qed.

  Lemma dmER s t : mprv ((~~: ER s t) <--> AU (~~: s) (~~: t)).
  Proof. rewrite /ER. rule axAI; by do ! rewrite -> axDNE. Qed.

  Lemma dmEU s t : mprv ((~~: EU s t) <--> AR (~~: s) (~~: t)).
  Proof. rewrite /EU. rule axAI; by do ! rewrite -> axDNE. Qed.

  Lemma axERu s t : mprv (ER s t ---> t :/\: (s :\/: EX (ER s t))).
  Proof.
    rule ax_contra. rewrite /ER. rewrite <- axDNI, dmA, dmO.
    rewrite /EX. do ! rewrite -> axDN. rule axOE. exact: axAUI.
    rule axAcase. exact: axAUf.
  Qed.

  Lemma axAUERF s t : mprv (AU s t :/\: ER (~~: s) (~~: t) ---> Bot).
  Proof. rule axAcase. rewrite /ER. do 2 Intro. Apply. Rev. by do ! rewrite <- axDNI. Qed.

  Lemma axAUAEr s t u : mprv (AU (s :/\: u) (t :/\: u) ---> u).
  Proof. apply: rAU_ind => //. rewrite -> axAEr. by K. Qed.

  Lemma axAUAw s t u : mprv (AU (s :/\: u) (t :/\: u) ---> AU s t).
  Proof.
    apply: rAU_ind. rewrite -> axAEl. exact: axAUI.
    rewrite -> axAEl. exact: axAUf.
  Qed.

  Lemma EU_ind s t u :
    mprv (t ---> u) -> mprv (s ---> EX u ---> u) -> mprv (EU s t ---> u).
  Proof.
    move => H1 H2. rewrite /EU. rule ax_contra. rewrite <- axDNI.
    apply: rAR_ind; first by rule ax_contraNN.
    rewrite -[~~: s ---> Bot]/(~~: ~~: s). rewrite -> axDN. rule axC.
    Intro. ApplyH ax_contra. rewrite <- axDNI. ApplyH H2.
  Qed.

  Lemma axEUI s t : mprv (t ---> EU s t).
  Proof. rewrite /EU. rewrite -> (axDNI t) at 1. rule ax_contraNN. exact: axARE. Qed.

  Lemma axEUI2 s t : mprv (s ---> EX (EU s t) ---> EU s t).
  Proof.
    rewrite /EU. rewrite -> (axDNI s) at 1. Intro. ApplyH ax_contraNN; Intro.
    Suff (AX (AR (~~: s) (~~: t))). drop. apply: rNorm. exact: axDNI.
    ApplyH axARu.
  Qed.

  Lemma axAReq s t : mprv (AR s t <--> t :/\: (s :\/: AX (AR s t))).
  Proof.
    rule axEI.
    - ApplyH axAI. exact: axARE. do 2 Intro. ApplyH axARu.
    - apply: rAR_ind; first exact: axAEl.
      rule axAcase; drop. rule axOE; first exact: axContra. rule axC; drop.
      apply: rNorm. ApplyH axAI. exact: axARE. exact: axARu.
  Qed.

  Lemma axEUeq s t : mprv (EU s t <--> t :\/: s :/\: EX (EU s t)).
  Proof.
    rewrite /EU /EX. rewrite -> axDNE, axAReq at 1. rewrite -> dmA,dmO at 1.
    by do ! rewrite -> axDNE.
  Qed.

  Lemma axEUw s t u : mprv (EU (s :/\: u) (t :/\: u) ---> EU s t).
  Proof. by do ! rewrite -> axAEl. Qed.

  Lemma axEUEr s t u : mprv (EU (s :/\: u) (t :/\: u) ---> u).
  Proof.
    rewrite -> axEUeq. rule axOE; first exact: axAEr.
    rewrite -> axAEl. exact: axAEr.
  Qed.

  Lemma rAU_ind_weak u s t :
    mprv (t ---> u) -> mprv (AX u ---> u) -> mprv ((AU s t) ---> u).
  Proof. move => A B. apply rAU_ind => //. rewrite -> B. by drop. Qed.

  Lemma rER_ind_weak u s t :
    mprv (u ---> t) -> mprv (u ---> EX u) -> mprv (u ---> ER s t).
  Proof.
    move => H0 H1. rewrite /ER. rule ax_contra. rewrite -> axDN.
    apply: rAU_ind_weak. by rewrite -> H0. do 2 Intro. ApplyH H1.
  Qed.

  Lemma EXR_ind s t u : mprv (u ---> EX (t :/\: (s :\/: u))) -> mprv (u ---> EX (ER s t)).
  Proof.
    move => IH. rewrite -> IH. apply: rEXn. apply: rER_ind. exact: axAEl.
    rewrite <- IH. rule axAcase. drop. exact: axI.
  Qed.

  Lemma AXR_ind s t u : mprv (u ---> AX (t :/\: (s :\/: u))) -> mprv (u ---> AX (AR s t)).
  Proof.
    move => IH. rewrite -> IH. apply: rNorm. apply: rAR_ind. exact: axAEl.
    rewrite <- IH. rule axAcase. drop. exact: axI.
  Qed.

End CTLTheory.

(** fset lemmas *)

Lemma andU  (T : choiceType) (pS : pSystem) (F : T -> pS) (X Y : {fset T}) :
  mprv ((\and_(s <- X `|` Y) F s) <--> (\and_(s <- X) F s) :/\: (\and_(s <- Y) F s)).
Proof. rule axAI.
  - apply: rAI; apply: and_sub; apply/subP; auto with fset.
  - apply: bigAI => s; case/fsetUP; [rewrite -> axAEl|rewrite -> axAEr]; exact: bigAE.
Qed.

Lemma bigA1 (T : choiceType) (pS : pSystem) (F : T -> pS) (s : T) :
  mprv ((\and_(s <- [fset s]) F s) <--> F s).
Proof.
  rewrite fset1Es. rule axAI. rewrite big_cons big_nil. by rewrite -> axAEl.
  apply: bigAI => ?. by rewrite inE => /eqP ->.
Qed.

(** set lemmas (Ssreflect's finite sets) *)

Lemma bigAUA (T : finType) (pS : pSystem) (A B : {set T}) (F : T -> pS) :
  mprv ((\and_(s \in A :|: B) F s) ---> (\and_(s \in A) F s) :/\: (\and_(s \in B) F s)).
Proof. apply: rAI; apply: and_sub => x; by rewrite !mem_enum inE => ->.  Qed.

Lemma andAAU (T : finType) (pS : pSystem) (A B : {set T}) (F : T -> pS) :
  mprv ((\and_(s \in A) F s) :/\: (\and_(s \in B) F s) ---> (\and_(s \in A :|: B) F s)).
Proof.
  apply: bigAI => s.
  rewrite mem_enum => /setUP [H|H]; [rewrite -> axAEl | rewrite -> axAEr];
    apply: bigAE; by rewrite mem_enum.
Qed.


(************************************************************************)
(*                          Icharate Toolkit                            *)
(*                            Houda ANOUN                               *)
(*                          Pierre CASTERAN                             *)
(*                            2003 -2006                                *)
(*                              LaBRI                                   *)
(************************************************************************)

Set Implicit Arguments.
Require Export tacticsDed.
Require Export struct_ex.

Section props.
Variables I J A W:Set.
Variable eqdecI:(eqdec I).
Variable eqdecJ :(eqdec J).
Variable ext:(extension I J).

(* generalization of the axiom rule :
    Gamma |-- delta(Gamma) *)
Definition axiomGen :
  forall Gamma:context I J A W,
    natded eqdecI eqdecJ ext Gamma (contextToForm Gamma).
 induction Gamma.
 simpl; constructor 1.
 simpl.
 apply DotI; assumption.
 simpl.
 apply DiamI.
 assumption.
Defined.

(* binary relation between contexts
   (replaceNTimes ru G1 G2) iff G2 is a result of
   rewriting G1 a number of times using the structural rule ru *)
Inductive replaceNTimes(Ru:structrule I J):
context I J A W ->context I J A W->Set:=
|noRep:forall(T1:context I J A W),
          replaceNTimes Ru T1 T1
|repRu: forall(T1 T2 T3 T4 T5:context I J A W),
     struct_replace eqdecI eqdecJ Ru T4 T5 T1 T2->
     replaceNTimes Ru T2 T3->
     replaceNTimes Ru T1 T3.

(* binary relation between contexts
   (replaceNTimes ext G1 G2) iff G2 results from rewriting
   G1 a number of times using a rule among the set of rules ext *)
Inductive replaceNTimesExt:
context I J A W ->context I J A W->Set:=
|rep1:forall(T1:context I J A W), replaceNTimesExt T1 T1
|rep2:forall (T1 T2 T3:context I J A W)(ru:structrule I J),
                   in_extension ru ext->
                   replaceNTimesExt  T1 T2->
                   replaceNTimes ru T2 T3->
                   replaceNTimesExt  T1 T3.

(* some properties of the above relations *)

Definition MonoLeftNRu:forall (Ru:structrule I J)(T1 T2 T3:context I J A W)i,
                       replaceNTimes Ru  T1 T2->
                       replaceNTimes Ru (Comma i T3 T1) (Comma i T3 T2).
 induction 1.
 constructor.
 eapply repRu with (T2 := (Comma i T3 T2)).
 constructor 3.
 eauto.
 auto.
Defined.

Definition replNPermut:forall (T1 T2 T3:context I J A W)(ru:structrule I J),
                   in_extension ru ext->
                   replaceNTimesExt  T2 T3->
                   replaceNTimes  ru T1 T2->
                   replaceNTimesExt  T1 T3.
 induction 2; intros.
 econstructor 2.
 eauto.
 constructor 1.
 auto.
 econstructor.
 eauto.
 eauto.
 auto.
Defined.

Definition replaceExtMonoLeft:forall (T1 T2 T3:context I J A W)i,
                   replaceNTimesExt T1 T2->
                   replaceNTimesExt  (Comma i T3 T1) (Comma i T3 T2).

  induction 1; intros.
  constructor.
  econstructor 2.
  eauto.
  eauto.
  eapply MonoLeftNRu; auto.
Defined.

Definition MonoRightNRu:forall (T1 T2 T3:context I J A W)i ru,
                    replaceNTimes ru T1 T2->
                    replaceNTimes ru (Comma i T1 T3) (Comma i T2 T3).
 induction 1.
 constructor 1.
 econstructor 2.
 econstructor 2.
 eauto.
 auto.
Defined.

Definition replaceExtMonoRight:forall (T1 T2 T3:context I J A W)i,
                    replaceNTimesExt T1 T2->
                    replaceNTimesExt  (Comma i T1 T3) (Comma i T2 T3).

  induction 1; intros.
  constructor.
  econstructor 2.
  eauto.
  eauto.
  eapply MonoRightNRu; auto.
Defined.

Definition replExtTrans:forall (T1 T2 T3:context I J A W) ,
                               replaceNTimesExt T1 T2->
                               replaceNTimesExt T2 T3->
                               replaceNTimesExt T1 T3.
 induction 1.
 auto.
 intro.
 apply IHreplaceNTimesExt.
 eapply replNPermut;eauto.
Defined.

Definition replExtMono:forall (T1 T2 T3 T4:context I J A W) (i:I),
                               replaceNTimesExt T1 T2->
                               replaceNTimesExt T3 T4 ->
                               replaceNTimesExt (Comma i T1 T3) (Comma i T2 T4).
  intros.
  eapply replExtTrans.
  eapply replaceExtMonoRight.
  eauto.
  eapply replaceExtMonoLeft;eauto.
Defined.

(* if (Ru C ext) and (T2 --->(Ru) T1) and T1 |--{ext} C then
   T2 |--{ext} C *)
Definition natdedNRep:forall (Ru:(structrule I J))(T1 T2:context I J A W)(C:Form I J A),
                              in_extension Ru ext ->
                              replaceNTimes Ru T2 T1->
                              natded eqdecI eqdecJ ext T1 C ->
                              natded eqdecI eqdecJ ext T2 C.
 induction 2.
 intro.
 auto.
 intro.
 eapply StructRule;eauto.
Defined.

(* proof that if T1 --->(ext) T2 and T2 |--{ext}C then
  T1|--{ext}C *)
Definition repExtnatDed:forall (T1 T2:context I J A W)(B:Form I J A),
                         replaceNTimesExt T1 T2->
                         natded eqdecI eqdecJ ext T2 B->
                         natded eqdecI eqdecJ ext T1 B.
 induction 1.
 auto.
 intro.
 apply IHreplaceNTimesExt.
 eapply natdedNRep;eauto.
Defined.

(* derivation of cut rule *)

Definition cut_rule :forall
   (Gamma Delta: context I J A W)
   (F G: Form I J A),
   weak_sahlqvist_ext  ext ->
   natded eqdecI eqdecJ ext Delta F ->
   natded  eqdecI eqdecJ ext Gamma G ->
   forall Gamma' r,
      par_replace (res (hyp  r) F) Delta Gamma Gamma' ->
      natded  eqdecI eqdecJ ext Gamma' G.

 intros Gamma Delta F G cond ;induction 2.
 intros.
 inversion H0.
 constructor.
 subst.
 auto.
 intros.
 apply SlashI with n.
 apply IHnatded with r.
 constructor.
 auto.
 constructor.
 intros.
 apply BackI with n.
 apply IHnatded with r.
 constructor.
 constructor.
 auto.
 intros.
 elim (replaceParCom H0).
 intros Gamma1 H1.
 elim H1; clear H1; intros Delta2' H1.
 elim H1; clear H1; intros H1 H2; elim H2; clear H2; intros H2 H3.
 rewrite H3.
 apply DotI.
 eapply IHnatded1.
 eauto.
 eapply IHnatded2; eauto.
 intros.
 elim (replaceParDiam H1).
 intros Gamma1 H2; elim H2; clear H2; intros H2 H3.
 rewrite H3.
 apply DiamI.
 eapply IHnatded; eauto.
 intros.
 apply BoxI.
 eapply IHnatded.
 constructor.
 eauto.
 intros.
 elim (replaceParCom H0).
 intros Gamma1 H1; elim H1; clear H1; intros Delta2' H1.
 elim H1; clear H1; intros H1 H2.
 elim H2; clear H2; intros H2 H3.
 rewrite H3.
 apply SlashE with G.
 eapply IHnatded1; eauto.
 eapply IHnatded2; eauto.
 intros.
 elim (replaceParCom H0).
 intros Gamma1 H1; elim H1; clear H1; intros Delta2' H1.
 elim H1; clear H1; intros H1 H2; elim H2; clear H2; intros H2 H3.
 rewrite H3.
 apply BackE with G.
 eapply IHnatded1; eauto.
 eapply IHnatded2; eauto.
 intros.
 elim (doubleReplacePar r H1).
 intros Gamma1 H2; elim H2; clear H2; intros Gamma2 H2.
 elim H2; clear H2; intros H2 H3.
 elim H3; clear H3; intros H3 H4.
 eapply DotE.
 eauto.
 eapply IHnatded1; eauto.
 eapply IHnatded2; eauto.
 intros.
 elim (doubleReplacePar r H0).
 intros Gamma1 H1; elim H1; clear H1; intros Gamma2 H1; elim H1; clear H1;
 intros H1 H2.
 elim H2; clear H2; intros H2 H3.
 eapply DiamE.
 eauto.
 eapply IHnatded1;eauto.
 eapply IHnatded2; eauto.
 intros.
 elim (replaceParDiam H1).
 intros Gamma1 H2; elim H2; clear H2; intros H2 H3.
 rewrite H3.
 apply BoxE.
 eapply IHnatded; eauto.
 intros.
 cut (weak_sahlqvist_rule  Ru).
 intro cond'.
 elim (structrule_subst_commute cond' s H1).
 intros Gamma1 H2; elim H2; clear H2; intros T2' H2; elim H2; clear H2;
 intros Gamma2 H2; elim H2; clear H2; intros H2 H3;
 elim H2; clear H2; intros; elim H3; clear H3; intros.
 eapply StructRule;eauto.
 auto.
Defined.

Definition cut_rule1:forall
   (Gamma Gamma': context I J A W)
   (Delta: context I J A W)
   (F G: Form I J A)r,
   weak_sahlqvist_ext  ext ->
   natded eqdecI eqdecJ ext Delta F ->
   replace (res (hyp r) F) Delta Gamma Gamma' ->
   natded  eqdecI eqdecJ ext Gamma G ->
   natded  eqdecI eqdecJ ext Gamma'  G.
 intros.
 eapply cut_rule.
 auto.
 eexact H.
 eauto.
 eapply repToParRep;eauto.
Defined.

Definition cut_rule' :
  forall
   (HGamma : hcontext I J A W)
   (Delta: context I J A W)
   (F G: Form I J A),
   weak_sahlqvist_ext ext ->
   natded eqdecI eqdecJ ext Delta F ->
   forall r,
   natded  eqdecI eqdecJ ext (fill HGamma (res (hyp  r) F)) G ->
   natded  eqdecI eqdecJ ext (fill HGamma Delta) G.
   intros.
   eapply cut_rule.
   apply X.
   eexact H.
   eauto.
   eapply fill_to_par_replace.
Defined.

Definition simple_cut_rule :forall
   (ZGamma : zcontext I J A W)
   (Delta: context I J A W)
   (F G: Form I J A),
   weak_sahlqvist_ext  ext ->
   natded eqdecI eqdecJ ext Delta F ->
   forall r,
   natded  eqdecI eqdecJ ext (zfill ZGamma (res (hyp  r) F)) G ->
   natded  eqdecI eqdecJ ext (zfill ZGamma Delta) G.
intros.
rewrite zfill_fill.
rewrite zfill_fill in H0.
eapply cut_rule'.
auto.
eauto.
eauto.
Defined.

(* particular case of cut rule *)
Definition natded_trans :
  forall r (Gamma:context I J A W) (F G:Form I J A),
   weak_sahlqvist_ext  ext ->
    natded  eqdecI eqdecJ ext Gamma F ->
    natded   eqdecI eqdecJ ext (res (W:=W) (hyp r) F) G ->
    natded  eqdecI eqdecJ ext Gamma G.
 intros.
 eapply cut_rule with (r:=r).
 auto.
 eexact H.
 eexact H0.
 econstructor.
Defined.

(* derived rules taken from chapter 2
  of the Handbook
 contribution of M.Moortgat *)
(* derived rules in NL *)

(*  F/iG oi G |-F *)
Definition application_l:forall (r:resource W)(F G :Form I J A)i,
    natded eqdecI eqdecJ ext (res r (Dot i (Slash i F G) G)) F.

 intros.
 eapply DotE with (n:= 1)(p:=2).
 constructor 1.
 constructor 1.
 eapply SlashE; constructor 1.
Defined.

(*  G oi G \i F |-F *)
Definition application_r : forall (r:resource W) (F G: Form I J A)i,
   natded eqdecI eqdecJ ext (res r (Dot i G (Backslash i G F))) F.
 intros.
 eapply DotE with (n:= 1)(p:=2).
 constructor 1.
 constructor 1.
 eapply BackE ;constructor 1.
Defined.

(* F |- (F oi G) /i G *)
Definition co_application_l : forall (r:resource W)(F G : Form I J A)i,
   natded   eqdecI eqdecJ ext (res r F) (Slash i (Dot i F G) G).
 intros; eapply  SlashI with (n:=1).
 eapply DotI ;constructor 1.
Defined.

(* F|- G \i (G oi F) *)
Definition co_application_r : forall (r:resource W) (F G: Form I J A)i,
   natded   eqdecI eqdecJ ext (res r F) (Backslash i G (Dot i G F)).
  intros; eapply BackI with (n:= 1).
  apply DotI ;constructor 1.
Defined.

(* if F |- G and H|-K then F oiH |- G oi K *)
Lemma Dot_monotonicity : forall (F G H K : Form I J A)i ,
  (natded0 eqdecI eqdecJ ext (form F) G) ->
  (natded0  eqdecI eqdecJ ext (form H ) K) ->
  natded0  eqdecI eqdecJ ext (form (Dot i F H)) (Dot i G K).
 unfold  natded0 at 3;intros.
 eapply DotE with (n:=9)(p:=10).
 constructor 1.
 axiom.
 eapply DotI.
 apply X ; auto.
 apply X0; auto.
Defined.

Lemma Dot_monotonicity0 : forall (F G H K : Form I J A)i ,
   natded0  eqdecI eqdecJ ext (form F) G ->
   natded0   eqdecI eqdecJ ext (form H) K ->
  forall r3, natded  eqdecI eqdecJ ext (res (W:=W) r3 (Dot i F H)) (Dot i G  K).
 intros.
 z_root.
 dotE 9 10.
 axiom.
 unfocus; eapply DotI.
 apply X ; auto.
 apply X0; auto.
Defined.

(* F|- G /i (F \i G) *)
Definition Slash_lifting :  forall (r:resource W) (F G: Form I J A)i,
                       natded eqdecI eqdecJ ext (res r F) (Slash i G (Backslash i F  G)).
 intros.
 eapply SlashI with 6.
 eapply BackE; axiom.
Defined.

(* F |- (G/iF)\iG *)
Definition Back_lifting : forall (r:resource W)(F G: Form I J A) i ,
                       natded  eqdecI eqdecJ ext (res r F) (Backslash i (Slash i G F) G).
 intros.
 eapply BackI with 6.
 eapply SlashE; axiom.
Defined.

(* a revoir apres la demonstration de la transitivite de |-
Lemma Slash_isotonicity : (weak_sahlqvist_ext  e)->
                          forall (F G   : Form I J A)  ,
                          (natded0  decI decJ e (form F) G)->
   forall H , natded0 decI decJ e (form (F /i H)) (G /i H).

 unfold natded0 at 2;  intros.
 eapply SlashI with 5.
 xtrans 6 F.
 auto.
 eapply SlashE; axiom.
 apply X0; auto.
Defined.

Lemma Back_isotonicity : (weak_sahlqvist_ext  e)->
                          forall (F G   : Form I J A)  ,
                          (natded0   decI decJ e (form F) G) ->
   forall H, natded0  decI decJ e (form (H \i F)) (H \i G).
  unfold natded0 at 2; intros.
 eapply BackI with 5.
 z_root.
 xcut 6 F; auto.
 eapply BackE; axiom.
 unfocus;apply X0;auto.
Qed.

*)

(* if F |- G then H/i G |- H/i F *)
Definition Slash_antitonicity :
  forall (r:resource W) (F G : Form I J A)i ,
    (natded0   eqdecI eqdecJ ext (form F) G) ->
   forall H , natded   eqdecI eqdecJ ext (res r (Slash i H  G)) (Slash i H  F).

 intros.
 eapply SlashI with 5.
 eapply SlashE.
 axiom.
 apply X;auto.
Defined.

(* if F |- G then  G \i H |- F\i H *)
Lemma Back_antitonicity :
   forall (r:resource W)(F G: Form I J A) i,
      (natded0 eqdecI eqdecJ ext (form F) G) ->
   forall H, natded  eqdecI eqdecJ ext (res r (Backslash i G H)) (Backslash i F H).
 intros.
 eapply BackI with 5.
 eapply BackE.
 eapply X;auto.
 axiom.
Qed.

(* F /i ((G/i H) \i G) |- F /i H *)
Definition argument_lowering :
 forall (r:resource W) (F G H: Form  I J A) i,
  natded eqdecI eqdecJ ext  (res r (Slash i F  (Backslash i (Slash i G  H) G))) (Slash i F  H).
 intros.
 apply Slash_antitonicity.
 unfold natded0 in |- *.
 intros.
 elim (matches_inv_form H0).
 intros.
 subst.
 backI 1.
 eslashE;axiom.
Defined.

(*for unaries*)

(* < []j B >j |-B *)
Definition diam_Box:forall (r:resource W)(B :Form I J A)(j:J),
                  natded eqdecI eqdecJ ext (TDiamond j (res r (Box j B))) B.
 intros.
 boxE.
 axiom.
Defined.

(* <>j[]j B |- B *)
Definition diamBox:forall (r:resource W)(B :Form I J A)(j:J),
                  natded eqdecI eqdecJ ext (res r (Diamond j (Box j B))) B.
 intros.
 elimDiam 1.
 apply diam_Box.
Defined.

(* B |- []j <>j B *)
Definition boxDiam:forall (r:resource W)(B :Form I J A)(j:J),
                   natded eqdecI eqdecJ ext (res r B) (Box j (Diamond j B)).
 intros.
 boxI.
 diamI;axiom.
Defined.

(* if <>j A |- B then A |-[]j B*)
Definition box2diam : forall (r:resource W)(F G  : Form I J A)j ,
  weak_sahlqvist_ext  ext ->
  (natded0 eqdecI eqdecJ ext (form (Diamond j F)) G) ->
  natded  eqdecI eqdecJ ext (res r  F) (Box j G).

 intros; unfold natded0;intros.
 boxI.
 eapply natded_trans with (r:=3).
 auto.
 eapply DiamI .
 axiom.
 auto.
Defined.

Section L.

(* derived rules in L *)
  Variable a:I.
  Hypothesis L1_a : (in_extension (L1 a) ext).
  Hypothesis L2_a : (in_extension (L2 a) ext).

(* D ,a ((D \a C)/a B ,a (((C /a B)\a C) /a E ,a E)) |-C *)
Definition objectLift:forall (D B C E:Form I J A)(r1 r2 r3 r4:resource W),
             natded eqdecI eqdecJ ext
            (Comma a (res r1 D)
                     (Comma a (res r2 (Slash a (Backslash a D C) B))
                             (Comma a (res r3 (Slash a (Backslash a (Slash a C B) C) E))
                                      (res r4 E))))
             C.

 intros.
 eapply StructRule.
 eexact L1_a.
 here.
 autorewrite with ctl_db; auto.
 eapply BackE;[idtac|eapply SlashE; constructor 1].
 eapply SlashI with 0.
 eapply StructRule.
 eexact L2_a.
 here.
 autorewrite with ctl_db; auto.
 eapply BackE.
 constructor 1.
 eapply SlashE;constructor.
Defined.

(* F/a G |- (F/a H)/a (G/a H) *)
  Definition Geach_main_Slash : forall (r:resource W)(F G H : Form I J A) ,
                           natded   eqdecI eqdecJ ext (res r (Slash a F G))
                                              (Slash a (Slash a F  H) (Slash a G H)).
  intros r F G H.
  eapply SlashI with 3.
  eapply SlashI with 2.
  eapply StructRule.
  eexact L2_a.
  here.
  autorewrite with ctl_db; auto.
  eslashE; try axiom.
  eslashE; axiom.
 Defined.

(* G \a F |- (H\a G) \a (H \a F) *)
Definition Geach_main_Back : forall(r:resource W) (F G H : Form I J A),
                           natded  eqdecI eqdecJ ext (res r (Backslash a G F))
                                              (Backslash a (Backslash a H  G)
                                                           (Backslash a H  F)).
  intros r F G H.
  eapply BackI with 3.
  eapply BackI with 2.
  eapply StructRule.
  eexact L1_a.
  here.
  autorewrite with ctl_db; auto.
  ebackE; try axiom.
  ebackE; axiom.
 Defined.

(* H\a G |- (H\a F) /a (G \a F) *)
 Definition Geach_secondary_Slash : forall (r:resource W)(F G H: Form I J A),
                           natded eqdecI eqdecJ ext (res r (Backslash a H  G))
                                              (Slash a (Backslash a H  F)  (Backslash a G F)).
 intros r F G H.
 eapply SlashI with 3.
 eapply BackI with 2.
 eapply StructRule.
 eexact L1_a.
 here.
 autorewrite with ctl_db; auto.
 ebackE;try axiom.
 ebackE; axiom.
 Defined.

(* G /a H |- (F /a G) \a (F /a H) *)
 Definition Geach_secondary_Back : forall(r:resource W) (F G H : Form I J A),
                           natded  eqdecI eqdecJ ext (res r (Slash a G  H))
                                              (Backslash a (Slash a F  G)  (Slash a F  H)).
  intros r F G H.
  eapply BackI with 3.
  eapply SlashI with 2.
  eapply StructRule.
  eexact L2_a.
  here.
  autorewrite with ctl_db; auto.
  eslashE; try axiom.
  eslashE; axiom.
 Defined.

(* (F /a G) oa (G/a H) |- F /a H *)
Definition composition_Slash : forall (r:resource W) (F G H : Form I J A),
                                natded  eqdecI eqdecJ ext
                                (res r (Dot a (Slash a F  G)  (Slash a G  H)))
                                (Slash a F  H).
 intros r F G H.
 eapply DotE with (n:=1)(p:=2).
 here.
 axiom.
 eapply SlashI with 3.
 eapply StructRule.
 eexact L2_a.
 here.
 autorewrite with ctl_db; auto.
 eslashE; try axiom.
 eslashE; axiom.
Defined.

(* H\a G oa G\a F |-H \a F *)
Definition composition_Back : forall (r:resource W) (F G H : Form I J A),
                                natded  eqdecI eqdecJ ext
                                (res r  (Dot a (Backslash a H  G)  (Backslash a G  F)))
                                (Backslash a H  F).
 intros.
 eapply DotE with (n:=1)(p:=2).
 here.
 axiom.
 eapply BackI with 3.
 eapply StructRule.
 eexact L1_a.
 here.
 autorewrite with ctl_db; auto.
 ebackE; try axiom.
 ebackE; axiom.
Defined.

(* (F \a G)/a H |- F \a (G /a H) *)
 Definition restructuring_l :   forall (r:resource W)(F G H : Form I J A),
                                natded  eqdecI eqdecJ ext
                                (res r  (Slash a (Backslash a F  G) H))
                                (Backslash a F  (Slash a G  H)).
 intros.
 eapply BackI with 1.
 eapply SlashI with 2.
 eapply StructRule.
 eexact L2_a.
 here.
 autorewrite with ctl_db; auto.
 eapply BackE.
 axiom.
 eapply SlashE; axiom.
Defined.

(* F \a (G /a H) |- (F \a G)/a H *)
Definition restructuring_r : forall (r:resource W) (F G H : Form I J A),
                                natded  eqdecI eqdecJ ext
                                (res r (Backslash a F (Slash a G  H)))
                                 (Slash a (Backslash a F G) H) .
 intros.
 eapply SlashI with 2.
 eapply BackI with 1.
 eapply StructRule.
 eexact L1_a.
 here.
 autorewrite with ctl_db; auto.
 eslashE.
 ebackE;axiom.
 axiom.
 Defined.

(* F /a (G oa H) |- (F /a H)/a G *)
Definition currying_Slash :   forall(r:resource W) (F G H : Form I J A),
                                natded  eqdecI eqdecJ ext
                                (res r  (Slash a F (Dot a G  H)))
                                 (Slash a (Slash a F  H)  G) .
 intros.
 eapply SlashI with 1.
 eapply SlashI with 2.
 eapply StructRule.
 eexact L2_a.
 here.
 autorewrite with ctl_db; auto.
 eapply SlashE with (Dot a G H).
 axiom.
 eapply DotI.
 axiom.
 axiom.
Defined.

(* (F /a H) /a G) |- (F /a (G oa H)) *)
Definition De_currying_Slash :  forall (r:resource W)(F G H: Form I J A),
                                natded  eqdecI eqdecJ ext
                                (res r (Slash a (Slash a F  H)  G))
                                 (Slash a F (Dot a G  H))  .

 intros.
 eapply SlashI with 1.
 eapply DotE with (n:=2)(p:=3).
 down_r.
 here.
 axiom.
 eapply StructRule.
 eexact L1_a.
 here.
 autorewrite with ctl_db; auto.
 eslashE; try axiom.
 eslashE; axiom.
Defined.

(* (F oa G)\a H |- G \a (F \a H) *)
Definition currying_Back :  forall (r:resource W)(F G H : Form I J A),
                                natded eqdecI eqdecJ ext
                                (res r (Backslash a (Dot a F  G) H))
                                 (Backslash a G (Backslash a F  H)) .
 intros.
 eapply BackI with 1.
 eapply BackI with 2.
 eapply StructRule.
 eexact L1_a.
 here.
 autorewrite with ctl_db; auto.
 dotE 33 34.
 down_l; here.
 eapply DotI;axiom.
 ebackE; try axiom.
 eapply DotI;axiom.
Defined.

(* G \a (F \a H) |- (F oa G) \a H *)
Definition De_currying_Back :  forall (r:resource W)(F G H : Form I J A),
                                natded  eqdecI eqdecJ ext
                                (res r   (Backslash a G  (Backslash a F  H)))
                                 (Backslash a (Dot a F G) H)  .
 intros.
 eapply BackI with 1.
 dotE 2 3.
 down_l; here.
 axiom.
 eapply StructRule.
 eexact L2_a.
 here.
 autorewrite with ctl_db; auto.
 ebackE; try axiom.
 ebackE; axiom.
Defined.

End L.

Section P.
  Variable c:I.
  Hypothesis p_c : in_extension (P c) ext.

 (*  if F |- G \c H then G|- F \c H *)
  Definition Permutation : forall (F G H : Form I J A),
                           (natded0  eqdecI eqdecJ ext
                                       (form F) (Backslash c G H))->
                           natded0  eqdecI eqdecJ ext
                                       (form G) (Backslash c F  H).

  intros;unfold natded0;intros.
  eapply BackI with 1.
  eapply StructRule.
  eauto.
  here.
  autorewrite with ctl_db; auto.
  ebackE.
  axiom.
  apply X; auto.
Defined.

(* if F |- H/c G then G |-H /c F *)
  Definition Permutation2 : forall (F G H : Form I J A),
                           (natded0  eqdecI eqdecJ ext
                                       (form F) (Slash c H  G))->
                           natded0  eqdecI eqdecJ ext
                                       (form G) (Slash c H  F).

  intros; unfold natded0; intros.
  eapply SlashI with 1.
  eapply StructRule.
  eauto.
  here.
  autorewrite with ctl_db; auto.
  eslashE.
  apply X; auto.
 axiom.
Defined.

(* F/c G |-G \c F *)
Definition exchange_l : forall (r:resource W) (F G : Form I J A),
                       natded  eqdecI eqdecJ ext (res r (Slash c F  G)) (Backslash c G F).
 intros.
 eapply BackI with 1.
 eapply StructRule.
 eauto.
 here.
 autorewrite with ctl_db; auto.
 eslashE; axiom.
Defined.

(* G \c F |- F /c G *)
Definition exchange_r : forall (r:resource W) (F G : Form I J A),
                       natded  eqdecI eqdecJ ext (res r (Backslash c G  F)) (Slash c F  G).
 intros.
 eapply SlashI with 1.
 eapply StructRule.
 eauto.
 here.
 autorewrite with ctl_db; auto.
 ebackE; axiom.
Defined.

(* F |- G /c (G /c F) *)
Definition preposing : forall (r:resource W) (F G : Form I J A),
                       natded  eqdecI eqdecJ ext (res r F) (Slash c G  (Slash c G  F)).
 intros.
 eapply SlashI with 1.
 eapply StructRule.
 eauto.
 here.
 autorewrite with ctl_db; auto.
 eslashE; axiom.
Defined.

(* F |- (F \c G) \c G*)
Definition postponing : forall(r:resource W) (F G : Form I J A),
                       natded  eqdecI eqdecJ ext (res r F) (Backslash c (Backslash c F  G) G).
 intros.
 eapply BackI with 1.
 eapply StructRule.
 eauto.
 here.
 autorewrite with ctl_db; auto.
 ebackE; axiom.
Defined.

End P.

(* for LP logic*)

  Section LP.
 Variable c:I.
  Hypothesis L1_c : in_extension (L1 c) ext.
  Hypothesis L2_c : in_extension (L2 c) ext.
  Hypothesis P_c: in_extension (P c) ext.

(* (F /c G) oc (H \c G) |- (H \c F)*)
Definition mixed_composition_Back : forall (r:resource W) (F G H :Form I J A),
                                          natded  eqdecI eqdecJ ext
                                          (res r (Dot c (Slash c F  G) (Backslash c H  G)))
                                          (Backslash c H  F).
 intros.
 eapply DotE with (n:=2)(p:=3).
 here.
 axiom.
 eapply StructRule.
 eexact P_c.
 here.
 autorewrite with ctl_db; auto.
 eapply BackI with 1.
 eapply StructRule.
 eexact L1_c.
 here.
 autorewrite with ctl_db; auto.
 ebackE.
 ebackE; axiom.
 apply exchange_l; auto.
Defined.

(* (G /c H) oc (G\c F) |-F /c H *)
Definition mixed_composition_Slash : forall (r:resource W)(F G H : Form I J A),
                                          natded  eqdecI eqdecJ ext
                                          (res r (Dot c (Slash c G  H) (Backslash c G  F)))
                                          (Slash c F  H).
 intros.
 dotE 2 3.
 here.
 axiom.
 eapply StructRule.
 eexact P_c.
 here.
 autorewrite with ctl_db; auto.
 eapply SlashI with 1.
 eapply StructRule.
 eexact L2_c.
 here.
 autorewrite with ctl_db; auto.
 eslashE.
 apply exchange_r; auto.
 eslashE; axiom.
Defined.

End LP.

Section MP.

 Variables h r : I.
 Variable MP_hr : in_extension (MP h r) ext.

(* F /h G  |- (H \r F) /h (H \r G) *)
Definition mixed_composition_Geach : forall (re:resource W)(F G H : Form I J A),
                                          natded  eqdecI eqdecJ ext
                                          (res re  (Slash h F  G))
                                          (Slash h (Backslash r H  F) (Backslash r H  G)).
intros.
slashI 1.
backI 2.
eapply StructRule.
eauto.
here.
autorewrite with ctl_db; auto.
eslashE .
axiom.
ebackE; axiom.
Defined.

End MP.

Section MC.
Variables i j :I.
Hypothesis MC_ij : in_extension (MC i j) ext.

 (* Moortgat, page 133 *)

  (* F /j H ,i (F \i G) /j H |- G /j H *)
 Definition S_combinator : forall (r1 r2:resource W)(F G H : Form I J A) ,
                            natded eqdecI eqdecJ ext
                                    (Comma i (res r1  (Slash j F H))
                                             (res r2  (Slash j (Backslash i F  G) H)))
                                          (Slash j G  H).
 intros.
 slashI 1.
 eapply StructRule.
 eauto.
 here.
 autorewrite with ctl_db;auto.
 backE F.
 slashE H; axiom.
 slashE H; axiom.
Defined.

End MC.

End  props.


Require Import Coq.Init.Notations.
Require Import Coq.Init.Datatypes.
Require Import Coq.Program.Tactics.
From Coq.Logic Require Import  FunctionalExtensionality ProofIrrelevance.
Require Import Coq.Bool.Bool.
From mathcomp Require Import ssreflect ssrfun eqtype.
From mathcomp Require Import bigop choice fintype.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool ssrnat.
Set Warnings "parsing".
Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Require Import Algebras Morphism.
Import GRing.

Open Scope ring_scope.
Module Hom.
  Section Def.
    Variable (R : ringType) (U V : lmodType R).
    Definition add (f g : {linear U -> V}) : {linear U -> V}
    := (add_fun_linear f g).

    Definition neg (f : {linear U -> V}) : {linear U -> V}
    := (sub_fun_linear (linZero.map U V) f).

    Lemma addA : associative add.
    Proof. move=>x y z.
    destruct x, y, z.
    rewrite/add=>/=.
    apply linearPZ.
    unfold AddLinear=>/=.

    Program Definition zmodMixin_hom
    := @ZmodMixin {linear U -> V} (linZero.map U V) (neg) (add) _ _ _ _.
    Next Obligation. Admitted.
    Next Obligation. Admitted.
    Next Obligation. Admitted.
    Next Obligation. Admitted.

    Definition zmodType_hom := ZmodType {linear U -> V} zmodMixin_hom.

    Program Definition lmodMixin_hom
    := @LmodMixin R (@ZmodType {linear U -> V} zmodMixin_hom).
Check zmodMixin_hom.
    (*
    Definition zmod {R : ringType} (U V : lmodType R)
    := ZmodType _ (zmodMixin U V).
    *)

    Axiom class : GRing.Lmodule.class_of R {linear U -> V}.
Print ZmodType.
    Definition type := @ZmodType {linear U -> V} zmodMixin_hom.
    Canonical type := @GRing.Lmodule.Pack R (Phant R) _ (class U V) {linear U -> V}.

    Definition leftHomMorph {R : ringType} {U V : lmodType R}
      (f : type U V) (W : lmodType R) : type W U -> type W V
        := fun g : {linear W -> U} => GRing.comp_linear f g.

    Axiom leftHomMorph_lin : forall {R : ringType} {U V : lmodType R}
      (f : {linear U -> V}) (W : lmodType R)
        , linear (leftHomMorph f W).

    Definition rightHomMorph {R : ringType} (T : lmodType R) {U V : lmodType R}
      (f : type U V) : type V T -> type U T
        := fun g : {linear V -> T} => GRing.comp_linear g f.

    Axiom rightHomMorph_lin : forall {R : ringType} (T : lmodType R) {U V : lmodType R}
      (f : {linear U -> V})
        , linear (rightHomMorph T f).

    Module Exports.

    Canonical leftHomMorphLin {R : ringType} {U V : lmodType R}
      (f : type U V) (W : lmodType R) := Linear (leftHomMorph_lin f W).

    Canonical rightHomMorphLin {R : ringType} (T : lmodType R) {U V : lmodType R}
      (f : type U V) := Linear (rightHomMorph_lin T f).

  Notation homType := type.
  Notation homMorphL := leftHomMorphLin.
  Notation homMorphR := rightHomMorphLin.
  Notation "\Hom( A , B )" := (homType A B) (at level 99).
  Notation "\fHom1( f , B )" := (homMorphL f B) (at level 99).
  Notation "\fHom2( A , f )" := (homMorphR A f) (at level 99).
  End Exports.

End Hom.
Export Hom.Exports.


Require Import CT.Category.
Require Import CT.Functor.

(** [F : A -> A]. An _endofunctor_ maps a category to itself. *)
Program Definition Endofunctor (C : Category) := Functor C C.


From Coq Require Import List SetoidList.
Import ListNotations.

Set Implicit Arguments.

(** * Some complements on bool and lists *)

Lemma eq_bool_alt b b' : b=b' <-> (b=true <-> b'=true).
Proof.
 destruct b, b'; intuition.
Qed.

Lemma eq_option_alt {A}(o o':option A) :
 o=o' <-> (forall x, o=Some x <-> o'=Some x).
Proof.
split; intros.
- now subst.
- destruct o, o'; rewrite ?H; auto.
  symmetry; now apply H.
Qed.

Lemma option_map_some {A B}(f:A->B) o :
 option_map f o <> None <-> o <> None.
Proof.
 destruct o; simpl. now split. split; now destruct 1.
Qed.

Definition option_bind {A B} o (f:A->option B) :=
 match o with
 | None => None
 | Some a => f a
 end.

(** An hybrid of [map] and [filter] *)

Fixpoint mapfilter {A B} (f:A->option B) l :=
 match l with
 | [] => []
 | a::l => match f a with
           | Some b => b::mapfilter f l
           | None => mapfilter f l
           end
 end.

Lemma mapfilter_app {A B} (f:A->option B) l l' :
  mapfilter f (l++l') = mapfilter f l ++ mapfilter f l'.
Proof.
induction l; simpl; auto.
destruct f; simpl; auto; f_equal; auto.
Qed.

Instance mapfilter_ext {A B} :
 Proper ((eq ==> eq) ==> eq ==> eq) (@mapfilter A B).
Proof.
 intros f f' E l l' <-.
 induction l; simpl; auto.
 rewrite <- (E a); auto. destruct f; auto. f_equal; auto.
Qed.

Lemma map_as_mapfilter {A B} (f:A->B) l :
 map f l = mapfilter (fun a => Some (f a)) l.
Proof.
induction l; simpl; f_equal; auto.
Qed.

Lemma filter_as_mapfilter {A} (f:A->bool) l :
 filter f l = mapfilter (fun a => if f a then Some a else None) l.
Proof.
induction l; simpl; auto. destruct f; simpl; auto. f_equal; auto.
Qed.

Lemma mapfilter_comp {A B C}(f:A->option B)(g:B->option C) l :
 mapfilter g (mapfilter f l) = mapfilter (fun a => option_bind (f a) g) l.
Proof.
induction l; simpl; auto.
destruct f; simpl; auto. destruct g; simpl; auto. f_equal; auto.
Qed.

Lemma mapfilter_map {A B C} (f:A->B)(g:B->option C) l :
 mapfilter g (map f l) = mapfilter (fun a => g (f a)) l.
Proof.
now rewrite map_as_mapfilter, mapfilter_comp.
Qed.

Lemma map_mapfilter {A B C} (f:A->option B)(g:B->C) l :
 map g (mapfilter f l) = mapfilter (fun a => option_map g (f a)) l.
Proof.
rewrite map_as_mapfilter, mapfilter_comp. f_equiv.
Qed.

(** Properties of [List.filter] *)

Lemma filter_app {A} (f:A->bool) l l' :
  filter f (l++l') = filter f l ++ filter f l'.
Proof.
induction l; simpl; auto. destruct (f a); simpl; f_equal; auto.
Qed.

Lemma filter_map {A B} (f:A->B)(h:B->bool) l :
  filter h (map f l) = map f (filter (fun x => h (f x)) l).
Proof.
induction l; simpl; auto. destruct (h (f a)); simpl; f_equal; auto.
Qed.

Instance filter_ext {A} : Proper ((eq==>eq)==>eq==>eq) (@filter A).
Proof.
intros f f' E l l' <-.
induction l; simpl; auto. rewrite <- (E a); auto.
destruct f; simpl; auto. f_equal; auto.
Qed.

Lemma filter_rev {A} (f:A->bool) l :
 rev (filter f l) = filter f (rev l).
Proof.
induction l; simpl; auto.
rewrite filter_app, <- IHl. simpl.
destruct (f a); simpl; auto using app_nil_r.
Qed.

Lemma NoDupA_filter {A} (eq:relation A) (f:A->bool) l :
 NoDupA eq l -> NoDupA eq (filter f l).
Proof.
 induction 1; simpl; auto.
 destruct f; auto. constructor; auto.
 rewrite InA_alt in *. setoid_rewrite filter_In. firstorder.
Qed.

(** [List.partition] via [List.filter] *)

Lemma partition_filter {A} (f:A->bool) l :
 partition f l = (filter f l, filter (fun a => negb (f a)) l).
Proof.
induction l; simpl; auto. rewrite IHl. now destruct f.
Qed.

(** More results about [List.forallb] and [List.existsb] *)

Lemma forallb_map {A B} (f:A->B)(h:B->bool) l:
 forallb h (map f l) = forallb (fun a => h (f a)) l.
Proof.
induction l; simpl; auto. destruct h; simpl; auto.
Qed.

Lemma existsb_map {A B} (f:A->B)(h:B->bool) l:
 existsb h (map f l) = existsb (fun a => h (f a)) l.
Proof.
induction l; simpl; auto. destruct h; simpl; auto.
Qed.

Instance forallb_ext {A} : Proper ((eq==>eq)==>eq==>eq) (@forallb A).
Proof.
intros f f' E l l' <-.
induction l; simpl; auto. rewrite <- (E a); auto.
destruct f; simpl; auto.
Qed.

Instance existsb_ext {A} : Proper ((eq==>eq)==>eq==>eq) (@existsb A).
Proof.
intros f f' E l l' <-.
induction l; simpl; auto. rewrite <- (E a); auto.
destruct f; simpl; auto.
Qed.

Lemma forallb_rev {A} (f:A->bool) l :
 forallb f (rev l) = forallb f l.
Proof.
 apply eq_bool_alt. rewrite !forallb_forall.
 now setoid_rewrite <- in_rev.
Qed.

Lemma existsb_rev {A} (f:A->bool) l :
 existsb f (rev l) = existsb f l.
Proof.
 apply eq_bool_alt. rewrite !existsb_exists.
 now setoid_rewrite <- in_rev.
Qed.

(** [SetoidList.SortA_app] written via a [iff] *)

Section MoreOnSortA.
Context {A} eqA `{Equivalence A eqA}.
Context ltA `{StrictOrder A ltA} `{!Proper (eqA==>eqA==>iff) ltA}.

Lemma SortA_app_iff (l1 l2 : list A) :
 sort ltA (l1++l2) <->
 sort ltA l1 /\ sort ltA l2 /\
  forall a1 a2, In a1 l1 -> In a2 l2 -> ltA a1 a2.
Proof.
 split.
 { induction l1 as [|a1 l1 IHl1].
   - easy.
   - simpl. inversion_clear 1 as [ | ? ? Hs Hhd ].
     destruct (IHl1 Hs) as (H1 & H2 & H3); clear IHl1.
     repeat split.
     * constructor; auto.
       destruct l1; simpl in *; auto; inversion_clear Hhd; auto.
     * trivial.
     * intros b1 b2 [->|Hb1] Hb2; eauto.
       eapply SortA_InfA_InA with (eqA:=eqA)(l:=l1++l2); auto.
       rewrite InA_app_iff. right. apply In_InA; auto with *. }
 { intros (U & V & W); eapply SortA_app; eauto.
   intros x y. rewrite !InA_alt.
   intros (x' & -> & Hx) (y' & -> & Hy); auto. }
Qed.

End MoreOnSortA.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

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

  VPrl 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 General Public License
  along with VPrl.  Ifnot, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

 *)

Require Export continuity_type.

Unset Regular Subst Tactic.

Definition rule_continuity {o}
           (F f : @NTerm o)
           (H : barehypotheses) :=
    mk_rule
      (mk_baresequent H (mk_conclax (mk_squash (continuous_type F f))))
      [
        mk_baresequent H (mk_conclax (mk_member F (mk_fun (mk_fun mk_int mk_int) mk_int))),
        mk_baresequent H (mk_conclax (mk_member f (mk_fun mk_int mk_int)))
      ]
      [].

Lemma rule_continuity_true {p} :
  forall lib
         (F f : NTerm)
         (H : @barehypotheses p),
    rule_true lib (rule_continuity
                     F f
                     H).
Proof.
  unfold rule_continuity, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp.
  rename Hyp into hyp1.
  rename Hyp0 into hyp2.
  destruct hyp1 as [wc1 hyp1].
  destruct hyp2 as [wc2 hyp2].
  destseq; allsimpl; proof_irr; GC.
  unfold closed_extract; simpl.

  exists (@covered_axiom p (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  vr_seq_true.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 eqh sim) as h; exrepnd; clear hyp1.

  vr_seq_true in hyp2.
  pose proof (hyp2 s1 s2 eqh sim) as k; exrepnd; clear hyp2.

  lsubst_tac.

  assert ((newvarlst [F, f]
           <> newvarlst
                [F, f, mk_var (newvarlst [F, f]),
                 mk_var (newvarlst [F, f, mk_var (newvarlst [F, f])])])
            # (newvarlst [F, f]
               <> newvarlst [F, f, mk_var (newvarlst [F, f])])
            # (newvarlst [F, f, mk_var (newvarlst [F, f])]
               <> newvarlst
                    [F, f, mk_var (newvarlst [F, f]),
                     mk_var (newvarlst [F, f, mk_var (newvarlst [F, f])])])
            # (!LIn (newvarlst
                       [F, f, mk_var (newvarlst [F, f]),
                        mk_var (newvarlst [F, f, mk_var (newvarlst [F, f])])])
                (free_vars f))
            # (!LIn (newvarlst [F, f, mk_var (newvarlst [F, f])]) (free_vars f))
            # (!LIn (newvarlst [F, f]) (free_vars f))
            # (!LIn (newvarlst
                       [F, f, mk_var (newvarlst [F, f]),
                        mk_var (newvarlst [F, f, mk_var (newvarlst [F, f])])])
                (free_vars F))
            # (!LIn (newvarlst [F, f, mk_var (newvarlst [F, f])]) (free_vars F))
            # (!LIn (newvarlst [F, f]) (free_vars F))) as d.
  { repeat gen_newvar.
    repeat get_newvar_prop.
    allsimpl; allrw in_app_iff.
    allrw not_over_or; sp. }
  repnd.

  prove_and teq.

  - apply tequality_mkc_squash.
    allrw @member_eq.
    allrw <- @member_member_iff.
    allrw @tequality_mkc_member_sp; repnd.
    allrw @fold_equorsq.

    unfold continuous_type, continuous_type_aux; simpl.
    lsubst_tac.

    apply tequality_product; dands; eauto with slow.

    { allrw @lsubstc_mkc_tnat.
      apply type_tnat. }

    introv e1.
    repeat substc_lsubstc_vars3.
    lsubst_tac.

    apply tequality_isect; dands.

    { unfold int2int.
      lsubst_tac.
      repeat one_lift_lsubst2_concl.
      apply tequality_fun; dands.
      - apply tequality_int.
      - introv x; apply tequality_int. }

    introv e2.

    repeat substc_lsubstc_vars3.
    repeat one_lift_lsubst_concl.
    apply tequality_mkc_ufun; dands.

    { unfold agree_upto_b_type.
      repeat one_lift_lsubst_concl.
      repeat one_lift_lsubst2_concl.

      apply tequality_isect; dands.

      - apply tequality_set; dands.

        { apply tequality_int. }

        introv e3.
        repeat substc_lsubstc_vars3.
        repeat one_lift_lsubst_concl.
        apply tequality_mkc_member_sp; dands.

        + unfold mk_natk_aux.
          repeat one_lift_lsubst_concl.
          repeat one_lift_lsubst2_concl.
          apply tequality_set; dands.

          { apply tequality_int. }

          introv e4.

          repeat substc_lsubstc_vars3.
          repeat one_lift_lsubst_concl.
          apply tequality_mkc_prod; dands.

          { repeat one_lift_lsubst2_concl.
            repeat one_lift_lsubst_concl.
            repeat (rw @lsubstc_cons_var).

            clear_cv.

            apply tequality_mkc_le.
            apply equality_in_int in e4.
            unfold equality_of_int in e4; exrepnd.
            exists (0%Z) k (0%Z) k; dands; spcast; auto;
            try (complete (unfold computes_to_valc; simpl;
                           unfold computes_to_value; dands;
                           eauto with slow)).

            destruct (Z_le_gt_dec 0 k); tcsp.
            right; dands; omega. }

          revert e1 e4.

          repeat one_lift_lsubst2_concl.
          repeat one_lift_lsubst_concl.
          repeat (rw @lsubstc_cons_var).
          lsubstc_snoc.
          introv e1 e4 inh1.

          apply equality_in_int_and_inhabited_le_implies_equality_in_nat in e4; auto.
          apply equality_in_tnat in e1.
          apply equality_in_tnat in e4.
          unfold equality_of_nat in e1.
          unfold equality_of_nat in e4.
          exrepnd.

          apply tequality_mkc_less_than.
          exists (Z.of_nat k) (Z.of_nat k3) (Z.of_nat k) (Z.of_nat k3).
          dands; spcast; auto.

          destruct (Z_lt_ge_dec (Z.of_nat k) (Z.of_nat k3)); tcsp.
          right; dands; omega.

        + right.
          unfold absolute_value, mk_natk_aux.
          repeat one_lift_lsubst2_concl.
          repeat one_lift_lsubst_concl.
          repeat one_lift_lsubst2_concl.
          repeat (rw @lsubstc_cons_var).
          revert e3; intro e3.
          fold (absolute_value_c a1).
          fold (absolute_value_c a'1).
          spcast.
          apply cequivc_absolute_value; auto.

      - introv e3.
        clear_cv.
        repeat substc_lsubstc_vars3.
        repeat one_lift_lsubst_concl.
        repeat one_lift_lsubst2_concl.
        repeat (rw @lsubstc_cons_var).
        lsubstc_snoc.
        clear_cv.

        apply tequality_mkc_equality_sp; dands.

        { apply tequality_int. }

        { revert k0.
          repeat one_lift_lsubst2_concl; intro k.
          apply equality_in_set in e3; repnd.
          dorn k.

          - left.
            apply equality_in_fun in k; repnd.
            apply k; auto.

          - right.
            apply equality_in_int_implies_cequiv in e4; spcast.
            apply implies_cequivc_apply; auto.
        }

        { revert e2; intro e2.
          unfold int2int in e2.
          repeat (one_lift_lsubst_hyp e2).
          repeat (one_lift_lsubst2_hyp e2).
          apply equality_in_set in e3; repnd.
          left.
          apply equality_in_fun in e2; repnd.
          apply e2; auto.
        }
    }

    { clear_cv.
      repeat one_lift_lsubst2_concl.
      intro inh.
      lsubstc_snoc_concl.
      revert h1 h0; intros h0 h1.
      unfold member in h0.
      repeat (one_lift_lsubst_hyp h0).
      eapply cequorsq_equality_trans2 in h1;[clear h0|exact h0].
      repeat (one_lift_lsubst2_hyp h1).
      apply tequality_mkc_equality_sp; dands.

      { apply tequality_int. }

      { left.
        apply equality_in_fun in h1; repnd.
        apply h1.
        repeat (one_lift_lsubst_concl).
        repeat (one_lift_lsubst2_concl).

        revert k1 k0; intros k0 k1.
        unfold member in k0.
        repeat (one_lift_lsubst_hyp k0).
        repeat (one_lift_lsubst2_hyp k0).
        repeat (one_lift_lsubst2_hyp k1).
        eapply cequorsq_equality_trans2 in k1;[clear k0|exact k0].
        auto.
      }

      { left.
        apply equality_in_fun in h1; repnd.
        apply h1; auto. }
    }

  - apply equality_in_mkc_squash; dands; spcast; auto;
    try computes_to_value_refl.

    allrw @member_eq.
    allrw <- @member_member_iff.
    allrw @tequality_mkc_member_sp; repnd.
    allrw @fold_equorsq.

    pose proof (continuity_axiom lib (lsubstc F wt0 s1 ct2)) as cont.
    autodimp cont hyp.
    {
      revert h1; unfold member; intro h.
      repeat (one_lift_lsubst_hyp h).
      allfold (@int2int p).
      allrw (@lsubstc_int2int).
      repeat (one_lift_lsubst2_hyp h).
      auto.
    }

    pose proof (cont (lsubstc f wt s1 ct1)) as cont1; clear cont.
    autodimp cont1 hyp.
    {
      revert k1; unfold member; intro h.
      repeat (one_lift_lsubst_hyp h).
      repeat (one_lift_lsubst2_hyp h).
      auto.
    }

    exrepnd.
    unfold continuous_type, continuous_type_aux; simpl.
    repeat (one_lift_lsubst_concl).
    repeat (one_lift_lsubst2_concl).
    exists (@mkc_pair p (mkc_nat b) mkc_axiom).

    rw @tequality_mkc_squash in teq.
    apply tequality_refl in teq.
    rw @fold_type in teq.
    unfold continuous_type, continuous_type_aux in teq; simpl in teq.
    repeat (one_lift_lsubst_hyp teq).
    repeat (one_lift_lsubst2_hyp teq).

    apply member_product2; dands; auto.

    apply tequality_product in teq; repnd.
    pose proof (teq (mkc_nat b) (mkc_nat b)) as teq2; clear teq.
    allrw @fold_type.

    keepdimp teq2 teq.
    {
      apply equality_in_tnat.
      exists b; dands; spcast; eauto with slow;
      apply computes_to_valc_refl; eauto with slow.
    }

    exists (@mkc_nat p b) (@mkc_axiom p); dands; spcast; auto.

    { apply computes_to_valc_refl; eauto with slow. }

    { repeat substc_lsubstc_vars3.
      repeat one_lift_lsubst_concl.
      repeat (one_lift_lsubst_hyp teq2).
      allrw (@lsubstc_int2int).
      clear_cv.

      apply tequality_isect in teq2; repnd.

      apply equality_in_isect; dands; auto.

      intros g1 g2 e1.
      pose proof (teq2 g1 g2 e1) as teq3; clear teq2.
      allrw @fold_type.
      repeat substc_lsubstc_vars3.
      repeat one_lift_lsubst_concl.
      repeat (one_lift_lsubst_hyp teq3).
      clear_cv.
      apply tequality_refl in teq3.
      rw @fold_type in teq3.

      apply tequality_mkc_ufun in teq3; repnd.
      apply equality_in_ufun; dands; auto.
      intro inh.
      autodimp teq3 hyp;[].
      apply tequality_refl in teq2.
      apply tequality_refl in teq3.
      allrw @fold_type.

      revert teq3.
      lsubstc_snoc_concl.
      intro teq3.
      apply tequality_mkc_equality_sp in teq3; repnd.

      pose proof (cont0 g1) as cont1; clear cont0.
      autodimp cont1 hyp.
      { apply equality_refl in e1; auto. }

      keepdimp cont1 cont2.
      {
        introv r1 r2 l.
        unfold agree_upto_b_type in inh.
        repeat (one_lift_lsubst_hyp inh).
        apply equality_of_int_imp_tt.
        unfold inhabited_type in inh; exrepnd.
        rw @equality_in_isect in inh0; repnd.
        pose proof (inh0 t2 t2) as inh; clear inh0.
        repeat (one_lift_lsubst2_hyp inh1).
        repeat (one_lift_lsubst2_hyp inh2).
        repeat (one_lift_lsubst2_hyp inh).
        autodimp inh hyp.
        {
          rw @tequality_set in inh1; repnd.
          assert (equality lib t2 t2 mkc_int) as ei.
          {
            apply equality_in_int.
            exists i; dands; spcast; auto;
            apply computes_to_valc_iff_reduces_toc; eauto with slow.
          }

          rw @equality_in_set; dands; auto; [].
          applydup inh1 in ei as inh3; clear inh1 inh2.
          repeat substc_lsubstc_vars3.
          apply tequality_refl in inh3.
          allrw @fold_type.
          repeat one_lift_lsubst_concl.
          repeat (one_lift_lsubst_hyp inh3).
          exists (@mkc_axiom p).
          rw <- @member_member_iff.
          apply tequality_mkc_member_sp in inh3; repnd.
          allrw @fold_type.
          clear inh3.

          unfold absolute_value, mk_natk_aux.
          unfold absolute_value, mk_natk_aux in inh1.
          repeat one_lift_lsubst2_concl.
          repeat one_lift_lsubst_concl.
          repeat one_lift_lsubst2_concl.
          repeat (rw @lsubstc_cons_var).
          fold (absolute_value_c t2).

          repeat (one_lift_lsubst_hyp inh1).
          repeat (one_lift_lsubst2_hyp inh1).
          rw @tequality_set in inh1; repnd.

          pose proof (inh1 (absolute_value_c t2) (absolute_value_c t2)) as inh.
          keepdimp inh ai.
          {
            apply equality_in_int.
            unfold equality_of_int.
            exists (Z.abs i).
            dands; spcast; apply computes_to_valc_absolute_value; auto;
            apply computes_to_valc_iff_reduces_toc; eauto with slow.
          }

          apply equality_in_set; dands; auto; clear inh1;[].

          repeat substc_lsubstc_vars3.
          apply tequality_refl in inh.
          allrw @fold_type.
          repeat (one_lift_lsubst_hyp inh).
          repeat (one_lift_lsubst2_hyp inh).
          repeat (one_lift_lsubst_concl).
          repeat (one_lift_lsubst2_concl).
          clear_cv.

          apply type_mkc_prod in inh; repnd.
          apply inhabited_prod2.

          prove_and ty1; GC.

          prove_and it1;[|prove_and ty2]; auto; GC.

          {
            repeat (one_lift_lsubst_hyp inh1).
            repeat (one_lift_lsubst2_hyp inh1).
            repeat (one_lift_lsubst_concl).
            repeat (one_lift_lsubst2_concl).
            lsubstc_snoc_concl.
            lsubstc_snoc_hyp inh1.
            apply inhabited_le.
            exists (0%Z) (Z.abs i).
            dands; spcast;
            try (complete (unfold computes_to_valc; simpl;
                           unfold computes_to_value; dands;
                           eauto with slow));
            try (complete (apply computes_to_valc_absolute_value; auto;
                           apply computes_to_valc_iff_reduces_toc; eauto with slow)).
            destruct i; allsimpl; try omega; apply Pos2Z.is_nonneg.
          }

          {
            autodimp inh hyp.
            repeat (one_lift_lsubst_hyp inh).
            repeat (one_lift_lsubst2_hyp inh).
            repeat (one_lift_lsubst_concl).
            repeat (one_lift_lsubst2_concl).
            lsubstc_snoc_concl.
            lsubstc_snoc_hyp inh.
            apply inhabited_less_than.
            exists (Z.abs i) (Z.of_nat b).
            dands; spcast;
            try (complete (unfold computes_to_valc; simpl;
                           unfold computes_to_value; dands;
                           eauto with slow));
            try (complete (apply computes_to_valc_absolute_value; auto;
                           apply computes_to_valc_iff_reduces_toc; eauto with slow)).
            revert l; intro l.
            destruct i; allsimpl; try omega; rw <- Znat.positive_nat_Z; apply Znat.inj_lt; auto.
          }
        }

        repeat substc_lsubstc_vars3.
        repeat (one_lift_lsubst_hyp inh).
        repeat (one_lift_lsubst2_hyp inh).
        revert inh.
        lsubstc_snoc_concl.
        intro inh.
        revert k1; intro k1.
        rw @equality_in_fun in k1; repnd.
        pose proof (k1 t1 t2) as ef; autodimp ef hyp.
        {
          apply equality_in_int.
          exists i; dands; spcast; auto;
          apply computes_to_valc_iff_reduces_toc; eauto with slow.
        }

        apply equality_in_mkc_equality in inh; repnd.
        apply equality_in_int.
        eapply equality_trans;[exact ef|]; auto.
      }

      rw @member_eq.
      rw <- @member_equality_iff.
      repeat (one_lift_lsubst2_concl).
      apply equality_in_int.
      unfold equality_of_int_tt in cont1; exrepnd.
      exists k; dands; spcast; auto.
    }
Qed.

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


Require Import List.
Require Import ListSet.
Require Import Coqlib.
Require Import Metatheory.
Require Import Maps.
Require Import maps_ext.
Require Import cfg.
Require Import Dipaths.

Require Import syntax.
Require Import infrastructure.
Require Import infrastructure_props.
Import LLVMsyntax.
Import LLVMinfra.

(* This file proves more properties of reachability. *)
Lemma reachable_has_entry: forall f l1 (Hrd: reachable f l1),
  getEntryBlock f <> None.
Proof.
  intros.
  unfold reachable in Hrd.
  intro EQ. rewrite EQ in Hrd. inv Hrd.
Qed.

Lemma reachable_dec: forall (f:fdef) (l1:l), reachable f l1 \/ ~ reachable f l1.
Proof.
  unfold reachable.
  intros.
  destruct (getEntryBlock f) as [[]|].
    apply ACfg.reachable_dec.
    right. intro H. inv H.
Qed.

Lemma reachable_entrypoint:
  forall (f:fdef) l0 s0,
    getEntryBlock f = Some (l0, s0) ->
    reachable f l0.
Proof.
  intros f l0 s0 Hentry. unfold reachable.
  rewrite Hentry. exists V_nil. exists A_nil. apply DW_null.
  eapply entry_in_vertexes; eauto.
Qed.

Module DecRD.

Section RdSucc.

Variable f:fdef.

Lemma reachable_successors:
  forall l0 cs ps tmn l1 (Hinvx: vertexes_fdef f (index l1)),
  uniqFdef f ->
  blockInFdefB (l0, stmts_intro cs ps tmn) f ->
  In l1 (successors_terminator tmn) ->
  reachable f l0 ->
  reachable f l1.
Proof.
  intros l0 cs ps tmn l1 Hinvx HuniqF HbInF Hin.
  unfold reachable. intro Hreach.
  remember (getEntryBlock f) as R.
  destruct R; auto.
  destruct b as [le ? ? ?].
  destruct Hreach as [vl [al Hreach]].
  exists (index l0::vl). exists (A_ends (index l1) (index l0)::al).
  apply DW_step; auto.
    eapply successor_in_arcs; eauto.
Qed.

End RdSucc.

End DecRD.