Require Import Kami.AllNotations.
Require Import FpuKami.Definitions.

Section Definitions.
  Variable expWidthMinus2 sigWidthMinus2: nat.

  Local Notation expWidthMinus1 := (expWidthMinus2 + 1).
  Local Notation expWidth := (expWidthMinus1 + 1).

  Local Notation sigWidthMinus1 := (sigWidthMinus2 + 1).
  Local Notation sigWidth := (sigWidthMinus1 + 1).

  Section Ty.
    Variable ty: Kind -> Type.

    Definition Compare_Output :=
      STRUCT_TYPE {
          "gt" :: Bool;
          "eq" :: Bool;
          "lt" :: Bool;
          "exceptionFlags" :: ExceptionFlags
        }.

    Section Compare.
      Variable a: NF expWidthMinus2 sigWidthMinus2 @# ty.
      Variable b: NF expWidthMinus2 sigWidthMinus2 @# ty.
      Open Scope kami_expr.

      Definition signA := a @% "sign".
      Definition expA  := a @% "sExp".
      Definition sigA := a @% "sig".

      Definition signB := b @% "sign".
      Definition expB  := b @% "sExp".
      Definition sigB := b @% "sig".

      Open Scope kami_action.
      Definition Compare_expr
        :  Compare_Output ## ty
        := LETC invalid <- a @% "isNaN" || b @% "isNaN";
           LETC bothInfs <- a @% "isInf" && b @% "isInf";
           LETC bothZeros <- a @% "isZero" && b @% "isZero";
           LETC eitherZero <- a@% "isZero" || b @% "isZero";

           LETC eqExp <- expA == expB;
           LETC eqSign <- signA == signB;
           LETC eqSig <- sigA == sigB;

           LETC eqMags <- #eqExp && #eqSig;

           LETC ltMags_common <- (b@%"isInf") || ((!(a@%"isInf")) && ((expA <s expB) || (#eqExp && (sigA < sigB))));

           LETC ltMags <- (signA && !signB)
           || (!signA && !signB && #ltMags_common)
           || (signA && signB && !#ltMags_common && !#eqMags);

           LETC zLtPos <- a @% "isZero" && !signB;
           LETC aLtInf <- !(a @% "isInf") && !signB && (b @% "isInf");
           LETC ltSign <- signA && !signB;
           LETC negLtZero <- (signA && b @% "isZero");

           LETC eq <- #bothZeros || (!#eitherZero && #eqSign && (#bothInfs || #eqMags));
           LETC lt <-
               !#bothZeros
               && (#ltSign
                   || (!#bothInfs && (#zLtPos || #aLtInf || #negLtZero || #ltMags)));

           LETC gt <- !#lt && !#eq;

           LETC flags: ExceptionFlags <- STRUCT {
                                       "invalid" ::= #invalid;
                                       "infinite" ::= $$false;
                                       "overflow" ::= $$false;
                                       "underflow" ::= $$false;
                                       "inexact" ::= $$false
                                     };
           LETC Compare: Compare_Output <- STRUCT {
                                                "gt" ::= !#invalid && #gt;
                                                "eq" ::= !#invalid && #eq;
                                                "lt" ::= !#invalid && #lt;
                                                "exceptionFlags" ::= #flags
                                              };
           RetE #Compare.

      Definition Compare_action
        :  ActionT ty (Compare_Output)
        := convertLetExprSyntax_ActionT Compare_expr.

    End Compare.
  End Ty.
End Definitions.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal35.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (y:natural) (z:natural) (a:natural):@eq natural (qexp x y (mult z (mult a x))) (qexp x y (mult (mult z a) x)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal35_mult_qexp_111_mult_assoc/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (y:natural) (z:natural) (a:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"++ "|" ++"z:" ++ "(" ++ show z ++ ")"++ "|" ++"a:" ++ "(" ++ show a ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y z a.
QuickChick collect_data.
Success.


Require Import Coq.Strings.String.

Require Export Parser.Structures.

Polymorphic Definition cast { A B } (p: A = B) (v: A): B := eq_rect A (fun T => T) v B p.

Definition cast_syntax { A B } (p: A = B) (s: Syntax A): Syntax B :=
  eq_rect A (fun T => Syntax T) s B p.

Lemma cast_refl:
  forall A (v: A), cast eq_refl v = v.
Proof.
  lights.
Qed.

Lemma cast_syntax_refl:
  forall A (s: Syntax A), cast_syntax eq_refl s = s.
Proof.
  lights.
Qed.

Ltac cast_refl :=
  rewrite cast_refl in * ||
  rewrite cast_syntax_refl in *.

(** Proof Irrelevance axiom **)

Axiom UIP: forall A (x y: A) (p1 p2: x = y), p1 = p2.
Arguments UIP { A x y}.

Lemma proofs_refl:
  forall (A: Type) (x: A) (H: x = x), H = eq_refl.
Proof.
  intros.
  apply UIP.
Qed.

Polymorphic Lemma cast_irrelevance:
  forall A H (x: A), cast H x = x.
Proof.
  intros A H.
  intros.
  pose proof (proofs_refl _ _ H) as HR.
  rewrite HR.
  lights.
Qed.

Polymorphic Lemma eq_rekt:
  forall A (x1 x2: A) (F: A -> Type) (y: F x1) (H: x1 = x2),
    eq_rect x1 F y x2 H = eq_rect (F x1) (fun T => T) y (F x2) (f_equal F H).
Proof.
  intros.
  destruct H; lights.
Qed.

Lemma eq_rect_irrelevance:
  forall A (x1 x2: A) (F: A -> Type) (y: F x1) (H H': x1 = x2),
    eq_rect x1 F y x2 H = eq_rect x1 F y x2 H'.
Proof.
  destruct H; lights.
  pose proof (proofs_refl _ _ H') as HR.
  rewrite HR; lights.
Qed.

Lemma eq_rect_irrelevance2:
  forall (x1 x2: Type) (y: x1) (H H': x1 = x2),
    eq_rect x1 (fun T => T) y x2 H = eq_rect x1 (fun T => T) y x2 H'.
Proof.
  destruct H; lights.
  pose proof (proofs_refl _ _ H') as HR.
  rewrite HR; lights.
Qed.

Ltac proofs_refl :=
  match goal with
  | H: context[eq_rect _ _ _ _ ?H'] |- _ => progress (rewrite (proofs_refl _ _ H') in H)
  | |- context[eq_rect _ _ _ _ ?H'] => progress (rewrite (proofs_refl _ _ H'))
  end.

Ltac generalize_proofs :=
  repeat match goal with
  | |- context[eq_rect _ _ _ _ ?H] => generalize H
  | |- context[cast ?H _] => generalize H
  end.

Ltac eq_rekt :=
  match goal with
  | |- context[eq_rect ?x1 ?P ?y ?x2 ?H] =>
    tryif unify P (fun (T: Type) => T)
    then fail
    else rewrite (eq_rekt _ x1 x2 P y H) in *
  | H: context[eq_rect ?x1 ?P ?y ?x2 ?H] |- _ =>
    tryif unify P (fun (T: Type) => T)
    then fail
    else rewrite (eq_rekt _ x1 x2 P y H) in *
  end.

Ltac eq_dep' := proofs_refl || (unfold cast in *) || eq_rekt || rewrite rew_compose in *.

Lemma eq_rect_reverse:
  forall (T1 T2: Type) H H' y y',
    eq_rect T1 (fun T: Type => T) y T2 H = eq_rect T1 (fun T: Type => T) y' T2 H' ->
    y = y'.
Proof.
  intros T1 T2 H H' y y' HE.
  pose proof (f_equal (fun z => eq_rect T2 (fun T: Type => T) z T1 (eq_sym H)) HE);
    repeat light || eq_dep'.
Qed.

Ltac eq_dep := apply_anywhere eq_rect_reverse || eq_dep'.

Ltac proof_irrelevance :=
  match goal with
  | H: context[eq_rect _ _ _ _ ?p1] |- context[eq_rect _ _ _ _ ?p2] =>
    not_unify p1 p2;
    poseNew (Mark (p1, p2) "proof_irrelevance");
    pose proof (UIP p1 p2)
  | H1: context[eq_rect _ _ _ _ ?p1], H2: context[eq_rect _ _ _ _ ?p2] |- _ =>
    not_unify p1 p2;
    poseNew (Mark (p1, p2) "proof_irrelevance");
    pose proof (UIP p1 p2)
  | |- context[eq_rect _ _ _ _ ?p1] =>
    match goal with
    | |- context[eq_rect _ _ _ _ ?p2] =>
      not_unify p1 p2;
      poseNew (Mark (p1, p2) "proof_irrelevance");
      pose proof (UIP p1 p2)
    end
  end.


From Coq Require Import ssreflect ssrfun ssrbool.
Require Import stdpp.tactics.

Require Import depleted.proset.
Require Import depleted.bounds.
Local Open Scope proset_scope.
Local Open Scope proset_util_scope.

(* !!!
   IMPORTANT NOTE: Constraints for adjunctions should generally be placed BEFORE
   Monotone, etc constraints (as far as I can tell, so far) because resolving them
   can instantiate evars that would otherwise cause resolution of those other classes
   to fail! Hence, this ordering allows more powerful inference.
   !!! *)
Class Adjoint `{Proset X, Proset Y} (F : X -> Y) (G : Y -> X)
  : Prop := {adj_unit : id ⊢ G ∘ F; adj_counit : F ∘ G ⊢ id}.
(* TODO This is probably worth putting some more careful thought into! *)
Hint Mode Adjoint ! - - ! - - ! - : typeclass_instances.
Hint Mode Adjoint ! - - ! - - - ! : typeclass_instances.
Instance: Params (@Adjoint) 6 := {}.
Arguments adj_unit {_ _ _ _ _ _ _ _} Adj : rename.
Arguments adj_counit {_ _ _ _ _ _ _ _} Adj : rename.
Infix "⊣" := Adjoint (no associativity, at level 70) : proset_scope.
Definition adj_unit' `(Adj : Adjoint X Y F G) {A} : A ⊢ G (F A)
  := adj_unit Adj _.
Definition adj_counit' `(Adj : Adjoint X Y F G) {A} : F (G A) ⊢ A
  := adj_counit Adj _.
Definition adj_right `(Adj : Adjoint X Y F G) {A B} (D : A ⊢ B) : A ⊢ G (F B)
  := transitivity D (adj_unit Adj _).
Definition adj_left `(Adj : Adjoint X Y F G) {A B} (D : A ⊢ B) : F (G A) ⊢ B
  := transitivity (adj_counit Adj _) D.
Lemma transpose `(Adj : Adjoint X Y F G) `{!Monotone F, !Monotone G} (A : X) (B : Y)
  : F A ⊢ B <-> A ⊢ G B.
Proof.
  split=> D.
  - rewrite -D; by apply adj_unit'.
  - rewrite D; by apply adj_counit'.
Qed.
Lemma transpose_sufficient `{Proset X, Proset Y, !Monotone F, !Monotone G}
  : (forall (A : X) (B : Y), F A ⊢ B <-> A ⊢ G B) -> F ⊣ G.
Proof. move=> Transpose; constructor=> A /=; by apply/Transpose. Qed.
Instance adjoint_proper `{Proset X, Proset Y}
  : Proper ((⥊) ==> (⥊) ==> iff) (Adjoint (X:=X) (Y:=Y)).
Proof.
  apply: proper_sym_impl_iff_2.
  {firstorder. }
  {firstorder. }
  move=> F F' E_F G G' E_G Adj; constructor=> A /=.
  - rewrite -(proj1 (E_G _ _ (E_F _ _ _))) //; apply: (adj_unit Adj).
  - rewrite (proj2 (E_F _ _ (E_G _ _ _))) //; apply: (adj_counit Adj).
Qed.

Class OrderEquiv `{Proset X, Proset Y} (F : X -> Y) (G : Y -> X)
      `{!F ⊣ G, !G ⊣ F, !Monotone F, !Monotone G}.
Hint Mode OrderEquiv ! - - ! - - ! - - - - - : typeclass_instances.
Hint Mode OrderEquiv ! - - ! - - - ! - - - - : typeclass_instances.
Instance order_equiv_reflecting1 `{OrderEquiv X Y F G} : Reflecting F.
Proof. move=> A B /transpose D; apply: (transitivity D); apply: (adj_counit (F:=G)). Qed.
Instance order_equiv_reflecting2 `{OrderEquiv X Y F G} : Reflecting G.
Proof. move=> A B /transpose D; apply: (transitivity D); apply: (adj_counit (F:=F)). Qed.

Lemma reflecting_left_adjoint `(Adj : Adjoint X Y F G) `{!Reflecting F} : G ∘ F ⟛ id.
Proof.
  split=> A /=.
  - by apply (reflect F), adj_counit'.
  - by apply adj_unit'.
Qed.
Lemma reflecting_right_adjoint `(Adjoint X Y F G) `{!Reflecting G} : F ∘ G ⟛ id.
Proof.
  split=> A /=.
  - by apply adj_counit'.
  - by apply (reflect G), adj_unit'.
Qed.
Lemma reflecting_left_adjoint' `(Adj : Adjoint X Y F G) `{!Reflecting F} A B
  : A ⊢ F B -> G A ⊢ B.
Proof. move=> D; apply: (reflect F); rewrite -D; firstorder. Qed.
Lemma reflecting_right_adjoint' `(Adj : Adjoint X Y F G) `{!Reflecting G} A B
  : G A ⊢ B -> A ⊢ F B.
Proof. move=> D; apply: (reflect G); rewrite D; firstorder. Qed.

Instance left_adjoint_cocontinuous `{Proset X, Proset Y} {F : X -> Y} {G : Y -> X}
         `{Adj : F ⊣ G, !Monotone F, !Monotone G}
  : Cocontinuous F | 2.
Proof.
  move=> R J A [UB Uni]; split=> [r | A' UB'] /=; first by apply: mono.
  apply/transpose/Uni => r; apply/(transpose Adj)/UB'.
Qed.
Instance right_adjoint_continuous `{Proset X, Proset Y} {F : X -> Y} {G : Y -> X}
         `{Adj : F ⊣ G, !Monotone F, !Monotone G}
  : Continuous G | 2.
Proof.
  move=> R J A [LB Uni]; split=> [r | A' LB'] /=; first by apply: mono.
  apply/(transpose (F:=F))/Uni => r; apply/transpose/LB'.
Qed.

Lemma reflecting_left_adjoint_glb
      `{Adj : Adjoint Y X F G, !Monotone F, !Monotone G, !Reflecting F}
      {R} {J : R -> Y} {A}
  : glb (F ∘ J) A -> glb J (G A).
Proof.
  move=> Glb.
  enough (G ∘ F ∘ J ⟛ J) as E by (rewrite -E; apply: preserve_inf Glb).
  apply/pw_core' => r /=; apply/(pw_core (reflecting_left_adjoint Adj)).
Qed.
Lemma reflecting_right_adjoint_lub
      `{Adj : Adjoint Y X F G, !Monotone F, !Monotone G, !Reflecting G}
      {R} {J : R -> X} {A}
  : lub (G ∘ J) A -> lub J (F A).
Proof.
  move=> Lub.
  enough (F ∘ G ∘ J ⟛ J) as E by (rewrite -E; apply: preserve_sup Lub).
  apply/pw_core' => r /=; apply/(pw_core (reflecting_right_adjoint Adj)).
Qed.
Lemma reflecting_left_adjoint_lub
      `{Adj : Adjoint Y X F G, !Monotone F, !Monotone G, !Reflecting F}
      {R} {J : R -> Y} {A}
  : lub (F ∘ J) A -> lub J (G A).
Proof.
  move=> [UB Uni]; split.
  - move=> r; apply/(transpose Adj)/UB.
  - move=> B UB'; apply: reflecting_left_adjoint'; apply: Uni; firstorder.
Qed.
Lemma reflecting_right_adjoint_glb
      `{Adj : Adjoint Y X F G, !Monotone F, !Monotone G, !Reflecting G}
      {R} {J : R -> X} {A}
  : glb (G ∘ J) A -> glb J (F A).
Proof.
  move=> [LB Uni]; split.
  - move=> r; apply/(transpose Adj)/LB.
  - move=> B LB'; apply: reflecting_right_adjoint'; apply: Uni; firstorder.
Qed.
(* TODO handle non-discrete infs/sups? *)
Definition reflective_dsup
           `{Adjoint X Y F G, !Monotone F, !Monotone G, !Reflecting G}
           {R} (J : R -> Y) `{!HasSup (G ∘ J)}
  : HasSup J
  := {| sup := F (sup (G ∘ J));
        is_sup := reflecting_right_adjoint_lub (is_sup (G ∘ J)) |}.
Definition reflective_dinf
           `{Adjoint X Y F G, !Monotone F, !Monotone G, !Reflecting G}
           {R} (J : R -> Y) `{!HasInf (G ∘ J)}
  : HasInf J
  := {| inf := F (inf (G ∘ J));
        is_inf := reflecting_right_adjoint_glb (is_inf (G ∘ J)) |}.
Definition coreflective_dinf
           `{Adjoint Y X F G, !Monotone F, !Monotone G, !Reflecting F}
           {R} (J : R -> Y) `{!HasInf (F ∘ J)}
  : HasInf J
  := {| inf := G (inf (F ∘ J));
        is_inf := reflecting_left_adjoint_glb (is_inf (F ∘ J)) |}.
Definition coreflective_dsup
           `{Adjoint Y X F G, !Monotone F, !Monotone G, !Reflecting F}
           {R} (J : R -> Y) `{!HasSup (F ∘ J)}
  : HasSup J
  := {| sup := G (sup (F ∘ J));
        is_sup := reflecting_left_adjoint_lub (is_sup (F ∘ J)) |}.
(* Even if X is complete, *this is still the instance we want*, because we want
   to compute infs/sups in Y using different definitions according to the index set,
   in whichever way X does. If we just gave Y a complete lattice instance based on
   X's complete lattice instance, then binary meets, say, would end up being
   computed by means of X's complete lattice instance instead of any higher-priority
   instance it might have for bool-indexed infs. *)
Notation InheritsDInfs X Y := (forall {R}, DInfsOfShape R X -> DInfsOfShape R Y).
Notation InheritsDSups X Y := (forall {R}, DSupsOfShape R X -> DSupsOfShape R Y).

(* TOO Comma prosets? *)
Definition universal_left_adjoint `{Proset X, Proset Y, !InfLattice Y}
           (G : Y -> X) (A : X) : Y
  := Inf B : {B0 | A ⊢ G B0}, `B.
Definition universal_right_adjoint `{Proset X, Proset Y, !SupLattice X}
           (F : X -> Y) (B : Y) : X
  := Sup A : {A0 | F A0 ⊢ B}, `A.
Arguments universal_left_adjoint {_ _ _ _ _ _ _} G A /.
Arguments universal_right_adjoint {_ _ _ _ _ _ _} F B /.
Instance: Params (@universal_left_adjoint) 7 := {}.
Instance: Params (@universal_right_adjoint) 7 := {}.
Instance ula_proper `{Proset X, Proset Y, !InfLattice Y}
  : Proper ((⊢) --> (⇀)) (universal_left_adjoint (X:=X) (Y:=Y)).
Proof.
  move=> F G D A B D' /=.
  apply: inf_right => -[B0 D''] /=; apply: (inf_lb (B0 ↾ _)).
  rewrite D' D'' //.
Qed.
Instance ura_proper `{Proset X, Proset Y, !SupLattice X}
  : Proper ((⊢) --> (⇀)) (universal_right_adjoint (X:=X) (Y:=Y)).
Proof.
  move=> F G D A B D' /=.
  apply: sup_left => -[A0 D''] /=; apply: (sup_ub (A0 ↾ _)).
  rewrite -D' -D'' //.
Qed.
(* These are not instances because we don't want them to conflict with other ones when we
   give more useful/explicit definitions. But they should be suitable for using to make
   instances very quickly! *)
Lemma universal_adjunction1 `{Proset X, Proset Y, !InfLattice Y}
      {G : Y -> X} `{!Monotone G, !Continuous G}
  : universal_left_adjoint G ⊣ G.
Proof.
  constructor=> [A | B] /=.
  - case: (proj1 (preserves_inf_alt2 (F:=G) (J:=fun B : {B0 | A ⊢ G B0} => `B))) => LB Uni.
    apply/Uni => -[B0 ?] //.
  - by apply: (inf_lb (B ↾ _)).
Qed.
Lemma universal_adjunction2 `{Proset X, Proset Y, !SupLattice X}
      {F : X -> Y} `{!Monotone F, !Cocontinuous F}
  : F ⊣ universal_right_adjoint F.
Proof.
  constructor=> [A | B] /=.
  - by apply: (sup_ub (A ↾ _)).
  - case: (proj1 (preserves_sup_alt2 (F:=F) (J:=fun A : {A0 | F A0 ⊢ B} => `A))) => UB Uni.
    apply/Uni => -[B0 ?] //.
Qed.

Instance id_id_adjoint `{Proset X} : (@id X) ⊣ id.
Proof. done. Qed.
Instance id_id_equiv `{Proset X} : OrderEquiv (@id X) id := {}.
Instance compose_adjoint `{Proset X, Proset Y, Proset Z'}
         {F : Y -> Z'} {G : Z' -> Y} {F' : X -> Y} {G' : Y -> X}
         `{!F ⊣ G, !F' ⊣ G', !Monotone F, !Monotone G, !Monotone F', !Monotone G'}
  : F ∘ F' ⊣ G' ∘ G.
Proof. apply/transpose_sufficient => * /=; rewrite 2!transpose //. Qed.
Instance compose_equiv `{Proset X, Proset Y, Proset Z'}
         {F : Y -> Z'} {G : Z' -> Y} {F' : X -> Y} {G' : Y -> X}
         `{!F ⊣ G, !G ⊣ F, !F' ⊣ G', !G' ⊣ F',
           !Monotone F, !Monotone G, !Monotone F', !Monotone G',
           !OrderEquiv F G, !OrderEquiv G F}
  : OrderEquiv (F ∘ F') (G' ∘ G) := {}.
Instance pair0_snd_adjoint `{Proset X, Proset Y, !Bot X}
  : pair ⊥ ⊣ (@snd X Y).
Proof. constructor=> [B | [A B]] //=; by split; first apply: bot_left. Qed.
Instance snd_pair1_adjoint `{Proset X, Proset Y, !Top X}
  : (@snd X Y) ⊣ pair ⊤.
Proof. constructor=> [[A B] | B] //=; by split; first apply: top_right. Qed.
Instance flip_pair0_fst_adjoint `{Proset X, Proset Y, !Bot Y}
  : flip pair ⊥ ⊣ (@fst X Y).
Proof. constructor=> [B | [A B]] //=; by split; last apply: bot_left. Qed.
Instance fst_flip_pair1_adjoint `{Proset X, Proset Y, !Top Y}
  : (@fst X Y) ⊣ flip pair ⊤.
Proof. constructor=> [[A B] | B] //=; by split; last apply: top_right. Qed.
Instance const_einf_adjoint {R} `{Proset X, !DInfsOfShape R X} : @const X R ⊣ einf.
Proof. apply/transpose_sufficient => A B; rewrite -inf_universal //. Qed.
Instance esup_const_adjoint {R} `{Proset X, !DSupsOfShape R X} : esup ⊣ @const X R.
Proof. apply/transpose_sufficient => A B; rewrite -sup_universal //. Qed.
Definition is_top `{Proset X, !Top X} (A : X) : Prop := ⊤ ⊢ A.
Arguments is_top {_ _ _ _} A.
Instance: Params (@is_top) 4 := {}.
Instance is_top_mono `{Proset X, !Top X} : Monotone (is_top (X:=X)).
Proof. move=> A B; unfold is_top => -> //. Qed.
Instance embed_prop_is_top_adj `{Proset X, !SupLattice X, !Top X}
  : (embed_prop (X:=X)) ⊣ is_top.
Proof.
  apply: transpose_sufficient => A B; split.
  - move=> <-; apply: embed_prop_right.
  - apply: embed_prop_left.
Qed.

Lemma left_adjoint_unique `{Proset X, Proset Y} {F F' : X -> Y} {G : Y -> X}
      `{!F ⊣ G, !Monotone F, !Monotone F', !Monotone G}
  : F' ⊣ G -> F' ⟛ F.
Proof.
  move=> Adj2.
  enough (Hy : forall (F F' : X -> Y) `{!Monotone F, !Monotone F'}, F ⊣ G -> F' ⊣ G -> F ⊢ F')
    by by split; apply Hy.
  move=> F_ F'_ ? ? Adj1_ Adj2_ A.
  apply/(transpose Adj1_)/(adj_unit Adj2_).
Qed.
Lemma right_adjoint_unique `{Proset X, Proset Y} {F : X -> Y} {G G' : Y -> X}
      `{!F ⊣ G, !Monotone F, !Monotone G, !Monotone G'}
  : F ⊣ G' -> G' ⟛ G.
Proof.
  move=> Adj2.
  enough (Hy : forall (G G' : Y -> X) `{!Monotone G, !Monotone G'}, F ⊣ G -> F ⊣ G' -> G ⊢ G')
    by by split; apply Hy.
  move=> F_ F'_ ? ? Adj1_ Adj2_ A.
  apply/(transpose Adj2_)/(adj_counit Adj1_).
Qed.

(*
Record Adjunction {X Y : Type} `{Proset X, Proset Y} : Type :=
  {LeftAdjoint : X -> Y; RightAdjoint : Y -> X;
   LAdj_Monotone : Monotone LeftAdjoint; RAdj_Monotone : Monotone RightAdjoint;
   Adjunction_adjoint : LeftAdjoint ⊣ RightAdjoint}.
Arguments Adjunction _ _ {_ _}.
Existing Instances LAdj_Monotone RAdj_Monotone Adjunction_adjoint | 10.
Definition adj_compose {Z} `{Proset X, Proset Y, Proset Z}
        (Adj1 : Adjunction Y Z) (Adj2 : Adjunction X Y) : Adjunction X Z
  := {| LeftAdjoint := LeftAdjoint Adj1 ∘ LeftAdjoint Adj2;
        RightAdjoint := RightAdjoint Adj2 ∘ RightAdjoint Adj1 |}.
*)

Definition local_lan `{Proset X, Proset X', Proset Y}
           (p : X -> X') (F : X -> Y) (F' : X' -> Y) : Prop
  := forall (G : X' -> Y), Monotone G -> F' ⊢ G <-> F ⊢ G ∘ p.
Definition local_ran `{Proset X, Proset X', Proset Y}
           (p : X -> X') (F : X -> Y) (F' : X' -> Y) : Prop
  := forall (G : X' -> Y), Monotone G -> G ⊢ F' <-> G ∘ p ⊢ F.
Definition global_lan `{Proset X, Proset X', Proset Y}
           (p : X -> X') `{!Monotone p} (lan_p : Hom X Y -> Hom X' Y) : Prop
  := lan_p ⊣ (.○ in_Hom p).
Definition global_ran `{Proset X, Proset X', Proset Y}
           (p : X -> X') `{!Monotone p} (ran_p : Hom X Y -> Hom X' Y) : Prop
  := (.○ in_Hom p) ⊣ ran_p.
Instance: Params (@local_lan) 9 := {}.
Instance: Params (@local_ran) 9 := {}.
Instance: Params (@global_lan) 9 := {}.
Instance: Params (@global_ran) 9 := {}.
Lemma local_global_lan `{Proset X, Proset X', Proset Y}
      {p : X -> X'} {lan_p : Hom X Y -> Hom X' Y} `{!Monotone p, !Monotone lan_p}
  : global_lan p lan_p <-> forall F : Hom X Y, local_lan p F (lan_p F).
Proof.
  split.
  - move=> Glob F G ?.
    change (ap_Hom (lan_p F) ⊢ _) with (lan_p F ⊢ in_Hom G).
    rewrite (transpose Glob) //=.
  - move=> Loc; apply/transpose_sufficient => F G /=.
    change (lan_p F ⊢ G) with (ap_Hom (lan_p F) ⊢ ap_Hom G).
    rewrite Loc //=.
Qed.
Lemma local_global_ran `{Proset X, Proset X', Proset Y}
      {p : X -> X'} {ran_p : Hom X Y -> Hom X' Y} `{!Monotone p, !Monotone ran_p}
  : global_ran p ran_p <-> forall F : Hom X Y, local_ran p F (ran_p F).
Proof.
  split.
  - move=> Glob F G ?.
    change (_ ⊢ ap_Hom (ran_p F)) with (in_Hom G ⊢ ran_p F).
    rewrite -(transpose Glob) //=.
  - move=> Loc; apply/transpose_sufficient => F G /=.
    change (F ⊢ ran_p G) with (ap_Hom F ⊢ ap_Hom (ran_p G)).
    rewrite Loc //=.
Qed.

Definition local_lift `{Proset X, Proset Y, Proset Y'}
           (p : Y' -> Y) (F : X -> Y) (F' : X -> Y') : Prop
  := forall (G : X -> Y'), Monotone G -> F' ⊢ G <-> F ⊢ p ∘ G.
Definition local_rift `{Proset X, Proset Y, Proset Y'}
           (p : Y' -> Y) (F : X -> Y) (F' : X -> Y') : Prop
  := forall (G : X -> Y'), Monotone G -> G ⊢ F' <-> p ∘ G ⊢ F.
Definition global_lift `{Proset X, Proset Y, Proset Y'}
           (p : Y' -> Y) `{!Monotone p} (lift_p : Hom X Y -> Hom X Y') : Prop
  := lift_p ⊣ (in_Hom p ○.).
Definition global_rift `{Proset X, Proset Y, Proset Y'}
           (p : Y' -> Y) `{!Monotone p} (rift_p : Hom X Y -> Hom X Y') : Prop
  := (in_Hom p ○.) ⊣ rift_p.
Instance: Params (@local_lift) 9 := {}.
Instance: Params (@local_rift) 9 := {}.
Instance: Params (@global_lift) 9 := {}.
Instance: Params (@global_rift) 9 := {}.
Lemma local_global_lift `{Proset X, Proset Y, Proset Y'}
      {p : Y' -> Y} {lift_p : Hom X Y -> Hom X Y'} `{!Monotone p, !Monotone lift_p}
  : global_lift p lift_p <-> forall F : Hom X Y, local_lift p F (lift_p F).
Proof.
  split.
  - move=> Glob F G ?.
    change (ap_Hom (lift_p F) ⊢ _) with (lift_p F ⊢ in_Hom G).
    rewrite (transpose Glob) //=.
  - move=> Loc; apply/transpose_sufficient => F G /=.
    change (lift_p F ⊢ G) with (ap_Hom (lift_p F) ⊢ ap_Hom G).
    rewrite Loc //=.
Qed.
Lemma local_global_rift `{Proset X, Proset Y, Proset Y'}
      {p : Y' -> Y} {rift_p : Hom X Y -> Hom X Y'} `{!Monotone p, !Monotone rift_p}
  : global_rift p rift_p <-> forall F : Hom X Y, local_rift p F (rift_p F).
Proof.
  split.
  - move=> Glob F G ?.
    change (_ ⊢ ap_Hom (rift_p F)) with (in_Hom G ⊢ rift_p F).
    rewrite -(transpose Glob) //=.
  - move=> Loc; apply/transpose_sufficient => F G /=.
    change (F ⊢ rift_p G) with (ap_Hom F ⊢ ap_Hom (rift_p G)).
    rewrite Loc //=.
Qed.

Instance precomp_adjoint `{Proset X, Proset X', Proset Y}
         {p : Hom X X'} {p' : Hom X' X} `{!p ⊣ p'}
  : ((.○ p') : Hom X Y -> _) ⊣ (.○ p).
Proof.
  constructor=> f y /=.
  - apply: mono; apply: adj_unit.
  - apply: mono; apply: adj_counit.
Qed.
Instance postcomp_adjoint' `{Proset X, Proset Y', Proset Y}
         {p : Hom Y' Y} {p' : Hom Y Y'} `{!p ⊣ p'}
  : ((p ○.) : Hom X Y' -> _) ⊣ (p' ○.).
Proof.
  constructor=> f y /=.
  - apply: adj_unit.
  - apply: adj_counit.
Qed.

Program Definition universal_lan {X} `{Proset X', Proset Y, !SupLattice Y}
        (p : X -> X') (F : X -> Y) : Hom X' Y
  := fun x' => Sup y : {y0 | p y0 ⊢ x'}, F (`y).
Next Obligation.
  move=> X X' ? ? Y ? ? ? p F A B D.
  apply: sup_left => -[x D'] /=.
  apply: (sup_right (x ↾ _)); by etransitivity.
Qed.
Arguments universal_lan {_ _ _ _ _ _ _ _} p F /.
Instance: Params (@universal_lan) 8 := {}.
Program Definition universal_ran {X} `{Proset X', Proset Y, !InfLattice Y}
        (p : X -> X') (F : X -> Y) : Hom X' Y
  := fun x' => Inf y : {y0 | x' ⊢ p y0}, F (`y).
Next Obligation.
  move=> X X' ? ? Y ? ? ? p F A B D.
  apply: inf_right => -[x D'] /=.
  apply: (inf_left (x ↾ _)); by etransitivity.
Qed.
Arguments universal_ran {_ _ _ _ _ _ _ _} p F /.
Instance: Params (@universal_ran) 8 := {}.
Instance universal_lan_di {X} `{Proset X', Proset Y, !SupLattice Y}
  : Dimonotone (universal_lan (X:=X) (X':=X') (Y:=Y)).
Proof.
  move=> p p' D_p F F' D_F A /=.
  apply: sup_left => -[A0 /= D]. apply: (sup_right (A0 ↾ _)).
  - rewrite D_p //.
  - firstorder.
Qed.
Instance universal_ran_di {X} `{Proset X', Proset Y, !InfLattice Y}
  : Dimonotone (universal_ran (X:=X) (X':=X') (Y:=Y)).
Proof.
  move=> p p' D_p F F' D_F A /=.
  apply: inf_right => -[A0 /= D]. apply: (inf_left (A0 ↾ _)).
  - rewrite -D_p //.
  - firstorder.
Qed.
Lemma universal_lan_global_lan `{Proset X, Proset X', Proset Y, !SupLattice Y}
      {p : X -> X'} `{!Monotone p}
  : global_lan (Y:=Y) p (universal_lan p).
Proof.
  constructor=> f x /=.
  - by apply: (sup_ub (x ↾ _)).
  - apply: sup_left => -[? D] /=; rewrite D //.
Qed.
Lemma universal_ran_global_ran `{Proset X, Proset X', Proset Y, !InfLattice Y}
      {p : X -> X'} `{!Monotone p}
  : global_ran (Y:=Y) p (universal_ran p).
Proof.
  constructor=> f x /=.
  - apply: inf_right => -[? D] /=; rewrite D //.
  - by apply: (inf_lb (x ↾ _)).
Qed.


From iris.heap_lang Require Import notation proofmode.

Section proofmode.
  Context `{!heapG Σ}. (* Ghost stated required for HeapLang *)

  Lemma example (P Q : iProp Σ) : P -∗ (P -∗ Q) -∗ Q.
  Proof. iIntros "H1 H2". iApply ("H2" with "H1"). Qed.

  Lemma example2 (P Q : nat → iProp Σ) :
    (∀ x, P x -∗ Q (x+1)) -∗ (∃ x, P x) -∗ (∃ x, Q x).
  Proof.
    iIntros "H1 H2". iDestruct "H2" as (x) "H2".
    iExists (x+1). iApply ("H1" with "H2").
  Qed.

  Lemma example_wp (l1 l2 : loc) (v1 v2 w1 : val) :
    l1 ↦ v1 ∗ l2 ↦ v2 -∗
    WP (#l1 <- w1;; ! #l2) {{ v, ⌜v = v2⌝ }}.
  Proof.
    iIntros "[H1 H2]". wp_store. wp_load. eauto.
  Qed.
End proofmode.

Section list.
  Context `{!heapG Σ}.

  Definition llnil : val := λ: <>, NONEV.
  Definition llcons : val := λ: "x" "l", SOME ("x", "l").

  Definition llhead : val := λ: "l",
    match: "l" with
      SOME "p" => Fst "p"
    | NONE => #false
    end.

  Definition lltail : val := λ: "l",
    match: "l" with
      SOME "p" => Snd "p"
    | NONE => #false
    end.

  Definition llmember : val := rec: "llmember" "x" "l" :=
    match: "l" with
      SOME "p" => let: "h" := Fst "p" in

                  let: "t" := Snd "p" in
                  if: "h" = "x" then #true else "llmember" "x" "t"
    | NONE => #false
    end.

  Definition llfilter : val := rec: "llfilter" "f" "l" :=
    match: "l" with
      SOME "p" => let: "h" := Fst "p" in

                  let: "t" := Snd "p" in
                  if: "f" "h"
                  then llcons "h" ("llfilter" "f" "t")
                  else "llfilter" "f" "t"
    | NONE => llnil #()
    end.

  Fixpoint is_list (hd : val) (xs : list val) : iProp Σ :=
    match xs with
    | [] => ⌜hd = NONEV⌝
    | x :: xs => ∃ hd', ⌜hd = SOMEV (x,hd')⌝ ∗ is_list hd' xs
  end.

  Lemma is_list_dup v xs :
    is_list v xs ⊢ is_list v xs ∗ is_list v xs.
  Proof.
    revert v. induction xs as [|h t IHt]; first eauto.
    intros v. simpl. iDestruct 1 as (hd ->) "H".
    rewrite IHt. iDestruct "H" as "[H1 H2]".
    iSplitL "H1"; iExists _; eauto.
  Qed.

  Lemma wp_llnil :
    (⊢ WP llnil #() {{ v, is_list v [] }})%I.
  Proof. wp_rec. eauto. Qed.

  Lemma wp_llcons (h t : val) (ws : list val) :
    is_list t ws -∗
    WP llcons h t {{ v, is_list v (h::ws) }}.
  Proof. iIntros "Ht". wp_rec. wp_pures. simpl. eauto. Qed.

  Lemma wp_llhead v h ws :
    is_list v (h::ws) -∗
    WP llhead v {{ v', ⌜v' = h⌝ ∗ is_list v (h::ws) }}.
  Proof.
    simpl.
    iDestruct 1 as (hd ->) "Hhd".
    wp_rec. wp_pures. iModIntro. iSplit; eauto.
  Qed.

  Lemma wp_lltail v h ws :
    is_list v (h::ws) -∗
    WP lltail v {{ v', is_list v' ws }}.
  Proof.
    simpl.
    iDestruct 1 as (hd ->) "Hhd".
    wp_rec. wp_pures. eauto.
  Qed.

  Lemma wp_llfilter (f l : val) (P : val → iProp Σ) ws :
    is_list l ws -∗
    □ (∀ v : val, WP f v {{ v', (⌜v' = #true⌝ ∗ P v) ∨ ⌜v' = #false⌝ }}) -∗
    WP llfilter f l {{ v, ∃ ws', is_list v ws' ∗ ([∗ list] w'∈ws', P w') }}.
  Proof.
    iIntros "Hws #Hf".
    iLöb as "IH" forall (l ws).
    wp_rec. wp_pures.
    destruct ws as [|h t]; simpl.
    - iDestruct "Hws" as %->. wp_pures.
      iApply wp_wand. iApply wp_llnil.
      iIntros (v) "Hv". iExists []. iFrame. eauto.
    - iDestruct "Hws" as (hd ->) "Hhd". wp_pures.
      wp_bind (f h). iApply wp_wand.
      { iApply "Hf". }
      iIntros (v). iDestruct 1 as "[[-> Hh]|->]"; wp_pures.
      + wp_bind (llfilter _ _). iApply (wp_wand with "[Hhd]").
        { iApply ("IH" with "Hhd"). }
        iIntros (v). iDestruct 1 as (ws') "[Hws HP]".
        iApply (wp_wand with "[Hws]").
        { iApply (wp_llcons with "Hws"). }
        iIntros (v') "Hv'". iExists _. iFrame.
      + iApply ("IH" with "Hhd").
  Qed.

  Lemma wp_llmember (x l : val) ws :
    val_is_unboxed x →
    (* ^ make sure that we can safely compare `x` with other values *)
    is_list l ws -∗
    WP llmember x l {{ v, is_list l ws ∗
                      ((⌜v = #true⌝ ∗ ⌜x ∈ ws⌝) ∨ (⌜v = #false⌝ ∗ ⌜x ∉ ws⌝)) }}.
  Proof.
    iIntros (?) "Hl".
    iLöb as "IH" forall (l ws).
    wp_rec. wp_pures.
    destruct ws as [|h ws]; simpl.
    - iDestruct "Hl" as "->". wp_pures. iModIntro. repeat iSplit; eauto.
      iRight. iSplit; eauto. iPureIntro. set_solver.
    - iDestruct "Hl" as (t ->) "Ht". wp_pures.
      case_bool_decide; wp_pures; try iModIntro.
      + iSplitL. { iExists _; eauto. }
        iLeft. iSplit; eauto. iPureIntro; set_solver.
      + iSpecialize ("IH" with "Ht").
        iApply (wp_wand with "IH").
        iIntros (v) "[Ht [[-> %]|[-> %]]]".
        * iSplitL.
          { iExists _; eauto. }
          iLeft; iSplit; eauto. iPureIntro; set_solver.
        * iSplitL.
          { iExists _; eauto. }
          iRight. iSplit; eauto. iPureIntro. set_solver.
  Qed.

End list.

Section mset.
  Context `{!heapG Σ}.

  Definition mset_create : val := λ: <>, ref (llnil #()).

  Definition mset_member : val := λ: "x" "v",
    let: "l" := !"v" in
    llmember "x" "l".

  Definition mset_add : val := λ: "x" "v",
    let: "l" := !"v" in
    "v" <- llcons "x" "l".

  Definition mset_clear : val := λ: "v", "v" <- llnil #().

  Definition is_mset (v : val) (X : gset val) : iProp Σ :=
    (∃ hd ws (l : loc), ⌜v = #l⌝ ∗ l ↦ hd ∗ is_list hd ws ∗
        ⌜NoDup ws ∧ X = list_to_set ws⌝)%I.

  Lemma wp_mset_create :
    ⊢ WP mset_create #() {{ v, is_mset v ∅ }}.
  Proof.
    wp_rec. wp_bind (llnil #()).
    iApply wp_wand; first iApply wp_llnil.
    iIntros (v) "Hv". wp_alloc r as "Hr".
    iExists _,_,_. iFrame. iModIntro. iSplit; eauto. iPureIntro.
    split; eauto || econstructor.
  Qed.

  Lemma wp_mset_add v X (x : val) :
    x ∉ X →
    is_mset v X -∗ WP mset_add x v {{ v', ⌜v' = #()⌝ ∗ is_mset v ({[x]} ∪ X) }}.
  Proof.
    iIntros (Hx) "Hv".
    wp_rec. wp_pures.
    iDestruct "Hv" as (hd ws l ->) "(Hl & Hws & %)".
    wp_load. wp_pures. wp_bind (llcons _ _).
    iApply (wp_wand with "[Hws]").
    { iApply (wp_llcons with "Hws"). }
    iIntros (v) "Hv". wp_store. iModIntro. iSplit; eauto.
    iExists _,_,_. iFrame. iSplit; eauto.
    iPureIntro. destruct_and!. rewrite NoDup_cons. set_solver.
  Qed.

  Lemma wp_mset_member v X (x : val) :
    val_is_unboxed x →
    is_mset v X -∗
    WP mset_member x v {{ v', is_mset v X ∗
                            (⌜v' = #true⌝ ∗ ⌜x ∈ X⌝ ∨ ⌜v' = #false⌝ ∗ ⌜x ∉ X⌝) }}.
  Proof.
    iIntros (?) "Hv".
    wp_rec. wp_pures.
    iDestruct "Hv" as (hd ws l ->) "(Hl & Hws & %)".
    wp_load. wp_pures.
    iApply (wp_wand with "[Hws]").
    { iApply (wp_llmember with "Hws"); auto. }
    iIntros (v) "[Hws [[-> %]|[-> %]]]".
    - iSplitL.
      { iExists _,_,_. eauto with iFrame. }
      iLeft. iSplit; eauto. iPureIntro. set_solver.
    - iSplitL.
      { iExists _,_,_. eauto with iFrame. }
      iRight. iSplit; eauto. iPureIntro. set_solver.
  Qed.

  Lemma wp_mset_clear v X :
    is_mset v X -∗ WP mset_clear v {{ v', ⌜v' = #()⌝ ∗ is_mset v ∅ }}.
  Proof.
    iDestruct 1 as (hd ws l ->) "(Hl & _ & _)".
    wp_rec. wp_bind (llnil #()).
    iApply wp_wand; first iApply wp_llnil.
    iIntros (v) "Hv". wp_store. iModIntro. iSplit; eauto.
    iExists _,_,_. iFrame "Hl Hv".
    iSplit; eauto. iPureIntro.
    split; eauto || econstructor.
  Qed.

End mset.


(*******************************************************************
 * Este archivo especifica las acciones
 * (Como transformadores de estado)
 ******************************************************************)

Section Actions.

Require Export State.

(* Ejercicio 7.2 *)
(* Accion. Se definen solo las 3 acciones pedidas *)
Inductive action : Set :=
           read : vadd -> action
         | write : vadd -> value -> action
         | chmod : action.

(* Ejercicio 7.3 *)
Variable ctx : context.

Definition va_mapped_to_ma (s:state) (va:vadd) (ma:madd) : Prop :=
           exists os_inf : os_info, oss s (active_os s) = Some os_inf /\
             exists p_m : padd -> option madd, hypervisor s (active_os s) = Some p_m /\
               exists mdir : madd, p_m (curr_page os_inf) = Some mdir /\
                 exists pg : page, memory s mdir = Some pg /\
                   exists v_m : vadd -> option madd, page_content pg = PT v_m /\ v_m va = Some ma.

Definition is_RW (o : option page) :=
               exists p v, o = Some p /\ page_content p = RW v.

Definition Pre_read (s:state) (va:vadd) : Prop :=
                ctxt_vadd_accessible ctx va  = true
             /\ aos_activity s = running
             /\ (exists ma : madd,
                      va_mapped_to_ma s va ma
                   /\ is_RW (memory s ma)).

Definition Post_read (s:state) (va:vadd) (s':state) : Prop := s = s'.

Definition Pre_write (s:state) (va:vadd) (val:value) : Prop :=
                ctxt_vadd_accessible ctx va  = true
             /\ aos_activity s = running
             /\ (exists ma : madd,
                      va_mapped_to_ma s va ma
                   /\ is_RW (memory s ma)).

Definition Post_write (s:state) (va:vadd) (val:value) (s':state) : Prop :=
                exists ma : madd, va_mapped_to_ma s va ma
                  /\ (forall md : madd,
                              (md <> ma -> memory s' md = memory s md)
                           /\ (md = ma -> memory s' md = Some (Page (RW (Some val)) (Os (active_os s)))))
                  /\ active_os s' = active_os s
                  /\ aos_exec_mode s' = aos_exec_mode s
                  /\ aos_activity s' = aos_activity s
                  /\ oss s' = oss s
                  /\ hypervisor s' = hypervisor s.

Definition Pre_chmod (s:state) : Prop :=
                 aos_activity s = waiting
              /\ exists os_inf : os_info, oss s (active_os s) = Some os_inf /\ hcall os_inf = None.

Definition Post_chmod (s:state) (s':state) : Prop :=
                 ((ctxt_oss ctx (active_os s) = true /\ aos_exec_mode s' = svc /\ aos_activity s' = running)
                   \/ (ctxt_oss ctx (active_os s) = false /\ aos_exec_mode s' = usr /\ aos_activity s' = running))
                 /\ active_os s' = active_os s
                 /\ oss s' = oss s
                 /\ hypervisor s' = hypervisor s
                 /\ memory s' = memory s.

Definition Pre (s:state) (a:action) : Prop :=
         match a with
          | read va => Pre_read s va
          | write va val => Pre_write s va val
          | chmod => Pre_chmod s
         end.

Definition Post (s:state) (a:action) (s':state) : Prop :=
         match a with
          | read va => Post_read s va s'
          | write va val => Post_write s va val s'
          | chmod => Post_chmod s s'
         end.

(* Ejercicio 7.5*)
Definition PropIII (s:state) : Prop :=
                    (aos_activity s = running /\ ctxt_oss ctx (active_os s) = true)
                  \/ aos_activity s = waiting (* Esta ejecutando el hypervisor *)
                     -> aos_exec_mode s = svc.

Definition PropV_mapping (s:state) : Prop :=
               forall osi : os_ident, forall p_m : padd -> option madd, forall pa : padd,
                 hypervisor s osi = Some p_m ->
                   exists ma:madd, p_m pa = Some ma /\
                   exists pg:page, memory s ma = Some pg /\ page_owned_by pg = Os osi.

Definition PropV_inyectividad (s:state) : Prop :=
               forall osi : os_ident, forall p_m : padd -> option madd,
                  hypervisor s osi = Some p_m ->
                     forall p1 p2 : padd, p1 <> p2 -> p_m p1 <> p_m p2 \/ p_m p1 = None.

Definition PropV (s:state) : Prop := PropV_mapping s /\ PropV_inyectividad s.

Definition PropVI (s:state) : Prop :=
               forall osi : os_ident, forall ma1 ma2 : madd, forall pg1 : page,
               forall v_m : vadd -> option madd, forall va : vadd,
                   memory s ma1 = Some pg1 ->
                   page_content pg1 = PT v_m ->
                   page_owned_by pg1 = Os osi ->
                   v_m va = Some ma2 ->
                   exists pg2:page,
                        memory s ma2 = Some pg2
                       /\ (ctxt_vadd_accessible ctx va = true -> page_owned_by pg2 = Os osi)
                       /\ (ctxt_vadd_accessible ctx va = false -> page_owned_by pg2 = Hyp).

(* Se define valid_state solo con las 3 propiedades pedidas *)
Definition valid_state (s:state) := PropIII s /\ PropV s /\ PropVI s.

(* Ejercicio 7.4 *)

Inductive one_step_exec (s:state) (a:action) (s':state) : Prop :=
                 ose : valid_state s -> Pre s a -> Post s a s' -> one_step_exec s a s'.

(* Ejercicio 7.6 *)
Lemma ej7_6 : forall s s':state, forall a:action, Pre s a -> Post s a s'-> PropIII s -> PropIII s'.
Proof.
  intros.
  unfold PropIII.
  intro.
  case_eq a ; intros.
    (* Caso read *)
    rewrite -> H3 in *.
    simpl in H0.
    unfold Post_read in H0.
    unfold PropIII in H1.
    rewrite -> H0 in H1.
    apply (H1 H2).
    (* Caso write *)
    rewrite -> H3 in *.
    simpl in H0.
    unfold Post_write in H0.
    unfold PropIII in H1.
    elim H0; clear H0; intros.
    elim H0; clear H0; intros.
    elim H4; clear H4; intros.
    elim H5; clear H5; intros.
    elim H6; clear H6; intros.
    elim H7; clear H7; intros.
    rewrite -> H6.
    rewrite -> H7 in H2.
    rewrite -> H5 in H2.
    apply (H1 H2).
    (* Caso chmod *)
    rewrite -> H3 in *.
    simpl in H0.
    unfold Post_chmod in H0.
    elim H0; clear H0; intros.
    elim H0; intros.
      (* Caso SO confiable *)
      apply H5.
      (* Caso SO no confiable *)
      elim H5; clear H5; intros.
      elim H6; clear H6; intros.
      elim H2; intros.
        (* Caso SO confiable *)
        elim H8; clear H8; intros.
        elim H4; clear H4; intros.
        rewrite H4 in H9.
        rewrite -> H9 in H5.
        inversion H5.
        (* Caso Hypervisor *)
        rewrite H7 in H8.
        inversion H8.
Qed.

(* Ejercicio 7.7 *)
Lemma read_isolation : forall s s':state, forall va:vadd,
                       one_step_exec s (read va) s' ->
                              exists ma:madd, va_mapped_to_ma s va ma /\
                              exists pg: page, Some pg = memory s ma /\ page_owned_by pg = Os (active_os s).
Proof.
  intros.
  elim H; clear H; intros.
  simpl in H0.
  unfold Pre_read in H0.
  elim H0; clear H0; intros.
  elim H2; clear H2; intros.
  elim H3; clear H3; intros.
  exists x.
  split; try apply H3.
  unfold valid_state in H.
  elim H; clear H; intros p3 H.
  elim H; clear H; intros p5 p6.
  elim H3; clear H3; intros.

  (* Las sucesivas aplicaciones de la táctica
     'elim' son para sacar todas las instancias
     de los existenciales en H : va_mapped_to_ma s va x *)
  elim H; clear H; intros osi H.
  elim H; clear H; intros.
  elim H4; clear H4; intros p_m H4.
  elim H4; clear H4; intros.
  elim H5; clear H5; intros mdir H5.
  elim H5; clear H5; intros.
  elim H6; clear H6; intros pg H6.
  elim H6; clear H6; intros.
  elim H7; clear H7; intros v_m H7.
  elim H7; clear H7; intros.

  unfold PropVI in p6.
  elim (p6 (active_os s) mdir x pg v_m va H6 H7); try auto.
    (* Termino de probar el goal principal *)
    intros.
    exists x0.
    elim H9; clear H9; intros.
    elim H10; clear H10; intros.
    split; auto.
    (* Pruebo uno de las hipotesis necesarias de la propiedad 6 *)
    unfold PropV in p5.
    elim p5; clear p5; intros p5 p5_iny.
    unfold PropV_mapping in p5.
    elim (p5 (active_os s) p_m (curr_page osi) H4) ; intros.
    elim H9; clear H9; intros.
    elim H10; clear H10; intros.
    elim H10; clear H10; intros.
    rewrite -> H5 in H9.
    injection H9; intro.
    rewrite <- H12 in H10.
    rewrite -> H6 in H10.
    injection H10; intro.
    rewrite H13.
    auto.
Qed.

End Actions.


Require Import Chart.Util.
Require Import Chart.Semantics.Config.
Require Import Chart.Semantics.ConfigEnv.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Import ListNotations.
Local Open Scope string_scope.
Set Implicit Arguments.

Module Config <: ConfigType.
  Definition S := string.
  Definition E := unit.
  Inductive Config :=
  | U : Config
  | P : Config -> Config -> Config
  | N : S -> Config -> Config.
End Config.
Import Config.

Module CfgEnv := ConfigEnvSemantics Config.
Import CfgEnv.

Section Syntax.
  Definition nest m cs : Chart :=
    Nest m (fun x => match assoc string_dec cs x with
                     | Some ch => ch
                     | None => Unit
                     end).
End Syntax.

Section Turnstile.

  Definition power :=
    {| machine_initial '(x, tt) := In x ["Off"];
       machine_terminal '(x, tt) := In x [];
       machine_inner x tt tt := In x ["Off"; "On"];
       machine_step '(x,tt) '(x',tt) := In (x, x') [("Off", "On"); ("On", "Off")]
    |}.

  Definition gate :=
    {| machine_initial '(x, tt) := In x ["Locked"];
       machine_terminal '(x, tt) := In x ["Locked"; "Unlocked"];
       machine_inner x tt tt := In x ["Locked"; "Unlocked"];
       machine_step '(x,tt) '(x',tt) := In (x, x') [("Locked", "Unlocked"); ("Unlocked", "Locked")]
    |}.

  Definition card :=
    {| machine_initial '(x, tt) := In x ["Ready"];
       machine_terminal '(x, tt) := In x ["Ready"; "Reading"; "Accept"];
       machine_inner x tt tt := In x ["Ready"; "Reading"; "Accept"];
       machine_step '(x, tt) '(x', tt) :=
         In (x, x') [ ("Ready", "Reading");
                      ("Reading", "Ready");
                      ("Reading", "Accept");
                      ("Accept", "Ready")
                    ]
    |}.

  Definition turnstile := nest power [("On", Par (nest gate []) (nest card []))].

  Goal chart_initial turnstile (N "Off" U, tt).
  Proof.
    apply CI_Nest.
    simpl.
    intuition.
    simpl.
    apply CI_Unit.
  Qed.

  Goal chart_step turnstile
       (N "Off" U, tt)
       (N "On" (P (N "Locked" U) (N "Ready" U)), tt).
  Proof.
    repeat constructor.
  Qed.

  Goal chart_refines (nest power []) turnstile.
    unfold turnstile.
    constructor.
    intros x.
    destruct (string_dec x "On") as [H | H]; constructor.
  Qed.
End Turnstile.


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

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

(**********************************************************************)
(*                   LamSF_Closed.v                                   *)
(*                                                                    *)
(*                      Barry Jay                                     *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import Test.
Require Import General.
Require Import Max.
Require Import LamSF_Terms.
Require Import LamSF_Tactics.
Require Import LamSF_Substitution_term.
Require Import Components.
Require Import Compounds.
Require Import LamSF_reduction.
Require Import LamSF_Normal.

(* closed terms *)

Fixpoint maxvar (M: lamSF) :=
match M with
| Ref i => S i
| Op o  => 0
| App M1 M2 => max (maxvar M1) (maxvar M2)
| Abs N => pred (maxvar N)
end.

Definition closed M := maxvar M = 0.

Lemma maxvar_lift_rec : forall M n k, maxvar M + k >= maxvar (lift_rec M n k) .
Proof.
induction M; split_all.
unfold relocate. elim(test n0 n); split_all; omega.
omega.
assert(pred (maxvar M) + k >= pred (maxvar M + k)) by omega.
assert(maxvar M + k >= maxvar (lift_rec M (S n) k)) by eapply2 IHM.
omega.
rewrite max_plus.
eapply2 max_monotonic.
Qed.

Lemma subst_decreases_maxvar :
forall M N k,  max (pred (maxvar M)) (maxvar N + k) >= maxvar(subst_rec M N k).
Proof.
induction M; split_all.
unfold insert_Ref.
elim(compare k n); split_all.
elim a; split_all.
assert(max n (maxvar N + k) >= n) by eapply2 max_is_max.
omega.
unfold lift.
elim(maxvar_lift_rec N 0 k); split_all.
eapply2 max_is_max.
assert(max n (S m) >= max n m) by (eapply2 max_monotonic; omega).
omega.
assert(max n (maxvar N + k) >= maxvar N + k) by eapply2 max_is_max.
omega.
omega.

(* 2 subgoals *)
assert(max (pred (pred (maxvar M))) (maxvar N + k) >= pred(max (pred (maxvar M)) (maxvar N + (S k)))).
rewrite max_pred.
eapply2 max_monotonic.
omega.
assert(max (pred (maxvar M)) (maxvar N + S k) >= maxvar (subst_rec M N (S k)))
by eapply2 IHM.
assert(pred (max (pred (maxvar M)) (maxvar N + S k)) >= pred (maxvar (subst_rec M N (S k)))) by omega.
omega.
(* 1 *)
rewrite max_pred.
assert(max(max (pred (maxvar M1)) (maxvar N + k) ) (max (pred (maxvar M2)) (maxvar N + k)) >= max (maxvar (subst_rec M1 N k)) (maxvar (subst_rec M2 N k))).
eapply2 max_monotonic.
assert(max (max (pred (maxvar M1)) (pred (maxvar M2))) (maxvar N + k)  >=
max(max (pred (maxvar M1)) (maxvar N + k) ) (max (pred (maxvar M2)) (maxvar N + k))).
2: omega.
eapply2 max_max2; eapply2 max_monotonic; eapply2 max_is_max.
Qed.

Definition decreases  (rank: lamSF -> nat) (red:termred):=
forall M N, red M N -> rank M >= rank N.

Lemma decreases_multi_step:
forall rank red, decreases rank red -> decreases rank (multi_step red).
Proof.
red. intros rank red D M N R;  induction R; split_all.
assert(rank M >= rank N) by eapply2 D.
assert(rank N >= rank P) by eapply2 IHR.
omega.
Qed.

Lemma lift_rec_closed: forall M n, n>= maxvar M  -> forall k, lift_rec M n k = M.
Proof. induction M; split_all; subst; unfold lift; unfold lift_rec; fold lift_rec.
unfold relocate. elim(test n0 n); split_all; try noway.
rewrite IHM.  auto. omega.
assert(max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
assert(max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
rewrite IHM1; try omega; rewrite IHM2; try omega; congruence.
Qed.

Lemma lift_closed: forall M, maxvar M =0 -> forall k, lift k M = M.
Proof.  split_all; eapply2 lift_rec_closed. omega. Qed.

Lemma subst_rec_closed : forall M n, n>= maxvar M -> forall N, subst_rec M N n = M.
Proof.
induction M; split_all; subst.
unfold insert_Ref.
elim(compare n0 n); split_all; try noway.  elim a; split_all; try noway.
rewrite IHM; try omega; split_all.
assert(max (maxvar M1) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
assert(max (maxvar M1) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
rewrite IHM1; try omega; rewrite IHM2; try omega; split_all.
Qed.

Ltac closed_tac M :=  repeat (rewrite (subst_rec_closed M); [| split_all; omega]).

Lemma maxvar_subst_rec: forall M k, maxvar M <= k -> forall N, subst_rec M N k = M.
Proof.
induction M; unfold subst_rec; fold subst_rec; split_all; subst.
unfold insert_Ref. elim(compare k n); split_all; try noway.
elim a; split_all; try noway.
rewrite IHM; split_all; omega.

assert(k>= maxvar M1 /\ k>= maxvar M2) by eapply2 max_max; split_all.
rewrite IHM1; split_all.
rewrite IHM2; split_all.
Qed.

Lemma maxvar_star: forall M, maxvar (star M) = pred (maxvar M).
Proof.
induction M; split_all.
case n; split_all.
rewrite max_pred. auto.
Qed.

Lemma left_component_preserves_maxvar : forall M,
maxvar(left_component M) <= maxvar M.
Proof.
induction M; split_all; try omega.
eapply2 max_is_max.
Qed.

Lemma right_component_preserves_maxvar : forall M,
maxvar(right_component M) <= maxvar M.
Proof.
induction M; split_all.
rewrite maxvar_star. auto.
eapply2 max_is_max.
Qed.

Ltac max_l :=
match goal with
| |- max ?m ?n >= ?p =>
assert(max m n >= m) by eapply2 max_is_max;
cut(m >= p); split_all; try omega
end.
Ltac max_r :=
match goal with
| |- max ?m ?n >= ?p =>
assert(max m n >= n) by eapply2 max_is_max;
cut(n >= p); split_all; try omega
end.

Lemma decreases_maxvar_lamF_red1: decreases maxvar lamSF_red1.
(*
forall M N, lamF_red1 M N -> maxvar N <= maxvar M.
*)
Proof.
cut(forall M N, lamSF_red1 M N -> maxvar N <= maxvar M).
split_all; red.

intros M N R; induction R; split_all; eauto;
try (repeat (eapply2 max_monotonic); rewrite max_zero; omega); try omega; repeat (eapply2 max_max2);
try (max_r; rewrite max_zero; omega);
try (assert(max (max (maxvar M) (maxvar N)) (maxvar P) >= max (maxvar M) (maxvar N)) by max_l);
try (repeat max_l; rewrite max_zero; omega);
try (max_r; eapply2 left_component_preserves_maxvar; rewrite max_zero; omega);
try (max_r; eapply2 right_component_preserves_maxvar; rewrite max_zero; omega);
try (rewrite max_zero; assert(max(maxvar M) (maxvar N) >= maxvar M) by max_l; omega);
try (assert(max(maxvar M) (maxvar N) >= maxvar N) by max_r; omega);
try (max_l; max_l; eapply2 left_component_preserves_maxvar; rewrite max_zero; omega);
try (max_l; max_l; eapply2 right_component_preserves_maxvar; rewrite max_zero; omega);
try (max_l; max_r).
(* 2 *)
unfold subst.
assert(max (pred (maxvar M)) (maxvar N + 0) >= maxvar(subst_rec M N 0)).
eapply2 subst_decreases_maxvar.
replace (maxvar N + 0) with (maxvar N) in H by omega.
omega.
(* 1 *)
assert(max(maxvar M) (maxvar N) >= maxvar M) by max_l. omega.
Qed.

Lemma decreases_maxvar_lamF_red : decreases maxvar lamSF_red.
Proof. eapply2 decreases_multi_step. eapply2 decreases_maxvar_lamF_red1. Qed.

Lemma status_lt_maxvar: forall M i, (status M = Active i \/ status M = Lam i) -> i < maxvar M.
Proof.
rank_tac.
induction M; intros; try max_out; try (eapply2 IHM1); try (split_all; omega).
(* 4 *)
simpl in *; split_all.  inversion H0.
(* 5 *)
invsub; omega.
(* 4 *)
discriminate.
(* 3 *)
gen_case H0 o; simpl in *; or_tac.
(* 2 *)
simpl in *; inversion H0.
(* 3 *)
gen2_case IHM H0 (status M); try ( inversion H0; discriminate).
(* 4 *)
gen2_case IHM H0 n; inversion H0; try discriminate.  inversion H2; subst.
gen_case H1 (status M); gen_case H1 n0; discriminate.
(* 3 *)
gen2_case IHM H0 n; inversion H0; try discriminate.  inversion H2; subst.
gen_case H1 (status M); gen_case H1 n0; discriminate.
(* 2 *)
gen3_case IHM H0 H1 (status M).
(* 3 *)
gen3_case IHM H0 H1 n.
invsub. assert(S i < maxvar M).  eapply2 IHM; omega. omega.
(* 2 *)
gen3_case IHM H0 H1 n.
invsub. assert(S i < maxvar M).  eapply2 IHM; omega. omega.
(* 1 *)
inversion H0.
2: elim(lam_is_abs (App M1 M2) i); split_all; discriminate.
assert(status M1 = Active i \/ status M2 = Active i \/ status M2 = Lam i)
by eapply2 status_app_active.
simpl in *.
gen4_case IHM1 H0 H1 H2 (status M1).
invsub.
assert(max (maxvar M1 ) (maxvar M2) >= maxvar M1) by eapply2 max_is_max.
assert(i<maxvar M1) by (eapply2 IHM1; omega).
omega.
(* 2 *)
inversion H2. discriminate.
(* 2 *)
inversion H3; rewrite H4 in *.
assert(max (maxvar M1 ) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
assert(i<maxvar M2) by (eapply2 IHM2; omega).
omega.
(* 2 *)
assert(max (maxvar M1 ) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
assert(i<maxvar M2) by (eapply2 IHM2; omega).
omega.
(* 1 *)
inversion H2. discriminate.
(* 1 *)
inversion H3; rewrite H4 in *.
assert(max (maxvar M1 ) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
assert(i<maxvar M2) by (eapply2 IHM2; omega).
omega.
(* 1 *)
assert(max (maxvar M1 ) (maxvar M2) >= maxvar M2) by eapply2 max_is_max.
assert(i<maxvar M2) by (eapply2 IHM2; omega).
omega.
Qed.

Definition program M := normal M /\ maxvar M = 0.

Lemma components_monotonic:
forall M N, program M -> program N ->
left_component M = left_component N ->
right_component M = right_component N -> M = N.
Proof.
induction M; unfold program; split_all.
(* 3 *)
gen4_case H1 H2 H3 H4 N; try discriminate.
subst. inversion H3. simpl in *. assert False by eapply2 H7; noway.
(* 2 *)
gen4_case H1 H2 H3 H4 N; try discriminate.
(* 3 *)
assert(M=l). eapply2 star_monotonic. congruence.
(* 2 *)
subst. unfold abs_left in H3.  inversion H3. simpl in *. subst.
assert False by eapply2 H7; noway.
(* 1 *)
subst. gen2_case H4 H0 N; inversion H0; try discriminate.
subst. inversion H0. simpl in *. assert False by eapply2 H7; noway.
simpl in *. assert False by eapply2 H7; noway.
Qed.

Theorem programs_are_factorable : forall M, program M  -> factorable M.
Proof.
unfold program, factorable; split_all.
assert(status M <> Reducible). intro.
assert(exists N, lamSF_red1 M N) by eapply2 Reducible_implies_reducible.
split_all. eapply2 normal_is_irreducible.
assert(forall i, (status M <> Active i /\ status M <> Lam i)).
split_all; intro; assert(i< maxvar M) by eapply2 status_lt_maxvar; omega.
gen2_case H H2 (status M); or_tac; auto 10.
assert False by eapply2 H2; noway.
assert(Active n <> Active n) by eapply2 H2. assert False by eapply2 H3; noway.
Qed.

Ltac factorable_tac M := assert(factorable M)  by (eapply2 programs_are_factorable; split_all; omega);
 match goal with | H: factorable M |- _ => inversion H; split_all end.


(* This file contains the definitions of i-contraction/reduction,
   i-expansion, i,s-reduction, and the formalisation of their basic
   properties *)

Require Import general.
Require Import iterms.
Require Import lterms.
Require Import erase_facts.

Definition Contr_clc_i :=
  CtxClose_l (fun x y => match x, y with itm i1, itm i2 => Contr_clc i1 i2 | _, _ => False end).

Definition Red_clc_i := clos_refl_trans lterm Contr_clc_i.

Definition Contr_exp_clc_i :=
  CtxClose_l (fun x y => match x, y with
                         | itm i1, itm i2 =>
                           Contr_clc i1 i2 \/ Contr_clc i2 i1
                         | _, _ => False end).
Definition Contr_exp_eq_clc_i t1 t2 := Contr_exp_clc_i t1 t2 \/ t1 = t2.

Definition Contr_clc_i_s x y := Contr_clc_i x y \/ Contr_clc_s x y.
Definition Red_clc_i_s := clos_refl_trans lterm Contr_clc_i_s.

Lemma lem_contr_i_implies_erased_eqv : forall t1 t2, Contr_clc_i t1 t2 -> ErasedEqv t1 t2.
Proof.
  pose lem_contr_clc_implies_eqv_clc.
  unfold ErasedEqv, Eqv_clc.
  intros t1 t2 H; induction H; simpl; eqv_solve 1.
Qed.

Lemma lem_contr_exp_i_implies_erased_eqv : forall t1 t2, Contr_exp_clc_i t1 t2 -> ErasedEqv t1 t2.
Proof.
  pose lem_contr_clc_implies_eqv_clc.
  unfold ErasedEqv, Eqv_clc.
  intros t1 t2 H; induction H; simpl; try eqv_solve 1.
  ydestruct t1; ydestruct t2; try yelles 1.
  yintuition.
  eqv_solve 1.
  pose eqv_sym; pose eqv_lift; ycrush.
Qed.

Lemma lem_red_s_implies_red_i_s : forall x y, Red_clc_s x y -> Red_clc_i_s x y.
Proof.
  unfold Red_clc_s, Red_clc_i_s, Contr_clc_i_s.
  intros x y H; induction H; pose_rt; ycrush.
Qed.

Lemma lem_contr_clc0_implies_contr_i_s :
  forall q1 q2, Contr_clc0 q1 q2 -> Contr_clc_i_s (itm q1) (itm q2).
Proof.
  pose lem_contr_clc0_implies_contr_clc.
  unfold Contr_clc_i_s, Contr_clc_i; pose_ctx_l; ycrush.
Qed.

Lemma lem_rcontr_s_implies_red_i_s : forall x y, RootContr_clc_s x y -> Red_clc_i_s x y.
Proof.
  unfold Red_clc_i_s, Contr_clc_i_s, Contr_clc_s; pose_rt; pose_ctx_l; ycrush.
Qed.

Lemma lem_red_i_s_refl : forall x, Red_clc_i_s x x.
Proof.
  unfold Red_clc_i_s; pose_rt; ycrush.
Qed.

Lemma lem_red_i_s_trans : forall x y z, Red_clc_i_s x y -> Red_clc_i_s y z -> Red_clc_i_s x z.
Proof.
  unfold Red_clc_i_s; pose_rt; ycrush.
Qed.

Lemma lem_contr_i_s_to_red_i_s : forall x y, Contr_clc_i_s x y -> Red_clc_i_s x y.
Proof.
  unfold Red_clc_i_s; pose_rt; ycrush.
Qed.

Lemma lem_red_i_s_cong_l : forall x y z, Red_clc_i_s x y -> Red_clc_i_s (x @l z) (y @l z).
Proof.
  unfold Red_clc_i_s; intros; induction H.
  unfold Contr_clc_i_s, Contr_clc_i, Contr_clc_s in *; pose_rt; pose_ctx_l; ycrush.
  pose_rt; ycrush.
  pose_rt; ycrush.
Qed.

Lemma lem_red_i_s_cong_r : forall x y z, Red_clc_i_s x y -> Red_clc_i_s (z @l x) (z @l y).
Proof.
  unfold Red_clc_i_s; intros; induction H.
  unfold Contr_clc_i_s, Contr_clc_i, Contr_clc_s in *; pose_rt; pose_ctx_l; ycrush.
  pose_rt; ycrush.
  pose_rt; ycrush.
Qed.

Lemma lem_red_i_s_ltup_0 : forall x x' y l, Red_clc_i_s x x' -> Red_clc_i_s (ltup x y l) (ltup x' y l).
Proof.
  unfold Red_clc_i_s; intros; induction H.
  unfold Contr_clc_i_s, Contr_clc_i, Contr_clc_s in *; pose_rt; pose_ctx_l; ycrush.
  pose_rt; ycrush.
  pose_rt; ycrush.
Qed.

Lemma lem_red_i_s_ltup_1 : forall x y y' l, Red_clc_i_s y y' -> Red_clc_i_s (ltup x y l) (ltup x y' l).
Proof.
  unfold Red_clc_i_s; intros; induction H.
  unfold Contr_clc_i_s, Contr_clc_i, Contr_clc_s in *; pose_rt; pose_ctx_l; ycrush.
  pose_rt; ycrush.
  pose_rt; ycrush.
Qed.

Lemma lem_red_i_s_ltup_2 : forall x y z z' l l', Red_clc_i_s z z' ->
                                                 Red_clc_i_s (ltup x y (l ++ z :: l'))
                                                             (ltup x y (l ++ z' :: l')).
Proof.
  unfold Red_clc_i_s; intros; induction H.
  unfold Contr_clc_i_s, Contr_clc_i, Contr_clc_s in *; pose_rt; pose_ctx_l; ycrush.
  pose_rt; ycrush.
  pose_rt; ycrush.
Qed.

Ltac pose_red_i_s := pose lem_red_i_s_refl; pose lem_red_i_s_trans; pose lem_contr_i_s_to_red_i_s;
                     pose lem_red_i_s_cong_l; pose lem_red_i_s_cong_r;
                     pose lem_red_i_s_ltup_0; pose lem_red_i_s_ltup_1; pose lem_red_i_s_ltup_2.

Ltac cei_crush := unfold Contr_exp_clc_i in *; pose_ctx_l; ycrush.

Lemma lem_contr_exp_i : forall x y, Contr_exp_clc_i x y <-> Contr_clc_i x y \/ Contr_clc_i y x.
Proof.
  yintuition.
  induction H; [ ydestruct t1; ydestruct t2; try yelles 1 | .. ];
    unfold Contr_clc_i; pose_ctx_l; ycrush.
  induction H0; cei_crush.
  induction H0; cei_crush.
Qed.

Lemma lem_contr_exp_i_sym : forall x y, Contr_exp_clc_i x y -> Contr_exp_clc_i y x.
Proof.
  pose lem_contr_exp_i; ycrush.
Qed.


(* Copyright © 1998-2006
 * Henk Barendregt
 * Luís Cruz-Filipe
 * Herman Geuvers
 * Mariusz Giero
 * Rik van Ginneken
 * Dimitri Hendriks
 * Sébastien Hinderer
 * Bart Kirkels
 * Pierre Letouzey
 * Iris Loeb
 * Lionel Mamane
 * Milad Niqui
 * Russell O’Connor
 * Randy Pollack
 * Nickolay V. Shmyrev
 * Bas Spitters
 * Dan Synek
 * Freek Wiedijk
 * Jan Zwanenburg
 *
 * This work is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2 of the License, or
 * (at your option) any later version.
 *
 * This work is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License along
 * with this work; if not, write to the Free Software Foundation, Inc.,
 * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
 *)

Require Export CoRN.algebra.CPolynomials.
Require Import Coq.Classes.Morphisms.
Require Import CoRN.algebra.CRings.
Import CRing_Homomorphisms.coercions.

(**
* Polynomials: Nth Coefficient
%\begin{convention}% Let [R] be a ring and write [RX] for the ring of
polynomials over [R].
%\end{convention}%

** Definitions
*)

Section NthCoeff_def.

Variable R : CRing.

(* begin hide *)
Notation RX := (cpoly_cring R).
(* end hide *)

(**
The [n]-th coefficient of a polynomial. The default value is
[Zero:CR] e.g. if the [n] is higher than the length. For the
polynomial $a_0 +a_1 X +a_2 X^2 + \cdots + a_n X^n$ #a0 +a1 X +a2 X^2
+ ... + an X^n#, the [Zero]-th coefficient is $a_0$#a0#, the first
is $a_1$#a1# etcetera.  *)
Arguments cpoly_zero {CR}.
Arguments cpoly_linear [CR].

Fixpoint nth_coeff (n : nat) (p : RX) {struct p} : R :=
  match p with
  | cpoly_zero       => [0]
  | cpoly_linear c q =>
      match n with
      | O   => c
      | S m => nth_coeff m q
      end
  end.

Lemma nth_coeff_strext : forall n p p', nth_coeff n p [#] nth_coeff n p' -> p [#] p'.
Proof.
 do 3 intro.
 generalize n.
 clear n.
 pattern p, p' in |- *.
 apply Ccpoly_double_sym_ind.
   unfold Csymmetric in |- *.
   intros.
   apply ap_symmetric_unfolded.
   apply X with n.
   apply ap_symmetric_unfolded.
   assumption.
  intro p0.
  pattern p0 in |- *.
  apply Ccpoly_induc.
   simpl in |- *.
   intros.
   elim (ap_irreflexive_unfolded _ _ X).
  do 4 intro.
  elim n.
   simpl in |- *.
   auto.
  intros.
  cut (c [#] [0] or p1 [#] [0]).
   intro; apply _linear_ap_zero.
   auto.
  right.
  apply X with n0.
  astepr ([0]:R). auto.
  intros.
 induction  n as [| n Hrecn].
  simpl in X0.
  cut (c [#] d or p0 [#] q).
   auto.
  auto.
 cut (c [#] d or p0 [#] q).
  auto.
 right.
 apply X with n.
 exact X0.
Qed.

Lemma nth_coeff_wd : forall n p p', p [=] p' -> nth_coeff n p [=] nth_coeff n p'.
Proof.
 intros.
 generalize (fun_strext_imp_wd _ _ (nth_coeff n)); intro.
 unfold fun_wd in H0.
 apply H0.
  unfold fun_strext in |- *.
  intros.
  apply nth_coeff_strext with n.
  assumption.
 assumption.
Qed.

Global Instance: forall n, Proper (@st_eq _ ==> @st_eq _) (nth_coeff n).
Proof. intros n ??. apply (nth_coeff_wd n). Qed.

Definition nth_coeff_fun n := Build_CSetoid_fun _ _ _ (nth_coeff_strext n).

(**
%\begin{shortcoming}%
We would like to use [nth_coeff_fun n] all the time.
However, Coq's coercion mechanism doesn't support this properly:
the term
[(nth_coeff_fun n p)] won't get parsed, and has to be written as
[((nth_coeff_fun n) p)] instead.

So, in the names of lemmas, we write [(nth_coeff n p)],
which always (e.g. in proofs) can be converted
to [((nth_coeff_fun n) p)].
%\end{shortcoming}%
*)

Definition nonConst p : CProp := {n : nat | 0 < n | nth_coeff n p [#] [0]}.

(**
The following is probably NOT needed.  These functions are
NOT extensional, that is, they are not CSetoid functions.
*)

Fixpoint nth_coeff_ok (n : nat) (p : RX) {struct p} : bool :=
  match n, p with
  | O,   cpoly_zero       => false
  | O,   cpoly_linear c q => true
  | S m, cpoly_zero       => false
  | S m, cpoly_linear c q => nth_coeff_ok m q
  end.

(* The in_coeff predicate*)
Fixpoint in_coeff (c : R) (p : RX) {struct p} : Prop :=
  match p with
  | cpoly_zero       => False
  | cpoly_linear d q => c [=] d \/ in_coeff c q
  end.

(**
The [cpoly_zero] case should be [c [=] [0]] in order to be extensional.
*)

Lemma nth_coeff_S : forall m p c,
 in_coeff (nth_coeff m p) p -> in_coeff (nth_coeff (S m) (c[+X*]p)) (c[+X*]p).
Proof.
 simpl in |- *; auto.
Qed.

End NthCoeff_def.

Arguments nth_coeff [R].
Arguments nth_coeff_fun [R].

#[global]
Hint Resolve nth_coeff_wd: algebra_c.

Section NthCoeff_props.

(**
** Properties of [nth_coeff] *)

Variable R : CRing.

(* begin hide *)
Notation RX := (cpoly_cring R).
(* end hide *)

Lemma nth_coeff_zero : forall n, nth_coeff n ([0]:RX) [=] [0].
Proof.
 intros.
 simpl in |- *.
 algebra.
Qed.

Lemma coeff_O_lin : forall p (c : R), nth_coeff 0 (c[+X*]p) [=] c.
Proof.
 intros.
 simpl in |- *.
 algebra.
Qed.

Lemma coeff_Sm_lin : forall p (c : R) m, nth_coeff (S m) (c[+X*]p) [=] nth_coeff m p.
Proof.
 intros.
 simpl in |- *.
 algebra.
Qed.

Lemma coeff_O_c_ : forall c : R, nth_coeff 0 (_C_ c) [=] c.
Proof.
 intros.
 simpl in |- *.
 algebra.
Qed.

Lemma coeff_O_x_mult : forall p : RX, nth_coeff 0 (_X_[*]p) [=] [0].
Proof.
 intros.
 astepl (nth_coeff 0 ([0][+]_X_[*]p)).
 astepl (nth_coeff 0 (_C_ [0][+]_X_[*]p)).
 astepl (nth_coeff 0 ([0][+X*]p)).
 simpl in |- *.
 algebra.
Qed.

Lemma coeff_Sm_x_mult : forall (p : RX) m, nth_coeff (S m) (_X_[*]p) [=] nth_coeff m p.
Proof.
 intros.
 astepl (nth_coeff (S m) ([0][+]_X_[*]p)).
 astepl (nth_coeff (S m) (_C_ [0][+]_X_[*]p)).
 astepl (nth_coeff (S m) ([0][+X*]p)).
 simpl in |- *.
 algebra.
Qed.

Lemma coeff_Sm_mult_x_ : forall (p : RX) m, nth_coeff (S m) (p[*]_X_) [=] nth_coeff m p.
Proof.
 intros.
 astepl (nth_coeff (S m) (_X_[*]p)).
 apply coeff_Sm_x_mult.
Qed.

Hint Resolve nth_coeff_zero coeff_O_lin coeff_Sm_lin coeff_O_c_
  coeff_O_x_mult coeff_Sm_x_mult coeff_Sm_mult_x_: algebra.

Lemma nth_coeff_ap_zero_imp : forall (p : RX) n, nth_coeff n p [#] [0] -> p [#] [0].
Proof.
 intros.
 cut (nth_coeff n p [#] nth_coeff n [0]).
  intro H0.
  apply (nth_coeff_strext _ _ _ _ H0).
 algebra.
Qed.

Lemma nth_coeff_plus : forall (p q : RX) n,
 nth_coeff n (p[+]q) [=] nth_coeff n p[+]nth_coeff n q.
Proof.
 do 2 intro.
 pattern p, q in |- *.
 apply poly_double_comp_ind.
   intros.
   astepl (nth_coeff n (p1[+]q1)).
   astepr (nth_coeff n p1[+]nth_coeff n q1).
   apply H1.
  intros.
  simpl in |- *.
  algebra.
 intros.
 elim n.
  simpl in |- *.
  algebra.
 intros.
 astepl (nth_coeff n0 (p0[+]q0)).
 generalize (H n0); intro.
 astepl (nth_coeff n0 p0[+]nth_coeff n0 q0).
 algebra.
Qed.

Lemma nth_coeff_inv : forall (p : RX) n, nth_coeff n [--]p [=] [--] (nth_coeff n p).
Proof.
 intro.
 pattern p in |- *.
 apply cpoly_induc.
  intros.
  simpl in |- *.
  algebra.
 intros.
 elim n.
  simpl in |- *.
  algebra.
 intros. simpl in |- *.
 apply H.
Qed.

Hint Resolve nth_coeff_inv: algebra.

Lemma nth_coeff_c_mult_p : forall (p : RX) c n, nth_coeff n (_C_ c[*]p) [=] c[*]nth_coeff n p.
Proof.
 do 2 intro.
 pattern p in |- *.
 apply cpoly_induc.
  intros.
  astepl (nth_coeff n ([0]:RX)).
  astepr (c[*][0]).
  astepl ([0]:R).
  algebra.
 intros.
 elim n.
  simpl in |- *.
  algebra.
 intros.
 astepl (nth_coeff (S n0) (c[*]c0[+X*]_C_ c[*]p0)).
 astepl (nth_coeff n0 (_C_ c[*]p0)).
 astepl (c[*]nth_coeff n0 p0).
 algebra.
Qed.

Lemma nth_coeff_p_mult_c_ : forall (p : RX) c n, nth_coeff n (p[*]_C_ c) [=] nth_coeff n p[*]c.
Proof.
 intros.
 astepl (nth_coeff n (_C_ c[*]p)).
 astepr (c[*]nth_coeff n p).
 apply nth_coeff_c_mult_p.
Qed.

Hint Resolve nth_coeff_c_mult_p nth_coeff_p_mult_c_ nth_coeff_plus: algebra.

Lemma nth_coeff_complicated : forall a b (p : RX) n,
 nth_coeff (S n) ((_C_ a[*]_X_[+]_C_ b) [*]p) [=] a[*]nth_coeff n p[+]b[*]nth_coeff (S n) p.
Proof.
 intros.
 astepl (nth_coeff (S n) (_C_ a[*]_X_[*]p[+]_C_ b[*]p)).
 astepl (nth_coeff (S n) (_C_ a[*]_X_[*]p) [+]nth_coeff (S n) (_C_ b[*]p)).
 astepl (nth_coeff (S n) (_C_ a[*] (_X_[*]p)) [+]b[*]nth_coeff (S n) p).
 astepl (a[*]nth_coeff (S n) (_X_[*]p) [+]b[*]nth_coeff (S n) p).
 algebra.
Qed.

Lemma all_nth_coeff_eq_imp : forall p p' : RX,
 (forall i, nth_coeff i p [=] nth_coeff i p') -> p [=] p'.
Proof.
 intro. induction  p as [| s p Hrecp]; intros;
   [ induction  p' as [| s p' Hrecp'] | induction  p' as [| s0 p' Hrecp'] ]; intros.
    algebra.
   simpl in |- *. simpl in H. simpl in Hrecp'. split.
   apply eq_symmetric_unfolded. apply (H 0). apply Hrecp'.
    intros. apply (H (S i)).
   simpl in |- *. simpl in H. simpl in Hrecp. split.
  apply (H 0).
  change ([0] [=] (p:RX)) in |- *. apply eq_symmetric_unfolded. simpl in |- *. apply Hrecp.
  intros. apply (H (S i)).
  simpl in |- *. simpl in H. split.
 apply (H 0).
 change ((p:RX) [=] (p':RX)) in |- *. apply Hrecp. intros. apply (H (S i)).
Qed.

Lemma poly_at_zero : forall p : RX, p ! [0] [=] nth_coeff 0 p.
Proof.
 intros. induction  p as [| s p Hrecp]; intros.
 simpl in |- *. algebra.
  simpl in |- *. Step_final (s[+][0]).
Qed.

Lemma nth_coeff_inv' : forall (p : RX) i,
 nth_coeff i (cpoly_inv _ p) [=] [--] (nth_coeff i p).
Proof.
 intros. change (nth_coeff i [--] (p:RX) [=] [--] (nth_coeff i p)) in |- *. algebra.
Qed.

Lemma nth_coeff_minus : forall (p q : RX) i,
 nth_coeff i (p[-]q) [=] nth_coeff i p[-]nth_coeff i q.
Proof.
 intros.
 astepl (nth_coeff i (p[+][--]q)).
 astepl (nth_coeff i p[+]nth_coeff i [--]q).
 Step_final (nth_coeff i p[+][--] (nth_coeff i q)).
Qed.

Hint Resolve nth_coeff_minus: algebra.

Lemma nth_coeff_sum0 : forall (p_ : nat -> RX) k n,
 nth_coeff k (Sum0 n p_) [=] Sum0 n (fun i => nth_coeff k (p_ i)).
Proof.
 intros. induction  n as [| n Hrecn]; intros.
 simpl in |- *. algebra.
  change (nth_coeff k (Sum0 n p_[+]p_ n) [=]
    Sum0 n (fun i : nat => nth_coeff k (p_ i)) [+]nth_coeff k (p_ n)) in |- *.
 Step_final (nth_coeff k (Sum0 n p_) [+]nth_coeff k (p_ n)).
Qed.

Lemma nth_coeff_sum : forall (p_ : nat -> RX) k m n,
 nth_coeff k (Sum m n p_) [=] Sum m n (fun i => nth_coeff k (p_ i)).
Proof.
 unfold Sum in |- *. unfold Sum1 in |- *. intros.
 astepl (nth_coeff k (Sum0 (S n) p_) [-]nth_coeff k (Sum0 m p_)).
 apply cg_minus_wd; apply nth_coeff_sum0.
Qed.

Lemma nth_coeff_nexp_eq : forall i, nth_coeff i (_X_[^]i) [=] ([1]:R).
Proof.
 intros. induction  i as [| i Hreci]; intros.
 simpl in |- *. algebra.
  change (nth_coeff (S i) (_X_[^]i[*]_X_) [=] ([1]:R)) in |- *.
 Step_final (nth_coeff i (_X_[^]i):R).
Qed.

Lemma nth_coeff_nexp_neq : forall i j, i <> j -> nth_coeff i (_X_[^]j) [=] ([0]:R).
Proof.
 intro; induction  i as [| i Hreci]; intros;
   [ induction  j as [| j Hrecj] | induction  j as [| j Hrecj] ]; intros.
    elim (H (refl_equal _)).
   Step_final (nth_coeff 0 (_X_[*]_X_[^]j):R).
  simpl in |- *. algebra.
  change (nth_coeff (S i) (_X_[^]j[*]_X_) [=] ([0]:R)) in |- *.
 astepl (nth_coeff i (_X_[^]j):R).
 apply Hreci. auto.
Qed.

Lemma nth_coeff_mult : forall (p q : RX) n,
 nth_coeff n (p[*]q) [=] Sum 0 n (fun i => nth_coeff i p[*]nth_coeff (n - i) q).
Proof.
 intro; induction  p as [| s p Hrecp]. intros.
  stepl (nth_coeff n ([0]:RX)).
   simpl in |- *. apply eq_symmetric_unfolded.
   apply Sum_zero. auto with arith. intros. algebra.
    apply nth_coeff_wd.
  change ([0][=][0][*]q).
  algebra.
 intros.
 apply eq_transitive_unfolded with (nth_coeff n (_C_ s[*]q[+]_X_[*] ((p:RX) [*]q))).
  apply nth_coeff_wd.
  change ((s[+X*]p) [*]q [=] _C_ s[*]q[+]_X_[*] ((p:RX) [*]q)) in |- *.
  astepl ((_C_ s[+]_X_[*]p) [*]q).
  Step_final (_C_ s[*]q[+]_X_[*]p[*]q).
 astepl (nth_coeff n (_C_ s[*]q) [+]nth_coeff n (_X_[*] ((p:RX) [*]q))).
 astepl (s[*]nth_coeff n q[+]nth_coeff n (_X_[*] ((p:RX) [*]q))).
 induction  n as [| n Hrecn]; intros.
  astepl (s[*]nth_coeff 0 q[+][0]).
  astepl (s[*]nth_coeff 0 q).
  astepl (nth_coeff 0 (cpoly_linear _ s p) [*]nth_coeff 0 q).
  pattern 0 at 2 in |- *. replace 0 with (0 - 0).
  apply eq_symmetric_unfolded.
   apply Sum_one with (f := fun i : nat => nth_coeff i (cpoly_linear _ s p) [*]nth_coeff (0 - i) q).
  auto.
 astepl (s[*]nth_coeff (S n) q[+]nth_coeff n ((p:RX) [*]q)).
 apply eq_transitive_unfolded with (nth_coeff 0 (cpoly_linear _ s p) [*]nth_coeff (S n - 0) q[+]
   Sum 1 (S n) (fun i : nat => nth_coeff i (cpoly_linear _ s p) [*]nth_coeff (S n - i) q)).
  apply bin_op_wd_unfolded. algebra.
   astepl (Sum 0 n (fun i : nat => nth_coeff i p[*]nth_coeff (n - i) q)).
  apply Sum_shift. intros. simpl in |- *. algebra.
  apply eq_symmetric_unfolded.
 apply Sum_first with (f := fun i : nat => nth_coeff i (cpoly_linear _ s p) [*]nth_coeff (S n - i) q).
Qed.

End NthCoeff_props.

#[global]
Hint Resolve nth_coeff_wd: algebra_c.
#[global]
Hint Resolve nth_coeff_complicated poly_at_zero nth_coeff_inv: algebra.
#[global]
Hint Resolve nth_coeff_inv' nth_coeff_c_mult_p nth_coeff_mult: algebra.
#[global]
Hint Resolve nth_coeff_zero nth_coeff_plus nth_coeff_minus: algebra.
#[global]
Hint Resolve nth_coeff_nexp_eq nth_coeff_nexp_neq: algebra.


(************************************************************************)
(* Copyright (c) 2015-2019, Ajay Kumar Eeralla                          *)
(*                                                                      *)
(* This work is licensed under the MIT license. The license is          *)
(* described in the file "LICENSE" available at the root of the source  *)
(* or at https://opensource.org/licenses/MIT                            *)
(************************************************************************)

Require Export ifMorph.

(** This library defines a theorem that states,[ [[ msg x]] ~ [[ msg y]] -> x # y.] *)

Theorem Example10_M: forall (x  F z : message), [msg x] ~ [msg (const F z )] -> x # (const F z) .
 Proof.
intros.
simpl in H.
unfold const in H.
unfold const.
apply FUNCApp_const with (a := [msg F])(ml1 := ([msg x]))(ml2 := [msg F]) in H.
unfold const in H. unfold appMylist in H.
simpl in H.

apply FUNCApp_eqm with (p1 := 2) (p2:=1) in H.
simpl in H.
unfold eqm_at_pos in H.
unfold chkmsg_os in H. unfold getelt_at_pos in H.
simpl in H.
apply RESTR_proj with (p:=3) in H. unfold proj_at_pos in H. simpl in H.
apply RESTR_proj with (p:=2) in H. unfold proj_at_pos in H. simpl in H.
assert (J:[bol (eqm F F) ] ~[bol TRue]) .
assert(K: (EQm F F)).
reflexivity.
apply K.
assert (K:[bol (eqm x F)] ~[bol TRue]) .
apply EQI_trans with (ml2 := [bol (eqm F F)]).
assumption. assumption. assumption.
Qed.

(** The following theorem states that [x~f -> x=f] *)

Theorem Example10_B: forall (x  F z : Bool), [bol x] ~ [bol (const F z )] ->  x ## (const F  z) .
 Proof.
intros.
simpl in H.
unfold const in H.
unfold const.
apply FUNCApp_const with (a := [bol F])(ml1 := ([bol x]))(ml2 := [bol F]) in H.
unfold const in H.
simpl in H.
pose proof (FUNCApp_eqb).
apply FUNCApp_eqb with ( p1:=2)(p2:=1) in H.
unfold appMylist in H.
unfold eqb_at_pos in H.
simpl in H.
assert (J:[bol (eqb F F) ] ~[bol TRue]) .
assert(K: (EQb F F)).
reflexivity.
apply K.
assert (K:[bol (eqb x F)] ~[bol TRue]) .
apply EQI_trans with (ml2 := [bol (eqb F F)]).
apply H.
apply J.
apply K.
Qed.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.PreFun.

Require Import MirrorCore.TypesI.

Require Import Coq.Strings.String.

Require Import Charge.ModularFunc.Denotation.

Set Implicit Arguments.
Set Strict Implicit.
Set Maximal Implicit Insertion.

Class ListType (typ : Type) := {
  tyList : typ -> typ
}.

Section ListTypeD.
  Context {typ : Type} {LT : ListType typ} {RType_typ : RType typ}.

  Class ListTypeD := {
    btList : forall t, typD (tyList t) = list (typD t);

    tyList_inj : forall t u, Rty (tyList t) (tyList u) -> Rty t u
  }.

End ListTypeD.

Implicit Arguments ListTypeD [[typ] [RType_typ]].

Section ListTypeD'.
  Context {typ : Type} {LT : ListType typ} {RType_typ : RType typ} {LTD : ListTypeD LT}.

  Definition listE {A : Type} {t : typ} (e : typD t = A) : typD (tyList t) = list A :=
    eq_ind (typD t) (fun B : Type => typD (tyList t) = list B) (btList t) A e.

  Definition listD {t : typ} (lst : typD (tyList t)) : list (typD t) :=
    trmD lst (listE eq_refl).

  Definition listR {t : typ} (lst : list (typD t)) : typD (tyList t) :=
    trmR lst (listE eq_refl).

  Lemma trmDR_cons (t : typ) A B (x : A) (xs : list A) (e1 : typD t = A) (e2 : typD t = B) :
    (trmD (trmR (x :: xs) (listE e1)) (listE e2)) =
      trmD (trmR x e1) e2 :: trmD (trmR xs (listE e1)) (listE e2).
  Proof.
	unfold trmD, trmR, listE, eq_ind, eq_rect_r, eq_rect, eq_sym, id.
	clear.
	revert e1 e2.
	generalize (btList t).
	generalize dependent (typD (tyList t)).
	generalize dependent (typD t); intros; repeat subst. reflexivity.
  Qed.
    (*
  Lemma trmR_nil t (A : Type) (e : typD t = A) :
    trmR nil (listE e) = mkNil t.
    *)
End ListTypeD'.

Implicit Arguments listE [[A] [typ] [LT] [RType_typ] [LTD] [t]].

Ltac list_inj :=
  match goal with
    | typ : Type |- _ =>
      match goal with
        | LT : ListType typ, RType_typ : RType typ |- _ =>
          match goal with
            | _ : ListTypeD LT, H : tyList _ = tyList _ |- _ => apply tyList_inj in H; unfold Rty in H; subst
          end
      end
  end.

(*
This would be the ideal tactic, unfortunately it seems like LTac can not handle type class inference in a proper way
but everything has to be made explicit.

Ltac list_inj :=
  match goal with
    | H : tyList _ = tyList _ |- _ => apply tyList_inj in H; unfold Rty in H; subst
  end.
*)


(* Full safety for STLC *)
(* values well-typed with respect to runtime environment *)
(* inversion lemma structure *)
(* subtyping (in addition to nano2.v) *)
(* this version includes a proof of totality (like in nano0-total.v *)

Require Export SfLib.

Require Export Arith.EqNat.
Require Export Arith.Le.

Module STLC.

Definition id := nat.

Inductive ty : Type :=
  | TBool  : ty
  | TFun   : ty -> ty -> ty
  | TBot   : ty
  | TTop   : ty
.

Inductive tm : Type :=
  | ttrue : tm
  | tfalse : tm
  | tvar : id -> tm
  | tapp : tm -> tm -> tm (* f(x) *)
  | tabs : tm -> tm (* \f x.y *)
.

Inductive vl : Type :=
  | vbool : bool -> vl
  | vabs  : list vl -> tm -> vl
.

Definition venv := list vl.
Definition tenv := list ty.

Hint Unfold venv.
Hint Unfold tenv.

Fixpoint index {X : Type} (n : id) (l : list X) : option X :=
  match l with
    | [] => None
    | a :: l'  => if beq_nat n (length l') then Some a else index n l'
  end.

Inductive closed: nat -> ty -> Prop :=
| cl_bot: forall k,
    closed k TBot
| cl_top: forall k,
    closed k TTop
| cl_bool: forall k,
    closed k TBool
| cl_fun: forall k T1 T2,
    closed k T1 ->
    closed k T2 ->
    closed k (TFun T1 T2)
.

Inductive stp: tenv -> ty -> ty -> Prop :=
| stp_bot: forall G1 T1,
    closed (length G1) T1 ->
    stp G1 TBot T1
| stp_top: forall G1 T1,
    closed (length G1) T1 ->
    stp G1 T1 TTop
| stp_bool: forall G1,
    stp G1 TBool TBool
| stp_fun: forall G1 T1 T2 T3 T4,
    stp G1 T3 T1 ->
    stp G1 T2 T4 ->
    stp G1 (TFun T1 T2) (TFun T3 T4)
.

Inductive has_type : tenv -> tm -> ty -> Prop :=
| t_true: forall env,
    has_type env ttrue TBool
| t_false: forall env,
    has_type env tfalse TBool
| t_var: forall x env T1,
    index x env = Some T1 ->
    has_type env (tvar x) T1
| t_app: forall env f x T1 T2,
    has_type env f (TFun T1 T2) ->
    has_type env x T1 ->
    has_type env (tapp f x) T2
| t_abs: forall env y T1 T2,
    has_type (T1::env) y T2 ->
    closed (length env) (TFun T1 T2) ->
    has_type env (tabs y) (TFun T1 T2)
| t_sub: forall env x T1 T2,
    has_type env x T1 ->
    stp env T1 T2 ->
    has_type env x T2
.

(*
None             means timeout
Some None        means stuck
Some (Some v))   means result v

Could use do-notation to clean up syntax.
*)

Fixpoint teval(n: nat)(env: venv)(t: tm){struct n}: option (option vl) :=
  match n with
    | 0 => None
    | S n =>
      match t with
        | ttrue      => Some (Some (vbool true))
        | tfalse     => Some (Some (vbool false))
        | tvar x     => Some (index x env)
        | tabs y     => Some (Some (vabs env y))
        | tapp ef ex   =>
          match teval n env ex with
            | None => None
            | Some None => Some None
            | Some (Some vx) =>
              match teval n env ef with
                | None => None
                | Some None => Some None
                | Some (Some (vbool _)) => Some None
                | Some (Some (vabs env2 ey)) =>
                  teval n (vx::env2) ey
              end
          end
      end
  end.

Inductive stp2: bool -> venv -> ty -> venv -> ty -> nat -> Prop :=
| stp2_bot: forall G1 G2 T n1,
    closed (length G2) T ->
    stp2 true G1 TBot G2 T (S n1)
| stp2_top: forall G1 G2 T n1,
    closed (length G1) T ->
    stp2 true G1 T G2 TTop (S n1)
| stp2_bool: forall G1 G2 n1,
    stp2 true G1 TBool G2 TBool (S n1)
| stp2_fun: forall G1 G2 T1 T2 T3 T4 n1 n2,
    stp2 false G2 T3 G1 T1 n1 ->
    stp2 false G1 T2 G2 T4 n2 ->
    stp2 true G1 (TFun T1 T2) G2 (TFun T3 T4) (S (n1+n2))
| stp2_wrapf: forall G1 G2 T1 T2 n1,
    stp2 true G1 T1 G2 T2 n1 ->
    stp2 false G1 T1 G2 T2 (S n1)
| stp2_transf: forall G1 G2 G3 T1 T2 T3 n1 n2,
    stp2 true G1 T1 G2 T2 n1 ->
    stp2 false G2 T2 G3 T3 n2 ->
    stp2 false G1 T1 G3 T3 (S (n1+n2))
.

Definition tevaln env e v := exists nm, forall n, n > nm -> teval n env e = Some (Some v).

Fixpoint val_type0 (env:venv) (v:vl) (T:ty) {struct T}: Prop := match v, T with
| vbool b, TBool => True
| vabs env1 y, TFun T1 T2 =>
  closed (length env) T1 /\ closed (length env) T2 /\
  (forall vx, val_type0 env vx T1 ->
              exists v, tevaln (vx::env1) y v /\ val_type0 env v T2)
| _, TTop => True (* can NOT check v with other type *)
| _,_ => False
end.

(* ------------------------- NOTES -------------------------

val_type0 cannot straightforwardly be defined as inductive
family, because the (forall vx, val_type0 env vx T1 -> ... )
occurrence violates the positivity restriction.

The current definition as Fixpoint has some problems, too.
Since it recurses structurally on T, it is unclear how to
add the following desirable rules:

- v: x.T

    index y G1 = Some (vty TX) ->
    vtp G1 v TX ->
    vtp G1 v (TSel y)

- v: { z => T }

    vtp G1 v (open 0 (TVar true x) T2) ->
    closed 0 (length G1) T2 ->
    vtp G1 v (TBind T2)

- v: (x:T1) -> T2^x

    subst x in T2

Another concern is what to do if stp2 needs to use
val_type0 internally (for T < x.L < U).

Ideas:

1) can we define a more complex size measure on types?
   (to exclude recursion through x.T)
2) can stp2 get away with a restricted version of vtp?
   (stp2 only needs type members, not functions)

--------------------------------------------------------- *)

Inductive val_type : venv -> vl -> ty -> Prop :=
| v_sub: forall G1 T1 G2 T2 v,
    val_type0 G1 v T1 ->
    (exists n, stp2 true G1 T1 G2 T2 n) ->
    val_type G2 v T2
.

Inductive wf_env : venv -> tenv -> Prop :=
| wfe_nil : wf_env nil nil
| wfe_cons : forall v t vs ts,
    val_type vs v t ->
    wf_env vs ts ->
    wf_env (cons v vs) (cons t ts)
.

Definition stpd2 m G1 T1 G2 T2 := exists n, stp2 m G1 T1 G2 T2 n.

Hint Constructors stp2.

Ltac ep := match goal with
             | [ |- stp2 ?M ?G1 ?T1 ?G2 ?T2 ?N ] => assert (exists (n:nat), stp2 M G1 T1 G2 T2 n) as EEX
           end.

Ltac eu := match goal with
             | H: stpd2 _ _ _ _ _ |- _ => destruct H as [? H]
           end.

Lemma stpd2_bot: forall G1 G2 T,
    closed (length G2) T ->
    stpd2 true G1 TBot G2 T.
Proof. intros. exists 1. eauto. Qed.
Lemma stpd2_top: forall G1 G2 T,
    closed (length G1) T ->
    stpd2 true G1 T G2 TTop.
Proof. intros. exists 1. eauto. Qed.
Lemma stpd2_bool: forall G1 G2,
    stpd2 true G1 TBool G2 TBool.
Proof. intros. exists 1. eauto. Qed.
Lemma stpd2_fun: forall G1 G2 T1 T2 T3 T4,
    stpd2 false G2 T3 G1 T1 ->
    stpd2 false G1 T2 G2 T4 ->
    stpd2 true  G1 (TFun T1 T2) G2 (TFun T3 T4).
Proof. intros. repeat eu. eexists. eauto. Qed.

Lemma stpd2_wrapf: forall G1 G2 T1 T2,
    stpd2 true G1 T1 G2 T2 ->
    stpd2 false G1 T1 G2 T2.
Proof. intros. repeat eu. eexists. eauto. Qed.
Lemma stpd2_transf: forall G1 G2 G3 T1 T2 T3,
    stpd2 true G1 T1 G2 T2 ->
    stpd2 false G2 T2 G3 T3 ->
    stpd2 false G1 T1 G3 T3.
Proof. intros. repeat eu. eexists. eauto. Qed.

Hint Constructors ty.
Hint Constructors tm.
Hint Constructors vl.

Hint Constructors has_type.
Hint Constructors stp2.
Hint Constructors val_type.
Hint Constructors wf_env.

Hint Unfold stpd2.

Hint Constructors option.
Hint Constructors list.

Hint Unfold index.
Hint Unfold length.

Hint Resolve ex_intro.

Ltac ev := repeat match goal with
                    | H: exists _, _ |- _ => destruct H
                    | H: _ /\  _ |- _ => destruct H
           end.

Lemma wf_length : forall vs ts,
                    wf_env vs ts ->
                    (length vs = length ts).
Proof.
  intros. induction H. auto.
  assert ((length (v::vs)) = 1 + length vs). constructor.
  assert ((length (t::ts)) = 1 + length ts). constructor.
  rewrite IHwf_env in H1. auto.
Qed.

Hint Immediate wf_length.

Lemma index_max : forall X vs n (T: X),
                       index n vs = Some T ->
                       n < length vs.
Proof.
  intros X vs. induction vs.
  Case "nil". intros. inversion H.
  Case "cons".
  intros. inversion H.
  case_eq (beq_nat n (length vs)); intros E.
  SCase "hit".
  rewrite E in H1. inversion H1. subst.
  eapply beq_nat_true in E.
  unfold length. unfold length in E. rewrite E. eauto.
  SCase "miss".
  rewrite E in H1.
  assert (n < length vs). eapply IHvs. apply H1.
  compute. eauto.
Qed.

Lemma index_exists : forall X vs n,
                       n < length vs ->
                       exists (T:X), index n vs = Some T.
Proof.
  intros X vs. induction vs.
  Case "nil". intros. inversion H.
  Case "cons".
  intros. inversion H.
  SCase "hit".
  assert (beq_nat n (length vs) = true) as E. eapply beq_nat_true_iff. eauto.
  simpl. subst n. rewrite E. eauto.
  SCase "miss".
  assert (beq_nat n (length vs) = false) as E. eapply beq_nat_false_iff. omega.
  simpl. rewrite E. eapply IHvs. eauto.
Qed.

Lemma index_extend : forall X vs n a (T: X),
                       index n vs = Some T ->
                       index n (a::vs) = Some T.

Proof.
  intros.
  assert (n < length vs). eapply index_max. eauto.
  assert (n <> length vs). omega.
  assert (beq_nat n (length vs) = false) as E. eapply beq_nat_false_iff; eauto.
  unfold index. unfold index in H. rewrite H. rewrite E. reflexivity.
Qed.

Lemma closed_extend : forall X (a:X) G T,
                       closed (length G) T ->
                       closed (length (a::G)) T.
Proof.
  intros. induction T; inversion H;  econstructor; eauto.
Qed.

Lemma stp2_extend : forall m v1 G1 G2 T1 T2 n,
                      stp2 m G1 T1 G2 T2 n ->
                      stp2 m (v1::G1) T1 G2 T2 n /\
                      stp2 m G1 T1 (v1::G2) T2 n /\
                      stp2 m (v1::G1) T1 (v1::G2) T2 n.
Proof.
  intros. induction H; try solve [repeat split; econstructor; try eauto;
          try eapply IHstp2; eauto;
          try eapply index_extend; eauto; try eapply closed_extend; eauto;
          try eapply IHstp2_1; try eapply IHstp2_2;
            try eapply IHstp2_3; try eapply IHstp2_4].

  (* trans case left *)

  repeat split; eapply stp2_transf; try eapply IHstp2_1; eauto; try eapply IHstp2_2; eauto.
Qed.

Lemma stpd2_extend : forall m v1 G1 G2 T1 T2,
                      stpd2 m G1 T1 G2 T2 ->
                      stpd2 m (v1::G1) T1 G2 T2 /\
                      stpd2 m G1 T1 (v1::G2) T2 /\
                      stpd2 m (v1::G1) T1 (v1::G2) T2.
Proof.
  intros. repeat eu. repeat split; eexists; eapply stp2_extend; eauto.
Qed.

Lemma stp2_extend1 : forall m v1 G1 G2 T1 T2 n, stp2 m G1 T1 G2 T2 n -> stp2 m (v1::G1) T1 G2 T2 n.
Proof. intros. eapply stp2_extend. eauto. Qed.

Lemma stp2_extend2 : forall m v1 G1 G2 T1 T2 n, stp2 m G1 T1 G2 T2 n -> stp2 m G1 T1 (v1::G2) T2 n.
Proof. intros. eapply stp2_extend. eauto. Qed.

Lemma stpd2_extend1 : forall m v1 G1 G2 T1 T2, stpd2 m G1 T1 G2 T2 -> stpd2 m (v1::G1) T1 G2 T2.
Proof. intros. eapply stpd2_extend. eauto. Qed.

Lemma stpd2_extend2 : forall m v1 G1 G2 T1 T2, stpd2 m G1 T1 G2 T2 -> stpd2 m G1 T1 (v1::G2) T2.
Proof. intros. eapply stpd2_extend. eauto. Qed.

Lemma stp_closed : forall G1 T1 T2,
                      stp G1 T1 T2 ->
                      closed (length G1) T1 /\
                      closed (length G1) T2.
Proof.
  intros. induction H; repeat split; try  econstructor; try eapply IHstp1; try eapply IHstp2; eauto; try eapply IHstp; eauto; try eapply index_max; eauto.
  (* destruct IHstp. inversion H1. eauto.
  destruct IHstp2. inversion H3. eauto. *)
Qed.

Lemma stpd2_closed : forall m G1 G2 T1 T2,
                      stpd2 m G1 T1 G2 T2 ->
                      closed (length G1) T1 /\
                      closed (length G2) T2.
Proof.
  intros. eu. induction H; repeat split; try  econstructor; try eapply IHstp2_1; try eapply IHstp2_2; eauto; try eapply IHstp2; eauto; try eapply index_max; eauto.
  (* destruct IHstp2. inversion H1. eauto.
  eapply IHstp2_4. *)
Qed.

Lemma stpd2_closed1 : forall m G1 G2 T1 T2,
                      stpd2 m G1 T1 G2 T2 ->
                      closed (length G1) T1.
Proof. intros. eapply (stpd2_closed m G1 G2); eauto. Qed.

Lemma stpd2_closed2 : forall m G1 G2 T1 T2,
                      stpd2 m G1 T1 G2 T2 ->
                      closed (length G2) T2.
Proof. intros. eapply (stpd2_closed m G1 G2); eauto. Qed.

Lemma valtp0_closed : forall G1 v T,
                       val_type0 G1 v T ->
                       closed (length G1) T.
Proof.
  intros.
  induction T; simpl in H; destruct v; try (solve by inversion); ev; econstructor; eauto.
Qed.

Lemma valtp_extend : forall vs v v1 T,
                       val_type vs v T ->
                       val_type (v1::vs) v T.
Proof.
  intros. induction H; econstructor; eauto; try eapply stpd2_extend; eauto; try eapply index_extend; eauto.
Qed.

Lemma index_safe_ex: forall H1 G1 TF i,
             wf_env H1 G1 ->
             index i G1 = Some TF ->
             exists v, index i H1 = Some v /\ val_type H1 v TF.
Proof. intros. induction H.
       Case "nil". inversion H0.
       Case "cons". inversion H0.
         case_eq (beq_nat i (length ts)).
           SCase "hit".
             intros E.
             rewrite E in H3. inversion H3. subst t.
             assert (beq_nat i (length vs) = true). eauto.
             assert (index i (v :: vs) = Some v). eauto.  unfold index. rewrite H2. eauto.
             eauto using valtp_extend.
           SCase "miss".
             intros E.
             assert (beq_nat i (length vs) = false). eauto.
             rewrite E in H3.
             assert (exists v0, index i vs = Some v0 /\ val_type vs v0 TF) as HI. eapply IHwf_env. eauto.
           inversion HI as [v0 HI1]. inversion HI1.
           eexists. econstructor. eapply index_extend; eauto. eapply valtp_extend; eauto.
Qed.

Inductive res_type: venv -> option vl -> ty -> Prop :=
| not_stuck: forall venv v T,
      val_type venv v T ->
      res_type venv (Some v) T.

Hint Constructors res_type.
Hint Resolve not_stuck.

Lemma stpd2_refl: forall G1 T1,
  closed (length G1) T1 ->
  stpd2 true G1 T1 G1 T1.
Proof.
  intros. induction T1; inversion H.
  - Case "bool". eapply stpd2_bool; eauto.
  - Case "fun". eapply stpd2_fun; try eapply stpd2_wrapf; eauto.
  - Case "bot". exists 1. eauto.
  - Case "top". exists 1. eauto.
Qed.

Lemma stpd2_reg1 : forall m G1 G2 T1 T2,
                      stpd2 m G1 T1 G2 T2 ->
                      stpd2 true G1 T1 G1 T1.
Proof.
  intros. eapply stpd2_refl. eapply (stpd2_closed m G1 G2). eauto.
Qed.

Lemma stpd2_reg2 : forall m G1 G2 T1 T2,
                      stpd2 m G1 T1 G2 T2 ->
                      stpd2 true G2 T2 G2 T2.
Proof.
  intros. eapply stpd2_refl. eapply (stpd2_closed m G1 G2). eauto.
Qed.

Lemma valtp0_reg : forall G2 T2 v,
                      val_type0 G2 v T2 ->
                      stpd2 true G2 T2 G2 T2.
Proof.
  intros. eapply stpd2_refl. eapply valtp0_closed. eauto.
Qed.

Lemma stpd2_trans_axiom_aux: forall n, forall G1 G2 G3 T1 T2 T3 n1,
  stp2 false G1 T1 G2 T2 n1 -> n1 < n ->
  stpd2 false G2 T2 G3 T3 ->
  stpd2 false G1 T1 G3 T3.
Proof.
  intros n. induction n; intros; try omega; repeat eu; subst; inversion H; subst.
  - Case "wrapf". eapply stpd2_transf. eexists. eauto. eexists. eauto.
  - Case "transf". eapply stpd2_transf. eexists. eauto. eapply IHn. eauto. omega. eexists. eauto.
Qed.

Lemma stp2_trans_axiom: forall m G1 G2 G3 T1 T2 T3,
  stpd2 m G1 T1 G2 T2 ->
  stpd2 false G2 T2 G3 T3 ->
  stpd2 false G1 T1 G3 T3.
Proof.
  intros. destruct m; eu; eu; eapply stpd2_trans_axiom_aux; eauto.
Qed.

Lemma stp2_trans: forall n, forall m G1 G2 G3 T1 T2 T3 n1 n2,
  stp2 m G1 T1 G2 T2 n1 ->
  stp2 true G2 T2 G3 T3 n2 ->
  n1 < n ->
  stpd2 true G1 T1 G3 T3.
Proof.
  intros n. induction n; intros. solve by inversion.
  inversion H.
  - Case "bot". eapply stpd2_bot; eauto. eapply stpd2_closed2; eauto.
  - Case "top". inversion H0; subst; try solve by inversion.
    + SCase "top". eapply stpd2_top; eauto.
  - Case "bool". inversion H0; subst; try solve by inversion.
    + SCase "top". eapply stpd2_top; eauto. econstructor.
    + SCase "bool". eapply stpd2_bool; eauto.
  - Case "fun". inversion H0; subst; try solve by inversion.
    + SCase "top". eapply stpd2_top; eauto. eapply stpd2_closed1; eauto.
    + SCase "fun". inversion H14. subst. eapply stpd2_fun; eapply stp2_trans_axiom; eauto.
  - Case "wrapf".
    subst. eapply IHn. eapply H2. eapply H0. omega.
  - Case "transf".
    assert (stpd2 true G4 T4 G3 T3). eapply IHn. eapply H3. eapply H0. omega.
    eu. subst. eapply IHn. eapply H2. eauto. omega.
Qed.

Lemma stpd2_trans: forall m G1 G2 G3 T1 T2 T3,
  stpd2 m G1 T1 G2 T2 ->
  stpd2 true G2 T2 G3 T3 ->
  stpd2 true G1 T1 G3 T3.
Proof.
  intros. repeat eu. eapply stp2_trans; eauto.
Qed.

Lemma stp_to_stpd2: forall G1 T1 T2,
  stp G1 T1 T2 ->
  forall GX, wf_env GX G1 ->
  stpd2 true GX T1 GX T2.
Proof.
  intros G1 T1 T2 H. induction H; intros.
  - Case "bot". eapply stpd2_bot; eauto. rewrite (wf_length GX G1); eauto.
  - Case "top". eapply stpd2_top; eauto. rewrite (wf_length GX G1); eauto.
  - Case "bool". eapply stpd2_bool; eauto.
  - Case "fun".  eapply stpd2_fun; eapply stpd2_wrapf; eauto.
Qed.

Lemma valtp0_widen: forall n, forall m n1 vf H1 H2 T1 T2,
  val_type0 H1 vf T1 ->
  stp2 m H1 T1 H2 T2 n1 -> n1 < n ->
  val_type0 H2 vf T2.
Proof.
  intros n. induction n; intros. omega.
  inversion H0; subst.
  - Case "Bot". compute in H. destruct vf; inversion H.
  - Case "Top". destruct vf; compute; eauto.
  - Case "Bool". destruct vf; compute; eauto.
  - Case "Fun". destruct vf. simpl in H. inversion H.
    simpl in H. ev. simpl.
    split. eapply stpd2_closed1. eauto.
    split. eapply stpd2_closed2. eauto.
    intros.
    specialize (H7 vx).
    eapply IHn in H8.
    specialize (H7 H8).
    ev.
    exists x. split. eauto.
    eapply IHn. eauto. eauto. omega.
    eauto.
    omega.
  - Case "wrapf".
    eapply IHn. eauto. eapply H4. omega.
  - Case "transf".
    assert (val_type0 G2 vf T3). eapply IHn; eauto. omega.
    eapply IHn; eauto. omega.
Qed.

Lemma valtp_widen: forall vf H1 H2 T1 T2,
  val_type H1 vf T1 ->
  stpd2 true H1 T1 H2 T2 ->
  val_type H2 vf T2.
Proof.
  intros.  inversion H.
  - econstructor; eauto. eapply stpd2_trans; eauto.
Qed.

Lemma restp_widen: forall vf H1 H2 T1 T2,
  res_type H1 vf T1 ->
  stpd2 true H1 T1 H2 T2 ->
  res_type H2 vf T2.
Proof.
  intros. inversion H. eapply not_stuck. eapply valtp_widen; eauto.
Qed.

Lemma cvaltp: forall venv vf T1,
  val_type0 venv vf T1 ->
  val_type venv vf T1.
Proof.
  intros. econstructor. eauto. eapply valtp0_reg. eauto.
Qed.

Lemma invert_abs: forall venv vf T1 T2,
  val_type venv vf (TFun T1 T2) ->
  exists env y,
    vf = (vabs env y) /\
    (forall vx : vl,
       val_type venv vx T1 ->
       exists v : vl, tevaln (vx::env) y v /\ val_type venv v T2).
Proof.
  intros. inversion H. ev. subst.
  assert (val_type0 venv0 vf (TFun T1 T2)). eapply valtp0_widen;eauto.
  destruct vf. inversion H2.
  exists l. exists t. split. eauto.
  intros. simpl in H2. ev.
  inversion H3. subst.
  assert (val_type0 venv0 vx T1). ev. eapply valtp0_widen; eauto.
  specialize (H5 vx H8).
  ev. eexists. split. eauto. eapply cvaltp; eauto.
Qed.

(* if not a timeout, then result not stuck and well-typed *)

Theorem full_total_safety : forall e tenv T,
  has_type tenv e T -> forall venv, wf_env venv tenv ->
  exists v, tevaln venv e v /\ val_type venv v T.
Proof.
  intros ? ? ? W.
  induction W; intros ? WFE.

  - Case "True". eexists. split.
    exists 0. intros. destruct n. omega. simpl. eauto. eapply cvaltp. simpl. eauto.
  - Case "False". eexists. split.
    exists 0. intros. destruct n. omega. simpl. eauto. eapply cvaltp. simpl. eauto.

  - Case "Var".
    destruct (index_safe_ex venv0 env T1 x) as [v IV]. eauto. eauto.
    inversion IV as [I V].

    exists v. split. exists 0. intros. destruct n. omega. simpl. rewrite I. eauto. eapply V.

  - Case "App".
    destruct (IHW1 venv0 WFE) as [vf [IW1 HVF]].
    destruct (IHW2 venv0 WFE) as [vx [IW2 HVX]].

    eapply invert_abs in HVF.
    destruct HVF as [venv1 [y [HF IHF]]].

    destruct (IHF vx HVX) as [vy [IW3 HVY]].

    exists vy. split. {
      (* pick large enough n. nf+nx+ny will do. *)
      destruct IW1 as [nf IWF].
      destruct IW2 as [nx IWX].
      destruct IW3 as [ny IWY].
      exists (S (nf+nx+ny)). intros. destruct n. omega. simpl.
      rewrite IWF. subst vf. rewrite IWX. rewrite IWY. eauto.
      omega. omega. omega.
    }
    eapply HVY.

  - Case "Abs".
    erewrite <-(wf_length venv0 env WFE) in H. inversion H; subst.
    eexists. split. exists 0. intros. destruct n. omega. simpl. eauto.
    eapply cvaltp. simpl. repeat split; eauto.  intros.
    assert (stpd2 true venv0 T1 (vx::venv0) T1). eapply stpd2_extend2. eapply stpd2_refl; eauto. eu.
    assert (stpd2 true (vx::venv0) T2 venv0 T2). eapply stpd2_extend1. eapply stpd2_refl; eauto. eu.
    assert (val_type0 (vx::venv0) vx T1). eapply valtp0_widen; eauto.
    assert (wf_env (vx::venv0) (T1::env)). eapply wfe_cons; eauto. eapply cvaltp; eauto.
    specialize (IHW (vx::venv0) H6). ev.
    assert (val_type0 venv0 x1 T2). inversion H8. subst. ev. eapply valtp0_widen. eauto. eapply stp2_transf. eauto. eauto. eauto.
    (* we have all pieces ... *)
    eexists. split; eauto.
  - Case "Sub".
    specialize (IHW venv0 WFE). ev. eexists. split. eauto.
    eapply valtp_widen. eauto. eapply stp_to_stpd2; eauto.
Qed.

End STLC.