Require Export Base.Binatural.

Module Bicategory.

Structure mixin_of (obj: Type) := Mixin {
  bihom: obj -> obj -> Category;
  biid (x: obj): bihom x x;
  hcomp {x y z: obj}: Bifunctor (bihom y z) (bihom x y) (bihom x z);
  unitor_l {x y: obj}: fix_l hcomp (biid y) <~> id (bihom x y);
  unitor_r {x y: obj}: fix_r hcomp (biid x) <~> id (bihom x y);
  associator {x y z v: obj}: RComp (@hcomp x z v) (@hcomp x y z) <~> LComp hcomp hcomp;
  pentagon {x y z v w: obj} (f: bihom v w) (g: bihom z v) (h: bihom y z) (i: bihom x y): bmap hcomp (to associator f g h) (id i) ∘ to associator f (hcomp g h) i ∘ bmap hcomp (id f) (to associator g h i) = to associator (hcomp f g) h i ∘ to associator f g (hcomp h i);
  unit_triang {x y z: obj} (f: bihom y z) (g: bihom x y): bmap hcomp (to unitor_r f) (id g) ∘ to associator f (biid y) g = bmap hcomp (id f) (to unitor_l g)
}.

Notation class_of := mixin_of (only parsing).

Section ClassDef.

Structure type := Pack { obj: Type; _: class_of obj }.
Local Coercion obj: type >-> Sortclass.

Variable (C: type).
Definition class := match C return class_of C with Pack _ c => c end.

End ClassDef.

Module Exports.

Coercion obj: type >-> Sortclass.
Notation Bicategory := type.

End Exports.

End Bicategory.

Export Bicategory.Exports.

Definition bihom {C: Bicategory}: C -> C -> Category := Bicategory.bihom C (Bicategory.class C).
Definition biid {C: Bicategory}: forall x: C, bihom x x := Bicategory.biid C (Bicategory.class C).
Definition hcomp {C: Bicategory}: forall {x y z: C}, Bifunctor (bihom y z) (bihom x y) (bihom x z) := @Bicategory.hcomp C (Bicategory.class C).
Definition unitor_l {C: Bicategory}: forall {x y: C}, fix_l hcomp (biid y) <~> id (bihom x y) := @Bicategory.unitor_l C (Bicategory.class C).
Definition unitor_r {C: Bicategory}: forall {x y: C}, fix_r hcomp (biid x) <~> id (bihom x y) := @Bicategory.unitor_r C (Bicategory.class C).
Definition associator {C: Bicategory}: forall {x y z v: C}, RComp (@hcomp C x z v) (@hcomp C x y z) <~> LComp hcomp hcomp := @Bicategory.associator C (Bicategory.class C).

Infix "~~>" := bihom (at level 70, right associativity).
Infix "⊙" := hcomp (at level 40, left associativity).
Infix "⊚" := (bmap hcomp) (at level 40, left associativity).
Notation λ := unitor_l.
Notation ρ := unitor_r.
Notation α := associator.

Instance hcomp_iso (C: Bicategory) (x y z: C): Proper (isomorphic (y ~~> z) ==> isomorphic (x ~~> y) ==> isomorphic (x ~~> z)) hcomp.
Proof.
  intros f1 f2 Hf g1 g2 Hg.
  now apply bobj_iso.
Qed.

Section BicategoryTheory.
Context {C: Bicategory}.

Lemma pentagon: forall {x y z v w: C} (f: v ~~> w) (g: z ~~> v) (h: y ~~> z) (i: x ~~> y), to α f g h ⊚ id i ∘ to α f (g ⊙ h) i ∘ (id f ⊚ to α g h i) = to α (f ⊙ g) h i ∘ to α f g (h ⊙ i).
Proof. exact (@Bicategory.pentagon C (Bicategory.class C)). Qed.

Lemma unit_triang: forall {x y z: C} (f: y ~~> z) (g: x ~~> y), to ρ f ⊚ id g ∘ to α f (biid y) g = id f ⊚ to λ g.
Proof. exact (@Bicategory.unit_triang C (Bicategory.class C)). Qed.

Lemma hcomp_assoc {x y z v: C} (f: z ~~> v) (g: y ~~> z) (h: x ~~> y): f ⊙ (g ⊙ h) ≃ f ⊙ g ⊙ h.
Proof.
  constructor.
  exact (tritransform_iso α f g h).
Qed.

Lemma hcomp_id_l {x y: C} (f: x ~~> y): biid y ⊙ f ≃ f.
Proof.
  constructor.
  exact (transform_iso λ f).
Qed.

Lemma hcomp_id_r {x y: C} (f: x ~~> y): f ⊙ biid x ≃ f.
Proof.
  constructor.
  exact (transform_iso ρ f).
Qed.

End BicategoryTheory.

(* Hangs
Structure PseudoFunctor (S T: Bicategory) := {
  pfobj: S -> T;
  pfmap {x y: S}: Functor (x ~~> y) (pfobj x ~~> pfobj y);
  pfid (x: S): pfmap (biid x) <~> biid (pfobj x);
  pfcomp {x y z: S} (f: y ~~> z) (g: x ~~> y): pfmap (f ⊙ g) <~> pfmap f ⊙ pfmap g;
}.

Arguments pfobj {S T} _ _.
Arguments pfmap {S T} _ {_ _}.
Arguments pfid {S T} _ _.
Arguments pfcomp {S T} _ {_ _ _} _ _.
Coercion pfobj: PseudoFunctor >-> Funclass.
*)


