Require Export CatSem.CAT.NT.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section CatFunct.

(** we build a category of functors and natural transformations *)

Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.

Obligation Tactic := cat; unfold vcompNT1;
   try (match goal with | [ |- Proper _ _ ] =>
             unfold Proper; do 2 red end) ;
   cat; unfold vcompNT1 ; try rewrite assoc;
   repeat (match goal with [ H : forall a, _ == _ |- _ ] =>
                   rewrite H end);
   cat.

Program Instance FunctCat_struct :
           @Cat_struct (Functor C D) (NT (C:=C)(D:=D)) := {
   mor_oid F G :=  EXT_NT_oid F G;
   id F := vidNT F;
   comp a b c f g := g # f
}.

Definition FunctCat : Cat := Build_Cat FunctCat_struct.

End CatFunct.

Existing Instance FunctCat_struct.

Canonical Structure FunctCat.

Notation "[ C , D ]" := (FunctCat C D) (at level 75).

(*Definition END (C:Category) := [ C , C ].*)

Section FunctCat_lemmata.

(** we prove an extensionality principle on natural transformations *)

Variables obC obD: Type.
Variable morC : obC -> obC -> Type.
Variable morD : obD -> obD -> Type.
Variable C: Cat_struct morC.
Variable D: Cat_struct morD.

Variables F G H K: Functor C D.
Variable alpha: F ---> G.
Variable beta: H ---> K.

Hypothesis h: F = H.
Hypothesis h': G = K.

Lemma NT_Extensionality:
  (forall x: obC, alpha x === beta x) -> alpha === beta.
Proof.
  generalize dependent alpha; clear alpha.
  rewrite h.
  generalize dependent beta; clear beta.
  rewrite h'.
  clear h h' F G.
  intros beta alpha H'.
  apply Build_Equal_hom.
  simpl.
  intro c.
  apply Equal_hom_imp_setoideq2_jmq_eq.
  apply (H' c).
Qed.

End FunctCat_lemmata.


Require Import Coq.Arith.Wf_nat.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Equality.

Require Export Metalib.Metatheory.
Require Export Metalib.LibLNgen.

From Exp Require Export Exp_ott.

(*************************************************************************)
(** Notation, manually added *)
(*************************************************************************)

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

(* Empty context is represented as an empty list *)
Definition empty : list (atom * ty_poly) := nil.

(* Int datatype in the object language *)
Definition Int : ty_poly := (ty_poly_rho (ty_rho_tau ty_mono_base)).

(** Tells Coq to create a new custom grammar Exp for parsing the object language *)
(** See Imp chapter of Software Foundations for details *)
(* Coercion exp_lit : integer >-> tm. *)

Declare Custom Entry exp.
Declare Scope exp_scope.

Notation "<{ e }>" := e (at level 0, e custom exp at level 99) : exp_scope.
Notation "( x )" := x (in custom exp, x at level 99) : exp_scope.
Notation "x" := x (in custom exp at level 0, x constr at level 0) : exp_scope.
Notation "f x .. y" := (.. (f x) .. y)
                  (in custom exp at level 0, only parsing,
                  f constr at level 0, x constr at level 9,
                  y constr at level 9) : exp_scope.
(* Notation "'exp_lit' i" := (exp_lit i) (in custom exp at level 80) : exp_scope. *)

Notation "x" := x (in custom exp at level 0, x constr at level 0) : exp_scope.
(* Notation "S -> T" := (Ty_Arrow S T) (in custom exp at level 50, right associativity) : exp_scope *)
Notation "x y" := (exp_app x y) (in custom exp at level 1, left associativity) : exp_scope.
Notation "\ x : t , y" :=
  (exp_abs x t y) (in custom exp at level 90, x at level 99,
                     t custom exp at level 99,
                     y custom exp at level 99,
                     left associativity) : exp_scope.

Local Open Scope exp_scope.

(* Variant of is_value_of_tm which is type Prop instead of bool *)
Definition is_value (t : tm) : Prop :=
  match t with
  | exp_lit _ => True
  | exp_abs _ => True
  | exp_typed_abs _ _ => True
  | _ => False
  end.

(* Inductive value : tm -> Prop :=
  | v_int : forall (i : integer),
      value <{ exp_lit i }>
  | v_abs : forall x T2 t1,
      value <{ \ x : T2 , t1 }>.
       *)

(*************************************************************************)
(** Lemmas, manually added *)
(*************************************************************************)

(* Note: this doesn't compile even when surrounding exp_lit with <{ }> *)
(* Lemma canonical_forms_int : forall (t : tm),
  typing empty t Int ->
  is_value t ->
  exists (i : integer), t = <{ exp_lit i }>.
Proof.
  intros t HT HVal.
  destruct HVal. *)

Theorem progress : forall e T,
  typing empty e T ->
  is_value e \/ exists e', step e e'.
Proof.
  intros e T H.
  assert (typing empty e T); auto.
  induction H; subst; auto.
  - (* exp_lit *)
   left. admit.
  - (* exp_lit duplicate *)
    admit.
  Admitted.


(*|
#################################################
Coq - Obtaining equality from ``match`` statement
#################################################

:Link: https://stackoverflow.com/q/70946233
|*)

(*|
Question
********

Here's a simplified version of something I'm trying to implement in
Coq. I have an inductive type, say ``foo``, whose constructor takes in
another type ``A``, and a function with inputs in ``A``.
|*)

Inductive foo :=
| constructor (A : Type) (f : A -> bool).

(*|
I also have a function which, given an object of type ``foo``, tells
me what type was used to construct it.
|*)

Definition foo_type (x : foo) :=
  match x with
  | constructor A f => A
  end.

(*|
So far so good. But now, I want to define a function which takes in an
object ``x`` of type ``foo`` and an object ``y`` of type ``foo_type
x``, and returns the ``f y``, where ``f`` is the function used in the
constructor of ``x``.
|*)

Fail Definition foo_func (x : foo) (y : (foo_type x)) :=
  match x with
  | constructor A f => f y
  end. (* .fails *)

(*|
However, this doesn't work. Coq tells me that there is a type error:
``y`` is of type ``foo_type x``, when it should be of type ``A``.

Now, I know that ``foo_type x`` evaluates to ``A`` in this situation.
Using `this stackoverflow question
<https://stackoverflow.com/questions/52514957>`__, I found a function
I can use that takes as input an equality of types ``A = B`` and an
element ``a : A`` and returns ``a``, but of type ``B``. However, to
make use of this, I need to be able to obtain the equality ``foo_type
x = A`` within the ``match`` part of my function definition. This
boils down to obtaining the equality ``x = constructor A f``.

So: within a ``match x with`` statement in my definition, is it
possible to extract the equality ``x = constructor A f``? How can I do
this? Or is there another way to get around this issue?
|*)

(*|
Answer
******

You need to use dependent pattern matching (an give some information
to Coq) to get an equality proof between a term and its
pattern-matched content:

.. code-block:: coq

    match x as x0 return x = x0 -> ... with
    | pat => fun (e : x = pat) => ...
    | ...
    end eq_refl

On the outside of the match construct, you can build a term ``eq_refl
: x = x`` that is refined during pattern matching. This is called the
convoy pattern in `Certified programming with dependent types
<http://adam.chlipala.net/cpdt/>`__.

In your case however there is a related, slightly simpler alternative,
still using dependent pattern matching:
|*)

Definition foo_func (x : foo) (y : (foo_type x)) :=
  match x as x0 return foo_type x0 -> bool with
  | constructor A f => fun y => f y
  end y.

(*|
----

**A:** I would never write the first version, unless I was feeling the
need to write particularly bad code. Use the second version! (And you
would need about the same thing anyway, whether explicit or folded
into an existing lemma, to actually rewrite the equality you get from
the first version in the type of any term.)
|*)


From Domains Require Import Preamble Preorder Poset WF.

Section Skeleton.
  Variable A : Preorder.type.

  Local Definition rel (x y : A) : Prop :=
    x ≤ y ∧ y ≤ x.

  Instance : RelationClasses.Reflexive rel.
  Proof. by move=> x; split. Qed.

  Instance : RelationClasses.Symmetric rel.
  Proof. by move=> x y [xy yx]; split. Qed.

  Instance : RelationClasses.Transitive rel.
  Proof.
    move=> x y z [xy yx] [yz zy]; split.
    - by apply: ltT; eauto.
    - by apply: ltT; eauto.
  Qed.

  Global Instance : RelationClasses.Equivalence rel.
  Proof. by split; typeclasses eauto. Defined.

  Definition skel := Quotient.T A rel.
  Definition cls : A → skel := Quotient.intro.

  Definition skel_lt (u v : skel) : Prop :=
    ∀ x y, cls x = u → cls y = v → x ≤ y.

  Lemma skel_ltT : ∀ u v w : skel, skel_lt u v → skel_lt v w → skel_lt u w.
  Proof.
    apply: Quotient.indp=> x.
    apply: Quotient.indp=> y.
    apply: Quotient.indp=> z.
    move=> xy yz x' z' xx' zz'.
    apply: ltT.
    - by apply: xy.
    - by apply: yz.
  Qed.

  Lemma skel_ltR : ∀ u, skel_lt u u.
  Proof.
    apply: Quotient.indp=> x.
    move=> x' x''.
    move=>/Quotient.eff [x'x xx'].
    move=>/Quotient.eff [x''x xx''].
    by apply: ltT; eauto.
  Qed.

  HB.instance Definition _ := PreorderOfType.Build skel skel_lt skel_ltR skel_ltT.

  Lemma skel_ltE : ∀ u v : skel, u ≤ v → v ≤ u → u = v.
  Proof.
    apply: Quotient.indp=> x.
    apply: Quotient.indp=> y.
    move=> xy yx.
    apply: Quotient.glue; split.
    + by apply: xy.
    + by apply: yx.
  Qed.

  HB.instance Definition _ := PosetOfPreorder.Build skel skel_ltE.

  Lemma cls_mono : is_monotone cls.
  Proof.
    move=> x y xy x' y'.
    move=>/Quotient.eff [x'x xx'].
    move=>/Quotient.eff [y'y yy'].
    apply: ltT.
    - by apply: x'x.
    - apply: ltT.
      + by apply: xy.
      + by apply: yy'.
  Qed.

  Lemma cls_full : ∀ x y : A, cls x ≤ cls y → x ≤ y.
  Proof. by move=> x y; apply. Qed.

  Lemma skel_lt_char : ∀ x y : A, (x ≤ y) = (cls x ≤ cls y).
  Proof.
    move=> x y.
    apply: propext; split.
    - by apply: cls_mono.
    - by apply: cls_full.
  Qed.

  Lemma cls_surj : surjective cls.
  Proof. by apply: Quotient.indp=> x; exists x. Qed.
End Skeleton.

Arguments cls [A] x.

Section Wf.
  Variable A : WfPreorder.type.

  Definition skel_mem (u v : skel A) : Prop :=
    ∀ x y, cls x = u → cls y = v → x ≺ y.

  Lemma skel_mem_char : ∀ x y : A, (x ≺ y) = (skel_mem (cls x) (cls y)).
  Proof.
    move=> x y; apply: propext; split.
    - move=> xy x' y'.
      move=>/Quotient.eff [x'x xx'].
      move=>/Quotient.eff [y'y yy'].
      apply: memL.
      + by apply: x'x.
      + apply: memR.
        * apply: xy.
        * apply: yy'.
    - by apply.
  Qed.

  Lemma skel_memT : ∀ u v w : skel A, skel_mem u v → skel_mem v w → skel_mem u w.
  Proof.
    apply: Quotient.indp=> x.
    apply: Quotient.indp=> y.
    apply: Quotient.indp=> z.
    rewrite -?skel_mem_char.
    apply: memT.
  Qed.

  Lemma skel_memL : ∀ u v w : skel A, u ≤ v → skel_mem v w → skel_mem u w.
  Proof.
    apply: Quotient.indp=> x.
    apply: Quotient.indp=> y.
    apply: Quotient.indp=> z.
    rewrite -?skel_mem_char -skel_lt_char.
    by apply: memL.
  Qed.

  Lemma skel_memR : ∀ u v w : skel A, skel_mem u v → v ≤ w → skel_mem u w.
  Proof.
    apply: Quotient.indp=> x.
    apply: Quotient.indp=> y.
    apply: Quotient.indp=> z.
    rewrite -?skel_mem_char -skel_lt_char.
    by apply: memR.
  Qed.

  Lemma skel_memWf : well_founded skel_mem.
  Proof.
    apply: Quotient.indp.
    apply: (well_founded_induction memWf)=> x ih.
    constructor; apply: Quotient.indp=> y hy.
    apply: ih.
    by rewrite skel_mem_char.
  Qed.

  Lemma skel_memLt : ∀ u v : skel A, skel_mem u v → u ≤ v.
  Proof.
    apply: Quotient.indp=> x.
    apply: Quotient.indp=> y.
    rewrite -skel_mem_char -skel_lt_char.
    by apply: memLt.
  Qed.

  HB.instance Definition _ := HasWf.Build (skel A) skel_mem skel_memWf skel_memLt skel_memT skel_memL skel_memR.
End Wf.


Require Import FiatFormal.Language.SubstTypeType.
Require Export FiatFormal.Language.KiJudge.
Require Export FiatFormal.Language.TyEnv.
Require Export FiatFormal.Language.Exp.

(* Type judgement assigns a type to an expression. *)
Inductive TYPE (ds : defs) : kienv -> tyenv -> exp -> ty -> Prop :=
 | TYVar
   : forall i ke te t,
     get i te = Some t
   -> KIND ke t  KStar
   -> TYPE ds ke te (XVar i) t

 | TYApp
   : forall ke te x1 x2 t11 t12,
     TYPE ds ke te x1 (TFun t11 t12)
   -> TYPE ds ke te x2 t11
   -> TYPE ds ke te (XApp x1 x2) t12

 | TYTup
   : forall ke te xs ts,
     Forall2 (TYPE ds ke te) xs ts
     -> TYPE ds ke te (XTup xs) (TNProd ts)

 | TYNFun
   : forall ke te x ts tRes,
     Forall (fun t => KIND ke t KStar) ts
     -> TYPE ds ke (te >< ts) x tRes
     -> TYPE ds ke te (XNFun ts x) (TNFun ts tRes)

 | TYProj
   : forall ke te n x ts tRes,
     TYPE ds ke te x (TNProd ts)
     -> get n ts = Some tRes
     -> TYPE ds ke te (XProj n x) tRes

 | TYNApp
   : forall ke te x xArgs ts tRes,
     TYPE ds ke te x (TNFun ts tRes)
     -> Forall2 (TYPE ds ke te) xArgs ts
     -> TYPE ds ke te (XNApp x xArgs) tRes

 | TYFix
   : forall ke te t1 t2 x,
     KIND ke t1 KStar
     -> TYPE ds ke (te :> (TFun t1 t2) :> t1) x t2
     -> TYPE ds ke te (XFix t1 t2 x) (TFun t1 t2)

 | TYCon
   : forall ke te dc xs tsArgs tc dcs,
     getDataDef dc ds = Some (DefData dc tsArgs (TCon tc))
     -> getTypeDef tc ds = Some (DefDataType tc dcs)
     -> Forall (simpleType) tsArgs
     -> In dc dcs
     -> Forall2 (TYPE ds ke te) xs tsArgs
     -> TYPE ds ke te (XCon dc xs) (TCon tc)

 (* Case Expressions *)
 | TYMatch
   : forall ke te xObj tcPat tRes alts dcs,
     (* check types of expression and alternatives *)
     TYPE ds ke te xObj (TCon tcPat)
     -> Forall (fun alt => TYPEA ds ke te alt (TCon tcPat) tRes) alts
     (* there must be at least one alternative *)
     -> length alts > 0
     (* all data cons must have a corresponding alternative *)
     -> getTypeDef tcPat ds = Some (DefDataType tcPat dcs)
     -> Forall (fun dc => In dc (map dcOfAlt alts)) dcs
     -> TYPE ds ke te (XMatch xObj alts) tRes

 | TYChoice
   : forall ke te tRes pc xs tsArgs,
     (* get proof constructor definition *)
     getPropDef pc ds = Some (DefProp pc tsArgs)
     -> Forall (simpleType) tsArgs
     (* require at least one arg type for any prop *)
     -> get 0 tsArgs = Some tRes
     -> KIND ke tRes KStar
     (* check type of annotation plus types of expressions
        match signature of proof constructor *)
     -> Forall2 (TYPE ds ke te) xs (tl tsArgs)
     -> TYPE ds ke te (XChoice tRes pc xs) tRes

with TYPEA (ds : defs) : kienv -> tyenv -> alt -> ty -> ty -> Prop :=
 | TYAlt
   : forall ke te x1 t1 dc tsArgs tcPat,
     getDataDef dc ds = Some (DefData dc tsArgs (TCon tcPat))
     -> Forall (simpleType) tsArgs
     (* note: checking tRes well kinded is implicit in TYMatch, I *)
     (* believe *)
     (* note: currently there is no such KIND premise in TYCon, which seems wrongly asymmetric *)
     -> Forall (fun t => KIND ke t KStar) tsArgs
     -> TYPE  ds ke (te >< tsArgs) x1 t1
     -> TYPEA ds ke te (AAlt dc tsArgs x1) (TCon tcPat) t1.

Hint Constructors TYPE.
Hint Constructors TYPEA.

Fixpoint dup {A : Type} (a : A) (c : nat) : list A :=
  match c with
  | O => nil
  | S c' => a :: (dup a c')
  end.

Lemma dup_map {A : Type} : forall (f : A -> A) (a : A) (c : nat),
    map f (dup a c) = dup (f a) c.
Proof.
  induction c; burn.
Qed.

Inductive TYPEMETHOD (rep : ty) (ds : defs) : kienv -> tyenv -> method -> ty -> Prop :=
| TYMETHOD : forall ke te arity dom body cod tRes,
    cod = (TNProd ((nil :> rep) :> tRes))
    -> TYPE ds ke te body (TNFun ((dup rep arity) >< dom) cod)
    -> TYPEMETHOD rep ds ke te (mkMethod arity dom body cod) (TNFun ((dup rep arity) >< dom) cod).
Hint Constructors TYPEMETHOD.

(* ADT judgement assigns a type to an ADT. *)
Inductive TYPEADT (ds : defs) : kienv -> tyenv -> adt -> list ty -> Prop :=
| TYADT : forall ke te ms tr ts,
    KIND ke tr KStar
    -> Forall2 (TYPEMETHOD tr ds ke te) ms (map (substTT 0 tr) ts)
    -> TYPEADT ds ke te (IADT tr ms (map (TExists) ts)) (map (TExists) ts).
Hint Constructors TYPEADT.

(* Program judgement assigns a type to a program. *)
Inductive TYPEPROG (ds : defs) : kienv -> tyenv -> prog -> ty -> Prop :=
| TYLet :
    (* forall ke te tr ms ts t2 p, *)
    (* TYPEADT ds ke te (IADT tr ms (map (TExists) ts)) (map (TExists) ts) *)
    (* -> TYPEPROG ds (ke :> KStar) ((liftTE 0 te) >< ts) p t2 *)
    (* -> TYPEPROG ds ke te (PLET (IADT tr ms (map (TExists) ts)) p) (substTT 0 tr t2) *)
    forall ke te tr ms ts t2 p,
    TYPEADT ds ke te (IADT tr ms (map (TExists) ts)) (map (TExists) ts)
    -> TYPEPROG ds (ke :> KStar) ((liftTE 0 te) >< ts) p (liftTT 0 t2)
    -> KIND ke t2 KStar (* derivable, after: [t2 -> (liftTT 0 t2)] ? *)
    -> TYPEPROG ds ke te (PLET (IADT tr ms (map (TExists) ts)) p) t2
| TYExp : forall ke te x t,
    TYPE ds ke te x t
    -> TYPEPROG ds ke te (PEXP x) t.

Ltac invert_adt_type :=
  repeat
    (match goal with
     | [ H : TYPEADT _ _ _ ?a _ |- _ ] => destruct a; inverts H
     end).

Ltac invert_exp_type :=
  repeat
    (match goal with
     | [ H: TYPE  _ _ _ (XVar  _)     _    |- _ ] => inverts H
     | [ H: TYPE  _ _ _ (XApp  _ _)   _    |- _ ] => inverts H
     | [ H: TYPE  _ _ _ (XTup _)   _    |- _ ] => inverts H
     | [ H: TYPE  _ _ _ (XProj  _ _)   _    |- _ ] => inverts H
     | [ H: TYPE  _ _ _ (XFix  _ _ _)   _    |- _ ] => inverts H
     | [ H: TYPE  _ _ _ (XNFun _ _)   _    |- _ ] => inverts H
     | [ H: TYPE  _ _ _ (XNApp  _ _)   _    |- _ ] => inverts H
     | [ H: TYPE  _ _ _ (XCon _ _) _    |- _ ] => inverts H
     | [ H: TYPE  _ _ _ (XMatch _ _)   _    |- _ ] => inverts H
     | [ H: TYPE  _ _ _ (XChoice _ _ _) _ |- _ ] => inverts H
     | [ H: TYPEA _ _ _ (AAlt _ _ _)    _ _  |- _ ] => inverts H
    end).

Ltac invert_prog_type :=
  repeat
    (match goal with
     | [ H : TYPEPROG _ _ _ _ _ |- _] => inverts H
    end).

Ltac inverts_method_type :=
  repeat
    (match goal with
     | [ H : TYPEMETHOD _ _ _ _ _ |- _ ] => inverts H
    end).

Ltac inverts_type :=
  repeat
    (match goal with
     | [ H : TYPE _ _ _ _ _ |- _ ] => inverts H
     | [ H : TYPEADT _ _ _ _ _ |- _ ] => inverts H
     | [ H : TYPEPROG _ _ _ _ _ |- _ ] => inverts H
     end).

Lemma Forall2_exists_right_in
 : forall {A B} (R: A -> B -> Prop) y xs ys
 ,             In y ys  -> Forall2 R xs ys
 -> (exists x, In x xs  /\         R x  y).
Proof.
 intros.
 induction H0.
  false.
  simpl in H. destruct H.
   subst.
   exists x. split. simpl. auto. auto.
   lets D: IHForall2 H.
   destruct D.
   exists x0.
    inverts H2.
    split. simpl. auto. auto.
Qed.

(* ----------------------------------------------------- *)
(* The type produced by a type judgement is well kinded. *)
Theorem type_kind
  : forall ds ke te x t,
    TYPE ds ke te x t
    -> KIND ke t KStar.
Proof.
 intros. gen ds ke te t.
 induction x using exp_mutind
   with (PA := fun a => forall ds ke te tBuilds tRes,
                   TYPEA ds ke te a tBuilds tRes
                   -> KIND ke tRes KStar);
   intros; try (first [inverts H | inverts H0]); eauto.

 Case "XApp".
 eapply IHx1 in H4. inverts H4. auto.

 Case "XTup".
 inverts H0. inverts H3.
 apply KINProd; auto.
 inverts keep H0.
 inverts keep H5.
 apply KINProd. apply Forall_cons.
 eapply H1; eauto.
 rewrite Forall_forall; intros.
 rename x0 into t.
 rename l0 into xs.
 nforall.
 pose proof (Forall2_exists_right_in _ _ _ _ H H7) as [x' [INx' TYx']].
 spec H2 INx' TYx'; auto.

 Case "XProj".
 spec IHx H4.
 inverts_kind.
 nforall.
 pose proof (get_in _ _ _ _ H6).
 spec H1 H; auto.

 Case "XNApp".
 inverts keep H0.
 inverts keep H6.
 spec IHx H4. inverts_kind; auto.
 inverts keep H0.
 spec IHx H6.
 inverts_kind; auto.

 Case "XCon".
 inverts H0; auto.
 inverts H0; auto.

 Case "XMatch".
 inverts keep H0; nope.
 inverts keep H0.
 repeat nforall.
 spec H5 x0.
 assert (In x0 (l0 :> x0)) by auto.
 spec H5 H. spec H1 H5; auto.

 Case "XChoice".
 inverts H0; auto.
 inverts H0; auto.
Qed.

Theorem type_kind_prog :
  forall ds ke te p t,
    TYPEPROG ds ke te p t
    -> KIND ke t KStar.
Proof.
  intros. gen ds ke te t.
  induction p; intros; inverts keep H; eauto.
  Case "Exp".
  eapply type_kind; eauto.
Qed.

(* A well typed expression is well formed. *)
Theorem type_wfX
  : forall ds ke te x t,
    TYPE ds ke te x t
    -> wfX ke te x.
Proof.
  intros. gen ds ke te t.
  induction x using exp_mutind
    with (PA := fun a => forall ds ke te tBuilds tRes,
                    TYPEA ds ke te a tBuilds tRes
                    -> wfA ke te a);
    intros; simpl.

  Case "XVar".
  inverts H. eauto.

  Case "XApp".
  inverts H.
  apply IHx1 in H4.
  apply IHx2 in H6.
  auto.

  Case "XTup".
  inverts keep H0.
  nforall.
  constructor.
  rewrite Forall_forall; intros.
  pose proof (Forall2_exists_left_in _ _ _ _ H1 H4) as [y [INy TYx]].
  eapply H; eauto.

  Case "XProj".
  inverts keep H.
  constructor. eapply IHx.
  eauto.

  Case "XNFun".
  inverts keep H.
  constructor.
  apply Forall_forall; intros.
  nforall. spec H4 H0.
  eapply kind_wfT; eauto.
  spec IHx H6; auto.

  Case "XNApp".
  inverts keep H0.
  spec IHx H5.
  constructor; auto.
  rewrite Forall_forall; intros.
  repeat nforall.
  spec H H1.
  pose proof (Forall2_exists_left_in _ _ _ _ H1 H7) as [y [INy TYx]].
  eapply H; eauto.

  Case "XFix".
  inverts keep H.
  constructor.
  eapply kind_wfT; eauto.
  pose proof (type_kind _ _ _ _ _ H).
  inverts_kind. eapply kind_wfT; eauto.
  eapply IHx; eauto.

  Case "XCon".
  inverts keep H0.
  constructor.
  repeat nforall. intros.
  pose proof (Forall2_exists_left_in _ _ _ _ H1 H10) as [y [INy TYx]].
  eapply H; eauto.

  Case "XMatch".
  inverts keep H0.
  repeat nforall.
  constructor.
  eapply IHx; eauto.
  rewrite Forall_forall; intros.
  spec H H1. spec H4 H1. spec H H4; auto.

  Case "XChoice".
  inverts keep H0.
  constructor. eapply kind_wfT; eauto.
  repeat nforall. intros.
  pose proof (Forall2_exists_left_in _ _ _ _ H1 H11) as [y [INy TYx]].
  eapply H; eauto.

  Case "Alt".
  inverts keep H. econstructor; eauto.
Qed.
Hint Resolve type_wfX.

Lemma In_tl (A : Type)
  : forall x l,
    @In A x (tl l)
    -> @In A x l .
Proof.
  intros.
  destruct l. nope.
  simpl in *; auto.
Qed.

(********************************************************************)
(* Weakening the kind environment of a type judgement.
   We can insert a new kind into the kind environment of a type
   judgement, provided we lift existing references to kinds higher
   than this in the stack over the new one.

   References to existing elements of the kind environment may
   appear in the type environment, expression, as well as the
   resulting type -- so we must lift all of them.
 *)
Lemma type_kienv_insert
  : forall ix ds ke te x1 t1 k2,
    TYPE ds ke te x1 t1
    -> TYPE ds (insert ix k2 ke)
           (liftTE ix te)
           (liftTX ix x1)
           (liftTT ix t1).
Proof.
  intros. gen ix ds ke te t1 k2.
  induction x1 using exp_mutind
    with (PA := fun a => forall ix ds ke te tBuilds tRes k2,
                    TYPEA ds ke te a tBuilds tRes
                    -> TYPEA ds (insert ix k2 ke) (liftTE ix te) (liftTA ix a)
                            (liftTT ix tBuilds) (liftTT ix tRes));
    intros; invert_exp_type; simpl; eauto.

  Case "XVar".
  apply TYVar.
  apply get_map. auto.
  apply liftTT_insert. auto.

  Case "XApp".
  eapply TYApp.
  eapply IHx1_1 in H4. simpl in H4. eauto.
  eapply IHx1_2 in H6. eauto.

  Case "XTup".
  eapply TYTup; simpl; auto.
  forall2_pull_in_maps.
  apply (Forall2_impl_in  (TYPE ds ke te)); eauto.
  nforall. intros.
  eapply H; eauto.

  Case "XProj".
  eapply TYProj; simpl; eauto.
  spec IHx1 H4. simpl in *; eauto.

  Case "XNFun".
  eapply TYNFun; eauto.
  apply Forall_map.
  repeat nforall; intros.
  apply liftTT_insert; auto.
  spec IHx1 H6.
  unfold liftTE in *.
  rewrite <- map_app; eauto.

  Case "XNApp".
  apply TYNApp with (ts := map (liftTT ix) ts).
  assert (liftTT ix (TNFun ts t1) = (TNFun (map (liftTT ix) ts) (liftTT ix t1))) by auto.
  rewrite <- H0.
  apply IHx1; auto.

  forall2_pull_in_maps.
  apply (Forall2_impl_in  (TYPE ds ke te)); eauto.
  nforall. intros.
  eapply H; eauto.

  Case "XFix".
  eapply TYFix. apply liftTT_insert; auto.
  unfold liftTE in *.
  assert (liftTT ix (TFun t1 t2) = (TFun (liftTT ix t1) (liftTT ix t2))) by auto.
  rewrite <- H.
  repeat rewrite <- map_cons.
  apply IHx1; auto.

  Case "XCon".
  eapply TYCon; eauto.
  forall2_pull_in_maps.
  apply (Forall2_impl_in  (TYPE ds ke te)); eauto.
  nforall; eauto.
  intros. spec H5 H1.
  assert (y = liftTT ix y).
  apply simpleLiftEq; auto.
  rewrite H6.
  nforall.
  apply H; auto.

  Case "XMatch".
  eapply TYMatch; eauto.
  assert (TCon tcPat = (liftTT ix (TCon tcPat))) by auto.
  rewrite H0.
  apply IHx1; auto.

  apply Forall_map.
  apply (Forall_impl_in (fun a => TYPEA ds ke te a (TCon tcPat) t1)); eauto.
  repeat nforall; intros.
  spec H H0. spec H H1. eauto.
  rewrite map_length; auto.

  repeat nforall.
  intros. rename x into d.
  rewrite map_map. unfold Basics.compose.
  eapply map_exists_in.
  have (In d (map dcOfAlt aa)).
  assert (exists a, dcOfAlt a = d /\ In a aa).
  eapply map_in_exists. auto.
  shift a. rip.
  eapply dcOfAlt_liftTA.

  Case "XChoice".
  eapply TYChoice; eauto.
  assert (t1 = liftTT ix t1).
  nforall. apply get_in in H8.
  spec H5 H8.
  apply simpleLiftEq; auto.
  rewrite <- H0; auto.
  apply liftTT_insert; auto.

  forall2_pull_in_maps.
  apply (Forall2_impl_in  (TYPE ds ke te)); eauto.
  nforall; eauto.
  intros. apply In_tl in H1. spec H5 H1.
  assert (y = liftTT ix y).
  apply simpleLiftEq; auto.
  rewrite H3.
  nforall.
  apply H; auto.

  Case "XAlt".
  eapply TYAlt; eauto.
  assert (map (liftTT ix) ts = ts).
  repeat nforall. rewrite <- map_id.
  apply map_ext_in; intros. symmetry.
  spec H6 H.
  apply (simpleLiftEq _ _ H6).
  rewrite H; auto.
  pose proof (simpleLiftMapEq _ ix H6).
  rewrite <- H; auto.

  rewrite Forall_forall; intros.
  repeat nforall.
  pose proof map_in_exists.
  apply H0 in H as [y [FY INY]].
  rewrite <- FY.
  apply liftTT_insert. apply H9; auto.

  unfold liftTE in *.
  rewrite <- map_app.
  apply IHx1; auto.
Qed.

Lemma type_kienv_weaken
  : forall ds ke te x1 t1 k2,
    TYPE ds ke te x1 t1
 -> TYPE ds (ke :> k2) (liftTE 0 te) (liftTX 0 x1) (liftTT 0 t1).
Proof.
 intros.
 assert (ke :> k2 = insert 0 k2 ke).
  destruct ke; auto. rewrite H0.
  apply type_kienv_insert. auto.
Qed.

(********************************************************************)
(* Weakening the type environment of a type judgement.
   We can insert a new type into the type environment of a type
   judgement, provided we lift existing references to types higher
   than this in the stack over the new one.
 *)
Lemma type_tyenv_insert
  : forall ds ke te ix x1 t1 t2,
    TYPE ds ke te x1 t1
    -> TYPE ds ke (insert ix t2 te) (liftXX 1 ix x1) t1.
Proof.
  intros. gen ds ix ke te t1 t2.
  induction x1 using exp_mutind
    with (PA := fun a => forall ds ke te ix tBuilds tRes t2,
                    TYPEA ds ke te a tBuilds tRes
                    -> TYPEA ds ke (insert ix t2 te) (liftXA 1 ix a) tBuilds tRes);
    intros; invert_exp_type; simpl; eauto.

  Case "XVar".
  lift_cases; intros; auto.

  Case "XTup".
  eapply TYTup; eauto.
  forall2_pull_in_maps.
  apply (Forall2_impl_in  (TYPE ds ke te)); eauto.
  nforall. eauto.

  Case "XNFun".
  eapply TYNFun; eauto.
  rewrite insert_app. auto.

  Case "XNApp".
  eapply TYNApp; eauto.
  forall2_pull_in_maps.
  apply (Forall2_impl_in  (TYPE ds ke te)); eauto.
  nforall. eauto.

  Case "XFix".
  eapply TYFix; eauto.
  repeat rewrite insert_rewind.
  apply IHx1; auto.

  Case "XCon".
  eapply TYCon; eauto.
  forall2_pull_in_maps.
  apply (Forall2_impl_in  (TYPE ds ke te)); eauto.
  repeat nforall. eauto.

  Case "XMatch".
  eapply TYMatch; eauto.
  apply Forall_map.
  apply (Forall_impl_in (fun a => TYPEA ds ke te a (TCon tcPat) t1)); eauto.
  repeat nforall. burn.

  rewrite map_length; auto.

  repeat nforall.
  intros. rename x into d.
  rewrite map_map. unfold Basics.compose.
  eapply map_exists_in.
  have (In d (map dcOfAlt aa)).
  assert (exists a, dcOfAlt a = d /\ In a aa).
  eapply map_in_exists. auto.
  shift a. rip.
  eapply dcOfAlt_liftXA.

  Case "XChoice".
  eapply TYChoice; eauto.
  forall2_pull_in_maps.
  apply (Forall2_impl_in  (TYPE ds ke te)); eauto.
  repeat nforall. eauto.

  Case "XAlt".
  eapply TYAlt; eauto.
  rewrite insert_app. auto.
Qed.

Lemma type_tyenv_weaken
  : forall ds ke te x1 t1 t2,
    TYPE ds ke te x1 t1
    -> TYPE ds ke (te :> t2) (liftXX 1 0 x1) t1.
Proof.
  intros.
  assert (te :> t2 = insert 0 t2 te).
  destruct te; auto. rewrite H0.
  apply type_tyenv_insert. auto.
Qed.

Lemma type_tyenv_weaken_append
  : forall ds ke te x1 t1 te',
    TYPE ds ke te x1 t1
    -> TYPE ds ke (te >< te') (liftXX (length te') 0 x1) t1.
Proof.
 intros.
 induction te'; simpl.
 rewrite liftXX_zero; auto.
 rewrite <- nat_plus_one.
 rrwrite (length te' + 1 = 1 + length te').
 rewrite <- liftXX_plus.
 eapply type_tyenv_weaken. auto.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.proposition_37.

Section Euclid.

Context `{Ax:area}.

Lemma proposition_39A :
   forall A B C D M,
   Triangle A B C -> ET A B C D B C -> BetS A M C -> Out B D M ->
   Par A D B C.
Proof.
intros.
assert (nCol A B C) by (conclude_def Triangle ).
assert (neq A B) by (forward_using lemma_NCdistinct).
let Tf:=fresh in
assert (Tf:exists m, (BetS A m B /\ Cong m A m B)) by (conclude proposition_10);destruct Tf as [m];spliter.
assert (Col A m B) by (conclude_def Col ).
assert (Col A B m) by (forward_using lemma_collinearorder).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (Col A B A) by (conclude_def Col ).
assert (neq A m) by (forward_using lemma_betweennotequal).
assert (nCol A m C) by (conclude lemma_NChelper).
assert (neq m C) by (forward_using lemma_NCdistinct).
assert (neq C m) by (conclude lemma_inequalitysymmetric).
rename_H H;let Tf:=fresh in
assert (Tf:exists H, (BetS C m H /\ Cong m H m C)) by (conclude lemma_extension);destruct Tf as [H];spliter.
assert (BetS B m A) by (conclude axiom_betweennesssymmetry).
assert (BetS C M A) by (conclude axiom_betweennesssymmetry).
assert (Cong m B m A) by (conclude lemma_congruencesymmetric).
assert (Cong B m A m) by (forward_using lemma_congruenceflip).
assert (Cong m C m H) by (conclude lemma_congruencesymmetric).
assert (~ Col B A H).
 {
 intro.
 assert (Col A m B) by (conclude_def Col ).
 assert (Col B A m) by (forward_using lemma_collinearorder).
 assert (neq B A) by (conclude lemma_inequalitysymmetric).
 assert (Col A H m) by (conclude lemma_collinear4).
 assert (Col H m A) by (forward_using lemma_collinearorder).
 assert (Col C m H) by (conclude_def Col ).
 assert (Col H m C) by (forward_using lemma_collinearorder).
 assert (neq m H) by (forward_using lemma_betweennotequal).
 assert (neq H m) by (conclude lemma_inequalitysymmetric).
 assert (Col m A C) by (conclude lemma_collinear4).
 assert (Col m A B) by (forward_using lemma_collinearorder).
 assert (neq A m) by (forward_using lemma_betweennotequal).
 assert (neq m A) by (conclude lemma_inequalitysymmetric).
 assert (Col A B C) by (conclude lemma_collinear4).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists E, (BetS B M E /\ BetS H A E)) by (conclude postulate_Euclid5);destruct Tf as [E];spliter.
assert (BetS H m C) by (conclude axiom_betweennesssymmetry).
assert (Col C m H) by (conclude_def Col ).
assert (Col m C H) by (forward_using lemma_collinearorder).
assert (eq m m) by (conclude cn_equalityreflexive).
assert (Col m C m) by (conclude_def Col ).
assert (nCol m C A) by (forward_using lemma_NCorder).
assert (neq m H) by (forward_using lemma_betweennotequal).
assert (nCol m H A) by (conclude lemma_NChelper).
assert (nCol A m H) by (forward_using lemma_NCorder).
assert (CongA A m H C m B) by (conclude proposition_15a).
assert (nCol H m A) by (forward_using lemma_NCorder).
assert (Col A m B) by (conclude_def Col ).
assert (Col A B m) by (forward_using lemma_collinearorder).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (Col A B B) by (conclude_def Col ).
assert (neq m B) by (forward_using lemma_betweennotequal).
assert (nCol m B C) by (conclude lemma_NChelper).
assert (CongA H m A A m H) by (conclude lemma_ABCequalsCBA).
assert (CongA H m A C m B) by (conclude lemma_equalanglestransitive).
assert (Cong m A m B) by (conclude lemma_congruencesymmetric).
assert (CongA m H A m C B) by (apply (proposition_04 m H A m C B);auto).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (neq B C) by (forward_using lemma_NCdistinct).
assert (neq C B) by (conclude lemma_inequalitysymmetric).
assert (Out C B B) by (conclude lemma_ray4).
assert (Out C m H) by (conclude lemma_ray4).
assert (CongA m H A H C B) by (conclude lemma_equalangleshelper).
assert (CongA H C B m H A) by (conclude lemma_equalanglessymmetric).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (neq H A) by (forward_using lemma_NCdistinct).
assert (Out H A A) by (conclude lemma_ray4).
assert (BetS H m C) by (conclude axiom_betweennesssymmetry).
assert (neq H m) by (forward_using lemma_betweennotequal).
assert (Out H m C) by (conclude lemma_ray4).
assert (CongA H C B C H A) by (conclude lemma_equalangleshelper).
assert (CongA C H A H C B) by (conclude lemma_equalanglessymmetric).
assert (CongA A H C B C H) by (conclude lemma_equalanglesflip).
assert (nCol B C H) by (conclude lemma_equalanglesNC).
assert (CongA B C H H C B) by (conclude lemma_ABCequalsCBA).
assert (CongA A H C H C B) by (conclude lemma_equalanglestransitive).
assert (Col C m H) by (conclude_def Col ).
assert (Col H C m) by (forward_using lemma_collinearorder).
assert (Col H m C) by (forward_using lemma_collinearorder).
assert (eq H H) by (conclude cn_equalityreflexive).
assert (Col H m H) by (conclude_def Col ).
assert (neq H C) by (forward_using lemma_betweennotequal).
assert (nCol H C A) by (conclude lemma_NChelper).
assert (TS A H C B) by (conclude_def TS ).
assert (Par A H C B) by (conclude proposition_27B).
assert (Col H A E) by (conclude_def Col ).
assert (Col A H E) by (forward_using lemma_collinearorder).
assert (Col A H A) by (conclude_def Col ).
assert (neq A E) by (forward_using lemma_betweennotequal).
assert (Par C B A H) by (conclude lemma_parallelsymmetric).
assert (Par C B A E) by (conclude lemma_collinearparallel2).
assert (Par A E C B) by (conclude lemma_parallelsymmetric).
assert (Par A E B C) by (forward_using lemma_parallelflip).
assert (ET A B C E B C) by (conclude proposition_37).
assert (ET D B C A B C) by (conclude axiom_ETsymmetric).
assert (ET D B C E B C) by (conclude axiom_ETtransitive).
assert (Out B M D) by (conclude lemma_ray5).
assert (neq B M) by (forward_using lemma_betweennotequal).
assert (Out B M E) by (conclude lemma_ray4).
assert (Out B D E) by (conclude lemma_ray3).
assert ((BetS B E D \/ eq D E \/ BetS B D E)) by (conclude lemma_ray1).
assert (Par A D B C).
by cases on (BetS B E D \/ eq D E \/ BetS B D E).
{
 assert (~ ~ Par A D B C).
  {
  intro.
  assert (~ ET D B C E B C) by (conclude axiom_deZolt1).
  contradict.
  }
 close.
 }
{
 assert (Par A D B C) by (conclude cn_equalitysub).
 close.
 }
{
 assert (~ ~ Par A D B C).
  {
  intro.
  assert (~ ET E B C D B C) by (conclude axiom_deZolt1).
  assert (ET E B C D B C) by (conclude axiom_ETsymmetric).
  contradict.
  }
 close.
 }
(** cases *)
close.
Qed.

End Euclid.


(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*               Intensional Lambda Calculus                          *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                           Substitution.v                           *)
(*                                                                    *)
(* adapted from Substitution.v for Lambda Calculus                    *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Lambda.Test.
Require Import Lambda.General.
Require Import Lambda.Terms.
Require Import Lambda.Substitution_term.
Require Import Lambda.Redexes.
Require Import Omega.

(****************************)
(*  Substitution of redexes *)
(****************************)

(* Similar to lift_rec of Terms *)

Fixpoint lift_rec_r (L : redexes) : nat -> nat -> redexes :=
  fun k n : nat =>
  match L with
  | Var i => Var (relocate i k n)
  | Ap b M N => Ap b (lift_rec_r M k n) (lift_rec_r N k n)
  | Fun M => Fun (lift_rec_r M (S k) n)
  end.

Definition lift_r (n : nat) (N : redexes) := lift_rec_r N 0 n.

Definition insert_Var (N : redexes) (i k : nat) :=
  match compare k i with

     (* k<i *) | inleft (left _) => Var (pred i)
   (* k=i *) | inleft _ => lift_r k N
   (* k>i *) | _ => Var i
  end.

(* Similar to subst_rec of Terms *)

Fixpoint subst_rec_r (L : redexes) : redexes -> nat -> redexes :=
  fun (N : redexes) (k : nat) =>
  match L with
  | Var i => insert_Var N i k
  | Ap b M M' => Ap b (subst_rec_r M N k) (subst_rec_r M' N k)
  | Fun M => Fun (subst_rec_r M N (S k))
  end.

Definition subst_r (N M : redexes) := subst_rec_r M N 0.

(* Lifting lemmas *)

Lemma lift_le :
 forall (n i k : nat), k <= i -> lift_rec_r (Var i) k n = Var (n + i).
Proof.
simpl in |- *; unfold relocate in |- *.
intros; elim (test k i); intro P; trivial with arith.
absurd (k > i); trivial with arith.
apply le_not_gt; trivial with arith.
Qed.

Lemma lift1 :
 forall (U : redexes) (j i k : nat),
 lift_rec_r (lift_rec_r U i j) (j + i) k = lift_rec_r U i (j + k).
Proof.
simple induction U; split_all; try (case b); split_all.
unfold relocate; elim (test i n); split_all.
elim (test (j + i) (j + n)); split_all.
elim plus_permute; elim plus_assoc; trivial with arith.
noway.
elim (test (j + i) n); simpl in |- *; intros; trivial with arith.
noway.

replace (S(j+i)) with (j+ S i) by omega.
rewrite H. auto.
Qed.

Lemma lift_lift_rec :
 forall (U : redexes) (k p n i : nat),
 i <= n ->
 lift_rec_r (lift_rec_r U i p) (p + n) k = lift_rec_r (lift_rec_r U n k) i p.
Proof.
simple induction U; simpl in |- *; intros; try (case b); split_all.
(* Var *)
unfold relocate in |- *.
elim (test n0 n); elim (test i n); simpl in |- *.
elim (test (p + n0) (p + n)); elim (test i (k + n)); simpl in |- *; intros.
rewrite plus_permute; trivial with arith.
absurd (i > n); auto with arith.
apply gt_le_trans with (k + n); trivial with arith.
absurd (n0 > n); auto with arith.
apply plus_gt_reg_l with p; trivial with arith.
absurd (n0 > n); auto with arith.
apply plus_gt_reg_l with p; trivial with arith.
intros; absurd (i > n); trivial with arith.
apply le_not_gt; apply le_trans with n0; trivial with arith.
intros; elim (test (p + n0) (p + n)); simpl in |- *; intros;
 trivial with arith.
absurd (n0 > n); trivial with arith.
apply le_not_gt; apply (fun p n m : nat => plus_le_reg_l n m p) with p;
 trivial with arith.
intros; elim (test (p + n0) n); simpl in |- *; intros; trivial with arith.
absurd (n0 > n); trivial with arith.
apply le_not_gt; apply le_trans with (p + n0); trivial with arith.
(* Ap *)

rewrite H; trivial with arith.
rewrite H0; trivial with arith.

rewrite H; trivial with arith.
rewrite H0; trivial with arith.

(* Fun *)
replace (S(p + n)) with (p + S n) by omega.
rewrite H; auto. omega.
Qed.

Lemma lift_lift :
 forall (U : redexes) (k p n : nat),
 lift_rec_r (lift_r p U) (p + n) k = lift_r p (lift_rec_r U n k).
Proof.
unfold lift_r in |- *; intros; apply lift_lift_rec; trivial with arith.
Qed.

(*
Lemma liftrecO : forall (U : redexes) (n : nat), lift_rec_r U n 0 = U.
Proof.
simple induction U; split_all; unfold relocate; elim (test n0 n); split_all.
Qed.

Lemma liftO : forall U : redexes, lift_r 0 U = U.
Proof.
unfold lift_r in |- *; intro U; apply liftrecO.
Qed.

*)

Lemma lift_rec_lift_rec :
 forall (U : redexes) (n p k i : nat),
 k <= i + n ->
 i <= k -> lift_rec_r (lift_rec_r U i n) k p = lift_rec_r U i (p + n).
Proof.
simple induction U; simpl in |- *; intros; split_all.
(* Var *)
unfold relocate in |- *; elim (test i n); intro P.
elim (test k (n0 + n)); intro Q.
rewrite plus_assoc_reverse; trivial with arith.
absurd (k > n0 + n); trivial with arith.
apply le_not_gt; apply le_trans with (i + n0); trivial with arith.
replace (i + n0) with (n0 + i); auto with arith; apply plus_le_compat_l;
 trivial with arith.
elim (test k n); intro Q; trivial with arith.
absurd (i > k).
apply le_not_gt; trivial with arith.
apply gt_le_trans with n; trivial with arith.
(* Ap *)
rewrite H; trivial with arith; rewrite H0; trivial with arith.
(* Fun *)
rewrite H; trivial with arith; try omega.
Qed.

Lemma lift_rec_lift :
 forall (U : redexes) (n p k i : nat),
 k <= n -> lift_rec_r (lift_r n U) k p = lift_r (p + n) U.
Proof.
unfold lift_r in |- *; intros; rewrite lift_rec_lift_rec; trivial with arith.
Qed.

(* The three cases of substitution of U for (Var n) *)

Lemma subst_eq :
 forall (M U : redexes) (n : nat),
  subst_rec_r (Var n) U n = lift_r n U.
Proof.
simpl in |- *; unfold insert_Var in |- *.
intros; elim (compare n n); intro P.
elim P; intro Q; simpl in |- *; trivial with arith.
absurd (n > n); trivial with arith.
absurd (n > n); trivial with arith.
Qed.

Lemma subst_gt :
 forall (M U : redexes) (n p : nat),
 n > p -> subst_rec_r (Var n) U p =  Var (pred n).
Proof.
simpl in |- *; unfold insert_Var in |- *.
intros; elim (compare p n); intro P.
elim P; intro Q; trivial with arith.
absurd (n > p); trivial with arith; rewrite Q; trivial with arith.
absurd (n > p); auto with arith.
Qed.

Lemma subst_lt :
 forall (U : redexes) (n p : nat), p > n -> subst_rec_r (Var n) U p = Var n.
Proof.
simpl in |- *; unfold insert_Var in |- *.
intros; elim (compare p n); intro P; trivial with arith.
absurd (p > n); trivial with arith; elim P; intro Q; auto with arith.
rewrite Q; trivial with arith.
Qed.

(* Substitution lemma *)

Lemma lift_rec_subst_rec :
 forall (V U : redexes) (k p n : nat),
 lift_rec_r (subst_rec_r V U p) (p + n) k =
 subst_rec_r (lift_rec_r V (S (p + n)) k) (lift_rec_r U n k) p.
Proof.
simple induction V; split_all.
(* 2 Fun *)
2: replace (S(p + n)) with (S p +  n) by omega;  rewrite H; auto.
(* 1 Var *)
unfold insert_Var, relocate in |- *.
elim (compare p n); intro P.
(* 1.1  P : {(gt n p)}+{p=n} *)
elim P; intro P1.
(* 1.1.1 P1 : (gt n p) *)
elim (test (S (p + n0)) n); intro Q.
(* 1.1.1.1 Q : (le (S (plus p n0)) n) *)
elim (compare p (k + n)); intro R.
(* 1.1.1.1.1 R : {(lt p (plus k n))}+{p=(plus k n)} *)
elim R; intro R1; simpl in |- *.
(* 1.1.1.1.1.1 R1 : (lt p (plus k n)) *)
unfold relocate in |- *.
elim (test (p + n0) (pred n)); intro S.
assert(k+ pred n = pred (k+n)) by omega.
rewrite H; auto.
noway.
noway.
noway.
elim (compare p n); intro R.
(* 1.1.1.2.1  R : {(lt p n)}+{p=n} *)
elim R; intro R1.
simpl.
unfold relocate.
(* 1.1.1.2.1.1  R1 : (lt p n) *)
elim (test (p + n0) (pred n)); intro C.
noway.
auto.
noway.
noway.
elim (test (S (p + n0)) n); intro Q.
(* 1.1.2.1  Q : (le (S (plus n n0)) n) *)
noway.
subst.
(* 1.1.2.2  Q : (gt (S (plus n n0)) n) *)
elim (compare n n); intro R.
(* 1.1.2.2.1  R : {(lt n n)}+{n=n} *)
elim R; intro R1.
noway.
rewrite lift_lift; trivial with arith.
noway.
(* 1.2  P : (gt p n) *)
elim (test (S (p + n0)) n); intro Q.
(* 1.2.1  Q : (le (S (plus p n0)) n) *)
noway.
elim (compare p n); intro R.
(* 1.2.2.1  R : {(lt p n)}+{p=n} *)
elim R; intro R1; try noway.
simpl.
unfold relocate.
elim(test (p+n0) n); split_all; try noway.
Qed.

Lemma lift_subst :
 forall (U V : redexes) (k n : nat),
 lift_rec_r (subst_r U V) n k =
 subst_r (lift_rec_r U n k) (lift_rec_r V (S n) k).
Proof.
unfold subst_r in |- *; intros.
replace (S n) with (S (0 + n)).
elim lift_rec_subst_rec; trivial with arith.
simpl in |- *; trivial with arith.
Qed.

Lemma subst_rec_lift_rec1 :
 forall (U V : redexes) (n p k : nat),
 k <= n ->
 subst_rec_r (lift_rec_r U k p) V (p + n) =
 lift_rec_r (subst_rec_r U V n) k p.
Proof.
simple induction U; intros; simpl in |- *; split_all.
(* Var *)
unfold relocate.
elim(test k n); split_all; try noway.
unfold insert_Var.
elim(compare (p+n0) (p+n)); elim(compare n0 n); split_all; try noway.
elim a1; split_all; try noway.
elim a0; split_all; try noway.
unfold relocate.
elim(test k (pred n)); split_all; try noway.
assert(pred (p+n) = p + pred n) by omega.
rewrite H0; split_all.
elim a0; split_all; try noway.
rewrite lift_rec_lift; split_all.
elim a0; split_all; try noway.
elim a0; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.

unfold insert_Var.
elim(compare n0 n); split_all; try noway.
elim a; split_all; try noway.
elim(compare (p+n0) n); split_all; try noway.
elim a; split_all; try noway.
unfold relocate.
elim(test k n); split_all; try noway.

rewrite H; split_all. rewrite H0; split_all.

replace (S(p + n)) with (p + (S n)) by omega.
rewrite H; auto; try omega.
Qed.

Lemma subst_rec_lift1 :
 forall (U V : redexes) (n p : nat),
 subst_rec_r (lift_r p U) V (p + n) = lift_r p (subst_rec_r U V n).
Proof.
unfold lift_r in |- *; intros; rewrite subst_rec_lift_rec1;
 trivial with arith.
Qed.

Lemma subst_rec_lift_rec :
 forall (U V : redexes) (p q n : nat),
 q <= p + n ->
 n <= q -> subst_rec_r (lift_rec_r U n (S p)) V q = lift_rec_r U n p.
Proof.
simple induction U; intros; simpl in |- *; try (case b); split_all.

unfold insert_Var, relocate in |- *; simpl in |- *.
elim (test n0 n); intro P.
(* 1  P : (le n0 n) *)
elim (compare q (S (p + n))); intro Q; try noway.
(* 1.1  Q : {(lt q (S (plus p n)))}+{q=(S (plus p n))} *)
elim Q; intro Q1; simpl in |- *; trivial with arith; try noway.
elim (compare q n); intro Q; trivial with arith; try noway.
(* 2.1 Q : {(lt n q)}+{q=n} *)
elim Q; intro Q1; simpl in |- *; trivial with arith; try noway.
rewrite H; split_all.
rewrite H0; split_all.

rewrite H; split_all.
rewrite H0; split_all.

rewrite H; split_all; try omega.
Qed.

Lemma subst_rec_lift :
 forall (U V : redexes) (p q : nat),
 q <= p -> subst_rec_r (lift_r (S p) U) V q = lift_r p U.
Proof.
unfold lift_r in |- *; intros; rewrite subst_rec_lift_rec; trivial with arith.
elim plus_n_O; trivial with arith.
Qed.

(* subst_rec_subst_rec *)

Lemma subst_rec_subst_rec :
 forall (V U W : redexes) (n p : nat),
 subst_rec_r (subst_rec_r V U p) W (p + n) =
 subst_rec_r (subst_rec_r V W (S (p + n))) (subst_rec_r U W n) p.
Proof.
simple induction V; split_all.
2: replace (S(p+n)) with (S p+n) by omega; rewrite H; split_all.

unfold insert_Var in |- *.
elim (compare p n); intro C.
(* 1.1  C : {(lt p n)}+{p=n} *)
elim C; intro D.
(* 1.1.1  D : (lt p n) *)
elim (compare (S (p + n0)) n); intro P; try noway.
(* 1.1.1.1  P : {(lt (S (plus p i)) n)}+{(S (plus p i))=n} *)
elim P; intro P1; try noway.
simpl.
unfold insert_Var.
elim(compare (p+n0) (pred n)); split_all.
elim a; split_all; try noway.
elim(compare p (pred n)); split_all; try noway.
elim a1; split_all; try noway.
elim(compare p (pred n)); split_all; try noway.

simpl.
unfold insert_Var.
elim(compare (p+n0) (pred n)); split_all.
elim a; split_all; try noway.
rewrite subst_rec_lift. auto.
omega.
noway.

simpl.
unfold insert_Var.
elim(compare (p+n0) (pred n)); split_all.
elim a; split_all; try noway.
elim(compare p n); split_all; try noway.
elim a; split_all; try noway.

elim(compare (S(p+n0)) n); split_all; try noway.
elim a; split_all; try noway.
unfold insert_Var.
elim(compare p n); split_all.
elim a; split_all; try noway.
rewrite subst_rec_lift1. auto.
noway.

elim(compare (S (p + n0)) n); split_all; try noway.
elim a; split_all; try noway.
unfold insert_Var.
elim(compare (p+n0) n); split_all; try noway.
elim a; split_all; try noway.
elim(compare p n); split_all; try noway.
elim a; split_all; try noway.
Qed.

Lemma subst_rec_subst_0 :
 forall (U V W : redexes) (n : nat),
 subst_rec_r (subst_rec_r V U 0) W n =
 subst_rec_r (subst_rec_r V W (S n)) (subst_rec_r U W n) 0.
Proof.
intros; pattern n at 1 3 in |- *.
replace n with (0 + n).
rewrite (subst_rec_subst_rec V U W n 0); trivial with arith.
simpl in |- *; trivial with arith.
Qed.

(**************************)
(* The Substitution Lemma *)
(**************************)

Lemma substitution :
 forall (U V W : redexes) (n : nat),
 subst_rec_r (subst_r U V) W n =
 subst_r (subst_rec_r U W n) (subst_rec_r V W (S n)).
Proof.
unfold subst_r in |- *; intros; apply subst_rec_subst_0; trivial with arith.
Qed.

(* Substitution preserves compatibility *)

Lemma lift_rec_preserve_comp :
 forall U1 V1 : redexes,
 comp U1 V1 -> forall n m : nat, comp (lift_rec_r U1 m n) (lift_rec_r V1 m n).
Proof. simple induction 1; simpl in |- *; intro b; case b; split_all. Qed.

Lemma subst_rec_preserve_comp :
 forall U1 V1 : redexes, comp U1 V1 ->
 forall U2 V2,  comp U2 V2 ->
 forall n : nat, comp (subst_rec_r U1 U2 n) (subst_rec_r V1 V2 n).
Proof.
simple induction 1; simpl in |- *; auto with arith.
split_all; unfold insert_Var.
 elim (compare n i); split_all.
elim a; split_all.
unfold lift_r.
eapply2 lift_rec_preserve_comp.
Qed.

Lemma subst_preserve_comp :
 forall U1 V1 U2 V2 : redexes,
 comp U1 V1 -> comp U2 V2 -> comp (subst_r U2 U1) (subst_r V2 V1).
Proof.
intros; unfold subst_r in |- *; apply subst_rec_preserve_comp;
 trivial with arith.
Qed.

(* Substitution preserves regularity *)

Lemma lift_rec_preserve_regular :
 forall U : redexes,
 regular U -> forall n m : nat, regular (lift_rec_r U m n).
Proof.
simple induction U; simpl in |- *; auto with arith; split_all.
gen2_case H H1 b.
gen2_case H H1 r.
Qed.

Lemma subst_rec_preserve_regular :
 forall U V : redexes,
 regular U -> regular V -> forall n : nat, regular (subst_rec_r U V n).
Proof.
intro U; elim U; simpl in |- *; auto with arith; split_all.
unfold insert_Var in |- *; elim (compare n0 n); split_all.
elim a; split_all.
unfold lift_r in |- *; apply lift_rec_preserve_regular;
 trivial with arith.
gen_case H1 b.
gen2_case H H1 r.
Qed.

Lemma subst_preserve_regular :
 forall U V : redexes, regular U -> regular V -> regular (subst_r U V).
Proof.
unfold subst_r in |- *; intros; apply subst_rec_preserve_regular;
 trivial with arith.
Qed.


Require Import Platform.Cito.FreeVarsExpr.
Require Import Platform.Cito.Syntax.
Require Import Bedrock.StringSet.
Require Import Platform.Cito.Option.
Require Import Platform.Cito.Union.
Import StringSet.

Set Implicit Arguments.

Local Notation e_free_vars := FreeVarsExpr.free_vars.

Fixpoint free_vars (s : Syntax.Stmt) :=
  match s with
    | Syntax.Skip => empty
    | Syntax.Seq a b => union (free_vars a) (free_vars b)
    | Syntax.If cond t f => union (union (e_free_vars cond) (free_vars t)) (free_vars f)
    | Syntax.While cond body => union (e_free_vars cond) (free_vars body)
    | Syntax.Call var f args =>
      union
        (union
           (default empty (option_map singleton var))
           (e_free_vars f))
        (union_list (List.map e_free_vars args))
    | Syntax.Label x lbl => singleton x
    | Syntax.Assign x e => union (singleton x) (e_free_vars e)
  end.


(** * strandspace.v: Basic Strand Space Definitions *)

(* Created by Andrew Kent
   Brigham Young University
 *)

(* Source Material(s):

1) Strand Spaces: Proving Security Protocols Correct.
   F. Javier Thayer Fabrega, Jonathan C. Herzog, Joshua D. Guttman.
   Journal of Computer Security, 7 (1999), pages 191-230.
   http://web.cs.wpi.edu/~guttman/pubs/jcs_strand_spaces.pdf

2) Authentication tests and the structure of bundles.
   Joshua D. Guttman, F. Javier Thayer, Theoretical Computer Science,
   v.283 n.2, p.333-380, June 14, 2002.
   http://www.mitre.org/work/tech_papers/tech_papers_01/guttman_bundles/
 *)
Require Import Logic List ListSet Arith Peano_dec Omega.
Require Import Relation_Definitions Relation_Operators.
Require Import ProofIrrelevance.
Require Import CoLoRRelDec CoLoRRelSub.
Require Import Ensembles.
Require Import strictorder set_rep_equiv util.
Require Import LibTactics.

Module SS.

(* atomic messages *)
Variable Text : Set.
Variable eq_text_dec : forall (x y:Text), {x = y} + {x <> y}.
Hint Resolve eq_text_dec.

(* representing kryptographic key *)
Variable Key : Set.
Variable eq_key_dec : forall (x y:Key), {x = y} + {x <> y}.
Hint Resolve eq_key_dec.

Variable Inv : relation Key.
(* Used to indicate two keys are cryptographic
   inverses of eachother. *)

(* message or text, comprising the set of terms "A" *)
Inductive Term : Type :=
| term_text : Text -> Term
| term_key  : Key  -> Term
| term_join : Term  -> Term -> Term
| term_encr : Key  -> Term -> Term.
(* [REF 1] Section 2.1 pg 5
           Section 2.3 pg 9 *)
(* [REF 2] pg 4 paragraph 3 (details of encryption and subterms) *)
Hint Constructors Term.

Definition eq_term_dec : forall x y : Term,
  {x = y} + {x <> y}.
Proof. decide equality. Qed.

Notation "(! x )" := (term_text x) : ss_scope.
Notation "(# k )" := (term_key k) : ss_scope.
Notation "x * y" := (term_join x y) (at level 40, left associativity) : ss_scope.
Notation "{ m }^[ k ] " := (term_encr k m) (at level 0, m at level 99, k at level 99) : ss_scope.

Open Scope ss_scope.

(* subterm relationship for messages *)
(* subterm -> encompassing term -> Prop *)
Inductive Subterm : relation Term :=
| st_refl : forall m, Subterm m m
| st_join_l : forall st l r,
    Subterm st l -> Subterm st (l*r)
| st_join_r : forall st l r,
    Subterm st r -> Subterm st (l*r)
| st_encr : forall st t k,
    Subterm st t -> Subterm st ({t}^[k]).
(* [REF 1] Section 2.1 pg 6 and Definition 2.11 *)
Hint Constructors Subterm.

Notation "a <st b" := (Subterm a b) (at level 30) : ss_scope.

(* signed message, + (tx) or - (rx) *)
Inductive STerm : Type :=
| term_tx : Term -> STerm
| term_rx : Term -> STerm.
(* [REF 1] Definition 2.1 pg 6
   They are defined as a pair, w/ the first member being in {+, -}
   and the second a signed message. *)
Hint Constructors STerm.

Definition eq_sterm_dec : forall x y : STerm,
  {x = y} + {x <> y}.
Proof. intros. decide equality; apply eq_term_dec. Qed.

Notation "(+ x )" := (term_tx x) : ss_scope.
Notation "(- x )" := (term_rx x) : ss_scope.

(* strand *)
Definition Strand : Type := list STerm.
(* [REF 1] First sentence of Abstract: "sequence of events"
   Haven't hit a better def, and they start using strands
   pretty early so I'm rolling with this. *)

Definition eq_strand_dec : forall x y : Strand,
  {x = y} + {x <> y}.
Proof. intros. decide equality; apply eq_sterm_dec. Qed.

(* node in a strand space *)
Definition Node : Type := {n: (Strand * nat) | (snd n) < (length (fst n))}.
(* [REF 1] Definition 2.3.1 pg 6
   -"A node is a pair <s,i> where s is a strand and i a nat in [0, (length s))"
     NOTE: changed to be 0 based instead of 1 based sequences
   -"node <s,i> belongs to strand s"
   -"Every node belongs to a unique strand" *)

Definition eq_node_dec : forall x y : Node,
 {x = y} + {x <> y}.
Proof.
  intros [[xs xn] xp] [[ys yn] yp].
  destruct (eq_strand_dec xs ys) as [EQs | NEQs]; subst.
  destruct (eq_nat_dec xn yn) as [EQn | NEQn]; subst.
  left. rewrite (proof_irrelevance (lt yn (length ys)) xp yp). reflexivity.

  right. intros C. inversion C. auto.
  right. intros C. inversion C. auto.
Qed.
Hint Resolve eq_node_dec.

Definition Edge : Type := (prod Node Node).

(* index of a node *)
Definition index (n:Node) : nat :=
  match n with
    | exist npair _
      => snd npair
  end.
(* [REF 1] Definition 2.3.2 pg 6
   "If n = <s,i> then index(n) = i." *)

(* strand of a node *)
Definition strand (n:Node) : Strand :=
  match n with
    | exist npair _
      => fst npair
  end.
(* [REF 1] Definition 2.3.2 pg 6
   "If n = <s,i> then ... strand(n) = s." *)

(* signed message of a node *)
Fixpoint Node_sterm_option (n:Node) : (option STerm) :=
  match n with
    | exist (s, i) p
      =>  nth_error s i
  end.
(* [REF 1] Definition 2.3.2 pg 6
   "Define term(n) to be the ith signed term of the trace of s." *)

Lemma nth_error_len :
forall {X:Type} {l:list X} i,
  None = nth_error l i -> (length l) <= i.
Proof.
  intros X l i. generalize dependent l.
  induction i.
  Case "i = 0".
    intros l H.
    unfold nth_error in H.
    unfold error in H.
    destruct l.
    auto. inversion H.
  Case "i = S i".
    intros l' H.
    destruct l'.
    simpl; omega.
    inversion H.
    apply IHi in H1.
    simpl. omega.
Qed.

Lemma node_sterm_valid :
forall (n:Node), {m:STerm | Some m = Node_sterm_option n}.
Proof.
  intros n.
  remember (Node_sterm_option n) as funcall.
  destruct n. destruct funcall.
  exists s. reflexivity.

  unfold Node_sterm_option in Heqfuncall.
  destruct x. simpl in l.
  apply nth_error_len in Heqfuncall.
  omega.
Qed.

(* signed message of a node *)
Definition sterm (n:Node) : STerm :=
  match node_sterm_valid n with
    | exist m _ => m
  end.

Definition sterm_term (s:STerm) : Term :=
  match s with
    | (+t) => t
    | (-t) => t
  end.

(* unsigned message of a node *)
Definition term (n:Node) : Term :=
  sterm_term (sterm n).
(* [REF 1] Definition 2.3.2 pg 6
   "Define uns_term(n) to be the unsigned part of the ith signed term
    of the trace of s." *)

Definition is_tx (n:Node) : Prop :=
exists t, sterm n = (+ t).

Definition is_rx (n:Node) : Prop :=
exists t, sterm n = (- t).

Inductive Comm : relation Node :=
| comm :  forall n m t, ((sterm(n) = (+t)
                          /\ sterm(m) = (-t))
                         /\ strand(n) <> strand(m))
                        -> Comm n m.
(* [REF 1] Definition 2.3.3 pg 6
   "there is an edge n1 -> n2 iff term(n1) = +a and term(n2) = -a ...
   recording a potential causal link between those strands**"
  **We take this to mean a causal link between two *different*
  strands, as this is logical, and fits numerous informal
  descriptions in the literature such as "A strand (process)
  may send or receive a message but not both at the
  same time". *)

Notation "a --> b" := (Comm a b) (at level 0, right associativity)  : ss_scope.

Inductive Comm' : set Node -> relation Node :=
| comm' : forall N n m, set_In n N ->
                        set_In m N ->
                        n --> m ->
                        Comm' N n m.

Notation "a -[ N ]-> b" := (Comm' N a b) (at level 0, right associativity)  : ss_scope.

(* successor edge *)
(* node's direct predecessor -> node -> Prop *)
Inductive Successor : relation Node :=
| succ : forall i j, strand(i) = strand(j)
                       -> index(i) + 1 = index(j)
                       -> Successor i j.
(* [REF 1] Definition 2.3.4 pg 6
   "When n1= <s,i> and n2=<s,i+1> are members of N (set of node), there is
    an edge n1 => n2." *)

Notation "a ==> b" := (Successor a b)  (at level 0, right associativity) : ss_scope.

Inductive Successor' : set Node -> relation Node :=
| succ' : forall N n m, set_In n N ->
                        set_In m N ->
                        n ==> m ->
                        Successor' N n m.

Notation "a =[ N ]=> b" := (Successor' N a b)  (at level 0, right associativity) : ss_scope.

(* succecessor multi edge (not nec. immediate succecessor) *)
(* node's eventual succecessor -> node -> Prop *)
Definition StrandPath : relation Node :=
clos_trans Successor.
 (* [REF 1] Definition 2.3.4 pg 6
   "ni =>+ nj means that ni precedes nj (not necessarily immediately) on
    the same strand." *)
Hint Constructors clos_trans.

Notation "a ==>+ b" := (StrandPath a b)  (at level 0, right associativity) : ss_scope.

Definition StrandPath' (N: set Node) : relation Node :=
clos_trans (Successor' N) .

Notation "a =[ N ]=>+ b" := (StrandPath' N a b)  (at level 0, right associativity) : ss_scope.

Definition SSEdge : relation Node :=
union Comm Successor.
Hint Constructors or.

Notation "a =-> b" := (SSEdge a b) (at level 0, right associativity) : ss_scope.

Definition SSEdge' (N:set Node) : relation Node :=
union (Comm' N) (Successor' N).

Notation "a =[ N ]-> b" := (SSEdge' N a b) (at level 0, right associativity) : ss_scope.

(* transitive closure of edges. *)
Definition SSPath : relation Node :=
clos_trans SSEdge.

Notation "a << b" := (SSPath a b) (at level 0, right associativity) : ss_scope.

Definition SSPath' (N:set Node) :=
clos_trans (SSEdge' N).

Notation "a <[ N ]< b" := (SSPath' N a b) (at level 0, right associativity) : ss_scope.

(* transitive reflexive closure of edges. *)
Definition SSPathEq : relation Node :=
clos_refl_trans SSEdge.

Notation "a <<* b" := (SSPathEq a b) (at level 0, right associativity) : ss_scope.

Inductive SSPathEq' (N:set Node) : relation Node :=
| sspatheq'_refl : forall n, set_In n N -> SSPathEq' N n n
| sspatheq'_trans : forall n m, n <[N]< m -> SSPathEq' N n m.

Notation "a <[ N ]<* b" := (SSPathEq' N a b) (at level 0, right associativity) : ss_scope.

(* In for members of pairs *)
Inductive InPair {X:Type} (x:X) (E:set (X*X)): Prop :=
| inp_l : (exists y, set_In (x,y) E)
          -> InPair x E
| inp_r : (exists y, set_In (y,x) E)
          -> InPair x E.
Hint Constructors InPair.

Record Bundle : Type :=
{
  (* Prop 1 - A bundle is a finite portion of a strand space *)
  Nodes : set Node;
  Edges : set Edge;
  NodesSetP : NoDup Nodes;
  EdgesSetP : NoDup Edges;
  ValidEdges:
    (* N is the set of nodes incident with any edge in E *)
    (and (forall x, InPair x Edges -> set_In x Nodes)
    (* membership in Edge is equiv to an actual edge
      (assuming set membership) *)
    (forall x y, set_In (x,y) Edges <-> x =[Nodes]-> y));
  PredIncl:
    (* Prop 3 - Predececcors on a strand are included *)
    (forall x y, set_In y Nodes -> x ==> y -> x =[Nodes]=> y);
  TxIncl:
    (* Prop 2 - Transmitter is in Bundle *)
    (forall x y, set_In y Nodes -> x --> y -> x -[Nodes]-> y);
  ExistsUniqueTx:
    (* Prop 2 - Rx implies there exists a unique Tx *)
    (forall z m, set_In z Nodes ->
                 sterm(z) = (- m) ->
                 (* there exists a transmitter *)
                 (exists x, x -[Nodes]-> z)
                 (* Prop 2 - a transmitter is unique *)
                 /\ (forall x y, x --> z ->
                                 y --> z ->
                                 x = y));
  (* Prop 4 - The Bundle is acyclic*)
  Acyclic: forall x, ~ x <[Nodes]< x
}.

Notation "a -{ B }-> b"
  := (Comm' (Nodes B) a b) (at level 0, right associativity)  : ss_scope.
Notation "a ={ B }=> b"
  := (Successor' (Nodes B) a b)  (at level 0, right associativity) : ss_scope.
Notation "a ={ B }=>+ b"
  := (StrandPath' (Nodes B) a b)  (at level 0, right associativity) : ss_scope.
Notation "a ={ B }-> b"
  := (SSEdge' (Nodes B) a b) (at level 0, right associativity) : ss_scope.
Notation "a <{ B }< b"
  := (SSPath' (Nodes B) a b) (at level 0, right associativity) : ss_scope.
Notation "a <{ B }<* b"
  := (SSPathEq' (Nodes B) a b) (at level 0, right associativity) : ss_scope.

Definition bundle_height (B:Bundle) (s:Strand) (h:nat) : Prop :=
forall n:Node, index n < h ->
               strand n = s ->
               set_In n (Nodes B).

Definition set_minimal (B:Bundle) (N:set Node) (n:Node) : Prop :=
subset N (Nodes B) /\
set_In n N /\
forall n', set_In n' N -> ~ n' <{B}< n.

Definition OccursIn (t:Term) (n:Node) : Prop :=
 t <st term(n).
 (* [REF 1] Definition 2.3.5 pg 6
   "An unsigned term t occurs in n iff t is a subterm of the term of n" *)

Definition EntryPoint (n:Node) (tP: Term -> Prop) : Prop :=
tP (term n)
/\ is_tx n
/\ forall n', n' ==>+ n -> ~ tP (term n').

Definition Origin (t:Term) (n:Node) : Prop :=
EntryPoint n (fun t' => t <st t').

Definition SecretIn (t:Term) (B:Bundle) : Prop :=
forall n, set_In n (Nodes B) ->
          term n <> t.
(* [REF 1] pg 16
   "A value x is secret in a bundle C if for every
    n in C, term(n) <> x." *)

Definition UniqOrigin (t:Term) : Prop :=
exists n, Origin t n
/\ forall m, Origin t m -> n = m.
 (* [REF 1] Definition 2.3.8 pg 7
   "An unsigned term t is uniquely originating iff t originates on
    a unique n." *)

Definition Ideal (I : set Term) (K: set Key) : Prop :=
  forall h,
    set_In h I ->
    (forall g, (set_In (h * g) I /\ set_In (g * h) I)) /\
    (forall k, set_In k K -> set_In {h}^[k] I).

Definition IdealK (I : set Term) (K : set Key) (h : Term) : Prop :=
Ideal I K /\
set_In h I /\
forall I',
  Ideal I' K ->
  set_In h I' ->
  length I < length I'.

Inductive SimpleTerm (t : Term) : Prop :=
| sim_term_k : forall k, t = (#k) -> SimpleTerm t
| sim_term_t : forall t', t = (!t') -> SimpleTerm t
| sim_term_c : forall k t', t = {t'}^[k] -> SimpleTerm t.

Notation "a -{ B }-> b"
  := (Comm' (Nodes B) a b) (at level 0, right associativity)  : ss_scope.

(* Axiom 1 -- provable in this context *)
Theorem free_encryption : forall m1 m2 k1 k2,
{m1}^[k1] = {m2}^[k2] -> m1 = m2 /\ k1 = k2.
Proof.
  intros m m' k k' encreq.
  inversion encreq. split; auto.
Qed.
 (* [REF 1] Definition 2.4 Axiom 1 pg 10
   "A cipher text can be regarded as a cipher text in
   just one way."

   NOTE: This was an Axiom in the paper... but in Coq
   with these definitions this is provable... or
   inherently implied by the definitions/structures
*)

(* Axiom 2 -- provable in this context *)
Theorem free_term_algebra : forall m m' n n' k k' t,
(m * n = m' * n' -> m = m' /\ n = n')
/\ m * n <> {m'}^[k]
/\ (#k) <> m * n
/\ (!t) <> m * n
/\ (#k) <> {m}^[k']
/\ (!t) <> {m}^[k].
Proof.
  intros m m' n n' k k' t;
  split. intros eq. inversion eq; auto.
  split. intros F. inversion F.
  split. intros F. inversion F.
  split. intros F. inversion F.
  split. intros F. inversion F.
  intros F. inversion F.
Qed.

Fixpoint width (m:Term) : nat :=
match m with
| term_text _ => 1
| term_key _ => 1
| term_encr _  _ => 1
| term_join x y => width x + width y
end.
(* [REF 1] Definition 2.10 *)

(* Meta Strand Space properties/objects *)
(* [REF 1]
           Page 4 "One may think of a strand space as containing all the
                   legitimate executions of the protocol expected within
                   its useful lifetime, together with all the actions that
                   a penetrator might apply to messages contained in those
                   executions."

           Definition 2.2 pg 6 "A strand space over A (set of possible terms)
           is a set E with a trace mapping tr : E -> list sterm" *)

Variable Protocol : set Strand.
Definition RegularStrand (s:Strand) := set_In s Protocol.
Definition RegularNode (n:Node) := RegularStrand (strand n).
Variable Penetrators : Ensemble Strand.
Definition PenetratorStrand (s:Strand) := In Strand Penetrators s.
Definition PenetratorNode (n:Node) := PenetratorStrand (strand n).
Variable PenetratorModel : Strand -> Prop.
 Hypothesis penetrator_behaviour :
   forall s, PenetratorStrand s -> PenetratorModel s.

Hypothesis strand_alignment : forall s : Strand,
RegularStrand s \/ PenetratorStrand s.

(* Hidden Keys, not initially known to penetrators *)
Variable HKeys : set Key.

(* Hidden Texts, not initially known to penetrators (allows for nonces, etc...) *)
Variable HTexts : set Text.

Open Scope list_scope.
Import ListNotations.

Inductive StandardPenetrator : Strand -> Prop :=
| P_M : forall s t,
          ~ set_In t HTexts ->
          s = [ (+(!t)) ] ->
          StandardPenetrator s
| P_F : forall s g,
          s = [(-g)] ->
          StandardPenetrator s
| P_T : forall s g,
          s = [(-g) ; (+g) ; (+g)] ->
          StandardPenetrator s
| P_C : forall s g h,
          s = [(-g) ; (-h) ; (+g*h)] ->
          StandardPenetrator s
| P_S : forall s g h,
          s = [(-g*h) ; (+g) ; (+h)] ->
          StandardPenetrator s
| P_K : forall s k,
          ~set_In k HKeys ->
          s = [(+ (#k))] ->
          StandardPenetrator s
| P_E : forall s h k,
          s = [(- (#k)) ; (-h) ; (+ {h}^[k])] ->
          StandardPenetrator s
| P_D : forall s h k k',
          Inv k' k ->
          s = [(- (#k')) ; (- {h}^[k]) ; (+h)] ->
          StandardPenetrator s.
(* [REF 1] Definition 3.1
    The set of atomic actions/traces a penetrator
    may perform. *)

Definition term_filter
           {MP : Term -> Prop}
           (MPdec : forall x, {MP x} + {~ MP x})
           (s : set Node) : set Node :=
  filter (fun n => if MPdec (term n)
                   then true
                   else false)
         s.

End SS.

Export SS.


Require Import Modal.
Require Import SecOrder.
Require Import p_is_pos.
Require Import p_occurs_in.
Require Import P_occurs_in_alpha.
Require Import ST_setup.
Require Import Correctness_ST.
Require Import Arith.EqNat.
Require Import List_machinery_impl.

(* Uniform_Mod_Defns *)

(* ---------------------------------------------------------  *)

Definition uniform_pos (phi : Modal) : Prop :=
  forall (p : propvar), p_occurs_in_phi phi p = true ->
    p_is_pos phi p.

Definition uniform_neg (phi : Modal) : Prop :=
  forall (p : propvar), p_occurs_in_phi phi p = true ->
    p_is_neg phi p.

Definition uniform (phi : Modal) : Prop :=
  forall (p : propvar), p_occurs_in_phi phi p = true ->
    p_is_pos phi p \/ p_is_neg phi p.

(*
Definition p_uniform_pos (phi : Modal) (p : propvar) : Prop :=
  (p_is_pos phi p /\ ~ p_is_neg phi p).

Definition p_uniform_neg (phi : Modal) (p : propvar) : Prop :=
  (p_is_pos phi p /\ ~ p_is_neg phi p).

Definition p_uniform (phi : Modal) (p : propvar) : Prop :=
  p_uniform_pos phi p \/ p_uniform_neg phi p.

(* I don't really care about these, I guess, since for uniform formulas
   we're okay with having a mixture of pos only and neg only. *)

Definition uniform_pos (phi : Modal) : Prop :=
  forall (p: propvar), p_occurs_in_phi phi p = true ->
    p_uniform_pos phi p.

Definition uniform_neg (phi : Modal) : Prop :=
  forall (p: propvar), p_occurs_in_phi phi p = true ->
    p_uniform_neg phi p.

Definition uniform (phi : Modal) : Prop :=
  forall (p: propvar), p_occurs_in_phi phi p = true ->
    p_uniform phi p.
*)
(* ---------------------------------------------------------  *)


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.NaturalTransformations.
Require Import UniMath.CategoryTheory.DisplayedCats.Adjunctions.
Require Import UniMath.CategoryTheory.DisplayedCats.Equivalences.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.

Notation "# F" := (disp_functor_on_morphisms F)
  (at level 3) : mor_disp_scope.

(** * Displayed categories *)

Definition isaprop_is_cartesian_disp_functor
    {C C' : category} {F : functor C C'}
    {D : disp_cat C} {D' : disp_cat C'} {FF : disp_functor F D D'}
  : isaprop (is_cartesian_disp_functor FF).
Proof.
  do 7 (apply impred; intro).
  apply isaprop_is_cartesian.
Qed.

(* The following definition takes unfair advantage of the fact that  [functor_composite (functor_identity _) (functor_identity _)]
  is judgementally(!) equal to [functor_identity _]. *)
Definition disp_functor_id_composite
  {C : category}
  {CC DD EE : disp_cat C}
  (FF : disp_functor (functor_identity _) CC DD)
  (GG : disp_functor (functor_identity _) DD EE)
: disp_functor (functor_identity _) CC EE
:= disp_functor_composite FF GG.

(** * Displayed Equivalences *)

Section Displayed_Equivalences.
(** The total equivalence of a displayed equivalence *)

Definition total_functor_comp
    {C D E : category} {F : functor C D} {G : functor D E}
    {CC} {DD} {EE} (FF : disp_functor F CC DD) (GG : disp_functor G DD EE)
  : nat_z_iso
      (total_functor (disp_functor_composite FF GG))
      (functor_composite (total_functor FF) (total_functor GG)).
Proof.
  use tpair.
  - use tpair.
    + intros c. apply identity.
    + intros c c' f.
      etrans. { apply id_right. }
      apply pathsinv0, id_left.
  - intros a. apply identity_is_z_iso.
Defined.

Definition total_functor_id
    {C : category}
    {CC : disp_cat C}
  : nat_z_iso
      (total_functor (disp_functor_identity CC))
      (functor_identity _).
Proof.
  use tpair.
  - use tpair.
    + intros c. apply identity.
    + intros c c' f.
      etrans. { apply id_right. }
      apply pathsinv0, id_left.
  - intros a. apply identity_is_z_iso.
Defined.

Definition total_nat_trans
    {C D : category} {F G : functor C D} {α : nat_trans F G}
    {CC} {DD} {FF : disp_functor F CC DD} {GG : disp_functor G CC DD}
    (αα : disp_nat_trans α FF GG)
  : nat_trans (total_functor FF) (total_functor GG).
Proof.
  use tpair.
  { intros c; exists (α (pr1 c)). apply αα. }
  intros c c' f.
  eapply total2_paths_b. apply disp_nat_trans_ax.
Defined.

Definition total_adjunction_data_over_id
    {C} {CC DD : disp_cat C}
    (FG : disp_adjunction_id_data CC DD)
  : adjunction_data (total_category CC) (total_category DD).
Proof.
  exists (total_functor (left_adj_over_id FG)).
  exists (total_functor (right_adj_over_id FG)).
  split.
  - exact (total_nat_trans (unit_over_id FG)).
  - exact (total_nat_trans (counit_over_id FG)).
Defined.

Definition total_forms_adjunction_over_id
    {C} {CC DD : disp_cat C}
    (FG : disp_adjunction_id CC DD)
  : form_adjunction' (total_adjunction_data_over_id FG).
Proof.
  split.
  - intros c; cbn.
    eapply total2_paths_b.
    apply triangle_1_over_id.
  - intros c; cbn.
    eapply total2_paths_b.
    apply triangle_2_over_id.
Qed.

Definition total_adjunction_over_id
    {C} {CC DD : disp_cat C}
    (FG : disp_adjunction_id CC DD)
  : adjunction (total_category CC) (total_category DD).
Proof.
  exists (total_adjunction_data_over_id FG).
  apply total_forms_adjunction_over_id.
Defined.

Definition total_equiv_over_id
    {C} {CC DD : disp_cat C}
    (E : equiv_over_id CC DD)
  : adj_equiv (total_category CC) (total_category DD).
Proof.
  use adj_equiv_from_adjunction.
  - exact (total_adjunction_over_id (adjunction_of_equiv_over_id E)).
  - intros c. simpl.
    use is_z_iso_total. { apply identity_is_z_iso. }
    apply is_z_iso_unit_over_id, axioms_of_equiv_over_id.
  - intros c. simpl.
    use is_z_iso_total. { apply identity_is_z_iso. }
    apply is_z_iso_counit_over_id, axioms_of_equiv_over_id.
Defined.

End Displayed_Equivalences.

(** * Discrete fibrations *)

Section Discrete_Fibrations.

  (* Some access functions missing upstream *)
  Definition make_discrete_fibration {C} {D} (H : is_discrete_fibration D)
    : discrete_fibration C := (D,,H).

  Coercion discrete_fibration_property {C} {D : discrete_fibration C}
    : is_discrete_fibration D := pr2 D.

  (* arguments tweaked from upstream version, for easier applicability *)
  Definition unique_lift {C} {D : disp_cat C} (H_D : is_discrete_fibration D)
      {c c'} (f : c' --> c) (d : D c)
    : ∃! d' : D c', d' -->[f] d
  := pr1 H_D c c' f d.

  Arguments unique_lift : simpl never.

  Definition lift_source {C} {D : disp_cat C} (H_D : is_discrete_fibration D)
      {c c'} (f : c' --> c) (d : D c)
    : D c'
  := pr1 (iscontrpr1 (unique_lift H_D f d)).

  Definition lift {C} {D : disp_cat C} (H_D : is_discrete_fibration D)
      {c c'} (f : c' --> c) (d : D c)
    : lift_source H_D f d -->[f] d
  := pr2 (iscontrpr1 (unique_lift H_D f d)).

  Definition isaset_fiber_is_discrete_fibration
       {C} {D : disp_cat C} (H_D : is_discrete_fibration D) (c : C)
    : isaset (D c)
  := pr2 H_D c.

  Definition unique_lift_is_cartesian
             {C : category}
             {D : discrete_fibration C} {c c'}
             (f : c' --> c) (d : D c)
    : is_cartesian (pr2 (pr1 (unique_lift D f d))).
  Proof.
    apply (pr2 (pr2 (fibration_from_discrete_fibration _ D _ _ _ _))).
  Defined.

  (* useful for situations when a particularly canonical lift is known *)
  Definition unique_lift_explicit
             {C : category}
             {D : disp_cat C}
             (is_discrete_fibration_D : is_discrete_fibration D) {c c'}
             {d : D c} {f : c' --> c} (d' : D c') (ff : d' -->[f] d)
    : ∃! (d' : D c'), d' -->[f] d.
  Proof.
    exists (d' ,, ff).
    intros X.
    apply isapropifcontr, unique_lift, is_discrete_fibration_D.
  Defined.

  Definition unique_lift_explicit_eq
             {C : category}
             {D : disp_cat C}
             (is_discrete_fibration_D : is_discrete_fibration D) {c c'}
             {d : D c} {f : c' --> c} (d' : D c') (ff : d' -->[f] d)
    : pr1 is_discrete_fibration_D _ _ f d
      = unique_lift_explicit is_discrete_fibration_D d' ff.
  Proof.
    apply isapropiscontr.
  Defined.

  Definition unique_lift_identity
             {C : category}
             {D : disp_cat C}
             (is_discrete_fibration_D : is_discrete_fibration D) {c}
             (d : D c)
    : ∃! (d' : D c), d' -->[identity c] d.
  Proof.
    apply (unique_lift_explicit is_discrete_fibration_D d).
    apply id_disp.
  Defined.

  Definition unique_lift_id
             {C : category}
             {D : disp_cat C}
             (is_discrete_fibration_D : is_discrete_fibration D) {c}
             (d : D c)
    : unique_lift is_discrete_fibration_D (identity c) d
      = unique_lift_identity is_discrete_fibration_D d.
  Proof.
    apply isapropiscontr.
  Defined.

  Definition unique_lift_compose
             {C : category}
             {D : disp_cat C}
             (is_discrete_fibration_D : is_discrete_fibration D) {c c' c''}
             (f : c' --> c) (g : c'' --> c')
             (d : D c)
    : ∃! (d'' : D c''), d'' -->[g ;; f] d.
  Proof.
    eapply unique_lift_explicit; try assumption.
    refine (_;;_)%mor_disp; apply (lift is_discrete_fibration_D).
  Defined.

  Definition unique_lift_comp
             {C : category}
             {D : disp_cat C}
             (is_discrete_fibration_D : is_discrete_fibration D) {c c' c''}
             (f : c' --> c) (g : c'' --> c')
             (d : D c)
    : unique_lift is_discrete_fibration_D (g ;; f) d
      = unique_lift_compose is_discrete_fibration_D f g d.
  Proof.
    apply isapropiscontr.
  Defined.

  Definition discrete_fibration_mor_weq
             {C : category}
             {D : disp_cat C}
             (is_discrete_fibration_D : is_discrete_fibration D) {c c'}
             (f : c' --> c) (d : D c) (d' : D c')
    : (d' -->[f] d) ≃ (lift_source is_discrete_fibration_D f d = d').
  Proof.
    set (uf := unique_lift is_discrete_fibration_D f d).
    use weq_iso.
    - intros ff. apply (maponpaths pr1 (! pr2 uf (d' ,, ff))).
    - intros p. apply (transportf _ p (pr2 (pr1 uf))).
    - intros ff. simpl.
      refine (@fiber_paths _ (λ d'', d'' -->[ f] d) _ (_,,_) _).
    - intros ?. apply isaset_fiber_is_discrete_fibration; assumption.
  Defined.

  Definition discrete_fibration_mor
             {C : category}
             {D : disp_cat C}
             (is_discrete_fibration_D : is_discrete_fibration D) {c c'}
             (f : c' --> c) (d : D c) (d' : D c')
    : (d' -->[f] d) = (lift_source is_discrete_fibration_D f d = d').
  Proof.
    apply univalence.
    apply discrete_fibration_mor_weq.
  Defined.

  Definition isaprop_mor_disp_of_discrete_fibration
             {C : category}
             {D : disp_cat C}
             (is_discrete_fibration_D : is_discrete_fibration D) {c c'}
             (f : c' --> c) (d : D c) (d' : D c')
    : isaprop (d' -->[f] d).
  Proof.
    eapply isofhlevelweqb. { use discrete_fibration_mor_weq; assumption. }
    apply isaset_fiber_is_discrete_fibration; eassumption.
  Qed.

  Definition isaprop_disp_id_comp_of_discrete_fibration
             {C : category}
             {D : disp_cat C}
             (is_discrete_fibration_D : is_discrete_fibration D)
    : isaprop (disp_cat_id_comp C D).
  Proof.
    use isapropdirprod.
    - repeat (apply impred_isaprop; intro).
      apply isaprop_mor_disp_of_discrete_fibration; assumption.
    - repeat (apply impred_isaprop; intro).
      apply isaprop_mor_disp_of_discrete_fibration; assumption.
  Qed.

  Definition isaprop_is_discrete_fibration
             {C : category}
             (D : disp_cat C)
    : isaprop (is_discrete_fibration D).
  Proof.
    use isapropdirprod.
    - repeat (apply impred_isaprop; intro).
      apply isapropiscontr.
    - apply impred_isaprop; intro.
      apply isapropisaset.
  Qed.

End Discrete_Fibrations.