(**************************************************************************)
(*  This is part of EXCEPTIONS-PL, it is distributed under the terms of   *)
(*         the GNU Lesser General Public License version 3                *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms Bool.
Require Import Program.
Require Prerequistes Terms Decorations Axioms.
Set Implicit Arguments.
Module Make(Import M: Prerequistes.T).
Module Export HPExp := Axioms.Make(M).
Axiom excludedmiddle: forall P, P \/ ~P.
Axiom dblnegelim    : forall P, ~~P -> P.

(** **)
(** For the sake of simplicity, suppose that there is only one exception name. **)
Parameter e : EName.
Parameter EName_eq: forall e f: EName, e=f.

(** **)
(** Canonical form for throwers: for an exception thrower f: Y -> X, either there exists a pure term u: Y -> X
such that f is u or there exists a pure term v: Y -> (Val e) such that f is of the form: "tr o v". **)
Theorem Proposition_6_9_2: forall {X Y} (f: termpl X Y),
              (exists u: (termpl X Y), PL_EPURE u /\ f *== u)
                 \/
              (exists v: (termpl (Val e) Y), PL_EPURE v /\ f *== (@throw X e) O v).
Proof. intros X Y f.
         induction f.
           left. exists (@pl_tpure _ _ y). split. apply is_pl_tpure. reflexivity.
           destruct IHf1. destruct H as (u1&Ha&Hb).
           destruct IHf2. destruct H as (u2&H1a&H1b).
             left. exists (u1 O u2). split. pl_edecorate.
               remember pl_replsubs; rewrite Hb, H1b. reflexivity.
             destruct H as (u2&H1a&H1b).
               right. exists u2. split; auto.
                 remember pl_replsubs; rewrite H1b, pl_assoc. apply pl_replsubs; [apply ppg| reflexivity].
           destruct IHf2. destruct H as (u1&Ha&Hb). destruct H0 as (u2&H1a&H1b).
             right. exists (u1 O u2). split. pl_edecorate.
               remember pl_replsubs; rewrite Hb, H1b. rewrite pl_assoc; reflexivity.
             destruct H as (u1&Ha&Hb). destruct H0 as (u2&H1a&H1b).
               right. exists u2. split; auto.
                 remember pl_replsubs; rewrite Hb, H1b, pl_assoc. apply pl_replsubs; [apply ppg| reflexivity].
           destruct (EName_eq e e0). right. exists (@pl_id (Val e)).
             split. pl_edecorate. rewrite pl_ids. reflexivity.
           destruct (EName_eq e e0).
             destruct IHf1. destruct H as (u&Ha&Hb).
               left. exists u. split. auto.
               specialize (@try Y X e f1 u f2). intro H.
               remember try0.
               specialize (@try0 Y X e u f2). intros. apply H0 in Ha. rewrite <- Ha.
               apply H. exact Hb.
             destruct IHf2. destruct H as (v&Ha&Hb). destruct H0 as (u&H1a&H1b).
               left. exists (u O v). split. pl_edecorate.
               remember try1.
               specialize (@try1 _ _ e v u). intro H.
               specialize (@try Y X e f1 (throw e O v) f2). intro H1.
                 apply H1 in Hb. rewrite Hb. rewrite <- H1b.
               apply try1. exact Ha.
               destruct H as (v1&Ha&Hb). destruct H0 as (v2&H1a&H1b).
                 right. exists (v2 O v1). split. pl_edecorate.
               specialize (@try Y X e f1 (throw e O v1) f2). intro H.
                apply H in Hb. rewrite Hb. rewrite pl_assoc. rewrite <- H1b.
                apply try1. exact Ha.
Qed.

(** **)
(** An equation between two exception throwers is equivalent to an equations between pure terms. **)
 Lemma Proposition_6_9_3: forall {X Y} (a1 a2: termpl X Y) (v1 v2: termpl (Val e) Y),
                                (PL_EPURE v1) /\ (PL_EPURE v2) /\
                                (a1 = ((@throw X e) O v1)) /\ (a2 = ((@throw X e) O v2)) -> ((a1 *== a2) <-> (v1 *== v2)).
 Proof. intros X Y a1 a2 v1 v2 (H1&H2&H3&H4).
          split.
            intro H5.
              rewrite H3, H4 in H5. apply rcv in H5. apply H5.
            intro H5. rewrite H3, H4. remember pl_replsubs; rewrite H5.
              apply pl_replsubs; reflexivity.
 Qed.

 (** **)
 (**  An equality between an exception thrower and a pure term is absurd. **)

 Axiom Axiom_6_9_4: forall {X Y} (a1 v2: termpl X Y) (v1: termpl (Val e) Y),
                     (PL_EPURE v1) /\ (PL_EPURE v2) /\ (a1 = ((@throw X e) O v1)) ->
                     ((a1 *== v2) <-> (forall {X Y} (f g: termpl Y X), PL_EPURE f -> PL_EPURE g -> f *== g)).

(** **)
(** An equation between any two terms is either absurd or equivalent to an equation between pure terms.  **)

Theorem Theorem_6_9_5: forall {X Y} (a1 a2: termpl X Y),
              ((exists v1: (termpl (Val e) Y), exists v2: (termpl (Val e) Y),
               PL_EPURE v1 /\ PL_EPURE v2 /\ (a1 = ((@throw X e) O v1)) /\ (a2 = ((@throw X e) O v2)) ->
               ((a1 *== a2) <-> v1 *== v2))
                \/
               (exists v1: (termpl (Val e) Y), exists v2: (termpl X Y),
               PL_EPURE v1 /\ PL_EPURE v2 /\ (a1 = ((@throw X e) O v1)) ->
               ((a1 *== v2) <-> (forall {X Y} (f g: termpl Y X), PL_EPURE f -> PL_EPURE g -> f *== g)))
               \/
               (exists v1: (termpl X Y), exists v2: (termpl X Y),
               PL_EPURE v1 /\ PL_EPURE v2 ->
               (a1 *== a2) <-> v1 *== v2))
               \/
               (a1 *== a2).
Proof. intros X Y a1 a2.
         left.
           specialize(@Proposition_6_9_2 X Y a1). intro H0. destruct H0. destruct H as (u1&Ha&Hb).
           specialize(@Proposition_6_9_2 X Y a2). intro H1. destruct H1. destruct H as (u2&H0a&H0b).
           right. right.
             exists u1 u2.
               split. intro H1.
                 remember pl_replsubs; rewrite <- Hb. rewrite <- H0b.
                   apply H1. split; assumption.
                 intros H1 H2. rewrite H0b, Hb. apply H1.
           right. left.
             destruct H as (u2&H1b).
             exists u2 u1. intro H1. apply (@Axiom_6_9_4 _ _ a1 u1 u2).
             split. apply H1. split; apply H1.
         specialize(@Proposition_6_9_2 X Y a2). intro H1. destruct H1; destruct H0 as (u2&H0a&H0b).
           right. left.
             destruct H as (u1&H1b).
             exists u1 u2. intro H1. apply (@Axiom_6_9_4 _ _ a1 u2 u1).
             split. apply H1. split; apply H1.
           left.
             destruct H as (u1&H1b).
             exists u1 u2. intro H1. apply (@Proposition_6_9_3 _ _ a1 a2 u1 u2).
             split; apply H1.
Qed.

End Make.


(** The contents in this file are reconstructed from the proof of Bruno Barras
    in the Coq standard library. It is duplicated so that the definitions
    can be made transparent, and therefore computable.
    See Coq.Logic.Eqdep_dec for complete information
 **)
Section uip_trans.
  Context {A : Type}.

  Definition uip_prop_trans (dec : forall x y : A, x = y \/ x <> y)
    {x : A} :
    forall {y : A} (pf pf' : x = y), pf = pf' :=
    let comp :=
        fun (x y y' : A) (eq1 : x = y) (eq2 : x = y') =>
          eq_ind x (fun a : A => a = y') eq2 y eq1 in
    let eq_dec := dec x in
    let nu :=
        fun (y : A) (u : x = y) =>
          match eq_dec y with
          | or_introl eqxy => eqxy
          | or_intror neqxy => False_ind (x = y) (neqxy u)
          end in
    let nu_constant :=
        fun (y : A) (u v : x = y) =>
          let o := eq_dec y in
          match
            o as o0
            return
            (match o0 with
             | or_introl eqxy => eqxy
             | or_intror neqxy => False_ind (x = y) (neqxy u)
             end =
             match o0 with
             | or_introl eqxy => eqxy
             | or_intror neqxy => False_ind (x = y) (neqxy v)
             end)
          with
          | or_introl Heq => eq_refl
          | or_intror Hneq =>
            match
              Hneq u as f
              return (False_ind (x = y) f = False_ind (x = y) (Hneq v))
            with
            end
          end in
    let nu_inv := fun (y : A) (v : x = y) => comp x x y (nu x eq_refl) v
    in
    let trans_sym_eq := fun (x y : A) (u : x = y) =>
        match u as e in (_ = y0) return (comp x y0 y0 e e = eq_refl) with
        | eq_refl => eq_refl
        end
    in
    let nu_left_inv_on := fun (y : A) (u : x = y) =>
        match u as e in (_ = y0) return (nu_inv y0 (nu y0 e) = e) with
        | eq_refl => trans_sym_eq _ _ (nu _ eq_refl)
        end in
    fun (y : A) (p1 p2 : x = y) =>
      eq_ind (nu_inv y (nu y p1)) (fun p3 : x = y => p3 = p2)
             (eq_ind (nu_inv y (nu y p2)) (fun p3 : x = y => nu_inv y (nu y p1) = p3)
                     (eq_ind (nu y p1) (fun e : x = y => nu_inv y (nu y p1) = nu_inv y e)
                             eq_refl (nu y p2) (nu_constant y p1 p2)) p2
                     (nu_left_inv_on _ p2)) p1 (nu_left_inv_on _ p1).

  Definition uip_trans (dec : forall x y : A, {x = y} + {x <> y})
  := @uip_prop_trans (fun a b => match dec a b with
                                 | left pf => or_introl pf
                                 | right pf' => or_intror pf'
                                 end).
End uip_trans.


Require Import List.

Require Import Logic.Class.Eq.

Require Import Logic.STLC.Eval.
Require Import Logic.STLC.Value.
Require Import Logic.STLC.Subst.
Require Import Logic.STLC.Valid.
Require Import Logic.STLC.IsType.
Require Import Logic.STLC.Typing.
Require Import Logic.STLC.Syntax.
Require Import Logic.STLC.Replace.
Require Import Logic.STLC.Context.

Definition id (b v:Type)(x:v) : Exp b v := \x ~> `x.

Arguments id {b} {v}.

(* This will not have the right semantics unless x and y are distinct           *)
Definition const (b v:Type) (x y:v) : Exp b v := \x ~> \y ~> `x.

Arguments const {b} {v}.

(* Annotated identity applied to variable y reduces to variable y               *)
Lemma idAnn : forall (b v:Type) (e:Eq v) (x y:v) (Ty:T b),
    (id x :: Ty :-> Ty) $ `y >>> `y.
Proof.
    intros b v e x y Ty. apply (EAppL (id x :: Ty :-> Ty) `x _ _ x).
    - apply VVar.
    - apply VVar.
    - constructor. apply VLam, VVar. apply ELam.
        + apply VVar.
        + constructor.
    - rewrite substVar. rewrite replace_x. constructor.
Qed.

(* Annotated const applied to identity and variable u reduces to identity       *)
(* Note that we need the variables x and y to be distinct for this to hold      *)
Lemma constAnn : forall (b v:Type) (e:Eq v) (x y z u:v) (Ty Ty' : T b),
    x <> y ->
    (const x y :: (Ty' :-> Ty') :-> Ty :-> Ty' :-> Ty') $ (id z) $ `u >>> id z.
Proof.
    intros base v e x y z u Ty Ty' H1. apply (EAppL _ (id z) _ _ y).
    - apply VLam, VVar.
    - apply VLam, VVar.
    - apply (EAppL _ (\y ~> `x) _ _ x).
        + apply VLam, VVar.
        + apply VLam, VLam, VVar.
        + constructor.
            { apply VLam, VLam, VVar. }
            { constructor.
                { apply VLam, VVar. }
                { constructor.
                    { apply VVar. }
                    { constructor. }}}
        + constructor.
            { apply VLam, VVar. }
            { destruct (in_dec eqDec x (y :: nil)) as [H2|H2].
                { exfalso. destruct H2 as [H2|H2].
                    { auto. }
                    { inversion H2. }}
                { rewrite replace_x. apply ELam.
                    { apply VVar. }
                    { apply EVar. }}}
    - apply ELam.
        + apply VVar.
        + destruct (in_dec eqDec z (z :: nil)) as [H2|H2].
            { apply EVar. }
            { exfalso. apply H2. left. reflexivity. }
Qed.

(* An example of valid context.                                                 *)
Lemma Valid1 : forall (b v:Type) (t t':b) (x:v),
    Valid   ( O
            ; t  ::: *
            ; t' ::: *
            ; x  ::: (('t' :-> 't') :-> 't :-> 't' :-> 't')
            ).
Proof.
    intros b v t t' x. apply ValidV.
    - apply ValidT, ValidT, ValidO.
    - apply TFun.
        + apply TFun; apply TVar, FindTZ.
        + apply TFun.
            { apply TVar, FindTS, FindTZ. }
            { apply TFun; apply TVar, FindTZ. }
Qed.

Lemma Typing1 : forall (b v:Type)(eq:Eq v)(t:b)(x y:v),
    O ; t ::: * ; y ::: 't :- (id x :: 't :-> 't) $ `y >: 't.
Proof.
    intros b v eq t x y. apply JApp with 't.
    - apply JAnn, JLam.
        + apply ValidV.
            { apply ValidT, ValidO. }
            { apply TVar, FindTZ. }
        + apply TVar, FindTS, FindTZ.
        + apply JVar.
            { apply ValidV.
                { apply ValidV.
                    { apply ValidT, ValidO. }
                    { apply TVar, FindTZ. }}
                { apply TVar, FindTS, FindTZ. }}
            { apply FindVZ. }
    - apply JVar.
        + apply ValidV.
            { apply ValidT, ValidO. }
            { apply TVar, FindTZ. }
        + apply FindVZ.
Qed.

Lemma Typing2 : forall (b v:Type) (eq:Eq v) (t t':b) (x y z u:v),
    x <> y ->
        O ; t ::: * ; u ::: 't ; t' ::: *
            :-
        (const x y :: ('t' :-> 't') :-> 't :-> 't' :-> 't') $ (id z) $ `u
            >:
        't' :-> 't'.
Proof.
    intros b v eq t t' x y z u H1. apply JApp with 't.
    - apply JApp with ('t' :-> 't').
        + apply JAnn, JLam.
            { apply ValidT, ValidV.
                { apply ValidT, ValidO. }
                { apply TVar, FindTZ. }}
            { apply TFun; apply TVar, FindTZ. }
            { apply JLam.
                { apply ValidV.
                    { apply ValidT, ValidV.
                        { apply ValidT, ValidO. }
                        { apply TVar, FindTZ. }}
                    { apply TFun; apply TVar, FindTZ. }}
                { apply TVar, FindTS, FindTS, FindTS, FindTZ. }
                { apply JVar.
                    { apply ValidV.
                        { apply ValidV.
                            { apply ValidT, ValidV.
                                { apply ValidT, ValidO. }
                                { apply TVar, FindTZ. }}
                            { apply TFun; apply TVar, FindTZ. }}
                        { apply TVar, FindTS, FindTS, FindTS, FindTZ. }}
                    { apply FindVS; try assumption. apply FindVZ. }}}
        + apply JLam.
            { apply ValidT, ValidV.
                { apply ValidT, ValidO. }
                { apply TVar, FindTZ. }}
            { apply TVar, FindTZ. }
            { apply JVar.
                { apply ValidV.
                    { apply ValidT, ValidV.
                        { apply ValidT, ValidO. }
                        { apply TVar, FindTZ. }}
                    { apply TVar, FindTZ. }}
                { apply FindVZ. }}
    - apply JVar.
        + apply ValidT, ValidV.
            { apply ValidT, ValidO. }
            { apply TVar, FindTZ. }
        + apply FindVK, FindVZ.
Qed.

(* id x is of type Ty :-> Ty in any valid context for which Ty well-formed      *)
(* Note in particular that the typing relation is not deterministic: in a given *)
(* context, an expression is liable to be of more than one type.                *)
Lemma idTyping : forall (b v:Type) (eq:Eq v) (x:v) (G:Context) (Ty:T b),
    Valid G ->
    G :> Ty ->
    G :- id x >: Ty :-> Ty.
Proof.
    intros b v eq x G Ty H1 H2. apply JLam; try assumption. apply JVar.
    - apply ValidV; assumption.
    - apply FindVZ.
Qed.

(* Note that id x cannot be of type Ty :-> Ty unless Ty is well-formed and      *)
(* the given context is valid.                                                  *)
Lemma idTyping' : forall (b v:Type) (eq:Eq v) (x:v) (G:Context) (Ty:T b),
    G :- id x >: Ty :-> Ty -> Valid G /\ G :> Ty.
Proof.
    intros b v eq x G Ty H1. split.
    - apply TypedIsValid with eq (id x) (Ty :-> Ty). assumption.
    - apply IsTypeRevL with Ty. apply TypedIsType with eq (id x). assumption.
Qed.


(* An adaptation of Ni & Shao's XCAP assertion logic *)

Require Import Coq.Lists.List.

Set Implicit Arguments.

Section machine.
  Variables pc state : Type.

  Inductive propX : list Type -> Type :=
  | Inj : forall G, Prop -> propX G
  | Cptr : forall G, pc -> (state -> propX G) -> propX G
  | And : forall G, propX G -> propX G -> propX G
  | Or : forall G, propX G -> propX G -> propX G
  | Imply : forall G, propX G -> propX G -> propX G
  | Forall : forall G A, (A -> propX G) -> propX G
  | Exists : forall G A, (A -> propX G) -> propX G

  | Var0 : forall G A, A -> propX (A :: G)
  | Lift : forall G A, propX G -> propX (A :: G)
  | ForallX : forall G A, propX (A :: G) -> propX G
  | ExistsX : forall G A, propX (A :: G) -> propX G.

  Implicit Arguments Inj [G].
  Implicit Arguments Var0 [G A].
  Implicit Arguments Lift [G A].

  Definition PropX := propX nil.

  Fixpoint last (G : list Type) : Type :=
    match G with
      | nil => unit
      | T :: nil => T
      | _ :: G' => last G'
    end.

  Fixpoint eatLast (G : list Type) : list Type :=
    match G with
      | nil => nil
      | _ :: nil => nil
      | x :: G' => x :: eatLast G'
    end.

  Fixpoint subst G (p : propX G) : (last G -> PropX) -> propX (eatLast G) :=
    match p with
      | Inj _ P => fun _ => Inj P
      | Cptr _ i f => fun p' => Cptr i (fun x => subst (f x) p')
      | And _ p1 p2 => fun p' => And (subst p1 p') (subst p2 p')
      | Or _ p1 p2 => fun p' => Or (subst p1 p') (subst p2 p')
      | Imply _ p1 p2 => fun p' => Imply (subst p1 p') (subst p2 p')
      | Forall _ _ f => fun p' => Forall (fun x => subst (f x) p')
      | Exists _ _ f => fun p' => Exists (fun x => subst (f x) p')

      | Var0 G A v => match G return (last (A :: G) -> PropX) -> propX (eatLast (A :: G)) with
                        | nil => fun p' => p' v
                        | _ :: _ => fun _ => Var0 v
                      end

      | Lift G A p1 => match G return propX G -> ((last G -> PropX) -> propX (eatLast G))
                         -> (last (A :: G) -> PropX) -> propX (eatLast (A :: G)) with
                         | nil => fun p1 _ _ => p1
                         | _ :: _ => fun _ subst_p1 p' => Lift (subst_p1 p')
                       end p1 (subst p1)

      | ForallX G A p1 => fun p' =>
        match G return propX (A :: G) -> propX (eatLast (A :: G)) -> propX (eatLast G) with
          | nil => fun p1 _ => ForallX p1
          | _ :: _ => fun _ rc => ForallX rc
        end p1 (subst p1 (match G return (last G -> PropX) -> last (A :: G) -> PropX with
                            | nil => fun _ _ => Inj True
                            | _ => fun p' => p'
                          end p'))
      | ExistsX G A p1 => fun p' =>
        match G return propX (A :: G) -> propX (eatLast (A :: G)) -> propX (eatLast G) with
          | nil => fun p1 _ => ExistsX p1
          | _ :: _ => fun _ rc => ExistsX rc
        end p1 (subst p1 (match G return (last G -> PropX) -> last (A :: G) -> PropX with
                            | nil => fun _ _ => Inj True
                            | _ => fun p' => p'
                          end p'))
    end.

  Definition Subst A (p : propX (A :: nil)) (p' : A -> PropX) : PropX := subst p p'.

  Definition spec := state -> PropX.
  Definition codeSpec := pc -> option spec.

  Section specs.
    Variable specs : codeSpec.

    Inductive valid (G : list PropX) : PropX -> Prop :=
    | Env : forall P,
      In P G
      -> valid G P

    | Inj_I : forall (p : Prop),
      p
      -> valid G (Inj p)

    | Inj_E : forall p Q,
      valid G (Inj p)
      -> (p -> valid G Q)
      -> valid G Q

    | Cptr_I : forall f a,
      specs f = Some (fun x => a x)
      -> valid G (Cptr f a)

    | Cptr_E : forall f a Q,
      valid G (Cptr f a)
      -> (specs f = Some (fun x => a x) -> valid G Q)
      -> valid G Q

    | And_I : forall P Q,
      valid G P
      -> valid G Q
      -> valid G (And P Q)

    | And_E1 : forall P Q,
      valid G (And P Q)
      -> valid G P
    | And_E2 : forall P Q,
      valid G (And P Q)
      -> valid G Q

    | Or_I1 : forall P Q,
      valid G P
      -> valid G (Or P Q)
    | Or_I2 : forall P Q,
      valid G Q
      -> valid G (Or P Q)

    | Or_E : forall P Q R,
      valid G (Or P Q)
      -> valid (P :: G) R
      -> valid (Q :: G) R
      -> valid G R

    | Imply_I : forall P Q,
      valid (P :: G) Q
      -> valid G (Imply P Q)

    | Imply_E : forall P Q,
      valid G (Imply P Q)
      -> valid G P
      -> valid G Q

    | Forall_I : forall A P,
      (forall B : A, valid G (P B))
      -> valid G (Forall P)

    | Forall_E : forall A P (B : A),
      valid G (Forall P)
      -> valid G (P B)

    | Exists_I : forall A P (B : A),
      valid G (P B)
      -> valid G (Exists P)

    | Exists_E : forall A P Q,
      valid G (Exists P)
      -> (forall B : A, valid (P B :: G) Q)
      -> valid G Q

    | ForallX_I : forall A P,
      (forall a : A -> PropX, valid G (Subst P a))
      -> valid G (ForallX P)

    | ExistsX_I : forall A P (a : A -> PropX),
      valid G (Subst P a)
      -> valid G (ExistsX P).

    Inductive normal (G : list PropX) : PropX -> Prop :=
    | Coer : forall P,
      neutral G P
      -> normal G P

    | NoInj_I : forall p : Prop,
      p
      -> normal G (Inj p)

    | NoInj_E : forall p Q,
      neutral G (Inj p)
      -> (p -> normal G Q)
      -> normal G Q

    | NoCptr_I : forall f a,
      specs f = Some (fun x => a x)
      -> normal G (Cptr f a)

    | NoCptr_E : forall f a Q,
      neutral G (Cptr f a)
      -> (specs f = Some (fun x => a x) -> normal G Q)
      -> normal G Q

    | NoAnd_I : forall P Q,
      normal G P
      -> normal G Q
      -> normal G (And P Q)

    | NoOr_I1 : forall P Q,
      normal G P
      -> normal G (Or P Q)
    | NoOr_I2 : forall P Q,
      normal G Q
      -> normal G (Or P Q)

    | NoOr_E : forall P Q R,
      neutral G (Or P Q)
      -> normal (P :: G) R
      -> normal (Q :: G) R
      -> normal G R

    | NoImply_I : forall P Q,
      normal (P :: G) Q
      -> normal G (Imply P Q)

    | NoForall_I : forall A P,
      (forall B : A, normal G (P B))
      -> normal G (Forall P)

    | NoExists_I : forall A P (B : A),
      normal G (P B)
      -> normal G (Exists P)

    | NoExists_E : forall A P Q,
      neutral G (Exists P)
      -> (forall B : A, normal (P B :: G) Q)
      -> normal G Q

    | NoForallX_I : forall A P,
      (forall a : A -> PropX, normal G (Subst P a))
      -> normal G (ForallX P)

    | NoExistsX_I : forall A P (a : A -> PropX),
      normal G (Subst P a)
      -> normal G (ExistsX P)

    with neutral (G : list PropX) : PropX -> Prop :=
    | NoEnv : forall P,
      In P G
      -> neutral G P

    | NoAnd_E1 : forall P Q,
      neutral G (And P Q)
      -> neutral G P
    | NoAnd_E2 : forall P Q,
      neutral G (And P Q)
      -> neutral G Q

    | NoImply_E : forall P Q,
      neutral G (Imply P Q)
      -> normal G P
      -> neutral G Q

    | NoForall_E : forall A P (B : A),
      neutral G (Forall P)
      -> neutral G (P B).

    Scheme normal_min := Minimality for normal Sort Prop
    with neutral_min := Minimality for neutral Sort Prop.

    Combined Scheme normal_neutral_min from normal_min, neutral_min.

    Inductive normalP (G : list PropX) : PropX -> Prop :=
    | NopCoer : forall P,
      neutralP G P
      -> normalP G P

    | NopInj_I : forall p : Prop,
      p
      -> normalP G (Inj p)

    | NopInj_E : forall p Q,
      neutralP G (Inj p)
      -> (p -> normalP G Q)
      -> normalP G Q

    | NopCptr_I : forall f a,
      specs f = Some (fun x => a x)
      -> normalP G (Cptr f a)

    | NopCptr_E : forall f a Q,
      neutralP G (Cptr f a)
      -> (specs f = Some (fun x => a x) -> normalP G Q)
      -> normalP G Q

    | NopAnd_I : forall P Q,
      normalP G P
      -> normalP G Q
      -> normalP G (And P Q)

    | NopOr_I1 : forall P Q,
      normalP G P
      -> normalP G (Or P Q)
    | NopOr_I2 : forall P Q,
      normalP G Q
      -> normalP G (Or P Q)

    | NopOr_E : forall P Q R,
      neutralP G (Or P Q)
      -> normalP (P :: G) R
      -> normalP (Q :: G) R
      -> normalP G R

    | NopImply_I : forall P Q,
      normalP (P :: G) Q
      -> normalP G (Imply P Q)

    | NopForall_I : forall A P,
      (forall B : A, normalP G (P B))
      -> normalP G (Forall P)

    | NopExists_I : forall A P (B : A),
      normalP G (P B)
      -> normalP G (Exists P)

    | NopExists_E : forall A P Q,
      neutralP G (Exists P)
      -> (forall B : A, normalP (P B :: G) Q)
      -> normalP G Q

    | NopForallX_I : forall A P,
      (forall a : A -> PropX, normalP G (Subst P a))
      -> normalP G (ForallX P)

    | NopExistsX_I : forall A P (a : A -> PropX),
      normalP G (Subst P a)
      -> normalP G (ExistsX P)

    with neutralP (G : list PropX) : PropX -> Prop :=
    | Coer' : forall P,
      normalP G P
      -> neutralP G P

    | NopEnv : forall P,
      In P G
      -> neutralP G P

    | NopAnd_E1 : forall P Q,
      neutralP G (And P Q)
      -> neutralP G P
    | NopAnd_E2 : forall P Q,
      neutralP G (And P Q)
      -> neutralP G Q

    | NopImply_E : forall P Q,
      neutralP G (Imply P Q)
      -> normalP G P
      -> neutralP G Q

    | NopForall_E : forall A P (B : A),
      neutralP G (Forall P)
      -> neutralP G (P B).

    Scheme normalP_min := Minimality for normalP Sort Prop
    with neutralP_min := Minimality for neutralP Sort Prop.

    Combined Scheme normalP_neutralP_min from normalP_min, neutralP_min.

    Inductive seq (G : list PropX) : PropX -> Prop :=
    | Inj_R : forall p : Prop,
      p
      -> seq G (Inj p)

    | Inj_L : forall (p : Prop) Q,
      In (Inj p) G
      -> (p -> seq G Q)
      -> seq G Q

    | Cptr_R : forall f a,
      specs f = Some (fun x => a x)
      -> seq G (Cptr f a)

    | Cptr_L : forall f a Q,
      In (Cptr f a) G
      -> (specs f = Some (fun x => a x) -> seq G Q)
      -> seq G Q

    | And_R : forall P Q,
      seq G P
      -> seq G Q
      -> seq G (And P Q)

    | And_L1 : forall P Q R,
      In (And P Q) G
      -> seq (P :: G) R
      -> seq G R
    | And_L2 : forall P Q R,
      In (And P Q) G
      -> seq (Q :: G) R
      -> seq G R

    | Or_R1 : forall P Q,
      seq G P
      -> seq G (Or P Q)
    | Or_R2 : forall P Q,
      seq G Q
      -> seq G (Or P Q)

    | Or_L : forall P Q R,
      In (Or P Q) G
      -> seq (P :: G) R
      -> seq (Q :: G) R
      -> seq G R

    | Imply_R : forall P Q,
      seq (P :: G) Q
      -> seq G (Imply P Q)

    | Imply_L : forall P Q R,
      In (Imply P Q) G
      -> seq G P
      -> seq (Q :: G) R
      -> seq G R

    | Init : forall P,
      In P G
      -> seq G P

    | Forall_R : forall A P,
      (forall B : A, seq G (P B))
      -> seq G (Forall P)

    | Forall_L : forall A P (B : A) Q,
      In (Forall P) G
      -> seq (P B :: G) Q
      -> seq G Q

    | Exists_R : forall A P (B : A),
      seq G (P B)
      -> seq G (Exists P)

    | Exists_L : forall A P Q,
      In (Exists P) G
      -> (forall B : A, seq (P B :: G) Q)
      -> seq G Q

    | ForallX_R : forall A P,
      (forall a : A -> PropX, seq G (Subst P a))
      -> seq G (ForallX P)

    | ExistsX_R : forall A P (a : A -> PropX),
      seq G (Subst P a)
      -> seq G (ExistsX P).

    Inductive seqP (G : list PropX) : PropX -> Prop :=
    | Cut : forall P Q,
      seqP G P
      -> seqP (P :: G) Q
      -> seqP G Q

    | CInj_R : forall p : Prop,
      p
      -> seqP G (Inj p)

    | CInj_L : forall (p : Prop) Q,
      In (Inj p) G
      -> (p -> seqP G Q)
      -> seqP G Q

    | CCptr_R : forall f a,
      specs f = Some (fun x => a x)
      -> seqP G (Cptr f a)

    | CCptr_L : forall f a Q,
      In (Cptr f a) G
      -> (specs f = Some (fun x => a x) -> seqP G Q)
      -> seqP G Q

    | CAnd_R : forall P Q,
      seqP G P
      -> seqP G Q
      -> seqP G (And P Q)

    | CAnd_L1 : forall P Q R,
      In (And P Q) G
      -> seqP (P :: G) R
      -> seqP G R
    | CAnd_L2 : forall P Q R,
      In (And P Q) G
      -> seqP (Q :: G) R
      -> seqP G R

    | COr_R1 : forall P Q,
      seqP G P
      -> seqP G (Or P Q)
    | COr_R2 : forall P Q,
      seqP G Q
      -> seqP G (Or P Q)

    | COr_L : forall P Q R,
      In (Or P Q) G
      -> seqP (P :: G) R
      -> seqP (Q :: G) R
      -> seqP G R

    | CImply_R : forall P Q,
      seqP (P :: G) Q
      -> seqP G (Imply P Q)

    | CImply_L : forall P Q R,
      In (Imply P Q) G
      -> seqP G P
      -> seqP (Q :: G) R
      -> seqP G R

    | CInit : forall P,
      In P G
      -> seqP G P

    | CForall_R : forall A P,
      (forall B : A, seqP G (P B))
      -> seqP G (Forall P)

    | CForall_L : forall A P (B : A) Q,
      In (Forall P) G
      -> seqP (P B :: G) Q
      -> seqP G Q

    | CExists_R : forall A P (B : A),
      seqP G (P B)
      -> seqP G (Exists P)

    | CExists_L : forall A P Q,
      In (Exists P) G
      -> (forall B : A, seqP (P B :: G) Q)
      -> seqP G Q

    | CForallX_R : forall A P,
      (forall a : A -> PropX, seqP G (Subst P a))
      -> seqP G (ForallX P)

    | CExistsX_R : forall A P (a : A -> PropX),
      seqP G (Subst P a)
      -> seqP G (ExistsX P).

    Hint Constructors valid normal neutral normalP neutralP seqP.

    Theorem normal_neutral_sound : forall G,
      (forall P, normal G P -> valid G P)
      /\ (forall P, neutral G P -> valid G P).
    Proof.
      apply normal_neutral_min; try solve [
        intros; ((eapply Or_I1; assumption) ||
                 (eapply Or_I2; assumption))
      | eauto ].
    Qed.

    Theorem normalP_neutralP_sound : forall G,
      (forall P, normalP G P -> valid G P)
      /\ (forall P, neutralP G P -> valid G P).
    Proof.
      apply normalP_neutralP_min; try solve [
        intros; ((eapply Or_I1; assumption) ||
                 (eapply Or_I2; assumption))
      | eauto ].
    Qed.

    Theorem normalP_complete : forall G P, valid G P -> normalP G P.
    Proof.
      induction 1; eauto.
    Qed.

    Theorem neutralP_complete : forall G P, valid G P -> neutralP G P.
    Proof.
      induction 1; eauto.
    Qed.

    Hint Extern 1 (In _ _) => simpl; tauto.

    Hint Extern 3 (incl _ _) =>
      let x := fresh "x" in intro x;
        repeat match goal with
                 | [ H : incl _ _ |- _ ] => generalize (H x); clear H
               end; simpl; intuition (subst; assumption).

    Theorem incl_cons : forall A x (G G' : list A),
      incl G G'
      -> incl (x :: G) (x :: G').
    Proof.
      auto.
    Qed.

    Hint Resolve incl_cons.

    Lemma normal_neutral_weaken : forall G,
      (forall Q, normal G Q
      -> (forall G', incl G G'
        -> normal G' Q))
    /\ (forall Q, neutral G Q
      -> (forall G', incl G G'
        -> neutral G' Q)).
    Proof.
      apply normal_neutral_min; eauto; eauto 7.
    Qed.

    Lemma normal_weaken : forall G Q, normal G Q
      -> forall G', incl G G'
        -> normal G' Q.
    Proof.
      generalize normal_neutral_weaken; firstorder.
    Qed.

    Lemma neutral_weaken : forall G Q, neutral G Q
      -> forall G', incl G G'
        -> neutral G' Q.
    Proof.
      generalize normal_neutral_weaken; firstorder.
    Qed.

    Hint Extern 1 (normal _ _) =>
      match goal with
        | [ H : normal _ _ |- _ ] => apply (normal_weaken H)
      end.

    Hint Extern 1 (neutral _ _) =>
      match goal with
        | [ H : neutral _ _ |- _ ] => apply (neutral_weaken H)
      end.

    Lemma incl_cons2 : forall A (P P0 : A) G G0,
      incl G (P :: G0)
      -> incl (P0 :: G) (P :: P0 :: G0).
    Proof.
      auto.
    Qed.

    Hint Immediate incl_cons2.

    Lemma In_incl : forall A (ls1 ls2 : list A) x,
      In x ls1
      -> incl ls1 ls2
      -> In x ls2.
    Proof.
      intuition.
    Qed.

    Hint Resolve In_incl.

    Lemma subst_Env : forall P0 G P G0,
      In P0 G
      -> incl G (P :: G0)
      -> neutral G0 P
      -> neutral G0 P0.
    Proof.
      intros ? ? ? ? H1 H2; generalize (H2 _ H1); simpl; intuition; subst; auto.
    Qed.

    Hint Immediate subst_Env.

    Lemma normal_neutral_subst : forall P PG, (forall Q, normal PG Q
      -> (forall G, incl PG (P :: G)
        -> neutral G P
        -> normal G Q))
    /\ (forall Q, neutral PG Q
      -> (forall G, incl PG (P :: G)
        -> neutral G P
        -> neutral G Q)).
    Proof.
      intro; apply normal_neutral_min; eauto; eauto 7.
    Qed.

    Lemma normal_subst : forall G P Q,
      normal (P :: G) Q
      -> neutral G P
      -> normal G Q.
    Proof.
      generalize normal_neutral_subst; firstorder.
    Qed.

    Hint Resolve normal_subst.

    Theorem seq_sound : forall G P, seq G P -> normal G P.
    Proof.
      induction 1; eauto.
    Qed.

    Hint Resolve Init Inj_R Cptr_R And_R Or_R1 Or_R2 Imply_R Forall_R Exists_R ForallX_R ExistsX_R.

    Ltac ready con := eapply con; solve [ instantiate; eauto 7 ].

    Ltac doLeft := intros;
      ready Inj_L || ready Cptr_L || ready And_L1 || ready And_L2 || ready Or_L
        || ready Imply_L || ready Forall_L || ready Exists_L.

    Theorem seq_weaken : forall G p, seq G p
      -> forall G', incl G G'
        -> seq G' p.
    Proof.
      induction 1; eauto; doLeft.
    Qed.

    Section seq_complete.
      Hint Resolve seq_weaken.

      Theorem seq_complete : forall G,
        (forall P, normal G P
          -> seq G P)
        /\ (forall P, neutral G P
          -> forall Q, seq (P :: G) Q
            -> seq G Q).
      Proof.
        apply normal_neutral_min; eauto; intros;
          match goal with
            | [ H : _ |- _ ] => apply H; doLeft
          end.
      Qed.
    End seq_complete.

    Hint Extern 2 (seq _ _) =>
      match goal with
        | [ H : seq _ _ |- _ ] => apply (seq_weaken H)
        | [ H : forall x : ?A, seq _ _, B : ?A |- _ ] => apply (seq_weaken (H B))
      end.

    Lemma normalP_neutralP_weaken : forall G,
      (forall Q, normalP G Q
        -> (forall G', incl G G'
          -> normalP G' Q))
      /\ (forall Q, neutralP G Q
        -> (forall G', incl G G'
          -> neutralP G' Q)).
      apply normalP_neutralP_min; eauto; eauto 7.
    Qed.

    Lemma normalP_weaken : forall G Q, normalP G Q
      -> forall G', incl G G'
        -> normalP G' Q.
      generalize normalP_neutralP_weaken; firstorder.
    Qed.

    Lemma neutralP_weaken : forall G Q, neutralP G Q
      -> forall G', incl G G'
        -> neutralP G' Q.
      generalize normalP_neutralP_weaken; firstorder.
    Qed.

    Hint Extern 1 (normalP _ _) =>
      match goal with
        | [ H : normalP _ _ |- _ ] => apply (normalP_weaken H)
      end.

    Hint Extern 1 (neutralP _ _) =>
      match goal with
        | [ H : neutralP _ _ |- _ ] => apply (neutralP_weaken H)
      end.

    Lemma subst_EnvP : forall P0 G P G0,
      In P0 G
      -> incl G (P :: G0)
      -> neutralP G0 P
      -> neutralP G0 P0.
      intros ? ? ? ? H1 H2; generalize (H2 _ H1); simpl; intuition; subst; auto.
    Qed.

    Hint Immediate subst_EnvP.

    Lemma normalP_neutralP_subst : forall P PG,
      (forall Q, normalP PG Q
        -> (forall G, incl PG (P :: G)
          -> neutralP G P
          -> normalP G Q))
      /\ (forall Q, neutralP PG Q
        -> (forall G, incl PG (P :: G)
          -> neutralP G P
          -> neutralP G Q)).
    Proof.
      intro; apply normalP_neutralP_min; try solve [ eauto ].
      intros; eapply NopOr_E. eapply H0. eassumption. eassumption. eauto. eauto.
    Qed.

    Lemma normalP_subst : forall G P Q,
      normalP (P :: G) Q
      -> neutralP G P
      -> normalP G Q.
    Proof.
      generalize normalP_neutralP_subst; firstorder.
    Qed.

    Hint Resolve normalP_subst.

    Theorem seqP_sound : forall G P, seqP G P -> normalP G P.
    Proof.
      induction 1; eauto.
    Qed.

    Theorem seqP_weaken : forall G p, seqP G p
      -> forall G', incl G G'
        -> seqP G' p.
    Proof.
      induction 1; eauto.
    Qed.

    Hint Resolve seqP_weaken.

    Theorem seqP_complete : forall G,
      (forall P, normalP G P
        -> seqP G P)
      /\ (forall P, neutralP G P
        -> forall Q, seqP (P :: G) Q
          -> seqP G Q).
    Proof.
      apply normalP_neutralP_min; eauto.
    Qed.

    Lemma destruct_PropX' : forall G (P : propX G),
      match G return propX G -> Prop with
        | nil => fun P =>
          (exists p, P = Inj p)
          \/ (exists i, exists f, P = Cptr i f)
          \/ (exists p1, exists p2, P = And p1 p2)
          \/ (exists p1, exists p2, P = Or p1 p2)
          \/ (exists p1, exists p2, P = Imply p1 p2)
          \/ (exists A, exists p1 : A -> _, P = Forall p1)
          \/ (exists A, exists p1 : A -> _, P = Exists p1)
          \/ (exists A, exists p1 : propX (A :: _), P = ForallX p1)
          \/ (exists A, exists p1 : propX (A :: _), P = ExistsX p1)
        | _ => fun _ => True
      end P.
    Proof.
      destruct P; destruct G; eauto 11.
    Qed.

    Theorem destruct_PropX : forall P : PropX,
      (exists p, P = Inj p)
      \/ (exists i, exists f, P = Cptr i f)
      \/ (exists p1, exists p2, P = And p1 p2)
      \/ (exists p1, exists p2, P = Or p1 p2)
      \/ (exists p1, exists p2, P = Imply p1 p2)
      \/ (exists A, exists p1 : A -> _, P = Forall p1)
      \/ (exists A, exists p1 : A -> _, P = Exists p1)
      \/ (exists A, exists p1 : propX (A :: _), P = ForallX p1)
      \/ (exists A, exists p1 : propX (A :: _), P = ExistsX p1).
    Proof.
      intros; exact (destruct_PropX' P).
    Qed.

    Ltac innerPredicative := let GG := fresh "GG" in induction 1; intro GG; destruct GG; intuition;
      try match goal with
            | [ H1 : incl _ _, H2 : In _ _ |- _ ] => generalize (H1 _ H2); simpl; intuition; subst; intuition
          end;
      repeat match goal with
               | [ H : _ -> forall GG : list Type, _ |- _ ] => specialize (fun pf => H pf nil); simpl in H
               | [ H : forall GG : list Type, _ |- _ ] => specialize (H nil); simpl in H
             end;
      doLeft || solve [ eauto ]
        || (try match goal with
                  | [ _ : match ?P with Inj _ _ => _ | Cptr _ _ _ => _ | And _ _ _ => _ | Or _ _ _ => _ | Imply _ _ _ => _
                            | Forall _ _ _ => _ | Exists _ _ _ => _ | Var0 _ _ _ => _ | Lift _ _ _ => _
                            | ForallX _ _ _ => _ | ExistsX _ _ _ => _ end |- _ ] => specialize (destruct_PropX P); intro;
                  repeat match goal with
                           | [ H : _ \/ _ |- _ ] => destruct H
                           | [ H : ex _ |- _ ] => destruct H
                         end; subst; intuition
                end;
        try match goal with
              | [ H : ex _ |- _ ] => destruct H
            end;
        repeat match goal with
                 | [ _ : incl _ (?P :: _), H : forall P' : propX nil, _ |- _ ] =>
                   specialize (H P); simpl in H
                 | [ _ : incl _ (?P :: _), H : forall pf (P' : propX nil), _ |- _ ] =>
                   eapply Exists_L; [ solve [ eauto ] | intro witness;
                     specialize (H witness P); simpl in H ]
                 | [ _ : incl _ (?P :: _), x : _, H : forall pf (P' : propX nil), _ |- _ ] =>
                   specialize (H x P); simpl in H
               end;
        match goal with
          | [ H : _, G0 : _, P1 : propX nil |- _ ] =>
            solve [ apply H with (P1 :: G0); auto ]
          | [ H : _, G0 : _, P1 : _ -> propX nil, A : Type |- _ ] =>
            match goal with
            | [ B : A |- _ ] => solve [ apply H with B (P1 B :: G0); eauto ]
            end
          | _ => solve [ eauto | doLeft ]
          | [ H : _, G0 : _, P1 : propX nil |- _ ] =>
            solve [ apply H with (P1 :: G0); eauto ]
          | _ => solve [ eauto 8 ]
        end).

    Lemma inner_Inj : forall PG Q, seq PG Q
      -> forall (GG : list Type) (P' : propX GG) (G : list PropX),
        match GG return (propX GG -> Prop) with
          | nil =>
            fun P' =>
              match P' with
                | Inj GG' P => P
                | _ => False
              end -> incl PG (P' :: G) -> seq G Q
          | T :: l => fun _ : propX (T :: l) => True
        end P'.
    Proof.
      innerPredicative.
    Qed.

    Lemma inner_Cptr : forall PG Q, seq PG Q
      -> forall (GG : list Type) (P' : propX GG) (G : list PropX),
        match GG return (propX GG -> Prop) with
          | nil =>
            fun P' =>
              match P' with
                | Cptr GG' i P =>
                  match GG' return (_ -> propX GG') -> Prop with
                    | nil => fun P =>
                      specs i = Some (fun x => P x)
                      /\ (forall st (PG0 : list PropX) (Q0 : PropX),
                        seq PG0 Q0 ->
                        forall G0 : list (propX nil),
                          incl PG0 (P st :: G0) -> seq G0 (P st) -> seq G0 Q0)
                    | _ => fun _ => False
                  end P
                | _ => False
              end -> incl PG (P' :: G) -> seq G Q
          | T :: l => fun _ : propX (T :: l) => True
        end P'.
    Proof.
      innerPredicative.
    Qed.

    Lemma inner_And : forall PG Q, seq PG Q
      -> forall (GG : list Type) (P' : propX GG) (G : list PropX),
        match GG return (propX GG -> Prop) with
          | nil =>
            fun P' =>
              match P' with
                | And GG' P1 P2 =>
                  match GG' return propX GG' -> propX GG' -> Prop with
                    | nil => fun P1 P2 =>
                      seq G P1
                      /\ seq G P2
                      /\ (forall (PG0 : list PropX) (Q0 : PropX),
                        seq PG0 Q0 ->
                        forall G0 : list (propX nil),
                          incl PG0 (P1 :: G0) -> seq G0 P1 -> seq G0 Q0)
                      /\ (forall (PG0 : list PropX) (Q0 : PropX),
                        seq PG0 Q0 ->
                        forall G0 : list (propX nil),
                          incl PG0 (P2 :: G0) -> seq G0 P2 -> seq G0 Q0)
                    | _ => fun _ _ => False
                  end P1 P2
                | _ => False
              end -> incl PG (P' :: G) -> seq G Q
          | T :: l => fun _ : propX (T :: l) => True
        end P'.
    Proof.
      innerPredicative.
    Qed.

    Lemma inner_Or1 : forall PG Q, seq PG Q
      -> forall (GG : list Type) (P' : propX GG) (G : list PropX),
        match GG return (propX GG -> Prop) with
          | nil =>
            fun P' =>
              match P' with
                | Or GG' P1 P2 =>
                  match GG' return propX GG' -> propX GG' -> Prop with
                    | nil => fun P1 P2 =>
                      seq G P1
                      /\ (forall (PG0 : list PropX) (Q0 : PropX),
                        seq PG0 Q0 ->
                        forall G0 : list (propX nil),
                          incl PG0 (P1 :: G0) -> seq G0 P1 -> seq G0 Q0)
                    | _ => fun _ _ => False
                  end P1 P2
                | _ => False
              end -> incl PG (P' :: G) -> seq G Q
          | T :: l => fun _ : propX (T :: l) => True
        end P'.
    Proof.
      innerPredicative.
    Qed.

    Lemma inner_Or2 : forall PG Q, seq PG Q
      -> forall (GG : list Type) (P' : propX GG) (G : list PropX),
        match GG return (propX GG -> Prop) with
          | nil =>
            fun P' =>
              match P' with
                | Or GG' P1 P2 =>
                  match GG' return propX GG' -> propX GG' -> Prop with
                    | nil => fun P1 P2 =>
                      seq G P2
                      /\ (forall (PG0 : list PropX) (Q0 : PropX),
                        seq PG0 Q0 ->
                        forall G0 : list (propX nil),
                          incl PG0 (P2 :: G0) -> seq G0 P2 -> seq G0 Q0)
                    | _ => fun _ _ => False
                  end P1 P2
                | _ => False
              end -> incl PG (P' :: G) -> seq G Q
          | T :: l => fun _ : propX (T :: l) => True
        end P'.
    Proof.
      innerPredicative.
    Qed.

    Lemma inner_Imply : forall PG Q, seq PG Q
      -> forall (GG : list Type) (P' : propX GG) (G : list PropX),
        match GG return (propX GG -> Prop) with
          | nil =>
            fun P' =>
              match P' with
                | Imply GG' P1 P2 =>
                  match GG' return propX GG' -> propX GG' -> Prop with
                    | nil => fun P1 P2 =>
                      seq (P1 :: G) P2
                      /\ (forall (PG0 : list PropX) (Q0 : PropX),
                        seq PG0 Q0 ->
                        forall G0 : list (propX nil),
                          incl PG0 (P1 :: G0) -> seq G0 P1 -> seq G0 Q0)
                      /\ (forall (PG0 : list PropX) (Q0 : PropX),
                        seq PG0 Q0 ->
                        forall G0 : list (propX nil),
                          incl PG0 (P2 :: G0) -> seq G0 P2 -> seq G0 Q0)
                    | _ => fun _ _ => False
                  end P1 P2
                | _ => False
              end -> incl PG (P' :: G) -> seq G Q
          | T :: l => fun _ : propX (T :: l) => True
        end P'.
    Proof.
      innerPredicative.
    Qed.

    Lemma inner_Forall : forall PG Q, seq PG Q
      -> forall (GG : list Type) (P' : propX GG) (G : list PropX),
        match GG return (propX GG -> Prop) with
          | nil =>
            fun P' =>
              match P' with
                | Forall GG' A0 P =>
                  match GG' return (A0 -> propX GG') -> Prop with
                    | nil => fun P =>
                      (forall B : A0, seq G (P B)) /\
                      (forall (a : A0) (PG0 : list PropX) (Q0 : PropX),
                        seq PG0 Q0 ->
                        forall G0 : list (propX nil),
                          incl PG0 (P a :: G0) -> seq G0 (P a) -> seq G0 Q0)
                    | _ => fun _ => False
                  end P
                | _ => False
              end -> incl PG (P' :: G) -> seq G Q
          | T :: l => fun _ : propX (T :: l) => True
        end P'.
    Proof.
      innerPredicative.
    Qed.

    Lemma inner_Exists : forall PG Q, seq PG Q
      -> forall (GG : list Type) (P' : propX GG) (G : list PropX),
        match GG as GG0 return (propX GG0 -> Prop) with
          | nil =>
            fun P' =>
              match P' with
                | Exists GG' A0 P =>
                  match GG' return (A0 -> propX GG') -> Prop with
                    | nil => fun P =>
                      (exists B, seq G (P B)) /\
                      (forall (a : A0) (PG0 : list PropX) (Q0 : PropX),
                        seq PG0 Q0 ->
                        forall G0 : list (propX nil),
                          incl PG0 (P a :: G0) -> seq G0 (P a) -> seq G0 Q0)
                    | _ => fun _ => False
                  end P
                | _ => False
              end -> incl PG (P' :: G) -> seq G Q
          | T :: l => fun _ : propX (T :: l) => True
        end P'.
    Proof.
      innerPredicative.
    Qed.

    Lemma inner_ForallX : forall PG Q, seq PG Q
      -> forall (GG : list Type) (P' : propX GG) (G : list PropX),
        match GG as GG0 return (propX GG0 -> Prop) with
          | nil =>
            fun P' =>
              match P' with
                | ForallX GG' A0 P =>
                  match GG' return propX (_ :: GG') -> Prop with
                    | nil => fun P => forall B, seq G (Subst P B)
                    | _ => fun _ => False
                  end P
                | _ => False
              end -> incl PG (P' :: G) -> seq G Q
          | T :: l => fun _ : propX (T :: l) => True
        end P'.
    Proof.
      innerPredicative.
    Qed.

    Lemma inner_ExistsX : forall PG Q, seq PG Q
      -> forall (GG : list Type) (P' : propX GG) (G : list PropX),
        match GG as GG0 return (propX GG0 -> Prop) with
          | nil =>
            fun P' =>
              match P' with
                | ExistsX GG' A0 P =>
                  match GG' return propX (_ :: GG') -> Prop with
                    | nil => fun P => exists B, seq G (Subst P B)
                    | _ => fun _ => False
                  end P
                | _ => False
              end -> incl PG (P' :: G) -> seq G Q
          | T :: l => fun _ : propX (T :: l) => True
        end P'.
    Proof.
      innerPredicative.
    Qed.

    Ltac outerPredicative :=
      induction 2; intuition;
        try match goal with
              | [ |- match ?E with Inj _ _ => _ | Cptr _ _ _ => _ | And _ _ _ => _ | Or _ _ _ => _ | Imply _ _ _ => _
                       | Forall _ _ _ => _ | Exists _ _ _ => _ | Var0 _ _ _ => _ | Lift _ _ _ => _ | ForallX _ _ _ => _ | ExistsX _ _ _ => _ end ] =>
              specialize (destruct_PropX E); intro;
                repeat match goal with
                         | [ H : _ \/ _ |- _ ] => destruct H
                         | [ H : ex _ |- _ ] => destruct H
                       end; subst; intuition; doLeft
            end;
        match goal with
          | [ H : _, _ : incl _ (?P :: _) |- _ ] => solve [ apply (inner_Inj H P); intuition
            | apply (inner_Cptr H P); intuition
            | apply (inner_And H P); intuition
            | apply (inner_Or1 H P); intuition
            | apply (inner_Or2 H P); intuition
            | apply (inner_Imply H P); intuition
            | apply (inner_Forall H P); intuition
            | apply (inner_Exists H P); intuition eauto
            | apply (inner_ForallX H P); intuition
            | apply (inner_ExistsX H P); intuition eauto ]
        end.

    Lemma outer_Inj' : forall PG Q, seq PG Q
      -> forall G P, seq G P ->
        match P with
          | Inj GG' _ => incl PG (P :: G) -> seq G Q
          | _ => True
        end.
    Proof.
      outerPredicative.
    Qed.

    Lemma outer_Inj : forall PG Q, seq PG Q
      -> forall G P, seq G (Inj P) -> incl PG (Inj P :: G) -> seq G Q.
    Proof.
      intros; specialize (outer_Inj' H H0); eauto.
    Qed.

    Lemma outer_Cptr' : forall PG Q, seq PG Q
      -> forall G P, seq G P ->
        match P with
          | Cptr GG' i P1 =>
            match GG' return (_ -> propX GG') -> Prop with
              | nil => fun P1 =>
                forall st (PG0 : list PropX) (Q0 : PropX),
                  seq PG0 Q0 ->
                  forall G0 : list (propX nil),
                    incl PG0 (P1 st :: G0) -> seq G0 (P1 st) -> seq G0 Q0
              | _ => fun _ => False
            end P1 -> incl PG (P :: G) -> seq G Q
          | _ => True
        end.
    Proof.
      outerPredicative.
    Qed.

    Lemma outer_Cptr : forall PG Q, seq PG Q
      -> forall G i P1, seq G (Cptr i P1)
        -> (forall st (PG0 : list PropX) (Q0 : PropX),
          seq PG0 Q0 ->
          forall G0 : list (propX nil),
            incl PG0 (P1 st :: G0) -> seq G0 (P1 st) -> seq G0 Q0)
        -> incl PG (Cptr i P1 :: G) -> seq G Q.
    Proof.
      intros; specialize (outer_Cptr' H H0); eauto.
    Qed.

    Lemma outer_And' : forall PG Q, seq PG Q
      -> forall G P, seq G P ->
        match P with
          | And GG' P1 P2 =>
            match GG' return propX GG' -> propX GG' -> Prop with
              | nil => fun P1 P2 =>
                (forall (PG0 : list PropX) (Q0 : PropX),
                  seq PG0 Q0 ->
                  forall G0 : list (propX nil),
                    incl PG0 (P1 :: G0) -> seq G0 P1 -> seq G0 Q0)
                /\ (forall (PG0 : list PropX) (Q0 : PropX),
                  seq PG0 Q0 ->
                  forall G0 : list (propX nil),
                    incl PG0 (P2 :: G0) -> seq G0 P2 -> seq G0 Q0)
              | _ => fun _ _ => False
            end P1 P2 -> incl PG (P :: G) -> seq G Q
          | _ => True
        end.
    Proof.
      outerPredicative.
    Qed.

    Lemma outer_And : forall PG Q, seq PG Q
      -> forall G P1 P2, seq G (And P1 P2)
        -> (forall (PG0 : list PropX) (Q0 : PropX),
          seq PG0 Q0 ->
          forall G0 : list (propX nil),
            incl PG0 (P1 :: G0) -> seq G0 P1 -> seq G0 Q0)
        ->  (forall (PG0 : list PropX) (Q0 : PropX),
          seq PG0 Q0 ->
          forall G0 : list (propX nil),
            incl PG0 (P2 :: G0) -> seq G0 P2 -> seq G0 Q0)
        -> incl PG (And P1 P2 :: G) -> seq G Q.
    Proof.
      intros; specialize (outer_And' H H0); eauto.
    Qed.

    Lemma outer_Or' : forall PG Q, seq PG Q
      -> forall G P, seq G P ->
        match P with
          | Or GG' P1 P2 =>
            match GG' return propX GG' -> propX GG' -> Prop with
              | nil => fun P1 P2 =>
                (forall (PG0 : list PropX) (Q0 : PropX),
                  seq PG0 Q0 ->
                  forall G0 : list (propX nil),
                    incl PG0 (P1 :: G0) -> seq G0 P1 -> seq G0 Q0)
                /\ (forall (PG0 : list PropX) (Q0 : PropX),
                  seq PG0 Q0 ->
                  forall G0 : list (propX nil),
                    incl PG0 (P2 :: G0) -> seq G0 P2 -> seq G0 Q0)
              | _ => fun _ _ => False
            end P1 P2 -> incl PG (P :: G) -> seq G Q
          | _ => True
        end.
    Proof.
      outerPredicative.
    Qed.

    Lemma outer_Or : forall PG Q, seq PG Q
      -> forall G P1 P2, seq G (Or P1 P2)
        -> (forall (PG0 : list PropX) (Q0 : PropX),
          seq PG0 Q0 ->
          forall G0 : list (propX nil),
            incl PG0 (P1 :: G0) -> seq G0 P1 -> seq G0 Q0)
        ->  (forall (PG0 : list PropX) (Q0 : PropX),
          seq PG0 Q0 ->
          forall G0 : list (propX nil),
            incl PG0 (P2 :: G0) -> seq G0 P2 -> seq G0 Q0)
        -> incl PG (Or P1 P2 :: G) -> seq G Q.
    Proof.
      intros; specialize (outer_Or' H H0); eauto.
    Qed.

    Lemma outer_Imply' : forall PG Q, seq PG Q
      -> forall G P, seq G P ->
        match P with
          | Imply GG' P1 P2 =>
            match GG' return propX GG' -> propX GG' -> Prop with
              | nil => fun P1 P2 =>
                (forall (PG0 : list PropX) (Q0 : PropX),
                  seq PG0 Q0 ->
                  forall G0 : list (propX nil),
                    incl PG0 (P1 :: G0) -> seq G0 P1 -> seq G0 Q0)
                /\ (forall (PG0 : list PropX) (Q0 : PropX),
                  seq PG0 Q0 ->
                  forall G0 : list (propX nil),
                    incl PG0 (P2 :: G0) -> seq G0 P2 -> seq G0 Q0)
              | _ => fun _ _ => False
            end P1 P2 -> incl PG (P :: G) -> seq G Q
          | _ => True
        end.
    Proof.
      outerPredicative.
    Qed.

    Lemma outer_Imply : forall PG Q, seq PG Q
      -> forall G P1 P2, seq G (Imply P1 P2)
        -> (forall (PG0 : list PropX) (Q0 : PropX),
          seq PG0 Q0 ->
          forall G0 : list (propX nil),
            incl PG0 (P1 :: G0) -> seq G0 P1 -> seq G0 Q0)
        ->  (forall (PG0 : list PropX) (Q0 : PropX),
          seq PG0 Q0 ->
          forall G0 : list (propX nil),
            incl PG0 (P2 :: G0) -> seq G0 P2 -> seq G0 Q0)
        -> incl PG (Imply P1 P2 :: G) -> seq G Q.
      intros; specialize (outer_Imply' H H0); eauto.
    Qed.

    Lemma outer_Forall' : forall PG Q, seq PG Q
      -> forall G P, seq G P ->
        match P with
          | Forall GG' A p =>
            match GG' return (A -> propX GG') -> Prop with
              | nil => fun p =>
                forall (a : A) (PG0 : list PropX) (Q0 : PropX),
                  seq PG0 Q0 ->
                  forall G0 : list (propX nil),
                    incl PG0 (p a :: G0) -> seq G0 (p a) -> seq G0 Q0
              | _ => fun _ => False
            end p -> incl PG (P :: G) -> seq G Q
          | _ => True
        end.
    Proof.
      outerPredicative.
    Qed.

    Lemma outer_Forall : forall PG Q, seq PG Q
      -> forall G A (p : A -> _), seq G (Forall p) ->
        (forall (a : A) (PG0 : list PropX) (Q0 : PropX),
          seq PG0 Q0 ->
          forall G0 : list (propX nil),
            incl PG0 (p a :: G0) -> seq G0 (p a) -> seq G0 Q0)
        -> incl PG (Forall p :: G) -> seq G Q.
    Proof.
      intros; specialize (outer_Forall' H H0); eauto.
    Qed.

    Lemma outer_Exists' : forall PG Q, seq PG Q
      -> forall G P, seq G P ->
        match P with
          | Exists GG' A p =>
            match GG' return (A -> propX GG') -> Prop with
              | nil => fun p =>
                forall (a : A) (PG0 : list PropX) (Q0 : PropX),
                  seq PG0 Q0 ->
                  forall G0 : list (propX nil),
                    incl PG0 (p a :: G0) -> seq G0 (p a) -> seq G0 Q0
              | _ => fun _ => False
            end p -> incl PG (P :: G) -> seq G Q
          | _ => True
        end.
    Proof.
      outerPredicative.
    Qed.

    Lemma outer_Exists : forall PG Q, seq PG Q
      -> forall G A p, seq G (Exists p) ->
        (forall (a : A) (PG0 : list PropX) (Q0 : PropX),
          seq PG0 Q0 ->
          forall G0 : list (propX nil),
            incl PG0 (p a :: G0) -> seq G0 (p a) -> seq G0 Q0)
        -> incl PG (Exists p :: G) -> seq G Q.
    Proof.
      intros; specialize (outer_Exists' H H0); eauto.
    Qed.

    Lemma outer_ForallX' : forall PG Q, seq PG Q
      -> forall G P, seq G P ->
        match P with
          | ForallX _ A p =>
            incl PG (P :: G) -> seq G Q
          | _ => True
        end.
    Proof.
      outerPredicative.
    Qed.

    Lemma outer_ForallX : forall PG Q, seq PG Q
      -> forall G A (p : propX (A :: _)), seq G (ForallX p) ->
        incl PG (ForallX p :: G) -> seq G Q.
    Proof.
      intros; specialize (outer_ForallX' H H0); eauto.
    Qed.

    Lemma outer_ExistsX' : forall PG Q, seq PG Q
      -> forall G P, seq G P ->
        match P with
          | ExistsX _ A p =>
            incl PG (P :: G) -> seq G Q
          | _ => True
        end.
    Proof.
      outerPredicative.
    Qed.

    Lemma outer_ExistsX : forall PG Q, seq PG Q
      -> forall G A (p : propX (A :: _)), seq G (ExistsX p) ->
        incl PG (ExistsX p :: G) -> seq G Q.
    Proof.
      intros; specialize (outer_ExistsX' H H0); eauto.
    Qed.

    Hint Immediate outer_Inj outer_Cptr outer_And outer_Or outer_Imply
      outer_Forall outer_Exists outer_ForallX outer_ExistsX.

    Lemma cut_admissibility' : forall GG (P : propX GG),
      match GG return propX GG -> Prop with
        | _ :: _ => fun _ => True
        | nil => fun P => forall PG Q, seq PG Q
          -> forall G, incl PG (P :: G)
          -> seq G P
          -> seq G Q
      end P.
    Proof.
      induction P; destruct G; intuition eauto.
    Qed.

    Theorem cut_admissibility : forall P G Q,
      seq G P
      -> seq (P :: G) Q
      -> seq G Q.
    Proof.
      intros; eapply (@cut_admissibility' nil); eauto.
    Qed.

    Hint Resolve cut_admissibility.

    Theorem cut_elimination : forall G P,
      seqP G P
      -> seq G P.
    Proof.
      induction 1; eauto; doLeft.
    Qed.

    Lemma seqP_complete' : forall G P, normalP G P
      -> seqP G P.
    Proof.
      generalize seqP_complete; firstorder.
    Qed.

    Theorem normalization : forall G P,
      valid G P
      -> normal G P.
    Proof.
      intros; apply seq_sound; apply cut_elimination; apply seqP_complete';
        apply normalP_complete; assumption.
    Qed.

    Definition interp := valid nil.

    Lemma neutral_contra' : forall G P, neutral G P
      -> G = nil
      -> False.
    Proof.
      induction 1; simpl in *; intros; subst; intuition.
    Qed.

    Lemma neutral_contra : forall P, neutral nil P
      -> False.
    Proof.
      intros; eapply neutral_contra'; eauto.
    Qed.

    Hint Immediate neutral_contra.

    Hint Unfold interp.

    Theorem normal_sound : forall G P, normal G P -> valid G P.
      generalize normal_neutral_sound; firstorder.
    Qed.

    Hint Immediate normal_sound.

    Lemma interp_sound : forall P, interp P
      -> match P with
           | Inj _ p => p
           | Cptr G f a => match G return (_ -> propX G) -> Prop with
                             | nil => fun a => specs f = Some (fun x => a x)
                             | _ => fun _ => False
                           end a
           | And G P1 P2 => match G return propX G -> propX G -> Prop with
                              | nil => fun P1 P2 => interp P1 /\ interp P2
                              | _ => fun _ _ => False
                            end P1 P2
           | Or G P1 P2 => match G return propX G -> propX G -> Prop with
                             | nil => fun P1 P2 => interp P1 \/ interp P2
                             | _ => fun _ _ => False
                           end P1 P2
           | Imply G P1 P2 => match G return propX G -> propX G -> Prop with
                                | nil => fun P1 P2 => interp P1 -> interp P2
                                | _ => fun _ _ => False
                              end P1 P2
           | Forall G _ P1 => match G return (_ -> propX G) -> Prop with
                                | nil => fun P1 => forall x, interp (P1 x)
                                | _ => fun _ => False
                              end P1
           | Exists G _ P1 => match G return (_ -> propX G) -> Prop with
                                | nil => fun P1 => exists x, interp (P1 x)
                                | _ => fun _ => False
                              end P1
           | ForallX G _ P1 => match G return propX (_ :: G) -> Prop with
                                | nil => fun P1 => forall x, interp (Subst P1 x)
                                | _ => fun _ => False
                              end P1
           | ExistsX G _ P1 => match G return propX (_ :: G) -> Prop with
                                 | nil => fun P1 => exists x, interp (Subst P1 x)
                                 | _ => fun _ => False
                               end P1
           | _ => False
         end.
      intros ? H; apply normalization in H; inversion H; subst; clear H; try solve [ elimtype False; eauto ]; intuition eauto.
    Qed.

    Ltac sound := intros; match goal with
                            | [ H : interp _ |- _ ] => solve [ apply interp_sound in H; auto ]
                          end.

    Theorem Inj_sound : forall p, interp (Inj p) -> p.
      sound.
    Qed.

    Theorem Cptr_sound : forall f a, interp (Cptr f a)
      -> specs f = Some (fun x => a x).
      sound.
    Qed.

    Theorem And_sound : forall P Q, interp (And P Q)
      -> interp P /\ interp Q.
      sound.
    Qed.

    Theorem Or_sound : forall P Q, interp (Or P Q)
      -> interp P \/ interp Q.
      sound.
    Qed.

    Theorem Imply_sound : forall P Q, interp (Imply P Q)
      -> interp P -> interp Q.
      sound.
    Qed.

    Theorem Forall_sound : forall A (P : A -> _), interp (Forall P)
      -> forall x, interp (P x).
      sound.
    Qed.

    Theorem Exists_sound : forall A (P : A -> _), interp (Exists P)
      -> exists x, interp (P x).
      sound.
    Qed.

    Theorem ForallX_sound : forall A (P : propX (A :: nil)), interp (ForallX P)
      -> forall f, interp (Subst P f).
      sound.
    Qed.

    Theorem ExistsX_sound : forall A (P : propX (A :: nil)), interp (ExistsX P)
      -> exists f, interp (Subst P f).
      sound.
    Qed.
  End specs.
End machine.

Implicit Arguments Inj [pc state G].
Implicit Arguments Var0 [pc state G A].
Implicit Arguments Lift [pc state G A].
Notation "[| p |]" := (Inj p%type) : PropX_scope.
Infix "/\" := And : PropX_scope.
Infix "\/" := Or : PropX_scope.
Infix "--->" := Imply (at level 86, right associativity) : PropX_scope.

Notation "'Al' x , P" := (Forall (fun x => P)) (x ident, at level 89) : PropX_scope.
Notation "'Al' x : A , P" := (Forall (fun x : A => P)) (x ident, at level 89) : PropX_scope.
Notation "'Ex' x , P" := (Exists (fun x => P)) (x ident, at level 89) : PropX_scope.
Notation "'Ex' x : A , P" := (Exists (fun x : A => P)) (x ident, at level 89) : PropX_scope.

Notation "'AlX' , P" := (ForallX P) (at level 89) : PropX_scope.
Notation "'AlX' : A , P" := (ForallX (A := A) P) (at level 89) : PropX_scope.
Notation "'ExX' , P" := (ExistsX P) (at level 89) : PropX_scope.
Notation "'ExX' : A , P" := (ExistsX (A := A) P) (at level 89) : PropX_scope.

Notation "#0" := (fun x => Var0 x) : PropX_scope.
Notation "#1" := (fun x => Lift (Var0 x)) : PropX_scope.
Notation "#2" := (fun x => Lift (Lift (Var0 x))) : PropX_scope.
Notation "#3" := (fun x => Lift (Lift (Lift (Var0 x)))) : PropX_scope.
Notation "#4" := (fun x => Lift (Lift (Lift (Lift (Var0 x))))) : PropX_scope.
Notation "#5" := (fun x => Lift (Lift (Lift (Lift (Lift (Var0 x)))))) : PropX_scope.
Notation "#6" := (fun x => Lift (Lift (Lift (Lift (Lift (Lift (Var0 x))))))) : PropX_scope.
Notation "#7" := (fun x => Lift (Lift (Lift (Lift (Lift (Lift (Lift (Var0 x)))))))) : PropX_scope.
Notation "#8" := (fun x => Lift (Lift (Lift (Lift (Lift (Lift (Lift (Lift (Var0 x))))))))) : PropX_scope.

Delimit Scope PropX_scope with PropX.
Bind Scope PropX_scope with PropX propX.

Arguments Scope interp [type_scope type_scope _ PropX_scope].
Arguments Scope valid [type_scope type_scope _ PropX_scope PropX_scope].


From stdpp Require Import mapset.
From iris.algebra Require Import gmap.
From iris.prelude Require Import options.

Section Graphs.
  Context {T : Type} {HD : EqDecision T} {HC : @Countable T HD}.

  Definition graph := gmap T (option T * option T).

  Identity Coercion graph_to_gmap : graph >-> gmap.

  Definition get_left (g : graph) x : option T := g !! x ≫= fst.
  Definition get_right (g : graph) x : option T := g !! x ≫= snd.

  Definition strict_sub_child (ch ch' : option T) :=
    match ch, ch' with
    | Some c, Some c' => c = c'
    | Some c, None => True
    | None, Some _ => False
    | None, None => True
    end.

  Definition strict_sub_children (ch ch' : option T * option T) : Prop :=
    strict_sub_child (ch.1) (ch'.1) ∧ strict_sub_child (ch.2) (ch'.2).

  Definition strict_subgraph (g g' : graph) : Prop :=
    ∀ x, strict_sub_children (get_left g x, get_right g x)
           (get_left g' x, get_right g' x).

(* A path is a list of booleans true for left child and false for the right *)
(* The empty list is the identity trace (from x to x). *)
  Definition path := list bool.

  Identity Coercion path_to_list : path >-> list.

  Inductive valid_path (g : graph) (x y : T) : path → Prop :=
  | valid_path_E : x ∈ dom (gset _) g → x = y → valid_path g x y []
  | valid_path_l (xl : T) p : get_left g x = Some xl → valid_path g xl y p →
      valid_path g x y (true :: p)
  | valid_path_r (xr : T) p : get_right g x = Some xr → valid_path g xr y p →
      valid_path g x y (false :: p).

  Definition connected (g : graph) (x : T) :=
    ∀ z, z ∈ dom (gset _) g → ∃ p, valid_path g x z p.

  Definition front (g : graph) (t t' : gset T) := t ⊆ dom (gset _) g ∧
    ∀ x v, x ∈ t → (get_left g x = Some v) ∨ (get_right g x = Some v) →
       v ∈ t'.

  Definition maximal (g : graph) := front g (dom (gset _) g) (dom (gset _) g).

  Definition tree (g : graph) (x : T) :=
    ∀ z, z ∈ dom (gset _) g → exists !p, valid_path g x z p.

  (* graph facts *)

  Lemma front_t_t_dom g z t :
    z ∈ t → connected g z → front g t t → t = dom (gset _) g.
  Proof.
    intros Hz Hc [Hsb Hdt].
    apply set_eq_subseteq; split; trivial.
    apply elem_of_subseteq => x Hx. destruct (Hc x Hx) as [p pv].
    clear Hc Hx; revert z Hz pv.
    induction p => z Hz pv.
    - by inversion pv; subst.
    - inversion pv as [|? ? Hpv1 Hpv2 Hpv3|? ? Hpv1 Hpv2 Hpv3]; subst.
      + eauto.
      + eauto.
  Qed.

  Lemma front_mono g t t' s : front g t t' → t' ⊆ s → front g t s.
  Proof. intros [Htd Hf] Hts; split; eauto. Qed.

  Lemma front_empty g : front g ∅ ∅.
  Proof. split; auto. intros ? Hcn; inversion Hcn. Qed.

  Lemma strict_sub_children_refl v : strict_sub_children v v.
  Proof. by destruct v as [[] []]. Qed.

  Lemma strict_sub_children_trans v1 v2 v3 : strict_sub_children v1 v2 →
    strict_sub_children v2 v3 → strict_sub_children v1 v3.
  Proof.
   destruct v1 as [[] []]; destruct v2 as [[] []];
   destruct v3 as [[] []]; cbv; by intuition subst.
  Qed.

  Lemma strict_sub_children_None v : strict_sub_children v (None, None).
  Proof. by destruct v as[[] []]. Qed.

  Lemma strict_subgraph_empty g : strict_subgraph g ∅.
  Proof.
    intros i.
    rewrite /get_left /get_right /strict_sub_child lookup_empty //=.
    by destruct (g !! i) as [[[] []]|].
  Qed.

  Lemma get_left_dom g x y : get_left g x = Some y → x ∈ dom (gset _) g.
  Proof.
    rewrite /get_left elem_of_dom. case _ : (g !! x); inversion 1; eauto.
  Qed.

  Lemma get_right_dom g x y : get_right g x = Some y → x ∈ dom (gset _) g.
  Proof.
    rewrite /get_right elem_of_dom. case _ : (g !! x); inversion 1; eauto.
  Qed.

  Lemma path_start g x y p : valid_path g x y p → x ∈ dom (gset _) g.
  Proof. inversion 1; subst; eauto using get_left_dom, get_right_dom. Qed.

  Lemma path_end g x y p : valid_path g x y p → y ∈ dom (gset _) g.
  Proof. induction 1; subst; eauto. Qed.

End Graphs.

Global Arguments graph _ {_ _}.


(** Add-ons for Permutation library
Usefull properties apparently missing in the Permutation library. *)

From Coq Require Export Permutation List.
From RL.OLlibs Require Import List_more funtheory.

Set Implicit Arguments.

Lemma Permutation_app_app_inv A : forall (l1 l2 l3 l4 : list A),
  Permutation (l1 ++ l2) (l3 ++ l4) -> exists l3' l3'' l4' l4'',
    Permutation l1 (l3' ++ l4')  /\ Permutation l2 (l3'' ++ l4'') /\
    Permutation l3 (l3' ++ l3'') /\ Permutation l4 (l4' ++ l4'').
Proof.
induction l1 ; intros.
- exists (@nil A) ; exists l3 ; exists (@nil A) ; exists l4.
  now repeat split.
- assert (Heq := H).
  apply (Permutation_in a) in Heq.
  + apply in_app_or in Heq.
    destruct Heq as [Heq | Heq] ; apply in_split in Heq ;
    destruct Heq as (l' & l'' & Heq) ; subst.
    * rewrite <- ?app_comm_cons in H.
      rewrite <- app_assoc in H.
      rewrite <- app_comm_cons in H.
      apply Permutation_cons_app_inv in H.
      rewrite app_assoc in H.
      apply IHl1 in H.
      destruct H as (l3' & l3'' & l4' & l4'' & H1 & H2 & H3 & H4).
      exists (a::l3') ; exists l3'' ; exists l4' ; exists l4''.
      repeat split; auto.
      -- rewrite <- app_comm_cons.
         now apply Permutation_cons.
      -- apply Permutation_sym.
         rewrite <- app_comm_cons.
         now apply Permutation_cons_app, Permutation_sym.
    * rewrite <- ?app_comm_cons, app_assoc in H.
      apply Permutation_cons_app_inv in H.
      rewrite <- app_assoc in H.
      apply IHl1 in H.
      destruct H as (l3' & l3'' & l4' & l4'' & H1 & H2 & H3 & H4).
      exists l3', l3'', (a :: l4'), l4''.
      repeat split; auto.
      -- now apply Permutation_cons_app.
      -- apply Permutation_sym.
         rewrite <- app_comm_cons.
         now apply Permutation_cons_app, Permutation_sym.
  + now constructor.
Qed.

Lemma Permutation_map_inv_inj A B : forall f : A -> B, injective f ->
  forall l1 l2, Permutation (map f l1) (map f l2) -> Permutation l1 l2.
Proof.
intros f Hi l1; induction l1; intros l2 HP.
- apply Permutation_nil in HP.
  now destruct l2; inversion HP.
- symmetry in HP.
  destruct (Permutation_vs_cons_inv HP) as (l3 & l4 & Heq).
  decomp_map Heq; subst.
  rewrite map_app in HP; simpl in HP.
  rewrite Heq3 in HP; symmetry in HP.
  apply Permutation_cons_app_inv in HP.
  specialize IHl1 with (l0 ++ l6).
  rewrite map_app in IHl1.
  apply IHl1 in HP.
  apply Hi in Heq3; subst.
  now apply Permutation_cons_app.
Qed.

Lemma Permutation_map_inv_inj_local A B : forall (f : A -> B) l1 l2,
  (forall x y, In x l1 -> In y l2 -> f x = f y -> x = y) ->
    Permutation (map f l1) (map f l2) -> Permutation l1 l2.
Proof.
induction l1 ; intros l2 Hi HP.
- apply Permutation_nil in HP.
  now destruct l2; inversion HP.
- assert (Heq := HP).
  symmetry in Heq.
  apply Permutation_vs_cons_inv in Heq.
  destruct Heq as (l3 & l4 & Heq).
  decomp_map Heq; subst.
  rewrite map_app in HP; simpl in HP.
  rewrite Heq3 in HP.
  apply Permutation_cons_app_inv in HP.
  specialize IHl1 with (l0 ++ l6).
  rewrite map_app in IHl1.
  apply IHl1 in HP.
  + symmetry in Heq3; apply Hi in Heq3; subst.
    * now apply Permutation_cons_app.
    * apply in_eq.
    * apply in_elt.
  + intros x' y' Hx' Hy' Hf.
    apply Hi; auto.
    * now apply in_cons.
    * apply in_app_or in Hy'.
      destruct Hy' as [ Hy' | Hy' ]; apply in_or_app; [left|right]; auto.
      now apply in_cons.
Qed.

(** ** [repeat] *)
(* TODO included in PR #12799 submitted, remove once merged and released *)

Lemma Permutation_repeat A (a : A) n l :
  Permutation l (repeat a n) -> l = repeat a n.
Proof.
revert n; induction l; simpl; intros n HP; auto.
- now apply Permutation_nil in HP; inversion HP.
- assert (a0 = a) as Heq by (now apply repeat_spec with n, (Permutation_in _ HP); left); subst.
  destruct n; simpl; simpl in HP.
  + symmetry in HP; apply Permutation_nil in HP; inversion HP.
  + f_equal; apply IHl.
    now apply Permutation_cons_inv with a.
Qed.


Require Import VST.floyd.proofauto.
Require Import triang.
Require Import spec_stdlib.
Require Import spec_fastpile.
Global Open Scope funspec_scope.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Local Open Scope assert.

Fixpoint triang (n: nat) :=
 match n with
 | O => 0
 | S n' => Z.of_nat n + triang n'
 end.

Definition Triang_nth_spec :=
 DECLARE _Triang_nth
 WITH n:Z, gv: globals
 PRE [ tint ]
    PROP( 0 <= n < 1000)
    PARAMS (Vint (Int.repr n)) GLOBALS (gv)
    SEP(mem_mgr gv)
 POST[ tint ]
    PROP()
    LOCAL(temp ret_temp (Vint (Int.repr (triang (Z.to_nat n)))))
    SEP(mem_mgr gv).

Definition specs := [Triang_nth_spec].


(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

Require Import List Arith Lia Relations.

From Undecidability.MinskyMachines
  Require Import MM2 ndMM2.

From Undecidability.Shared.Libs.DLW
  Require Import utils.

From Undecidability.Synthetic
  Require Import Definitions ReducibilityFacts.

Set Implicit Arguments.

Set Default Proof Using "Type".

Section MM2_ndMM2.

  Notation STOP := (@ndmm2_stop _).
  Notation INC  := (@ndmm2_inc _).
  Notation DEC  := (@ndmm2_dec _).
  Notation ZERO := (@ndmm2_zero _).

  Notation α := true.
  Notation β := false.

  Definition mm2_instr_enc i ρ :=
    match ρ with
      | mm2_inc_a   => INC α i (1+i) :: nil
      | mm2_inc_b   => INC β i (1+i) :: nil
      | mm2_dec_a j => DEC α i j :: ZERO true  i (1+i) :: nil
      | mm2_dec_b j => DEC β i j :: ZERO false i (1+i) :: nil
    end.

  Fixpoint mm2_linstr_enc i l :=
    match l with
      | nil => nil
      | ρ::l => mm2_instr_enc i ρ ++ mm2_linstr_enc (1+i) l
    end.

  Fact mm2_linstr_enc_app i l m : mm2_linstr_enc i (l++m) = mm2_linstr_enc i l ++ mm2_linstr_enc (length l+i) m.
  Proof.
    revert i; induction l as [ | ? l IHl ]; intros ?; simpl; auto.
    rewrite app_ass, IHl; do 3 f_equal; auto.
  Qed.

  Fact mm2_linstr_enc_In i P c :
          In c (mm2_linstr_enc i P)
       -> exists l r ρ, P = l++ρ::r /\ In c (mm2_instr_enc (length l+i) ρ).
  Proof.
    revert i; induction P as [ | ρ P IH ]; intros i.
    + intros [].
    + simpl; rewrite in_app_iff; intros [ H | H ].
      * exists nil, P, ρ; split; auto.
      * destruct (IH (1+i)) as (l & r & ρ' & H1 & H2); auto.
        exists (ρ::l), r, ρ'; split; auto.
        - simpl; f_equal; auto.
        - eq goal H2; do 2 f_equal; simpl; lia.
  Qed.

  Notation "Σ // a ⊕ b ⊦ u" := (ndmm2_accept Σ a b u) (at level 70, no associativity).

  Local Fact mm2_instr_enc_sound Σ ρ s1 s2 :
          mm2_atom ρ s1 s2
       -> match s1, s2 with
            | (i,(a,b)), (j,(a',b')) => incl (mm2_instr_enc i ρ) Σ
                                     -> Σ // a' ⊕ b' ⊦ j
                                     -> Σ // a  ⊕ b  ⊦ i
          end.
  Proof.
    induction 1 as [ i a b | i a b | i j a b | i j a b | i j b | i j a ]; simpl; intros HΣ H.
    + constructor 2 with (1+i); auto; apply HΣ; simpl; auto.
    + constructor 3 with (1+i); auto; apply HΣ; simpl; auto.
    + constructor 4 with j; auto; apply HΣ; simpl; auto.
    + constructor 5 with j; auto; apply HΣ; simpl; auto.
    + constructor 6 with (1+i); auto; apply HΣ; simpl; auto.
    + constructor 7 with (1+i); auto; apply HΣ; simpl; auto.
  Qed.

  Local Fact mm2_step_linstr_sound Σ P s1 s2 :
          mm2_step P s1 s2
       -> match s1, s2 with
            | (i,(a,b)), (j,(a',b')) => incl (mm2_linstr_enc 1 P) Σ
                                     -> Σ // a' ⊕ b' ⊦ j
                                     -> Σ // a  ⊕ b  ⊦ i
          end.
  Proof.
    intros (ρ & (l&r&H1&H2) & H3).
    apply mm2_instr_enc_sound with (Σ := Σ) in H3; revert s1 s2 H2 H3.
    intros (i,(a,b)) (j,(a',b')); simpl; intros H2 H3 H4 H5.
    apply H3; auto.
    apply incl_tran with (2 := H4).
    rewrite H1, mm2_linstr_enc_app.
    apply incl_appr; simpl.
    apply incl_appl.
    rewrite <- H2, plus_comm.
    apply incl_refl.
  Qed.

  Notation "P // x ↠ y" := (clos_refl_trans _ (mm2_step P) x y) (at level 70).

  Variable P : list mm2_instr.

  Definition mm2_prog_enc := STOP 0 :: mm2_linstr_enc 1 P.

  Notation Σ := mm2_prog_enc.

  Local Lemma mm2_prog_enc_compute s1 s2 :
          P // s1 ↠ s2
       -> match s1, s2 with
            | (i,(a,b)), (j,(a',b')) => Σ // a' ⊕ b' ⊦ j
                                     -> Σ // a  ⊕ b  ⊦ i
          end.
  Proof.
    induction 1 as [ (?,(?,?)) (?,(?,?)) H
                   | (?,(?,?))
                   | (?,(?,?)) (?,(?,?)) (?,(?,?))  ]; eauto.
    apply mm2_step_linstr_sound with (Σ := Σ) in H.
    apply H, incl_tl, incl_refl.
  Qed.

  Local Lemma mm2_prog_enc_stop : Σ // 0 ⊕ 0 ⊦ 0.
  Proof. constructor 1; simpl; auto. Qed.

  Hint Resolve mm2_prog_enc_stop : core.

  Local Lemma mm2_prog_enc_complete a b p :
             Σ // a ⊕ b ⊦ p -> P // (p,(a,b)) ↠ (0,(0,0)).
  Proof.
    induction 1 as [ u H
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | a b u v H H1 IH1
                   | b p u H H1 IH1
                   | a p u H H1 IH1 ].
    + destruct H as [ H | H ].
      * inversion H; subst u; constructor 2.
      * apply mm2_linstr_enc_In in H
          as (l & r & [ | | | ] & H1 & H2); simpl in H2.
        1-2: now destruct H2.
        1-2: now destruct H2 as [ | [] ].
    + destruct H as [ H | H ]; try discriminate.
      apply mm2_linstr_enc_In in H
        as (l & r & [ | | | ] & H3 & H2); simpl in H2.
      2: now destruct H2.
      2-3: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [] ]; inversion H2; subst.
      constructor 3 with (length l+2, (S a,b)).
      * constructor 1.
        exists mm2_inc_a; split.
        - exists l, r; simpl; split; auto; lia.
        - rewrite !(plus_comm (length l)); constructor.
      * eq goal IH1; do 2 f_equal; lia.
    + destruct H as [ H | H ]; try discriminate.
      apply mm2_linstr_enc_In in H
        as (l & r & [ | | | ] & H3 & H2); simpl in H2.
      1: now destruct H2.
      2-3: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [] ]; inversion H2; subst.
      constructor 3 with (length l+2, (a,S b)).
      * constructor 1.
        exists mm2_inc_b; split.
        - exists l, r; simpl; split; auto; lia.
        - rewrite !(plus_comm (length l)); constructor.
      * eq goal IH1; do 2 f_equal; lia.
    + destruct H as [ H | H ]; try discriminate.
      apply mm2_linstr_enc_In in H
        as (l & r & [ | | | ] & H3 & H2); simpl in H2.
      1-2: now destruct H2.
      2: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | H2 ].
      2: now destruct H2.
      inversion H2; subst.
      constructor 3 with (v, (a,b)); auto.
      constructor 1.
      exists (mm2_dec_a v); split; auto.
      * exists l, r; simpl; split; auto; lia.
      * rewrite !(plus_comm (length l)); constructor.
    + destruct H as [ H | H ]; try discriminate.
      apply mm2_linstr_enc_In in H
        as (l & r & [ | | | ] & H3 & H2); simpl in H2.
      1-2: now destruct H2.
      1: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | H2 ].
      2: now destruct H2.
      inversion H2; subst.
      constructor 3 with (v, (a,b)); auto.
      constructor 1.
      exists (mm2_dec_b v); split; auto.
      * exists l, r; simpl; split; auto; lia.
      * rewrite !(plus_comm (length l)); constructor.
    + destruct H as [ H | H ]; try discriminate.
      apply mm2_linstr_enc_In in H
        as (l & r & [ | | | ] & H3 & H2); simpl in H2.
      1-2: now destruct H2.
      2: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [ H2 | [] ] ].
      1: easy.
      inversion H2; subst.
      constructor 3 with (length l+2, (0,b)).
      * constructor 1.
        exists (mm2_dec_a n); split.
        - exists l, r; simpl; split; auto; lia.
        - rewrite !(plus_comm (length l)); constructor.
      * eq goal IH1; do 2 f_equal; lia.
    + destruct H as [ H | H ]; try discriminate.
      apply mm2_linstr_enc_In in H
        as (l & r & [ | | | ] & H3 & H2); simpl in H2.
      1-2: now destruct H2.
      1: now destruct H2 as [ | [] ].
      destruct H2 as [ H2 | [ H2 | [] ] ].
      1: easy.
      inversion H2; subst.
      constructor 3 with (length l+2, (a,0)).
      * constructor 1.
        exists (mm2_dec_b n); split.
        - exists l, r; simpl; split; auto; lia.
        - rewrite !(plus_comm (length l)); constructor.
      * eq goal IH1; do 2 f_equal; lia.
  Qed.

  Theorem MM2_ndMM2_equiv a b : MM2_HALTS_ON_ZERO (P,a,b) <-> Σ // a ⊕ b ⊦ 1.
  Proof.
    split.
    + intros H; apply mm2_prog_enc_compute in H; auto.
    + apply mm2_prog_enc_complete.
  Qed.

End MM2_ndMM2.

Theorem reduction : MM2_HALTS_ON_ZERO ⪯ @ndMM2_ACCEPT nat.
Proof.
  apply reduces_dependent; exists.
  intros ((P,a),b).
  exists (existT _ (mm2_prog_enc P) (1,(a,b))).
  apply MM2_ndMM2_equiv.
Qed.


Require Import Notation.
Require Import GeneralTactics.
Require Import Axioms.Extensionality.

Require Import Setoid.

(* The inhabited type constructor is sometimes called "propositional truncation"
   because, under the proof-irrelevance interpretation, it truncates types down to
   a single witness.
 *)

Notation "| a |" := (inhabits a)
  (at level 50, format "| a |").
Notation "‖ A ‖" := (inhabited A)
  (at level 50, format "‖ A ‖").

Definition to_trunc (a b: Type): Prop := a -> ‖b‖.

(* If `H: ‖a‖`, and the goal is a Prop, then `uninhabit H` transforms the
   hypothesis into `H: a` by inversion.
 *)
Ltac uninhabit H :=
  let i := fresh in
  inversion H as [i];
  clear H;
  rename i into H.

(* `inhabit`/`in` applies the inhabits-valued theorem in the hypothesis, and then
   `uninhabits` the hypothesis.
 *)
Tactic Notation "inhabit" uconstr(c) "in" hyp(H) :=
  apply c in H;
  uninhabit H.

Tactic Notation "einhabit" uconstr(c) "in" hyp(H) :=
  eapply c in H;
  uninhabit H.

Tactic Notation "inhabitc" hyp(c) "in" hyp(H) :=
  inhabit c in H;
  clear c.

Tactic Notation "einhabitc" hyp(c) "in" hyp(H) :=
  einhabit c in H;
  clear c.

(* Theorem lift_arrow: forall a b, *)
Theorem inhabited_codomain: forall a b,
  (a -> b) ->
  a -> ‖b‖.
Proof using.
  intros * H Ha.
  constructor.
  auto.
Qed.

Theorem extend_truncation_domain: forall a b,
  (a -> ‖b‖) ->
  ‖a‖ -> ‖b‖.
Proof using.
  intros a b H inhA.
  uninhabit inhA.
  auto.
Qed.

(* Transforms goal from `‖a‖` to `a` *)
Tactic Notation "inhabit" :=
  match goal with
  | |- ‖ _ ‖ => constructor
  end.

(* ` *)
Tactic Notation "inhabit" uconstr(c) :=
  solve [inhabit; apply c] +
  match type of c with
  | ‖ _ ‖ -> ‖ _ ‖ => apply c
  | _ -> ‖ _ ‖ => apply (extend_truncation_domain _ _ c)
  end +
  apply c.

Tactic Notation "einhabit" uconstr(c) :=
  solve [inhabit; eapply c] +
  match type of c with
  | ‖ _ ‖ -> ‖ _ ‖ => eapply c
  | _ -> ‖ _ ‖ => eapply (extend_truncation_domain _ _ c)
  end +
  eapply c.

Tactic Notation "inhabitc" hyp(c) :=
  inhabit c; clear c.

Tactic Notation "einhabitc" hyp(c) :=
  einhabit c; clear c.

Theorem truncation_idempotent: forall a,
  ‖a‖ = ‖‖a‖‖.
Proof using.
  intro a.
  extensionality H.
  - inhabit H.
  - now uninhabit H.
Qed.

Theorem to_trunc_refl : reflexive Type to_trunc.
Proof using.
  intros ? x.
  inhabit x.
Qed.

Theorem to_trunc_trans : transitive Type to_trunc.
Proof using.
  unfold transitive, to_trunc.
  intros X Y Z Hxy Hyz x.
  inhabit Hyz.
  inhabit Hxy.
  inhabit x.
Qed.

Add Parametric Relation : Type to_trunc
  reflexivity  proved by to_trunc_refl
  transitivity proved by to_trunc_trans
  as to_trunc_rel.

Theorem to_trunc_weaker: forall a b (P: Prop),
  (a -> ‖b‖) ->
  (b -> P) ->
  a -> P.
Proof using.
  intros * Hab ? a.
  inhabitc Hab in a.
  auto.
Qed.

Theorem truncated_eq_exists_true : forall x,
  ‖x‖ = exists _: x, True.
Proof using.
  intros *.
  extensionality H; now destruct H.
Qed.

(* Various truncation-equivalents *)

Lemma trunc_prod_eq_conj : forall P Q: Prop,
  ‖P × Q‖ = (P /\ Q).
Proof using.
  intros *.
  extensionality H.
  - uninhabit H.
    now destruct H.
  - now inhabit.
Qed.

Lemma trunc_sig_eq_exists : forall A (P: A -> Prop),
  ‖{x | P x}‖ = exists x, P x.
Proof using.
  intros *.
  extensionality H.
  - uninhabit H.
    enow destruct H.
  - enow destruct H.
Qed.

Lemma trunc_sigma_eq_exists : forall A (P: A -> Type),
  ‖Σ x, P x‖ = exists x, ‖P x‖.
Proof using.
  intros *.
  extensionality H.
  - uninhabit H.
    enow destruct H.
  - enow destruct H as [? [?]].
Qed.

Lemma trunc_sum_eq_disj : forall P Q: Prop,
  ‖{P} + {Q}‖ = (P \/ Q).
Proof using.
  intros *.
  extensionality H.
  - uninhabit H.
    now destruct H; [left|right].
  - now destruct H; inhabit; [left|right].
Qed.


Require Import FP.Classes.WeakEqv.
Require Import FP.Classes.Eqv.
Require Import FP.Classes.Symmetric.
Require Import FP.Classes.Transitive.
Require Import FP.Data.Relation.
Require Import FP.Data.Function.
Require Import FP.Classes.Reflexive.
Require Import FP.Classes.Symmetric.
Require Import FP.Classes.Transitive.
Require Import FP.Data.Type.
Require Import FP.Data.Tactic.

Import Relation.Notation.
Import Function.Notation.
Import WeakEqv.Notation.
Import Eqv.Notation.

Inductive WeakSetoid : Type := mk_WeakSetoid
  { WeakSetoid_T : Type
  ; WeakSetoid_WeakEqv : WeakEqv WeakSetoid_T
  }.
Existing Instance WeakSetoid_WeakEqv.

(* Embed a type with Leibniz equality *)
Definition EL (A:Type) : WeakSetoid := mk_WeakSetoid A (Leibniz_WeakEqv A).

(* Domain of definition for a weak setoid. *)
Inductive DD (A:WeakSetoid) : Type := mk_DD
  { DD_value : WeakSetoid_T A
  ; DD_proper : proper weqv DD_value
  }.
Arguments DD_value {A} _.
Arguments DD_proper {A} _.

(* Equivalence relation over values in DD *)
Instance DD_Eqv {A:WeakSetoid} : Eqv (DD A) :=
  { eqv x y := DD_value x ≈ DD_value y }.
Proof.
  - econstructor ; intros.
    apply (DD_proper x).
  - econstructor ; intros.
    Symmetry ; auto.
  - econstructor ; intros.
    Transitivity (DD_value y) ; auto.
Defined.
(* Induced weak equivalence *)
Instance DD_WeakEqv {A:WeakSetoid} : WeakEqv (DD A) := Eqv_WeakEqv.

Definition DD_value_respect {A:WeakSetoid} : proper weqv (DD_value (A:=A)) :=
  fun_respect_intro DD_value DD_value (fun _ _ xRy => xRy).

(* Arrows in the weak setoid universe *)
Definition weak_setoid_arrow (A B:WeakSetoid) : WeakSetoid :=
  mk_WeakSetoid (DD A -> DD B) Function_WeakEqv.
Local Infix "⇨" := weak_setoid_arrow (right associativity, at level 100).

(* Application *)
Definition weak_setoid_apply {A B:WeakSetoid} (f:DD (A ⇨ B)) (x:DD A) : DD B :=
  mk_DD B (DD_value $ DD_value f $ x) (DD_proper f x x (DD_proper x)).
Local Infix "⊛" := weak_setoid_apply (left associativity, at level 50).

(* Lambdas *)
Definition mk_DD_f {A B:WeakSetoid} (f:DD A -> DD B) (p:proper weqv f) : DD (A ⇨ B) :=
  mk_DD (A ⇨ B) f p.
Local Notation "'λ?'  x .. y → e" :=
  (mk_DD_f (fun x => .. (mk_DD_f (fun y => e) _) ..) _)
  (right associativity, at level 200, x binder, y binder).

(* Respect introduction for _⇨_ *)
Definition weak_setoid_respect_intro {A B:WeakSetoid}
  {f g:DD (A ⇨ B)} (p:forall x y, x ≃ y -> f ⊛ x ≃ g ⊛ y)
  : f ≃ g := p.

(* Respect elimination for _⇨_ *)
Definition weak_setoid_respect_elim {A B:WeakSetoid}
  {f g:DD (A ⇨ B)} (pf:f ≃ g) (x y:DD A) (px:x ≃ y)
  : f ⊛ x ≃ g ⊛ y := pf x y px.

(* Respect introduction for DD_value application *)
Definition DD_value_respect_intro {A B:WeakSetoid}
  {f g:DD (A ⇨ B)} (p:forall x y, x ≃ y -> f ⊛ x ≃ g ⊛ y)
  : DD_value f ≈ DD_value g := p.

(* Respect elimination for DD_value application *)
Definition DD_value_respect_elim {A B:WeakSetoid}
  {f g:DD (A ⇨ B)} (pf:f ≃ g) (x y:DD A) (px:x ≃ y)
  : DD_value f x ≃ DD_value g y := pf x y px.

(* Beta rule *)
Definition weak_setoid_beta {A B:WeakSetoid}
  (f:DD A -> DD B) (p:proper weqv f) (e:DD A)
  : mk_DD_f f p ⊛ e ≃ f e := p e e reflexivity.

Section Relation.
  Context {T} {R:relation T} `{! Symmetric R ,! Transitive R }.
  Definition replace_left {x y z} : R x y -> R y z -> R x z := transitivity y.
  Definition replace_right {x y z} : R y z -> R x z -> R x y := fun yRz xRz => transitivity z xRz (symmetry yRz).
End Relation.

Class ByDecideWeqv {A:WeakSetoid} (x:WeakSetoid_T A) : Type :=
  by_decide_weqv : proper weqv x.
Definition mk_DD_infer (A:WeakSetoid) (x:WeakSetoid_T A) `{! ByDecideWeqv x } : DD A :=
  mk_DD A x by_decide_weqv.
Definition mk_DD_infer_f {A B:WeakSetoid} (f:DD A -> DD B) `{! ByDecideWeqv (A:=A ⇨ B) f } : DD (A ⇨ B) :=
  mk_DD_f f $ by_decide_weqv (A:=A ⇨ B).

Ltac other_rule :=
  match goal with
    | [ |- (λ? _ → _) ≃ (λ? _ → _) ] =>
        eapply weak_setoid_respect_intro ; intros ;
        eapply (replace_left (weak_setoid_beta _ _ _)) ;
        eapply (replace_right (weak_setoid_beta _ _ _))
    end.

Ltac decide_weqv :=
  repeat (
    try Reflexivity ;
    unfold mk_DD_infer_f ;
    match goal with
    | [ |- ByDecideWeqv _ ] => unfold ByDecideWeqv
    | [ |- proper _ _ ] => unfold proper
    | [ |- ?x ≈ ?y ] => match type of x with DD _ => change (x ≃ y) end
    | [ |- (fun _ => _) ≈ (fun _ => _) ] => eapply fun_respect_intro ; intros ; simpl
    | [ |- (λ? _ → _) ≃ (λ? _ → _) ] =>
        eapply weak_setoid_respect_intro ; intros ;
        match goal with
        | [ |- ?e1 ≃ ?e2 ] =>
            let e1' := eval red in e1 in
            let e2' := eval red in e2 in
            change (e1' ≃ e2')
        end ; simpl
    | [ |- _ ⊛ _ ≃ _ ⊛ _ ] => eapply weak_setoid_respect_elim
    | [ |- _ ≃ _ ] => Reflexivity
    | [ |- {| DD_value := _ ; DD_proper := _ |} ≃ {| DD_value := _ ; DD_proper := _ |} ] => unfold_eqv ; simpl
    | [ |- DD_value _ ≈ DD_value _ ] => eapply fun_respect_elim
    | [ |- DD_value ≈ DD_value ] => eapply DD_value_respect
    | [ |- DD_value _ _ ≃ DD_value _ _ ] => eapply DD_value_respect_elim
    end) ;
  auto.
Hint Extern 9 => (solve [ decide_weqv ]) : typeclass_instances.

Module Notation.
  Infix "⇨" := weak_setoid_arrow (right associativity, at level 100).
  Infix "⊛" := weak_setoid_apply (left associativity, at level 50).
  Notation "'λ'  x .. y → e" :=
    (mk_DD_infer_f (fun x => .. (mk_DD_infer_f (fun y => e)) ..))
    (right associativity, at level 200, x binder, y binder).
  Notation "'λ?'  x .. y → e" :=
    (mk_DD_f (fun x => .. (mk_DD_f (fun y => e) _) ..) _)
    (right associativity, at level 200, x binder, y binder).
End Notation.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal21.

Set Printing Depth 1000.
Definition lfind_eval  x n:=
Cons n x.

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ Zero)) Nil)) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero Nil)) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ (Succ (Succ (Succ (Succ Zero)))))).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ (Succ (Succ (Succ Zero))))) (Cons Zero (Cons Zero (Cons (Succ Zero) Nil))))) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil)))) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ Zero) Nil))))) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).