(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * Chapter 13: Types and Mutation
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap.

(* Our approach to type soundness works beyond purely functional programs, too.
 * Let's see how it applies to a classic ML feature: mutable references.
 * We'll complete the full exercise for one semantics first, then go back and
 * extend the result to cover a semantics with another crucial real-world
 * feature. *)

Module References.
  Notation loc := nat.
  (* Locations are the values allowed for references.  Think of them as memory
   * addresses. *)

  Inductive exp : Set :=
  | Var (x : var)
  | Const (n : nat)
  | Plus (e1 e2 : exp)
  | Abs (x : var) (e1 : exp)
  | App (e1 e2 : exp)

  | New (e1 : exp)
  (* Allocate a fresh reference, initialized with this value. *)

  | Read (e1 : exp)
  (* Return the value stored at this address. *)

  | Write (e1 e2 : exp)
  (* Overwrite the value at address [e1] with new value [e2]. *)

  | Loc (l : loc).
  (* A twist: though source programs may not mention locations directly,
   * intermediate execution states will need to include location constants. *)

  Inductive value : exp -> Prop :=
  | VConst : forall n, value (Const n)
  | VAbs : forall x e1, value (Abs x e1)

  | VLoc : forall l, value (Loc l).
  (* Locations are values, too. *)

  Fixpoint subst (e1 : exp) (x : string) (e2 : exp) : exp :=
    match e2 with
      | Var y => if y ==v x then e1 else Var y
      | Const n => Const n
      | Plus e2' e2'' => Plus (subst e1 x e2') (subst e1 x e2'')
      | Abs y e2' => Abs y (if y ==v x then e2' else subst e1 x e2')
      | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')

      | New e2' => New (subst e1 x e2')
      | Read e2' => Read (subst e1 x e2')
      | Write e2' e2'' => Write (subst e1 x e2') (subst e1 x e2'')
      | Loc l => Loc l
    end.

  (* We extend evaluation contexts in the natural way, though we won't dwell on
   * the details. *)

  Inductive context : Set :=
  | Hole : context
  | Plus1 : context -> exp -> context
  | Plus2 : exp -> context -> context
  | App1 : context -> exp -> context
  | App2 : exp -> context -> context
  | New1 : context -> context
  | Read1 : context -> context
  | Write1 : context -> exp -> context
  | Write2 : exp -> context -> context.

  Inductive plug : context -> exp -> exp -> Prop :=
  | PlugHole : forall e, plug Hole e e
  | PlugPlus1 : forall e e' C e2,
    plug C e e'
    -> plug (Plus1 C e2) e (Plus e' e2)
  | PlugPlus2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Plus2 v1 C) e (Plus v1 e')
  | PlugApp1 : forall e e' C e2,
    plug C e e'
    -> plug (App1 C e2) e (App e' e2)
  | PlugApp2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (App2 v1 C) e (App v1 e')

  | PlugNew1 : forall e e' C,
    plug C e e'
    -> plug (New1 C) e (New e')
  | PlugRead1 : forall e e' C,
    plug C e e'
    -> plug (Read1 C) e (Read e')
  | PlugWrite1 : forall e e' C e2,
    plug C e e'
    -> plug (Write1 C e2) e (Write e' e2)
  | PlugWrite2 : forall e e' v1 C,
    value v1
    -> plug C e e'
    -> plug (Write2 v1 C) e (Write v1 e').

  Definition heap := fmap loc exp.
  (* A heap assigns a value to each allocated location. *)

  Inductive step0 : heap * exp -> heap * exp -> Prop :=
  | Beta : forall h x e v,
    value v
    -> step0 (h, App (Abs x e) v) (h, subst v x e)
  | Add : forall h n1 n2,
    step0 (h, Plus (Const n1) (Const n2)) (h, Const (n1 + n2))

  (* To run a [New], pick a location [l] that isn't used yet and stash the
   * requested value at that spot before returning it. *)
  | Allocate : forall h v l,
    value v
    -> h $? l = None
    -> step0 (h, New v) (h $+ (l, v), Loc l)

  (* To run a [Read], just look up in the heap. *)
  | Lookup : forall h v l,
    h $? l = Some v
    -> step0 (h, Read (Loc l)) (h, v)

  (* To run a [Write], just replace in the heap, *after* verifying that the
   * location is really present in the heap.  If not, this is another
   * opportunity to get stuck, which we will prove never occurs! *)
  | Overwrite : forall h v l v',
    value v'
    -> h $? l = Some v
    -> step0 (h, Write (Loc l) v') (h $+ (l, v'), v').

  (* The overall relation is much like before, with a heap added. *)
  Inductive step : heap * exp -> heap * exp -> Prop :=
  | StepRule : forall C e1 e2 e1' e2' h h',
    plug C e1 e1'
    -> plug C e2 e2'
    -> step0 (h, e1) (h', e2)
    -> step (h, e1') (h', e2').

  Definition trsys_of (e : exp) := {|
    Initial := {($0, e)};
    Step := step
  |}.

  Inductive type :=
  | Nat
  | Fun (dom ran : type)
  | Ref (t : type).
  (* Crucial type addition: reference types *)

  (* New first parameter to typing relation: a *heap typing*, partial map from
   * locations to types *)
  Inductive hasty : fmap loc type -> fmap var type -> exp -> type -> Prop :=
  | HtVar : forall H G x t,
    G $? x = Some t
    -> hasty H G (Var x) t
  | HtConst : forall H G n,
    hasty H G (Const n) Nat
  | HtPlus : forall H G e1 e2,
    hasty H G e1 Nat
    -> hasty H G e2 Nat
    -> hasty H G (Plus e1 e2) Nat
  | HtAbs : forall H G x e1 t1 t2,
    hasty H (G $+ (x, t1)) e1 t2
    -> hasty H G (Abs x e1) (Fun t1 t2)
  | HtApp : forall H G e1 e2 t1 t2,
    hasty H G e1 (Fun t1 t2)
    -> hasty H G e2 t1
    -> hasty H G (App e1 e2) t2

  | HtNew : forall H G e1 t1,
    hasty H G e1 t1
    -> hasty H G (New e1) (Ref t1)
  | HtRead : forall H G e1 t1,
    hasty H G e1 (Ref t1)
    -> hasty H G (Read e1) t1
  | HtWrite : forall H G e1 e2 t1,
    hasty H G e1 (Ref t1)
    -> hasty H G e2 t1
    -> hasty H G (Write e1 e2) t1
  | HtLoc : forall H G l t,
     H $? l = Some t
     -> hasty H G (Loc l) (Ref t).
  (* Notice that the heap typing is only used here, for locations! *)

  (* When are a heap and a heap typing compatible? *)
  Inductive heapty (ht : fmap loc type) (h : fmap loc exp) : Prop :=
  | Heapty : forall bound,
      (* Condition 1: when the heap typing assigns a type to a location, the
       * heap assigns a value of that type to that location. *)
      (forall l t,
          ht $? l = Some t
          -> exists e, h $? l = Some e
                       /\ hasty ht $0 e t)

      (* Condition 2: all addresses above some bound are unallocated in the
       * heap.  Without this condition, we could get stuck proving that progress
       * can be made from a [New] expression, if the heap could be infinite! *)
      -> (forall l, l >= bound
                    -> h $? l = None)

      -> heapty ht h.

  Global Hint Constructors value plug step0 step hasty heapty : core.

  (* Perhaps surprisingly, this language admits well-typed, nonterminating
   * programs!  Here's an example. *)
  Definition let_ (x : var) (e1 e2 : exp) :=
    App (Abs x e2) e1.
  Example loopy :=
    let_ "r" (New (Abs "x" (Var "x")))
         (let_ "_" (Write (Var "r") (Abs "x" (App (Read (Var "r")) (Var "x"))))
               (App (Read (Var "r")) (Const 0))).

  Theorem loopy_hasty : hasty $0 $0 loopy Nat.
  Proof.
    repeat (econstructor; simplify).
  Qed.

  Global Hint Resolve lookup_add_eq : core.

  Ltac loopy := propositional; subst; simplify;
    repeat match goal with
           | [ x : (_ * _)%type |- _ ] => cases x; simplify
           end;
    propositional; subst;
    repeat match goal with
           | [ H : ex _ |- _ ] => invert H; propositional; subst
           end;
    try match goal with
        | [ H : step _ _ |- _ ] => invert H
        end;
    repeat match goal with
           | [ H : plug _ _ _ |- _ ] => invert1 H
           | [ H : plug _ _ _ |- _ ] => invert H
           | [ H : step0 _ _ |- _ ] => invert1 H
           | [ H : value _ |- _ ] => invert1 H
           | [ H : ?X = Some _, H' : ?X = Some _ |- _ ] => rewrite H in H'; invert H'
           end; eauto 7.

  Theorem loopy_diverge : invariantFor (trsys_of loopy) (fun he => ~value (snd he)).
  Proof.
    (* We prove divergence (unreachability of a value) by strengthening to an
     * invariant that enumerates all reachable expressions.  It isn't quite a
     * finite set.  We need to quantify existentially over the location chosen
     * for "r". *)
    apply invariant_weaken with (invariant1 := fun he =>
      snd he = loopy
      \/ exists l,
        (fst he $? l = Some (Abs "x" (Var "x")))
        /\ (snd he = let_ "r" (Loc l)
                          (let_ "_" (Write (Var "r") (Abs "x" (App (Read (Var "r")) (Var "x"))))
                                (App (Read (Var "r")) (Const 0)))
            \/ snd he = let_ "_" (Write (Loc l) (Abs "x" (App (Read (Loc l)) (Var "x"))))
                             (App (Read (Loc l)) (Const 0)))
        \/ (fst he $? l = Some (Abs "x" (App (Read (Loc l)) (Var "x")))
            /\ (snd he = let_ "_" (Abs "x" (App (Read (Loc l)) (Var "x")))
                               (App (Read (Loc l)) (Const 0))
                \/ snd he = App (Read (Loc l)) (Const 0)
                \/ snd he = App (Abs "x" (App (Read (Loc l)) (Var "x"))) (Const 0)))).

    apply invariant_induction; simplify.

    loopy.
    loopy.
    loopy.
  Qed.

  (** * Type soundness *)

  Definition unstuck (he : heap * exp) := value (snd he)
    \/ (exists he', step he he').

  Ltac t0 := match goal with
             | [ H : ex _ |- _ ] => invert H
             | [ H : _ /\ _ |- _ ] => invert H
             | [ |- context[?x ==v ?y] ] => cases (x ==v y)
             | [ H : Some _ = Some _ |- _ ] => invert H

             | [ H : heapty _ _ |- _ ] => invert H
             | [ H : step _ _ |- _ ] => invert H
             | [ H : step0 _ _ |- _ ] => invert1 H
             | [ H : hasty _ _ ?e _, H' : value ?e |- _ ] => (invert H'; invert H); []
             | [ H : hasty _ _ _ _ |- _ ] => invert1 H
             | [ H : plug _ _ _ |- _ ] => invert1 H
             end; subst.

  Ltac t := simplify; propositional; repeat (t0; simplify); try equality; eauto 7.

  Global Hint Extern 2 (exists _ : _ * _, _) => eexists (_ $+ (_, _), _) : core.

  (* Progress is quite straightforward. *)
  Lemma progress : forall ht h, heapty ht h
    -> forall e t,
      hasty ht $0 e t
      -> value e
         \/ exists he', step (h, e) he'.
  Proof.
    induct 2; t.
    match goal with
    | [ H1 : _ = Some _, H2 : forall l : loc, _ |- _ ] => apply H2 in H1; t
    end.
    match goal with
    | [ H1 : _ = Some _, H2 : forall l : loc, _ |- _ ] => apply H2 in H1; t
    end.
  Qed.

  (* Now, a series of lemmas essentially copied from the original type-soundness
   * proof. *)

  Lemma weakening_override : forall (G G' : fmap var type) x t,
    (forall x' t', G $? x' = Some t' -> G' $? x' = Some t')
    -> (forall x' t', G $+ (x, t) $? x' = Some t'
                      -> G' $+ (x, t) $? x' = Some t').
  Proof.
    simplify.
    cases (x ==v x'); simplify; eauto.
  Qed.

  Global Hint Resolve weakening_override : core.

  Lemma weakening : forall H G e t,
    hasty H G e t
    -> forall G', (forall x t, G $? x = Some t -> G' $? x = Some t)
      -> hasty H G' e t.
  Proof.
    induct 1; t.
  Qed.

  Global Hint Resolve weakening : core.

  Lemma hasty_change : forall H G e t,
    hasty H G e t
    -> forall G', G' = G
      -> hasty H G' e t.
  Proof.
    t.
  Qed.

  Global Hint Resolve hasty_change : core.

  Lemma substitution : forall H G x t' e t e',
    hasty H (G $+ (x, t')) e t
    -> hasty H $0 e' t'
    -> hasty H G (subst e' x e) t.
  Proof.
    induct 1; t.
  Qed.

  Global Hint Resolve substitution : core.

  (* A new property: expanding the heap typing preserves typing. *)
  Lemma heap_weakening : forall H G e t,
    hasty H G e t
    -> forall H', (forall x t, H $? x = Some t -> H' $? x = Some t)
      -> hasty H' G e t.
  Proof.
    induct 1; t.
  Qed.

  Global Hint Resolve heap_weakening : core.

  (* A property about extending heap typings *)
  Lemma heap_override : forall H h k t t0 l,
    H $? k = Some t
    -> heapty H h
    -> h $? l = None
    -> H $+ (l, t0) $? k = Some t.
  Proof.
    invert 2; simplify.
    cases (l ==n k); simplify; eauto.
    apply H2 in H0; t.
  Qed.

  Global Hint Resolve heap_override : core.

  (* A higher-level property, stated via [heapty] *)
  Lemma heapty_extend : forall H h l t v,
      heapty H h
      -> hasty H $0 v t
      -> h $? l = None
      -> heapty (H $+ (l, t)) (h $+ (l, v)).
  Proof.
    t.
    exists (max (S l) bound); simplify.

    cases (l ==n l0); simplify.
    invert H0; eauto 6.
    apply H3 in H0; t.

    apply H4.
    linear_arithmetic.
  Qed.

  Global Hint Resolve heapty_extend : core.

  (* The old cases of preservation proceed as before, and we need to fiddle with
   * the heap in the new cases.  Note a crucial change to the theorem statement:
   * now we say that *for all* original heap typings, *there exists* a new heap
   * typing that has not *dropped* any locations. *)
  Lemma preservation0 : forall h1 e1 h2 e2,
    step0 (h1, e1) (h2, e2)
    -> forall H1 t, hasty H1 $0 e1 t
                    -> heapty H1 h1
                    -> exists H2, hasty H2 $0 e2 t
                                  /\ heapty H2 h2
                                  /\ (forall l t, H1 $? l = Some t
                                                  -> H2 $? l = Some t).
  Proof.
    invert 1; t.

    exists (H1 $+ (l, t1)).
    split.
    econstructor.
    simplify.
    auto.
    eauto 6.

    apply H3 in H9; t.
    rewrite H1 in H2.
    invert H2.
    eauto.

    assert (H1 $? l = Some t) by assumption.
    apply H2 in H9.
    invert H9; propositional.
    rewrite H5 in H6.
    invert H6.
    eexists; propositional.
    eauto.
    exists bound; propositional.
    cases (l ==n l0); simplify; eauto.
    subst.
    rewrite H0 in H; invert H.
    eauto.
    apply H4 in H0.
    cases (l ==n l0); simplify; equality.
    assumption.
  Qed.

  Global Hint Resolve preservation0 : core.

  (* This lemma gets more complicated, too, to accommodate heap typings. *)
  Lemma generalize_plug : forall H e1 C e1',
    plug C e1 e1'
    -> forall t, hasty H $0 e1' t
    -> exists t0, hasty H $0 e1 t0
                  /\ (forall e2 e2' H',
                         hasty H' $0 e2 t0
                         -> plug C e2 e2'
                         -> (forall l t, H $? l = Some t -> H' $? l = Some t)
                         -> hasty H' $0 e2' t).
  Proof.
    Ltac applyIn := match goal with
                    | [ H : forall x, _, H' : _ |- _ ] =>
                      apply H in H'; clear H; invert H'; propositional
                    end.

    induct 1; t; (try applyIn; eexists; t).
  Qed.

  (* For overall preservation, most of the action was in the last few lemmas. *)
  Lemma preservation : forall h1 e1 h2 e2,
    step (h1, e1) (h2, e2)
    -> forall H1 t, hasty H1 $0 e1 t
                   -> heapty H1 h1
                   -> exists H2, hasty H2 $0 e2 t
                                 /\ heapty H2 h2.
  Proof.
    invert 1; simplify.
    eapply generalize_plug in H; eauto.
    invert H; propositional.
    eapply preservation0 in H6; eauto.
    invert H6; propositional.
    eauto.
  Qed.

  Global Hint Resolve progress preservation : core.

  (* We'll need this fact for the base case of invariant induction. *)
  Lemma heapty_empty : heapty $0 $0.
  Proof.
    exists 0; t.
  Qed.

  Global Hint Resolve heapty_empty : core.

  (* Now there isn't much more to the proof of type safety.  The crucial overall
   * insight is a strengthened invariant that quantifies existentially over a
   * heap typing. *)
  Theorem safety : forall e t, hasty $0 $0 e t
    -> invariantFor (trsys_of e)
                    (fun he' => value (snd he')
                                \/ exists he'', step he' he'').
  Proof.
    simplify.
    apply invariant_weaken with (invariant1 := fun he' => exists H,
                                                   hasty H $0 (snd he') t
                                                   /\ heapty H (fst he')); eauto.
    apply invariant_induction; simplify.
    propositional.
    subst; simplify.
    eauto.
    invert H0.
    propositional.
    cases s; cases s'; simplify.
    eauto.

    invert 1.
    propositional.
    cases s.
    eauto.
  Qed.
End References.

(* That last operational semantics lets references pile up in the heap.  Their
 * storage space is never reclaimed, even if the program will never use them
 * again.  It turns out, however, that our type system remains safe, even when
 * we extend the operational semantics with explicit *garbage collection*! *)

Module GarbageCollection.
  Import References.
  (* We'll start from the definitions we just made, only adding a few new ones
   * and revising a few. *)

  (* First key ingredient: which location constants appear in an expression? *)
  Fixpoint freeLocs (e : exp) : set loc :=
    match e with
    | Var _ => {}
    | Const _ => {}
    | Plus e1 e2 => freeLocs e1 \cup freeLocs e2
    | Abs _ e1 => freeLocs e1
    | App e1 e2 => freeLocs e1 \cup freeLocs e2
    | New e1 => freeLocs e1
    | Read e1 => freeLocs e1
    | Write e1 e2 => freeLocs e1 \cup freeLocs e2
    | Loc l => {l}
    end.

  (* When is there a path from one location to another through the heap, via
   * following free locations in the values associated to addresses? *)
  Inductive reachableLoc (h : heap) : loc -> loc -> Prop :=
  | ReachSelf : forall l, reachableLoc h l l
  | ReachLookup : forall l e l' l'',
      h $? l = Some e
      -> l' \in freeLocs e
      -> reachableLoc h l' l''
      -> reachableLoc h l l''.

  (* When is there a path from an expression to a location? *)
  Inductive reachableLocFromExp (h : heap) : exp -> loc -> Prop :=
  | ReachFromExp : forall l e l',
      l \in freeLocs e
      -> reachableLoc h l l'
      -> reachableLocFromExp h e l'.

  Inductive step : heap * exp -> heap * exp -> Prop :=
  | StepRule : forall C e1 e2 e1' e2' h h',
    plug C e1 e1'
    -> plug C e2 e2'
    -> step0 (h, e1) (h', e2)
    -> step (h, e1') (h', e2')

  (* New rule for the operational semantics!  Pick heap [h'] that is the result
   * of garbage collecting [h]. *)
  | StepGc : forall h h' e lDefinitelyGone,

    (* Fundamental condition: any *reachable* location in [h] has been preserved
     * precisely in [h']. *)
    (forall l e',
        reachableLocFromExp h e l
        -> h $? l = Some e'
        -> h' $? l = Some e')

    (* However, [h'] has not sprouted any new locations.  It only keeps some
     * subset of [h]'s locations. *)
    -> (forall l e',
           h' $? l = Some e'
           -> h $? l = Some e')

    (* Finally, we require that [h'] has dropped at least one location from [h].
     * Why?  If not, type safety follows trivially, because, from any starting
     * expression, we can run an infinite loop of no-op "garbage collection"! *)
    -> h $? lDefinitelyGone <> None
    -> h' $? lDefinitelyGone = None

    -> step (h, e) (h', e).

  Global Hint Constructors step : core.

  Definition trsys_of (e : exp) := {|
    Initial := {($0, e)};
    Step := step
  |}.

  (** * Type soundness *)

  Definition unstuck (he : heap * exp) := value (snd he)
    \/ (exists he', step he he').

  (* Progress is easy; we essentially reuse the old proof, since the original
   * [step] case is enough to cover all expressions. *)
  Lemma progress : forall ht h, heapty ht h
    -> forall e t,
      hasty ht $0 e t
      -> value e
         \/ exists he', step (h, e) he'.
  Proof.
    intros.
    eapply References.progress in H0; t.
  Qed.

  (* For preservation, we'll need a few more lemmas.  First, reachability is
   * preserved by moving to a "larger" expression that contains "at least as
   * many" free locations. *)
  Lemma reachableLocFromExp_trans : forall h e1 l e2,
      reachableLocFromExp h e1 l
      -> freeLocs e1 \subseteq freeLocs e2
      -> reachableLocFromExp h e2 l.
  Proof.
    invert 1; simplify.
    econstructor.
    sets; eauto.
    assumption.
  Qed.

  Global Hint Resolve reachableLocFromExp_trans : core.
  Global Hint Extern 1 (_ \in _) => simplify; solve [ sets ] : core.
  Global Hint Extern 1 (_ \subseteq _) => simplify; solve [ sets ] : core.
  Global Hint Constructors reachableLoc reachableLocFromExp : core.

  (* Typing is preserved by moving to a heap typing that only needs to preserve
   * the mappings for *reachable* locations. *)
  Lemma hasty_restrict : forall H h H' G e t,
      heapty H h
      -> hasty H G e t
      -> (forall l t, reachableLocFromExp h e l
                      -> H $? l = Some t
                      -> H' $? l = Some t)
      -> hasty H' G e t.
  Proof.
    induct 2; simplify; econstructor; eauto.
  Qed.

  (* The sandwich properties, for adding a new reachability step through the
   * heap, between two other chains of arbitrary length *)
  Lemma reachableLoc_sandwich : forall h l l' e l'',
    reachableLoc h l l'
    -> h $? l' = Some e
    -> reachableLocFromExp h e l''
    -> reachableLoc h l l''.
  Proof.
    induct 1; simplify; eauto.
    invert H0; eauto.
  Qed.

  Lemma reachableLocFromExp_sandwich : forall h e l e' l',
    reachableLocFromExp h e l
    -> h $? l = Some e'
    -> reachableLocFromExp h e' l'
    -> reachableLocFromExp h e l'.
  Proof.
    invert 1; simplify.
    econstructor; eauto.
    eapply reachableLoc_sandwich; eauto.
  Qed.

  (* Finally, we are ready for preservation. *)
  Lemma preservation : forall h1 e1 h2 e2,
    step (h1, e1) (h2, e2)
    -> forall H1 t, hasty H1 $0 e1 t
                   -> heapty H1 h1
                   -> exists H2, hasty H2 $0 e2 t
                                 /\ heapty H2 h2.
  Proof.
    invert 1; simplify.

    (* The case for the original [step] rule proceeds exactly the same way as
     * before. *)
    eapply generalize_plug in H; eauto 3.
    invert H; propositional.
    eapply preservation0 in H6; eauto 3.
    invert H6; propositional.
    eauto.

    (* The key insight for the garbage-collection rule: as the new heap typing
     * after collection, choose the *restriction* of the original heap typing to
     * just the *reachable* locations. *)
    exists (restrict (reachableLocFromExp h1 e2) H1).
    propositional.

    eapply hasty_restrict; eauto.
    simplify.
    invert H0.
    assert (H1 $? l = Some t0) by assumption.
    apply H8 in H0.
    invert H0; propositional.

    assert (heapty H1 h1) by assumption.
    invert H2.
    exists bound; simplify; propositional.
    assert (reachableLocFromExp h1 e2 l) by (eapply lookup_restrict_true_fwd; eassumption).
    simplify.
    apply H3 in H2.
    invert H2; propositional.
    apply H4 in H2; auto.
    eexists; propositional.
    eauto.
    eapply hasty_restrict.
    eauto.
    eauto.
    simplify.
    assert (H1 $? l0 = Some t1) by assumption.
    apply H3 in H13.
    invert H13; propositional.
    simplify.
    rewrite lookup_restrict_true; auto.
    eapply reachableLocFromExp_sandwich; eauto.

    cases (h2 $? l); eauto.
    apply H8 in H2.
    apply H5 in Heq.
    equality.
  Qed.

  Global Hint Resolve progress preservation : core.

  (* The safety proof itself is anticlimactic, looking the same as before. *)
  Theorem safety : forall e t, hasty $0 $0 e t
    -> invariantFor (trsys_of e)
                    (fun he' => value (snd he')
                                \/ exists he'', step he' he'').
  Proof.
    simplify.
    apply invariant_weaken with (invariant1 := fun he' => exists H,
                                                   hasty H $0 (snd he') t
                                                   /\ heapty H (fst he')); eauto.
    apply invariant_induction; simplify.
    propositional.
    subst; simplify.
    eauto.
    invert H0.
    propositional.
    cases s; cases s'; simplify.
    eauto.

    invert 1.
    propositional.
    cases s.
    eauto.
  Qed.
End GarbageCollection.


Require Import String.
Require Import Names.
Require Import PNames.
Require Import Arith.
Require Import Bool.
Require Import Lambda.
Require Import Arith_Lambda.
Require Import Bool_Lambda.
Require Import Functors.
Require Import Mu.
Require Import NatCase.

Section MiniML.

Open Scope string_scope.

Definition D := AType :+: LType :+: BType.

Definition E (A : Set) := Arith :+: (Lambda D A) :+: Bool :+: (Fix_ D A) :+: (NatCase A).

Definition letrec (A : Set) (t : DType D) (def : A -> Exp E A) (body : A -> Exp E A) :
  (Exp E A) :=  app' D E (lam' _ _ t body) (mu' _ _ t def).

Instance D_typeof T : FAlgebra TypeofName T (typeofR D) (E (typeofR D)).
  eauto with typeclass_instances.
Defined.

Global Instance Fun_E : forall (A : Set),
  Functor (E A).
Proof.
  eauto with typeclass_instances.
Defined.

  Definition V := StuckValue :+: BotValue :+: NatValue :+: (ClosValue E) :+: (BoolValue).

  Instance V_eval : FAlgebra EvalName (Exp E nat) (evalR V) (E nat).
    unfold V, E, D.
    auto 20 with typeclass_instances.
  Defined.

  Global Instance eq_DType_eq_D :
    PAlgebra eq_DType_eqName (sig (UP'_P (eq_DType_eq_P D))) D.
  Proof.
    unfold D.
    eauto 20 with typeclass_instances.
  Defined.

  Definition Eqv (A B : Set) :=
    (NP_Functor_eqv E Arith A B) ::+:: (NP_Functor_eqv E Bool A B) ::+::
    (Lambda_eqv D E A B) ::+:: (Fix_eqv D E A B) ::+:: (NatCase_eqv E A B).

  Definition WFV := (WFValue_Clos D E V Eqv (fun e => typeof _ _ (proj1_sig e))) ::+::
    (WFValue_Bot D V) ::+:: (WFValue_VI D V) ::+:: (WFValue_VB D V).

  Definition SV := (SubValue_refl V) ::+:: (SubValue_Bot V) ::+:: (SubValue_Clos E V).

  Definition EV_Alg : PAlgebra EC_ExpName (sig (UP'_P (eval_continuous_Exp_P V (E nat) SV))) (E nat).
    eauto 400 with typeclass_instances.
  Defined.

  Definition eval_continuous : forall m,
    forall (e : Exp E nat) (gamma gamma' : Env _),
      forall n (Sub_G_G' : Sub_Environment V SV gamma gamma'),
        m <= n ->
        SubValueC _ SV (beval _ _ m e gamma) (beval _ _ n e gamma').
    eapply beval_continuous with (eval_continuous_Exp_E := EV_Alg);
      eauto 800 with typeclass_instances.
  Qed.

  Eval compute in ("Continuity of Evaluation Proven for MiniML!").

  Global Instance Bool_sound P_bind P pb typeof_rec eval_rec :
    PAlgebra eval_Soundness_alg_Name
    (sig (UP'_P2 (eval_alg_Soundness_P D V (E nat) WFV P_bind P
      (E (typeofR D)) (Fun_E (typeofR D)) pb typeof_rec
      eval_rec f_algebra f_algebra))) Bool.
  eauto 250 with typeclass_instances.
  Defined.

  Theorem soundness : forall n gamma gamma' gamma'' e' e'',
    E_eqvC _ Eqv gamma gamma' e' e'' ->
    forall (WF_gamma : forall n b, lookup gamma' n = Some b ->
      exists T, lookup gamma b = Some T)
    (WF_gamma2 : List.length gamma = List.length gamma')
    (WF_gamma' : forall n b, lookup gamma' n = Some b -> b = n)
    (WF_gamma'' : WF_Environment _ _ WFV gamma'' gamma) T,
    typeof D (E _) (proj1_sig e') = Some T -> WFValueC _ _ WFV (beval _ _ n e'' gamma'') T.
  Proof.
    apply soundness_X with (eval_continuous_Exp_E := EV_Alg);
      eauto 800 with typeclass_instances.
  Qed.

  Eval compute in ("Type Soundness for MiniML Proven!").

End MiniML.

(*
*** Local Variables: ***
*** coq-prog-args: ("-emacs-U" "-impredicative-set") ***
*** End: ***
*)


Require Import Omega.

Require Import PreAutoSep.

(** Let's put the lemma prover through its paces. *)

Hint Extern 1 => elimtype False; omega : contradiction.

Theorem t0 : forall a b, a =*> b ===> a =*> b.
  sepLemma.
Qed.

Theorem t1 : forall a b c d, a =*> b * c =*> d ===> c =*> d * a =*> b.
  sepLemma.
Qed.

Theorem t2 : forall P : nat -> Prop, (Ex x, [| P x |]) ===> Ex x, [| P x |].
  sepLemma; eauto.
Qed.

Theorem t3 : forall ls : list nat, [| (length ls > 0)%nat |] ===> Ex x, Ex ls', [| ls = x :: ls' |].
  destruct ls; sepLemma.
Qed.

Theorem t4 : forall A (R : A -> A -> Prop),
  (Ex x, Ex y, Ex z, [| R x y /\ R y z |]) ===> (Ex y, ((Ex x, [| R x y |]) * (Ex z, [| R y z |]))).
  sepLemma.
  apply H.
  eassumption.
Qed.

(** Unification **)
Theorem t5 : forall p1 P2 V, exists p2, exists v,
  (p1 =*> P2 * P2 =*> V) ===> (p1 =*> p2 * p2 =*> v).
  intros. do 2 eexists.
  sepLemma.
Qed.

Theorem t6 : forall p1 P2 V, exists p2, exists v,
  (P2 =*> V * p1 =*> P2) ===> (p1 =*> p2 * p2 =*> v).
  intros. do 2 eexists.
  sepLemma.
Qed.

Theorem t7 : forall p1 P2 V, exists p2, exists v,
  (p1 =*> P2 * P2 =*> V) ===> (p2 =*> v * p1 =*> p2).
  intros. do 2 eexists.
  sepLemma.
Qed.

Theorem t8 : forall p1 P2 V, exists p2, exists v,
  (P2 =*> V * p1 =*> P2) ===> (p2 =*> v * p1 =*> p2).
  intros. do 2 eexists.
  sepLemma.
Qed.

Theorem t_err : forall a b c d, a =*> c * b =*> d ===> a =*> b * c =*> d.
  intros.
  progress sep_canceller ltac:ILTacCommon.isConst auto_ext ltac:(hints_ext_simplifier auto_ext).
  (progress sep_canceller ltac:ILTacCommon.isConst auto_ext ltac:(hints_ext_simplifier auto_ext); fail 3) || idtac.
Abort.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require list.List.
Require list.Length.
Require int.Int.
Require list.Mem.
Require list.Append.

(* Why3 assumption *)
Definition unit := unit.

Axiom qtmark : Type.
Parameter qtmark_WhyType : WhyType qtmark.
Existing Instance qtmark_WhyType.

Axiom char : Type.
Parameter char_WhyType : WhyType char.
Existing Instance char_WhyType.

(* Why3 assumption *)
Inductive regexp :=
  | Empty : regexp
  | Epsilon : regexp
  | Char : char -> regexp
  | Alt : regexp -> regexp -> regexp
  | Concat : regexp -> regexp -> regexp
  | Star : regexp -> regexp.
Axiom regexp_WhyType : WhyType regexp.
Existing Instance regexp_WhyType.

(* Why3 assumption *)
Definition word := (list char).

(* Why3 assumption *)
Inductive mem: (list char) -> regexp -> Prop :=
  | mem_eps : (mem Init.Datatypes.nil Epsilon)
  | mem_char : forall (c:char), (mem
      (Init.Datatypes.cons c Init.Datatypes.nil) (Char c))
  | mem_altl : forall (w:(list char)) (r1:regexp) (r2:regexp), (mem w r1) ->
      (mem w (Alt r1 r2))
  | mem_altr : forall (w:(list char)) (r1:regexp) (r2:regexp), (mem w r2) ->
      (mem w (Alt r1 r2))
  | mem_concat : forall (w1:(list char)) (w2:(list char)) (r1:regexp)
      (r2:regexp), (mem w1 r1) -> ((mem w2 r2) -> (mem
      (Init.Datatypes.app w1 w2) (Concat r1 r2)))
  | mems1 : forall (r:regexp), (mem Init.Datatypes.nil (Star r))
  | mems2 : forall (w1:(list char)) (w2:(list char)) (r:regexp), (mem w1
      r) -> ((mem w2 (Star r)) -> (mem (Init.Datatypes.app w1 w2) (Star r))).

Axiom inversion_mem_star_gen : forall (c:char) (w:(list char)) (r:regexp)
  (w':(list char)) (r':regexp), ((w' = (Init.Datatypes.cons c w)) /\
  (r' = (Star r))) -> ((mem w' r') -> exists w1:(list char),
  exists w2:(list char), (w = (Init.Datatypes.app w1 w2)) /\ ((mem
  (Init.Datatypes.cons c w1) r) /\ (mem w2 r'))).

Axiom inversion_mem_star : forall (c:char) (w:(list char)) (r:regexp), (mem
  (Init.Datatypes.cons c w) (Star r)) -> exists w1:(list char),
  exists w2:(list char), (w = (Init.Datatypes.app w1 w2)) /\ ((mem
  (Init.Datatypes.cons c w1) r) /\ (mem w2 (Star r))).

(* Why3 goal *)
Theorem WP_parameter_residual : forall (r:regexp) (c:char),
  forall (x:regexp), (r = (Star x)) -> forall (o:regexp),
  (forall (w:(list char)), (mem w o) <-> (mem (Init.Datatypes.cons c w)
  x)) -> forall (w:(list char)), (mem w (Concat o r)) <-> (mem
  (Init.Datatypes.cons c w) r).
intros r c x h1 o h2 w.
subst.
intuition.

inversion H; subst; clear H.
rewrite List.app_comm_cons.
constructor; auto.
rewrite <- h2; auto.

destruct (inversion_mem_star _ _ _ H) as (w1 & w2 & hh1 & hh2 & hh3).
subst w.
constructor; auto.
now rewrite h2.

Qed.


(** This is a very simple arithmetic and boolean language that
 ** can be useful for testing.
 **)
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.Nat.
Require Import ExtLib.Data.PList.
Require Import ExtLib.Tactics.

Require Import MirrorCore.ExprI.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.CTypes.CoreTypes.
Require Import MirrorCore.CTypes.TSymOneOf.
Require Import MirrorCore.Lambda.Ptrns.
Require Import MirrorCore.CTypes.ListType.
Require Import MirrorCore.CTypes.BaseType.
Require Import MirrorCore.CTypes.ProdType.
Require Import MirrorCore.Views.ViewSumN.
Require Import MirrorCore.Reify.ReifyClass.
Require Import MirrorCore.Reify.ReifyView.

Set Implicit Arguments.
Set Strict Implicit.

Import OneOfType.

Definition typ_map :=
  list_to_pmap
    (pcons base_typ
           (pcons list_typ
                  (pcons prod_typ
                         pnil))).

Definition typ' := OneOfF typ_map.

Definition typ := ctyp typ'.

Ltac pmap_lookup'_simpl :=
  repeat (
    match goal with
    | H : match pmap_lookup' Empty ?p with | _Some _ => _ | _None => Empty_set end |- _ =>
      exfalso; clear -H; rewrite pmap_lookup'_Empty in H; destruct H
    | H : match pmap_lookup' _ ?p with | _Some _ => _ | _None => Empty_set end |- _ =>
      destruct p; simpl in H
    end).

Ltac eq_dec_right :=
  let H := fresh "H" in
    right; intro H; inv_all; congruence.

Definition typ'_dec {n} (a : typ' n) : forall b, {a = b} + {a <> b}.
Proof.
  intros.
  destruct a as [a1 v1].
  destruct b as [a2 v2].
  unfold typ_map, list_to_pmap, type_nth in *; simpl in *.
  pmap_lookup'_simpl; try eq_dec_right.
  pose proof (prod_typ_dec v1 v2).
  destruct H; [left; subst; reflexivity|].
  right; intros H; apply n0; inv_all; subst.
  assert (x = eq_refl) by (apply UIP_refl); subst. reflexivity.
  pose proof (list_typ_dec v1 v2).
  destruct H; [left; subst; reflexivity|].
  right; intros H; apply n0; inv_all; subst.
  assert (x = eq_refl) by (apply UIP_refl); subst. reflexivity.
  pose proof (base_typ_dec v1 v2).
  destruct H; [left; subst; reflexivity|].
  right; intros H; apply n0; inv_all; subst.
  assert (x = eq_refl) by (apply UIP_refl); subst. reflexivity.
Defined.

Definition typ'D {n} (t : typ' n) : type_for_arity n.
Proof.
  unfold typ', typ_map, list_to_pmap, type_nth in t; simpl in t.
  destruct t as [p v].
  unfold type_nth in v.
  pmap_lookup'_simpl.
  apply prod_typD; assumption.
  apply list_typD; assumption.
  apply base_typD; assumption.
Defined.

Global Instance TypeView_list_typ' : PartialView (typ' 1) (list_typ 1) :=
  PartialViewPMap_Type 2 (typ_map) eq_refl 1.

Global Instance TypeView_base_typ' : PartialView (typ' 0) (base_typ 0) :=
  PartialViewPMap_Type 1 typ_map eq_refl 0.

Global Instance TypeView_prod_typ' : PartialView (typ' 2) (prod_typ 2) :=
  PartialViewPMap_Type 3 typ_map eq_refl 2.

Global Instance TypeView_list_typ : PartialView typ (list_typ 1 * typ).
eapply PartialView_trans.
apply TypeView_sym1.
eapply (@PartialView_prod _ _ _ _ _ PartialView_id).
Defined.

Global Instance TypeView_prod_typ : PartialView typ (prod_typ 2 * (typ * typ)).
eapply PartialView_trans.
apply TypeView_sym2.
eapply (@PartialView_prod _ _ _ _ _ PartialView_id).
Defined.

Global Instance TypeView_base_typ : PartialView typ (base_typ 0).
eapply PartialView_trans.
eapply TypeView_sym0.
apply TypeView_base_typ'.
Defined.

Definition TSymAll_typ_map : TSym_All typ_map.
  repeat first [eapply TSym_All_Branch_None |
                eapply TSym_All_Branch_Some; [eapply _ | |] |
                eapply TSym_All_Empty].
Defined.

Global Instance TSym_typ' : TSym typ'.
  apply TSymOneOf. apply TSymAll_typ_map.
Defined.

Global Instance RType_typ : RType typ.
apply RType_ctyp.
apply _.
Defined.

Global Instance RTypeOk_typ : RTypeOk.
apply RTypeOk_ctyp.
Defined.

Global Instance Typ2_tyArr : Typ2 RType_typ Fun := Typ2_Fun.
Global Instance Typ2Ok_tyArr : Typ2Ok Typ2_tyArr := Typ2Ok_Fun.

Global Instance Typ2_tyProd : Typ2 RType_typ prod := Typ2_sym (f_insert tProd).
Global Instance Typ2Ok_tyProd : Typ2Ok Typ2_tyProd := Typ2Ok_sym (f_insert tProd).

Global Instance Typ0_tyProp : Typ0 RType_typ Prop := Typ0_sym tyProp.
Global Instance Typ0Ok_tyProp : Typ0Ok Typ0_tyProp := Typ0Ok_sym tyProp.

Global Instance Typ0_tyNat : Typ0 RType_typ nat := Typ0_sym tyNat.
Global Instance Typ0Ok_tyNat : Typ0Ok Typ0_tyNat := Typ0Ok_sym tyNat.

Global Instance Typ0_tyString : Typ0 RType_typ String.string := Typ0_sym tyString.
Global Instance Typ0Ok_tyString : Typ0Ok Typ0_tyString := Typ0Ok_sym tyString.

Global Instance Typ0_tyBool : Typ0 RType_typ bool := Typ0_sym tyBool.
Global Instance Typ0Ok_tyBool : Typ0Ok Typ0_tyBool := Typ0Ok_sym tyBool.

Global Instance Typ1_tyList : Typ1 RType_typ list := Typ1_sym (f_insert tList).
Global Instance Typ1Ok_tyList : Typ1Ok Typ1_tyList := Typ1Ok_sym (f_insert tList).

Section ReifyType.

Global Instance Reify_typ : Reify typ :=
  Reify_typ typ (reify_base_typ typ ::
                 reify_list_typ typ ::
                 reify_prod_typ typ :: nil).

End ReifyType.


From iris.algebra Require Import
  proofmode_classes.

From caml5 Require Import
  prelude.
From caml5.algebra Require Export
  base.

Record Z_max := {
  Z_max_car : Z
}.
Add Printing Constructor Z_max.

Canonical Z_max_O :=
  leibnizO Z_max.

Implicit Types n m : Z.
Implicit Types x y z : Z_max.

#[local] Instance Z_max_valid : Valid Z_max :=
  λ _,
    True.
#[local] Instance Z_max_validN : ValidN Z_max :=
  λ _ _,
    True.
#[local] Instance Z_max_pcore : PCore Z_max :=
  Some.
#[local] Instance Z_max_op : Op Z_max :=
  λ x1 x2,
    Build_Z_max (Z_max_car x1 `max` Z_max_car x2).

Lemma Z_max_op_eq n1 n2 :
  Build_Z_max n1 ⋅ Build_Z_max n2 = Build_Z_max (n1 `max` n2).
Proof.
  done.
Qed.

Lemma Z_max_included x1 x2 :
  x1 ≼ x2 ↔
  (Z_max_car x1 ≤ Z_max_car x2)%Z.
Proof.
  split.
  - intros [y ->]. simpl. lia.
  - exists x2. rewrite /op /Z_max_op Z.max_r; last lia. destruct x2. done.
Qed.

Lemma Z_max_ra_mixin :
  RAMixin Z_max.
Proof.
  apply ra_total_mixin; apply _ || eauto.
  - intros [] [] []. rewrite !Z_max_op_eq Z.max_assoc //.
  - intros [] []. rewrite Z_max_op_eq Z.max_comm //.
  - intros []. rewrite Z_max_op_eq Z.max_id //.
Qed.
Canonical Z_max_R :=
  discreteR Z_max Z_max_ra_mixin.
#[global] Instance Z_max_cmra_discrete :
  CmraDiscrete Z_max_R.
Proof.
  apply discrete_cmra_discrete.
Qed.

#[global] Instance Z_max_core_id x :
  CoreId x.
Proof.
  constructor. done.
Qed.

Lemma Z_max_local_update x y x' :
  (Z_max_car x ≤ Z_max_car x')%Z →
  (x, y) ~l~> (x', x').
Proof.
  move: x y x' => [n] [m] [n'] /= ?.
  rewrite local_update_discrete. move=> [[p] |] _ /=; last done.
  rewrite !Z_max_op_eq => [= ?].
  split; first done. f_equal. lia.
Qed.

#[global] Instance Z_max_idemp :
  IdemP (=@{Z_max}) (⋅).
Proof.
  intros []. rewrite Z_max_op_eq. f_equal. lia.
Qed.

#[global] Instance Z_max_is_op n1 n2 :
  IsOp (Build_Z_max (n1 `max` n2)) (Build_Z_max n1) (Build_Z_max n2).
Proof.
  done.
Qed.


Require Import Models.

Module Type Syntax.
  Module T.
    Parameter sub : Type.
    Parameter term : Type.
    Parameter eq_term : term -> term -> Prop.
    Parameter prop kind : term.
    Parameter Ref : nat -> term.
    Parameter App Abs Prod : term -> term -> term.

    Parameter eq_sub : sub -> sub -> Prop.
    Parameter sub_id : sub.
    Parameter sub_comp : sub -> sub -> sub.
    Parameter sub_lift : nat -> sub -> sub.
    Parameter sub_shift : nat -> sub.
    Parameter sub_cons : term -> sub -> sub.

    Parameter Sub : term -> sub -> term.

    Parameter lift : nat -> term -> term.
    Parameter lift1 : nat -> term -> term.
    Parameter subst : term -> term -> term.
  End T.
  Import T.

  Definition env : Type := list term.

  Module J.
    Parameter typ eq_typ sub_typ : env -> term -> term -> Prop.
    Parameter typ_sub : env -> sub -> env -> Prop.
  End J.
  Import J.

End Syntax.

Module Type Judge.
  Include Syntax.
  Import T J.

  Module R.
    (** Equivalence and congruence rules *)
    Parameter refl : forall e M, eq_typ e M M.
    Parameter sym : forall e M M', eq_typ e M M' -> eq_typ e M' M.
    Parameter trans : forall e M M' M'',
      eq_typ e M M' -> eq_typ e M' M'' -> eq_typ e M M''.

    Parameter eq_typ_app : forall e M M' N N',
      eq_typ e M M' ->
      eq_typ e N N' ->
      eq_typ e (App M N) (App M' N').

    Parameter eq_typ_abs : forall e T T' M M',
      eq_typ e T T' ->
      eq_typ (T::e) M M' ->
      eq_typ e (Abs T M) (Abs T' M').

    Parameter eq_typ_prod : forall e T T' U U',
      eq_typ e T T' ->
      eq_typ (T::e) U U' ->
      eq_typ e (Prod T U) (Prod T' U').

    Parameter eq_typ_beta : forall e T M M' N N',
      eq_typ (T::e) M M' ->
      eq_typ e N N' ->
      typ e N T -> (* Typed reduction! *)
      T <> kind ->
      eq_typ e (App (Abs T M) N) (subst N' M').

    (** Typing rules *)
    Parameter typ_prop : forall e, typ e prop kind.

    Parameter typ_var : forall e n T,
      nth_error e n = value T ->
      typ e (Ref n) (lift (S n) T).

    Parameter typ_app : forall e u v V Ur,
      typ e v V ->
      typ e u (Prod V Ur) ->
      V <> kind ->
      typ e (App u v) (subst v Ur).

    Parameter typ_abs : forall e T M U,
      typ (T :: e) M U ->
      U <> kind ->
      typ e (Abs T M) (Prod T U).

    Parameter typ_prod : forall e T U s2,
      s2 = kind \/ s2 = prop ->
      typ (T :: e) U s2 ->
      typ e (Prod T U) s2.

    Parameter typ_conv : forall e M T T',
      typ e M T ->
      eq_typ e T T' ->
      T <> kind ->
      typ e M T'.

    (** Subtyping *)
    Parameter sub_refl : forall e M M',
      eq_typ e M M' -> sub_typ e M M'.

    Parameter sub_trans : forall e M1 M2 M3,
      sub_typ e M1 M2 -> sub_typ e M2 M3 -> sub_typ e M1 M3.

    Parameter typ_subsumption : forall e M T T',
      typ e M T ->
      sub_typ e T T' ->
      T <> kind ->
      typ e M T'.

    (** Substitution *)
    Parameter typ_sub_comp : forall e f g s1 s2,
      typ_sub e s1 f ->
      typ_sub f s2 g ->
      typ_sub e (sub_comp s2 s1) g.

    Parameter typ_Sub : forall e f s m u,
      typ f m u ->
      typ_sub e s f ->
      typ e (Sub m s) (Sub u s).

    Parameter typ_sub_shift1 : forall e ty,
      typ_sub (ty::e) (sub_shift 1) e.

    Parameter typ_sub_lams1 : forall e s f t,
      typ_sub e s f ->
      typ_sub (Sub t s :: e) (sub_lift 1 s) (t::f).

    (** Admissible rules *)
    (* TODO: weakening is an instance of typ_Sub *)
    Parameter weakening : forall e M T A,
      typ e M T ->
      typ (A::e) (lift 1 M) (lift 1 T).

  End R.

End Judge.

Module Type ECC_Rules (M:Syntax).
  Import M M.T M.J.

  Parameter type : nat -> term.

  Parameter typ_Prop : forall e, typ e prop (type 0).

  Parameter typ_Type : forall e n, typ e (type n) (type (S n)).
  Parameter cumul_Type : forall e n, sub_typ e (type n) (type (S n)).
  Parameter cumul_Prop : forall e, sub_typ e prop (type 0).

  Parameter typ_prod2 : forall e n T U,
    typ e T (type n) ->
    typ (T :: e) U (type n) ->
    typ e (Prod T U) (type n).

  Parameter sub_typ_covariant : forall e U1 U2 V1 V2,
    U1 <> kind ->
    eq_typ e U1 U2 ->
    sub_typ (U1::e) V1 V2 ->
    sub_typ e (Prod U1 V1) (Prod U2 V2).

End ECC_Rules.

Module Type Nat_Rules (M:Syntax).
  Import M M.T M.J.

  Parameter Nat Zero Succ : term.
  Parameter NatRec : term -> term -> term -> term.

  Parameter typ_N : forall e, typ e Nat kind.
  Parameter typ_0 : forall e, typ e Zero Nat.
  Parameter typ_S : forall e, typ e Succ (Prod Nat (lift 1 Nat)).
  Parameter typ_Nrect : forall e n f g P,
    typ e n Nat ->
    typ e f (App P Zero) ->
    typ e g (Prod Nat (Prod (App (lift 1 P) (Ref 0))
               (App (lift 2 P) (App Succ (Ref 1))))) ->
    typ e (NatRec f g n) (App P n).

  Parameter eq_typ_NatRec : forall e f f' g g' n n',
    eq_typ e f f' ->
    eq_typ e g g' ->
    eq_typ e n n' ->
    eq_typ e (NatRec f g n) (NatRec f' g' n').

  Parameter NatRec_eq_0 : forall e f g,
    eq_typ e (NatRec f g Zero) f.

  Parameter NatRec_eq_S : forall e f g n,
    typ e n Nat ->
    eq_typ e (NatRec f g (App Succ n)) (App (App g n) (NatRec f g n)).

End Nat_Rules.

Module Type W_Rules (M:Syntax).
  Import M M.T M.J.

  (*Parameter Ordt : set -> term. *)
  Parameter OSucc : term -> term.
  Parameter OSucct : term -> term.

  Parameter WI : term -> term -> term -> term.
  Parameter Wc : term -> term -> term -> term -> term.
  Parameter Wcase : term -> term -> term -> term -> term.
  Parameter WFix : term -> term -> term -> term -> term.

End W_Rules.

Module Type Variance (M:Judge).
  Import M M.T M.J.

  Parameter fenv_ : Type.
  Parameter tenv : fenv_ -> env.
  Parameter push_var : fenv_ -> term -> fenv_.
  Parameter push_ord : fenv_ -> term -> fenv_.
  Parameter push_fun : fenv_ -> term -> term -> fenv_.
  Parameter var_equals : fenv_ -> term -> Prop.
End Variance.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*                      Evgeny Makarov, INRIA, 2007                     *)
(************************************************************************)

(*i $Id: NZMul.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import NZAxioms NZBase NZAdd.

Module Type NZMulPropSig
 (Import NZ : NZAxiomsSig')(Import NZBase : NZBasePropSig NZ).
Include NZAddPropSig NZ NZBase.

Theorem mul_0_r : forall n, n * 0 == 0.
Proof.
nzinduct n; intros; now nzsimpl.
Qed.

Theorem mul_succ_r : forall n m, n * (S m) == n * m + n.
Proof.
intros n m; nzinduct n. now nzsimpl.
intro n. nzsimpl. rewrite succ_inj_wd, <- add_assoc, (add_comm m n), add_assoc.
now rewrite add_cancel_r.
Qed.

Hint Rewrite mul_0_r mul_succ_r : nz.

Theorem mul_comm : forall n m, n * m == m * n.
Proof.
intros n m; nzinduct n. now nzsimpl.
intro. nzsimpl. now rewrite add_cancel_r.
Qed.

Theorem mul_add_distr_r : forall n m p, (n + m) * p == n * p + m * p.
Proof.
intros n m p; nzinduct n. now nzsimpl.
intro n. nzsimpl. rewrite <- add_assoc, (add_comm p (m*p)), add_assoc.
now rewrite add_cancel_r.
Qed.

Theorem mul_add_distr_l : forall n m p, n * (m + p) == n * m + n * p.
Proof.
intros n m p.
rewrite (mul_comm n (m + p)), (mul_comm n m), (mul_comm n p).
apply mul_add_distr_r.
Qed.

Theorem mul_assoc : forall n m p, n * (m * p) == (n * m) * p.
Proof.
intros n m p; nzinduct n. now nzsimpl.
intro n. nzsimpl. rewrite mul_add_distr_r.
now rewrite add_cancel_r.
Qed.

Theorem mul_1_l : forall n, 1 * n == n.
Proof.
intro n. now nzsimpl.
Qed.

Theorem mul_1_r : forall n, n * 1 == n.
Proof.
intro n. now nzsimpl.
Qed.

End NZMulPropSig.


(************************************************************************)
(* Copyright (c) 2017, Ajay Kumar Eeralla <ae266@mail.missouri.edu>     *)
(*                   University of Missouri-Columbia.                   *)
(*                                                                      *)
(*                                                                      *)
(*                                                                      *)
(************************************************************************)

Load "ex5_4_IFIDEMP".

(** This library defines several theorems of [IFMORPH] and the proofs. Notice that we use [#] (resp. [##]) for [message] (resp. [Bool]) in lieu of [=].

[(if b then (if b' then x else y) else z) = (if b' then (if b then x else z) else (if b then y else z))]. *)

Theorem IFMORPH_M1: forall ( x y z : message) (n1 n2:nat),
(ifm (Bvar n2)(ifm (Bvar n1)  x y) z) # (ifm (Bvar n1) (ifm (Bvar n2)  x  z) (ifm  (Bvar n2) y z) ).
Proof.
intros.
rewrite <- IFSAME_M with (b:= (Bvar n1)) (x:= (ifm (Bvar n2) (ifm (Bvar n1) x y) z)).
rewrite IFEVAL_M.
simpl.
rewrite <- beq_nat_refl.
rewrite IFTRUE_M.
rewrite IFFALSE_M.
rewrite IFEVAL_M with (t1:= (ifm (Bvar n2) x z))(t2:= (ifm (Bvar n2) y z)).
simpl.
reflexivity.
Qed.

Theorem IFMORPH_B1: forall ( b b1 b2 : Bool) (n1 n2:nat) ,
 (ifb (Bvar n2)(ifb (Bvar n1)  b b1) b2)  ## (ifb (Bvar n1) (ifb (Bvar n2)  b  b2) (ifb  (Bvar n2) b1 b2) ).
Proof.
intros.
rewrite <- IFSAME_B with (b:= (Bvar n1)) (b1:= (ifb (Bvar n2) (ifb (Bvar n1) b b1) b2)).
rewrite IFEVAL_B.
simpl.
rewrite <- beq_nat_refl.
rewrite IFTRUE_B.
rewrite IFFALSE_B.
rewrite IFEVAL_B with (n:=n1)(b1:= (ifb (Bvar n2) b b2))(b2:= (ifb (Bvar n2) b1 b2)).
simpl.
reflexivity.
Qed.
(**For a function [f:Bool -> Bool-> Bool], we have [f(if b then x else y, z , z1) = if b then f(x,z,z1) else f(x,y,z1)] *)

Theorem IFMORPH_B2: forall (n:nat)(b1 b2 b3 b4 : Bool) ,
(ifb (ifb (Bvar n) b1 b2 ) b3 b4)  ##  (ifb (Bvar n) (ifb  b1  b3 b4 ) (ifb  b2 b3 b4) ).
Proof.
intros.
pose proof (IFSAME_B).
rewrite <- IFSAME_B with (b:= (Bvar n)) (b1:=(ifb (ifb (Bvar n) b1 b2 ) b3 b4)).
pose proof(IFEVAL_B).
rewrite IFEVAL_B.
simpl.
rewrite <- beq_nat_refl.
rewrite IFTRUE_B.
rewrite IFFALSE_B.
rewrite IFEVAL_B with (b1 := (ifb b1 b3 b4))(b2:= (ifb b2 b3 b4)).
simpl.
reflexivity.
Qed.
(**For a function [f: message -> message -> Bool], we have [f(if b then x else y, z , z1) = if b then f(x,z,z1) else f(x,y,z1)] *)
Theorem IFMORPH_M2: forall (n:nat)(b1 b2 :Bool)(y z : message),
 (ifm (ifb (Bvar n) b1 b2 ) y z)  #(ifm (Bvar n) (ifm  b1  y z ) (ifm  b2 y z) ).
Proof.
intros.
rewrite <- IFSAME_M with (b:=(Bvar n))(x:= ifm (ifb (Bvar n) b1 b2) y z).
rewrite IFEVAL_M.
simpl.
rewrite <- beq_nat_refl.
rewrite IFTRUE_B.
rewrite IFFALSE_B.
rewrite IFEVAL_M with (t1:=  (ifm b1 y z))(t2:= (ifm b2 y z)).
simpl.
reflexivity.
Qed.

(** For a function [f: Bool -> Bool -> Bool], we have [f(if b then x else y, z) = if b then f(x,z) else f(y,z) ] *)

Theorem IFMORPH_B3: forall  (n n1 n2 n3 :nat), ( eqb (ifb (Bvar n) (Bvar n1) (Bvar n2)) (Bvar n3)) ##  (ifb (Bvar n) (eqb (Bvar n1) (Bvar n3) ) (eqb (Bvar n2) (Bvar n3))).
Proof.
intros.
rewrite <- IFSAME_B with (b:=(Bvar n))( b1:= eqb (ifb (Bvar n) (Bvar n1) (Bvar n2)) (Bvar n3)).
rewrite IFEVAL_B.
simpl. rewrite <- beq_nat_refl.
rewrite IFTRUE_B.
rewrite IFFALSE_B.
rewrite IFEVAL_B with (b1:= (eqb (Bvar n1) (Bvar n3)))(b2:= (eqb (Bvar n2) (Bvar n3))).
simpl.
reflexivity.
Qed.

Theorem IFMORPH_M3: forall  (n n1 n2 n3 :nat), ( eqm (ifm (Bvar n) (Mvar n1) (Mvar n3))  (ifm (Bvar n) (Mvar n2) (Mvar n3))) ## ( ifb (Bvar n) (eqm (Mvar n1)  (ifm (Bvar n) (Mvar n2) (Mvar n3) )) (eqm (Mvar n3)  (ifm (Bvar n) (Mvar n2) (Mvar n3)))).
Proof.
intros.
rewrite <- IFSAME_B with (b:=(Bvar n))( b1:= eqm (ifm (Bvar n) (Mvar n1) (Mvar n3))  (ifm (Bvar n) (Mvar n2) (Mvar n3))).
rewrite IFEVAL_B.
simpl.
rewrite <- beq_nat_refl.
rewrite IFTRUE_M.
rewrite IFFALSE_M .
rewrite IFTRUE_M.
rewrite IFFALSE_M.
rewrite IFEVAL_B with (b1:= (eqm (Mvar n1) (ifm (Bvar n) (Mvar n2) (Mvar n3))))(b2:= (eqm (Mvar n3) (ifm (Bvar n) (Mvar n2) (Mvar n3)))).
simpl.
rewrite <- beq_nat_refl.
rewrite IFTRUE_M.
rewrite IFFALSE_M.
reflexivity.
Qed.

Theorem IFMORPH_M5 : forall (n1 n2 n3 :nat) (m1 m2 m3 m4: message),  (ifm (Bvar n1) (ifm (Bvar n2) m1 m2 ) (ifm (Bvar n3) m3 m4)) # (ifm (Bvar n2) (ifm (Bvar n1) m1 (ifm (Bvar n3) m3 m4)) (ifm (Bvar n1) m2 (ifm (Bvar n3) m3 m4))).
Proof. intros.
pose proof(IFSAME_M (Bvar n2) (ifm (Bvar n1) (ifm (Bvar n2) m1 m2 ) (ifm (Bvar n3) m3 m4))).
rewrite IFEVAL_M with (n:= n2) (t1:= (ifm (Bvar n1) (ifm (Bvar n2) m1 m2 ) (ifm (Bvar n3) m3 m4))) (t2 := (ifm (Bvar n1) (ifm (Bvar n2) m1 m2 ) (ifm (Bvar n3) m3 m4))) in H.
simpl in H.
repeat rewrite <- beq_nat_refl in H.
rewrite <-H.
rewrite IFEVAL_M with (n:= n2) (t1:= (ifm (Bvar n1) m1 (ifm (Bvar n3) m3 m4))) (t2 := (ifm (Bvar n1) m2 (ifm (Bvar n3) m3 m4))).
simpl. rewrite  IFTRUE_M, IFFALSE_M.
reflexivity. Qed.

Theorem IFMORPH_M6 : forall(n1 n2 :nat) (m1 m2 m3:message), (ifm (Bvar n1) m1 (ifm (Bvar n2) m2 m3)) # (ifm (Bvar n2) (ifm (Bvar n1) m1 m2) (ifm (Bvar n1)  m1 m3)).
Proof. intros. pose proof(IFSAME_M (Bvar n2)  (ifm (Bvar n1) m1 (ifm (Bvar n2) m2 m3))).
rewrite IFEVAL_M in H.
simpl in H. repeat rewrite <- beq_nat_refl in H.
rewrite  IFTRUE_M, IFFALSE_M in H.
rewrite <-H. clear H.
rewrite IFEVAL_M with (t1:= (ifm (Bvar n1) m1 m2)).
simpl. reflexivity. Qed.
(*
Axiom IFMORPH_B4: forall  (n1:nat) (b1 b2 b3:Bool), (ifb (Bvar n1) b1 (ifb (Bvar (n1+1)) b2 b3))  ## (ifb (Bvar (n1+1)) (ifb (Bvar n1) b1 b2) (ifb (Bvar n1) b1 b3)) .
*)

Theorem IFMORPH_M4 : forall (n1:nat) (m1 m2 m3 : message), (ifm (Bvar n1) m1 (ifm (Bvar (n1+1)) m2 m3) ) # (ifm (Bvar (n1+1)) (ifm (Bvar n1) m1 m2)(ifm (Bvar n1) m1 m3)).
Proof.
intros.
rewrite <- IFSAME_M with (b:= (Bvar (n1+1))) (x:= (ifm (Bvar n1)  m1 (ifm (Bvar (n1+1)) m2 m3))).
rewrite IFEVAL_M.
simpl.
rewrite <- beq_nat_refl.
rewrite IFTRUE_M.
rewrite IFFALSE_M.
assert(H: beq_nat n1 (n1 +1) = false).
induction n1.
simpl.  reflexivity.
simpl.
rewrite IHn1.
reflexivity.
rewrite H.
 rewrite IFEVAL_M with (t1:=(ifm (Bvar n1) m1 m2) )(t2:= (ifm (Bvar n1) m1 m3) ).
simpl.
rewrite H.
reflexivity.
Qed.


(** * Substitution *)

Set Implicit Arguments.

Require Import decidable_In.
Require Import environments.
Require Import sublist.
Require Import language_syntax.
Require Import variable_sets.
Require Import relocation.

(** Defining substitution requires special consideration for two reasons.

   - First, the relationship between syntax and semantics such as soundness
     and completeness should be realized in a natural way.

     For this purpose, we find that simultaneous substitution provides
     a convenient way in establishing the relationship.

   - Second, because of the trace part, it is not clear to which class
     the resulting expression of a substitution should belong.

     Thus we decided to state clearly the type of the resulting expression
     in the definition of substitution.

   - Notice the special role of the [Var] case because it needs relocation.

   - No alpha-conversion is used.

   - Since there are no parameters, substitution only for variables are necessary. *)

Notation assoc := (env name).

Fixpoint tsubst (eta:assoc (term nil)) l m (t: term m) {struct t} : term l :=
  match t with
    | Var y h    => match y <-? l with
                       | left p  => @Var l y p
                       | right _ => match eta ^^ y with
                                      | Some u => (treloc u (term_sub u l))
                                      | None   => @Cst l 0
                                    end
                     end
    | Cst c       => @Cst l c
    | App f t1 t2 => App f (tsubst eta l t1)  (tsubst eta l t2)
  end.

Notation "[[ l ! eta ]] t" := (tsubst eta l t) (at level 55, eta at next level).

Fixpoint subst (eta: assoc (term nil)) l m (A:formula m) {struct A} : formula l :=
  match A with
    | Atom (p,t) => Atom (p, [[l ! eta ]] t )
    | B --> C    => (subst eta l B) --> (subst eta l C)
    | Forall y B => Forall y (subst eta (y::l) B)
  end.

Notation "[ l ! eta ] A" := (subst eta l A) (at level 55).

Lemma trm_tsubst : forall m (t:term m) eta l (H: sub_name (ov_t t) l),
  [[l ! eta]] t = treloc t H.
Proof.
  induction t; simpl; intros;
    [ destruct (x <-? l) as [|Hnotin]; [ f_equal | elim Hnotin];
      auto with datatypes
      | reflexivity
      | f_equal; auto ].
Qed.

(** For well-defined terms, local variable substitution has no effect. *)

Lemma term_tsubst : forall (t:term nil) (eta:assoc (term nil)),
  [[nil ! eta]] t = t.
Proof.
  intros;
  assert (sub_name (ov_t t) nil) as Hsub ;
    [ rewrite term_ov_nil_1; apply incl_refl
      | transitivity (treloc t Hsub); auto using trm_tsubst
    ].
Qed.

Lemma formula_subst : forall m (A:formula m) eta l (H: sub_name (ov_f A) l),
  [l ! eta] A = freloc A H.
Proof.
  induction A as [m [p t] | |]; simpl; intros; f_equal; auto.
  f_equal; auto using trm_tsubst.
Qed.

(** For well-defined formulae, local variable substitution has no effect. *)

Lemma fml_subst : forall (A:formula nil) (eta:assoc (term nil)),
  [nil ! eta] A = A.
Proof.
  intros; assert (sub_name (ov_f A) nil) as Hsub ;
    [ rewrite fml_ov_nil_1; apply incl_refl
      | transitivity (freloc A Hsub); auto using formula_subst
    ].
Qed.

(** Relocation has no effect on substitution. *)

Lemma tsubst_treloc_1 : forall m (t:term m) l l' eta (h: sub_name (ov_t t) l),
  [[l' ! eta]] (treloc t h) = [[l' ! eta]] t.
Proof.
  induction t; simpl; intros; f_equal; auto.
Qed.

Lemma tsubst_reloc_2 : forall m (t:term m) l l' eta
  (h1: sub_name (ov_t t) l) (h2: sub_name (ov_t t) l'),
  [[l' ! eta]] (treloc t h1) = treloc t h2.
Proof.
  intros; transitivity ([[l'! eta]] t);
    auto using tsubst_treloc_1, trm_tsubst.
Qed.

(** Extending substitution with forbidden variables has no impact. *)

Lemma tsubst_In : forall m (t:term m) x l v eta,
  x @ l ->
  [[l ! eta]] t = [[l ! (x,v)::eta]] t.
Proof.
  induction t; simpl; intros; auto.
  - case_In; auto; case_name; case_Env; auto; elim n; intuition.
  - f_equal; auto.
Qed.

Lemma subst_In : forall m (A:formula m) x l u eta,
  x @ l ->
  [l ! eta] A = [l ! (x,u)::eta] A.
Proof.
  induction A as [m [p t] | | ]; simpl; intros;
    [ rewrite <- tsubst_In; [reflexivity | exact H]
      | f_equal; auto
      | f_equal; auto using in_cons
    ].
Qed.

(** Substitution and [LEq] *)

Lemma tsubst_LEq_1 : forall m (t:term m) l l' eta eta',
  LEq l l' ->
  [[l' ! eta']] ([[l ! eta]] t) = [[l' ! eta]] t.
Proof.
  induction t; simpl; intros;
    [ destruct (x <-? l); simpl; destruct (x <-? l'); try reflexivity;
      [ elim n; elim H; intros; apply H0; exact i0
        | elim n; elim H; intros; apply H1; exact i0
        | case_Env; auto;
          apply tsubst_reloc_2; apply term_ov_nil_1
      ]
      | reflexivity
      | f_equal; auto
    ].
Qed.

Lemma subst_LEq_1 : forall m (A:formula m) l l' eta eta',
  LEq l l' ->
  [l' ! eta'] ([l ! eta] A) = [l' ! eta] A.
Proof.
  induction A as [m [p t] | | ]; simpl; intros l l' eta eta' H; inversion H;
    [ do 2 f_equal; apply tsubst_LEq_1; auto
      | f_equal; auto
      | f_equal; auto using LEq_cons
    ].
Qed.

Lemma tsubst_LEq_2 : forall m (t:term m) l l' k eta eta',
  LEq l l' ->
  [[k ! eta']] ([[l ! eta]] t) = [[k ! eta']] ([[l' ! eta]] t).
Proof.
  induction t; simpl; intros; auto.
  - inversion H; repeat (case_In); auto;
    [ elim n
    | elim n
    | case_Env]; auto.
    transitivity (treloc t (term_sub t k)); auto using tsubst_reloc_2.
  - f_equal; auto.
Qed.

Lemma subst_LEq_2 : forall m (A:formula m) l l' k eta eta',
  LEq l l' ->
  [k ! eta'] ([l ! eta] A) = [k ! eta' ] ([l' ! eta] A).
Proof.
  induction A as [m [p t] | | ]; simpl; intros;
    [ do 2 f_equal; auto using tsubst_LEq_2
      | f_equal
      | f_equal
    ]; auto using LEq_cons.
Qed.

(** ** Substitutions Lemma *)

Lemma t_substitution : forall m (t:term m) y l (eta:assoc (term nil)) (u:term nil),
  [[l ! (y,u)::nil]] ([[(y :: l) ! eta]] t) =
  [[l ! (y, u) :: eta]] t.
Proof.
  induction t; intros; auto; [| simpl; f_equal; auto].
  unfold tsubst at 2; destruct ( x == y); subst; auto.
  - case_In; [simpl; case_name; congruence | elim n; auto with datatypes].
  - case_In; simpl. apply neq_In_cons in i0; auto.
    + case_In; auto; intuition.
    + generalize (notIn_cons_2 n0); intros; case_Env; simpl.
      * case_In; auto; [elim H; auto |].
        case_name; auto;
        [elim n0; auto with datatypes
        | rewrite trm_tsubst with (t:= treloc t (term_sub t (y ::l))) (H:= treloc_ov_2 t _ _)]; auto.
      * case_In; auto;
        [ elim H
        | case_name; auto; elim n0] ; auto with datatypes.
Qed.

Lemma substitution : forall m (A : formula m) y l (eta:assoc (term nil)) (u:term nil),
  [l ! (y,u) :: nil] ([y :: l ! eta] A) = [l ! (y, u) :: eta] A.
Proof.
  induction A as [m [p t] | | ]; simpl; intros;
    [ do 2 f_equal; apply t_substitution
      | f_equal; auto
      | f_equal; destruct (x == y) as [xy | nxy];
        [ subst y; rewrite subst_LEq_1; auto using LEq_xx, subst_In, in_eq
          | rewrite subst_LEq_2 with (l':= y::x::l); auto using LEq_xy
        ]
    ].
Qed.


Require Import Reals Psatz Omega ClassicalEpsilon.
From stdpp Require Import tactics.
From discprob.measure Require Export sets.

Record sigma_algebra (A: Type) :=
  mkSigma {
      sigma_sets:> (A → Prop) → Prop;
      sigma_proper : Proper (@eq_prop A ==> iff) sigma_sets;
      sigma_full : sigma_sets (λ _, True);
      sigma_closed_complements :
        ∀ P, sigma_sets P → sigma_sets (compl P);
      sigma_closed_unions :
               ∀ Ps : nat → (A → Prop), (∀ i, sigma_sets (Ps i)) →
                                        sigma_sets (unionF Ps)
    }.

Definition eq_sigma {A: Type} (F1 F2: sigma_algebra A) := eq_prop F1 F2.
Definition le_sigma {A: Type} (F1 F2: sigma_algebra A) := le_prop F1 F2.

(*
Global Instance le_sigma_Transitive {X}: Transitive (@le_sigma X).
Proof. rewrite /le_sigma => ??? Heq1 Heq2 x. intros. by apply Heq2, Heq1. Qed.
Global Instance le_sigma_Reflexive {X}: Reflexive (@le_sigma X).
Proof. rewrite /le_sigma //=. intros ??. done. Qed.

Global Instance eq_sigma_Transitive {X}: Transitive (@eq_sigma X).
Proof. rewrite /eq_sigma/eq_prop => ??? Heq1 Heq2 x. by rewrite Heq1 Heq2.  Qed.
Global Instance eq_sigma_Reflexive {X}: Reflexive (@eq_sigma X).
Proof. rewrite /eq_sigma. by apply eq_prop_Reflexive. Qed.
Global Instance eq_sigma_Symmetry {X}: Symmetric (@eq_sigma X).
Proof. rewrite /eq_sigma/eq_prop => ?? Heq x. by rewrite Heq. Qed.
Global Instance eq_sigma_Equivalence {X}: Equivalence (@eq_sigma X).
Proof. split; apply _. Qed.
*)

Global Instance sigma_algebra_proper {A: Type} X : Proper (@eq_prop A ==> iff) (@sigma_sets A X).
Proof. apply sigma_proper. Qed.

Lemma sigma_closed_intersections {A: Type} (X: sigma_algebra A) (Ps: nat → (A → Prop)) :
  (∀ i, X (Ps i)) → X (intersectF Ps).
Proof.
  intros Hmem.
  assert (eq_prop (λ x : A, ∀ i, Ps i x) (λ x, ¬ (∃ i, ¬ (Ps i x)))) as ->.
  { intros x; split.
    - intros Hall (i&Hnot). apply Hnot. auto.
    - intros Hnot i. eapply Classical_Pred_Type.not_ex_not_all in Hnot. eauto.
  }
  apply sigma_closed_complements, sigma_closed_unions.
  intros i. apply sigma_closed_complements. auto.
Qed.

Lemma union_pair_unionF {A: Type} (X Y: A → Prop) :
  eq_prop (X ∪ Y)
          (unionF (λ n : nat, match n with
                              | O => X
                              | S O => Y
                              | _ => ∅ end)).
Proof.
  rewrite /eq_prop/union/unionF; split.
  * intros [?|?]; [exists O | exists (S O)]; auto.
  * intros (n&H).
    destruct n; first by left.
    destruct n; first by right.
    inversion H.
Qed.

Lemma intersect_pair_intersectF {A: Type} (X Y: A → Prop) :
  eq_prop (X ∩ Y)
          (intersectF (λ n : nat, match n with
                              | O => X
                              | S O => Y
                              | _ => (λ _, True) end)).
Proof.
  rewrite /eq_prop/intersect/intersectF; split.
  * intros [? ?] [|[|]]; auto.
  * intros H; split.
    ** apply (H O).
    ** apply (H (S O)).
Qed.

Lemma sigma_empty_set {A: Type} (F: sigma_algebra A) :
  F ∅.
Proof.
  eapply sigma_proper; last apply sigma_closed_complements, sigma_full.
  intros x; split => [] []; auto.
Qed.

Hint Resolve sigma_empty_set sigma_full sigma_closed_complements sigma_closed_unions.

Lemma sigma_closed_pair_union {A: Type} (F: sigma_algebra A) X Y:
  F X → F Y → F (X ∪ Y).
Proof.
  intros. rewrite union_pair_unionF.  apply sigma_closed_unions.
  intros [|[|]]; auto.
Qed.

Lemma range_union_S {A: Type} (Us: nat → A → Prop) n:
  (λ x, ∃ i, (i <= S n)%nat ∧ Us i x) ≡ (λ x, ∃i, (i <= n)%nat ∧ Us i x) ∪ (Us (S n)).
Proof.
  intros x; split.
  - intros (?&Hle&?). inversion Hle; subst; firstorder.
  - firstorder.
Qed.

Lemma sigma_closed_range_union {A: Type} (F: sigma_algebra A) Us n:
  (∀ i, (i <= n)%nat → F (Us i)) → F (λ x, ∃ i, (i <= n)%nat ∧ Us i x).
Proof.
  induction n.
  - intros Hle. apply (sigma_proper _ _ (Us O)); eauto.
    intros x; split.
    * firstorder.
    * intros (i&Hle'&?). inversion Hle'; firstorder congruence.
  - intros.  setoid_rewrite range_union_S. apply sigma_closed_pair_union; eauto.
Qed.

Lemma sigma_closed_list_union {A: Type} (F: sigma_algebra A) l:
  (∀ U, In U l → F U) → F (union_list l).
Proof.
  induction l => //=.
  intros. apply sigma_closed_pair_union; eauto.
Qed.

Lemma sigma_closed_pair_intersect {A: Type} (F: sigma_algebra A) X Y:
  F X → F Y → F (X ∩ Y).
Proof.
  intros. rewrite intersect_pair_intersectF. apply sigma_closed_intersections.
  intros [|[|]]; auto.
Qed.

Lemma sigma_closed_set_minus {A: Type} (F: sigma_algebra A) X Y:
  F X → F Y → F (X ∖ Y).
Proof.
  intros HX HY.
  rewrite set_minus_union_complement.
  apply sigma_closed_pair_intersect; auto.
Qed.

Hint Resolve sigma_closed_pair_union sigma_closed_pair_intersect sigma_closed_set_minus.

Definition intersection_sigma {A: Type} (I: Type) (U: I → sigma_algebra A) : sigma_algebra A.
  refine {| sigma_sets := λ x, ∀ i, (U i) x |}.
  - abstract (intros X X' Heq; split => H i; [ rewrite -Heq | rewrite Heq ]; auto).
  - abstract (intros; by apply sigma_full).
  - abstract (intros; by apply sigma_closed_complements).
  - abstract (intros; by apply sigma_closed_unions).
Defined.

Definition minimal_sigma {A: Type} (F: (A → Prop) → Prop) : sigma_algebra A :=
  intersection_sigma { F' : sigma_algebra A | le_prop F F' } sval.

Lemma minimal_sigma_ub {A: Type} (F : (A → Prop) → Prop) :
  le_prop F (minimal_sigma F).
Proof.
  intros i HF (F'&Hle) => //=. by apply Hle.
Qed.

Lemma minimal_sigma_lub {A: Type} (F : (A → Prop) → Prop) (F': sigma_algebra A) :
  le_prop F F' → le_prop (minimal_sigma F) F'.
Proof.
  intros Hle X. rewrite /minimal_sigma/intersection_sigma => //=.
  intros H. specialize (H (exist _ F' Hle)). apply H.
Qed.

Definition sigma_measurable {A B: Type} f (F1: sigma_algebra A) (F2: sigma_algebra B) :=
  ∀ U, F2 U → F1 (fun_inv f U).

Lemma sigma_measurable_proper {A B: Type} f :
  Proper (@eq_sigma A ==> @eq_sigma B ==> iff) (@sigma_measurable A B f).
Proof.
  intros F1 F1' Heq1 F2 F2' Heq2.
  split; intros Hmeasure U.
  - rewrite -Heq1 -Heq2. auto.
  - rewrite Heq1 Heq2. auto.
Qed.

Global Instance sigma_measurable_proper' {A B: Type} :
  Proper (pointwise_relation _ eq ==> eq ==> eq ==> iff) (@sigma_measurable A B).
Proof.
  intros f1 f2 Heq ?? ? ?? ?; subst.
  assert (Heq': eq_fun f1 f2).
  { intros x; eauto. }
  split; intros Hmeasure U.
  - rewrite -Heq'. eauto.
  - rewrite Heq'. eauto.
Qed.

Lemma sigma_measurable_ext {A B: Type} F1 F2 f1 f2 :
  (∀ x, f1 x = f2 x) →
  @sigma_measurable A B f1 F1 F2 →
  @sigma_measurable A B f2 F1 F2.
Proof.
  intros Heq Hmeas. eapply sigma_measurable_proper'; eauto.
  intros x. done.
Qed.

Global Instance sigma_measurable_mono {A B: Type} f :
  Proper (@le_sigma A ==> @le_sigma B --> impl) (@sigma_measurable A B f).
Proof.
  intros F1 F1' Heq1 F2 F2' Heq2.
  intros Hmeas U HU. by apply Heq2, Hmeas, Heq1 in HU.
Qed.

Lemma sigma_measurable_comp {A B C: Type} (f: A → B) (g: B → C) F1 F2 F3 :
  sigma_measurable f F1 F2 →
  sigma_measurable g F2 F3 →
  sigma_measurable (λ x, g (f x)) F1 F3.
Proof. intros Hf Hg ? HU. by apply Hg, Hf in HU. Qed.

Lemma sigma_measurable_id {A: Type}  F:
  sigma_measurable (λ x : A, x) F F.
Proof. intros U HF => //=. Qed.

Lemma sigma_measurable_const {A B: Type} (b: B) F G:
  sigma_measurable (λ a : A, b) F G.
Proof.
  intros U HF => //=.
  destruct (Classical_Prop.classic (U b)).
  - eapply sigma_proper; last eapply sigma_full. rewrite /fun_inv.
    split; intuition.
  - eapply sigma_proper; last eapply sigma_empty_set. rewrite /fun_inv.
    split.
    * contradiction.
    * inversion 1.
Qed.

(* Any function f : A  → B on a sigma_measurable space A induces a sigma algebra on B *)
Definition fun_sigma {A B: Type} (F: sigma_algebra A) (f: A → B) : sigma_algebra B.
  refine {| sigma_sets := λ U, F (fun_inv f U) |}.
  - abstract (by intros ?? ->).
  - abstract (rewrite //=).
  - abstract (intros P HF; rewrite fun_inv_compl; auto).
  - abstract (intros Ps HF; rewrite fun_inv_unionF; auto).
Defined.

Lemma sigma_measurable_intersection {I} {A B: Type} f (F1: sigma_algebra A) (F2 : I → sigma_algebra B):
  (∃ i, sigma_measurable f F1 (F2 i)) →
  sigma_measurable f F1 (intersection_sigma _ F2).
Proof.
  intros HF2 U HminU.
  cut (le_prop (intersection_sigma _ F2) (fun_sigma F1 f)).
  { intros Hle. by apply Hle. }
  intros V. rewrite /fun_sigma//=. intros Hin.
  edestruct HF2 as (i&Hmeas). eapply Hmeas; eauto.
Qed.

Lemma sigma_measurable_generating_sets {A B: Type} f (F1: sigma_algebra A) (F2 : (B → Prop) → Prop):
  (∀ U, F2 U → F1 (fun_inv f U)) →
  sigma_measurable f F1 (minimal_sigma F2).
Proof.
  intros HF2 U HminU.
  cut (le_prop (minimal_sigma F2) (fun_sigma F1 f)).
  { intros Hle. by apply Hle. }
  apply minimal_sigma_lub. rewrite /fun_sigma//=.
Qed.

Definition disjoint_sum_sigma {A1 A2: Type} (F1: sigma_algebra A1) (F2: sigma_algebra A2)
  : sigma_algebra (A1 + A2).
Proof.
  refine {| sigma_sets := λ U, F1 (fun_inv inl U) ∧ F2 (fun_inv inr U) |}.
  - intros U1 U2 Heq. rewrite Heq. done.
  - split; rewrite //=.
  - intros U (HF1&HF2).
    split.
    * apply sigma_closed_complements in HF1. eapply sigma_proper; eauto.
      firstorder.
    * apply sigma_closed_complements in HF2. eapply sigma_proper; eauto.
      firstorder.
  - intros Us.
    intros Hi. split.
    * assert (Hinl: ∀ i, F1 (fun_inv inl (Us i))); first by firstorder.
      apply sigma_closed_unions in Hinl.
      eapply sigma_proper; eauto.
      firstorder.
    * assert (Hinr: ∀ i, F2 (fun_inv inr (Us i))); first by firstorder.
      apply sigma_closed_unions in Hinr.
      eapply sigma_proper; eauto.
      firstorder.
Defined.

Lemma inv_union {A B: Type} (f: A → B) (Us: nat → B → Prop):
    eq_prop (fun_inv f (unionF Us))
            (unionF (λ i : nat, fun_inv f (Us i))).
Proof. intros z. split; firstorder. Qed.

Definition discrete_algebra (A: Type) : sigma_algebra A.
Proof.
  refine {| sigma_sets := λ _, True |}; abstract (auto).
Defined.

Definition initial_algebra {I: Type} {A: Type} {B: Type} (Y : sigma_algebra B) (f: I → A → B)
  : sigma_algebra A.
Proof.
  set (S := { σ : sigma_algebra A | ∀ i, sigma_measurable (f i) σ Y }).
  exact (intersection_sigma S sval).
Defined.

Lemma initial_algebra_meas {I} {A B: Type} (Y: sigma_algebra B) (f: I → A → B) (i: I):
  sigma_measurable (f i) (initial_algebra Y f) Y.
Proof.
  intros U HYU (σ&Hspec) => //=.
  eapply Hspec. eauto.
Qed.

Lemma initial_algebra_lb {I} {A B: Type} (Y: sigma_algebra B) (f: I → A → B) (X: sigma_algebra A):
  (∀ i, sigma_measurable (f i) X Y) →
  le_sigma (initial_algebra Y f) X.
Proof.
  intros Hmeas. intros U HU.
  apply (HU (exist _ X Hmeas)).
Qed.

Lemma initial_algebra_codom_meas {I} {C A B: Type} (X: sigma_algebra C)
      (Y: sigma_algebra B) (f: I → A → B) g:
  (∀ i, sigma_measurable (λ x, (f i (g x))) X Y) →
  sigma_measurable g X (initial_algebra Y f).
Proof.
  intros Hspec.
  apply sigma_measurable_intersection.
  unshelve (eexists).
  { exists (fun_sigma X g). eauto. }
  rewrite //=.
Qed.

Lemma initial_algebra_in {I} {A B: Type} (Y: sigma_algebra B) (f: I → A → B) U:
  (∃ i U', Y U' ∧ U ≡ fun_inv (f i) U') →
  initial_algebra Y f U.
Proof.
  intros (i&U'&Hin&Heq).
  rewrite Heq. apply initial_algebra_meas. eauto.
Qed.

Definition initial_algebra1 {A: Type} {B: Type} (Y : sigma_algebra B) (f: A → B)
  : sigma_algebra A := @initial_algebra unit A B Y (λ _, f).

Lemma initial_algebra1_meas {A B: Type} (Y: sigma_algebra B) (f: A → B) :
  sigma_measurable f (initial_algebra1 Y f) Y.
Proof.
  eapply sigma_measurable_ext; last first.
  { eapply (initial_algebra_meas _ _ tt).  }
  done.
Qed.

Lemma initial_algebra1_codom_meas {C A B: Type} (X: sigma_algebra C)
      (Y: sigma_algebra B) (f: A → B) g:
  sigma_measurable (λ x, (f (g x))) X Y →
  sigma_measurable g X (initial_algebra1 Y f).
Proof. intros. by eapply initial_algebra_codom_meas. Qed.

Lemma initial_algebra1_lb {A B: Type} (Y: sigma_algebra B) (f: A → B) (X: sigma_algebra A):
  sigma_measurable f X Y →
  le_sigma (initial_algebra1 Y f) X.
Proof. intros. eapply initial_algebra_lb; eauto. Qed.

Lemma initial_algebra1_in {A B: Type} (Y: sigma_algebra B) (f: A → B) U:
  (∃ U', Y U' ∧ U ≡ fun_inv f U') →
  initial_algebra1 Y f U.
Proof.
  intros (U'&Hin&Heq).
  rewrite Heq. apply initial_algebra1_meas. eauto.
Qed.

Lemma initial_algebra1_eq_min {A B: Type} (Y: sigma_algebra B) (f: A → B):
  eq_sigma (initial_algebra1 Y f) (minimal_sigma (λ U, ∃ U', U ≡ fun_inv f U' ∧ Y U')).
Proof.
  rewrite /eq_sigma. apply le_prop_antisym.
  - apply initial_algebra_lb. intros _. intros U HYU.
    apply minimal_sigma_ub. eexists; split; eauto.
  - apply minimal_sigma_lub. intros U (U'&Hequiv&HY).
    rewrite Hequiv. by apply initial_algebra1_meas.
Qed.

(*
Lemma initial_algebra1_img {A B: Type} (Y: sigma_algebra B) (f: A → B) U:
  initial_algebra1 Y f U →
  Y (fun_img f U).
Proof.
  intros Hinit.
  apply initial_algebra1_eq_min in Hinit.
  cut ((λ U : A → Prop, ∃ U' : B → Prop, U ≡ fun_inv f U' ∧ Y U') U).
  { intros Halt.  destruct Halt as (U'&Hequiv&?).
    eapply sigma_proper; eauto. intros z.
    rewrite /fun_img. split.
    intros (x&HU&Heq).
    * subst. eapply Hequiv in HU. eauto.
    * intros HU'z.
    setoid_rewrite Hequiv.
    rewrite /fun_ing.
    rewrite Hequiv.
  destruct Hinit.
*)


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require list.List.
Require list.Length.
Require list.Mem.
Require list.Nth.
Require option.Option.
Require list.NthLength.
Require list.Append.

(* Why3 goal *)
Lemma nth_append_1 : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (i:Z), (i < (list.Length.length l1))%Z -> ((list.Nth.nth i
  (Init.Datatypes.app l1 l2)) = (list.Nth.nth i l1)).
Proof.
intros a a_WT l1.
induction l1 as [|x l1].
intros l2 i.
apply NthLength.nth_none_1.
intros l2 i Hi.
simpl.
generalize (Zeq_bool_if i 0).
case Zeq_bool.
easy.
intros _.
apply IHl1.
assert (i < 1 + Length.length l1)%Z by exact Hi.
omega.
Qed.

(* Why3 goal *)
Lemma nth_append_2 : forall {a:Type} {a_WT:WhyType a}, forall (l1:(list a))
  (l2:(list a)) (i:Z), ((list.Length.length l1) <= i)%Z -> ((list.Nth.nth i
  (Init.Datatypes.app l1 l2)) = (list.Nth.nth (i - (list.Length.length l1))%Z
  l2)).
Proof.
intros a a_WT l1.
induction l1 as [|x l1].
intros l2 i _.
simpl.
now rewrite Zminus_0_r.
intros l2 i.
change (Length.length (x :: l1)) with (1 + Length.length l1)%Z.
intros Hi.
replace (i - (1 + Length.length l1))%Z with ((i - 1) - Length.length l1)%Z by ring.
simpl.
generalize (Zeq_bool_if i 0).
case Zeq_bool.
intros Hi'.
exfalso.
generalize (Length.Length_nonnegative l1).
omega.
intros _.
apply IHl1.
omega.
Qed.


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
*)

Require Import List Lia.
Require Import Undecidability.SystemF.SysF Undecidability.SystemF.Autosubst.syntax.
From Undecidability.SystemF.Util Require Import Facts poly_type_facts typing_facts.
Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

Local Arguments nth_error_In {A l n x}.
Local Arguments In_nth_error {A l x}.

(* intuitionistic implicational propositional calculus of order 2  *)
Definition iipc2 (Gamma: environment) (t: poly_type) := exists P, typing Gamma P t.
Arguments iipc2 : simpl never.

Lemma iipc2I {Gamma P t} : typing Gamma P t -> iipc2 Gamma t.
Proof. move=> ?. eexists. by eassumption. Qed.

Lemma iipc2_weakening {Gamma Gamma' t} :
  incl Gamma Gamma' -> iipc2 Gamma t -> iipc2 Gamma' t.
Proof. by move=> /incl_nth_error [?] /typing_ren_term' H [?] /H /iipc2I. Qed.

(* generalized weakening in case if every assumption is derivable *)
Lemma iipc2_generalization {Gamma Gamma' t} :
  Forall (iipc2 Gamma') Gamma -> iipc2 Gamma t -> iipc2 Gamma' t.
Proof.
  move=> H [P HP]. elim: P Gamma Gamma' t HP H.
  - move=> > /typingE /nth_error_In. rewrite Forall_forall.
    by move=> + H => /H.
  - move=> ? IH1 ? IH2 > /typingE [?] [/IH1{}IH1 /IH2{}IH2].
    move=> /copy [/IH1 [? ?] /IH2 [? ?]]. eexists. apply: typing_app; by eassumption.
  - move=> s > IH Gamma Gamma' > /typingE [?] [->] /IH.
    move=> /(_ (s :: Gamma')) + HG. apply: unnest.
    {
      constructor.
      - exists (var 0). by apply: typing_var.
      - move: HG. apply: Forall_impl. move=> ?.
        apply: iipc2_weakening => ? /=. clear. by firstorder done.
    }
    move=> [? ?]. eexists. apply: typing_abs. by eassumption.
  - move=> ? IH > /typingE [?] [->] /IH{}IH /IH [? ?].
    eexists. apply: typing_ty_app. by eassumption.
  - move=> > IH Gamma Gamma' > /typingE [?] [->] /IH.
    move=> /(_ (map (ren_poly_type S) Gamma')) + HG. apply: unnest.
    {
      rewrite Forall_map. apply: Forall_impl HG.
      move=> ? [Q]. eexists. apply: typing_ren_poly_type. by eassumption.
    }
    move=> [? ?]. eexists. apply: typing_ty_abs. by eassumption.
Qed.

Lemma iipc2_poly_arrE {Gamma s t}: iipc2 Gamma (poly_arr s t) -> iipc2 (s :: Gamma) t.
Proof.
  move=> [?] /(@typing_ren_term' S) => /(_ (s :: Gamma) ltac:(done)).
  move=> /typing_app => /(_ (var 0)) H. eexists. apply: H. by apply: typing_var.
Qed.

Corollary last_poly_var_typingI {t Gamma}:
  (if last_poly_var t is Some x then In (poly_var x) Gamma else False) -> iipc2 Gamma t.
Proof.
  move Hox: (last_poly_var t) => ox Hx. case: ox Hox Hx; last done.
  move=> x. elim: t x Gamma.
  - move=> /= > [->] /In_nth_error [? ?]. eexists. apply: typing_var. by eassumption.
  - move=> ? _ ? IH > /= /IH H /H [P]. move=> /(@typing_ren_term' S) HP. eexists.
    apply: typing_abs. by apply: HP.
  - move=> s + x Gamma /= => /(_ (S x) (map (ren_poly_type S) Gamma)).
    case: (last_poly_var s); last done. move=> [|y]; first done.
    move=> + [?] ?. subst y. rewrite in_map_iff.
    apply: unnest; first done. apply: unnest.
    { eexists. constructor; last by eassumption. done. }
    move=> [?] /typing_ty_abs ?. eexists. by eassumption.
Qed.

(* deriving arrow composition *)
Lemma iipc2_poly_arr_comp {Gamma s r t} : iipc2 Gamma (poly_arr s r) -> iipc2 Gamma (poly_arr r t) ->
  iipc2 Gamma (poly_arr s t).
Proof.
  move=> [?] /(@typing_ren_term' S) HP1 [?] /(@typing_ren_term' S) HP2.
  eexists. apply: typing_abs. apply: typing_app; first by apply: HP2.
  apply: typing_app; first by apply: HP1.
  by apply: (typing_var (x := 0)).
Qed.

Lemma Forall2_typing_Forall_iipc2 {Gamma Ps ts} : Forall2 (typing Gamma) Ps ts -> Forall (iipc2 Gamma) ts.
Proof. elim; [by constructor | by move=> > /iipc2I; constructor]. Qed.

(* iipc2 is preserved under type renamings *)
Lemma iipc2_ren_poly_type {Gamma t} ξ : iipc2 Gamma t ->
  iipc2 (map (ren_poly_type ξ) Gamma) (ren_poly_type ξ t).
Proof. by move=> [?] /(typing_ren_poly_type ξ) /iipc2I. Qed.

Lemma iipc2_var_InI {Gamma t} : In t Gamma -> iipc2 Gamma t.
Proof. move=> /In_nth_error [?] /typing_var ?. eexists. by eassumption. Qed.

Lemma iipc2_poly_arrI {Gamma s t} : iipc2 (s :: Gamma) t -> iipc2 Gamma (poly_arr s t).
Proof. move=> [?] /typing_abs ?. eexists. by eassumption. Qed.

Lemma iipc2_poly_absI (x: nat) {Gamma t} :
  Forall (fresh_in x) Gamma -> fresh_in (S x) t ->
  iipc2 Gamma (ren_poly_type (scons x id) t) ->
  iipc2 Gamma (poly_abs t).
Proof.
  pose ξ := fun y => if PeanoNat.Nat.eq_dec x y then 0 else S y.
  move=> HG Ht /(iipc2_ren_poly_type ξ).
  have -> : map (ren_poly_type ξ) Gamma = (map (ren_poly_type S) Gamma).
  {
    elim: Gamma HG; first done.
    move=> s Gamma H /Forall_cons_iff [Hx /H{H} /= ->].
    congr cons. apply: ext_ren_poly_type_allfv_poly_type.
    apply: allfv_poly_type_impl Hx => ? ?. rewrite /ξ. by case: (PeanoNat.Nat.eq_dec _ _).
  }
  move=> [?] /typing_ty_abs /iipc2I. congr iipc2. congr poly_abs.
  rewrite poly_type_norm /ξ /= ren_poly_type_allfv_id; last done.
  apply: allfv_poly_type_impl Ht. clear.
  move=> [|y]; case: (PeanoNat.Nat.eq_dec _ _); move=> /=; by lia.
Qed.

Lemma iipc2_poly_varI x {Gamma ts ss y} :
  nth_error Gamma x = Some (many_poly_abs (length ts) (many_poly_arr ss (poly_var (length ts + y)))) ->
  Forall (iipc2 Gamma) (map (subst_poly_type (fold_right scons poly_var (rev ts))) ss) ->
  iipc2 Gamma (poly_var y).
Proof.
  move=> /typing_var /typing_many_ty_appI => /(_ ts ltac:(done)).
  rewrite subst_poly_type_many_poly_arr /subst_poly_type -rev_length fold_right_length_ts -/subst_poly_type.
  move=> /iipc2I. move: (map _ ss) => {}ss. move: (poly_var y) => t.
  elim: ss t; first done.
  by move=> s ss IH t /= [?] /typing_app H /Forall_cons_iff [[?] /H{H} /iipc2I /IH].
Qed.


MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Examples.

Coq < Require Import Classical.

Coq < Variables P Q R : Prop.
P is assumed
Q is assumed
R is assumed

Coq < Goal ((P \/ Q) /\ ~P /\ (Q -> R)) -> R.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  ============================
   (P \/ Q) /\ ~ P /\ (Q -> R) -> R

Unnamed_thm < intros.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  H : (P \/ Q) /\ ~ P /\ (Q -> R)
  ============================
   R

Unnamed_thm < elim H.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  H : (P \/ Q) /\ ~ P /\ (Q -> R)
  ============================
   P \/ Q -> ~ P /\ (Q -> R) -> R

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  H : (P \/ Q) /\ ~ P /\ (Q -> R)
  H0 : P \/ Q
  ============================
   ~ P /\ (Q -> R) -> R

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  R : Prop
  H : (P \/ Q) /\ ~ P /\ (Q -> R)
  H0 : P \/ Q
  H1 : ~ P /\ (Q -> R)
  ============================
   R

Unnamed_thm < firstorder.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
firstorder .

Unnamed_thm is defined

Coq <


From Coq Require Import Lists.List.
From Coq Require Import BinNums.
From Coq Require Import ZArith.BinInt.
From Coq Require Import ZArith.BinIntDef.
From Coq Require Import ZArith.Zdigits.
From Coq Require Import ZArith.Znat.
From Coq Require Import NArith.Nnat.
From Coq Require Import ZArith Psatz.
From Coq Require Import PeanoNat.
From Coq Require Import Strings.String.
From Coq Require Import Strings.Ascii.
Import ListNotations.

Open Scope string_scope.
Definition test_in := [
"Sabqponm";
"abcryxxl";
"accszExk";
"acctuvwj";
"abdefghi"
].
Close Scope string_scope.

Fixpoint deop {A} (l : list (option A)) : list A :=
  match l with
  | nil => nil
  | None :: r => deop r
  | (Some a) :: r => a :: deop r
  end.

Fixpoint transpose' {A} (n : nat) (l : list (list A)) : list (list A) :=
  match n with
  | O => nil
  | S n =>
    let fsts := deop (map (fun ll => hd_error ll) l) in
    let tls := map (fun ll => tl ll) l in
    fsts :: transpose' n tls
  end.

Definition transpose {A} (l : list (list A)) : list (list A) :=
  transpose' (List.length (hd nil l)) l.

Fixpoint zip {A B} (l1 : list A) (l2 : list B) : list (A*B) :=
  match l1,l2 with
  | nil,_ => nil
  | _,nil => nil
  | (a :: ra),(b :: rb) => (a,b) :: zip ra rb
  end.

Fixpoint range (n1 n2 : nat) :=
  match n2 with
  | O => nil
  | S n => n1 :: range (S n1) n
  end.

Definition dist (n1 n2 : nat) := if n1 <=? n2 then n2 - n1 else n1 - n2.

Fixpoint line_adj' (row : nat) (s : list (nat * (ascii * ascii))) : list ((nat * nat)*(nat * nat)) :=
  match s with
  | nil => nil
  | (idx,(c1,c2)) :: r => (if dist (nat_of_ascii c1) (nat_of_ascii c2) <=? 1 then [((row,idx+1),(row,idx));((row,idx),(row,idx+1))] else []) ++ line_adj' row r
  end.

Definition line_adj (row : nat) (la : list ascii) : list ((nat * nat)*(nat * nat)) :=
  let ps := zip la (tl la) in
  let idxl := zip (range 0 (List.length ps)) ps in
  line_adj' row idxl
  .

Fixpoint bind {A B} (l : list A) (f : A -> list B) : list B :=
  match l with
  | nil => nil
  | a :: r => f a ++ bind r f
  end.

Definition once_adj (l : list (list ascii)) : list ((nat*nat)*(nat*nat)) :=
  let idxl := zip (range 0 (List.length l)) l in
  bind idxl (fun p => let (idx,r) := p in line_adj idx r).

Definition full_adj (la : list (list ascii)) : list ((nat*nat)*(nat*nat)) :=
  let adj1 := once_adj la in
  let adj2 := map (fun p => ((snd (fst p),fst (fst p)),(snd (snd p),fst (snd p))))
  (once_adj (transpose la)) in
  adj1 ++ adj2.

Fixpoint update_fst {A} (c : A -> bool) (def : A) (f : A -> A) (l : list A) :=
  match l with
  | nil => [def]
  | (a :: r) => if c a then f a :: r else a :: update_fst c def f r
  end.

Fixpoint update_all {A} (c : A -> bool) (f : A -> A) (l : list A) :=
  match l with
  | nil => nil
  | (a :: r) => if c a then f a :: update_all c f r else a :: update_all c f r
  end.

Definition adj_list := list (nat*nat*list (nat*nat)).

Fixpoint adj' (l : list ((nat*nat)*(nat*nat))) : adj_list :=
  match l with
  | nil => nil
  | (((a,b),(c,d))) :: r => update_fst (fun p => andb (a =? fst (fst p)) (b =? snd (fst p))) ((a,b),[(c,d)]) (fun p => (fst p, (c,d) ::snd p)) (adj' r)
  end.

Definition adj (l : list (list ascii)) := adj' (full_adj l).

Compute adj (map (update_all (fun x => Ascii.eqb x "S"%char) (fun _ => "a"%char)) (map list_ascii_of_string test_in)).

Fixpoint find_char' (ca : ascii) (l : list (nat*nat*ascii)) : (nat*nat) :=
  match l with
  | nil => (0,0)
  | (y,x,c) :: r => if Ascii.eqb c ca then (x,y) else find_char' ca r
  end.

Definition find_char (ca : ascii) (l : list (list ascii)) : (nat*nat) :=
  let z1 := zip (range 0 (List.length l)) l in
  let z2 := bind z1 (fun p => zip (zip (repeat (fst p) (List.length (snd p)))(range 0 (List.length (snd p)))) (snd p)) in find_char' ca z2.

Definition source (l : list (list ascii)) : (nat*nat) := find_char "S"%char l .

Definition target (l : list (list ascii)) : (nat*nat) := find_char "E"%char l .

Definition dijkstra (src : (nat * nat)) (tgt : (nat * nat)) (l : adj_list) : list (nat * nat). Admitted.


(**************************************************************************)
(*                                                                        *)
(*     SMTCoq                                                             *)
(*     Copyright (C) 2011 - 2021                                          *)
(*                                                                        *)
(*     See file "AUTHORS" for the list of authors                         *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence     *)
(*                                                                        *)
(**************************************************************************)

(* This example tests the tactics in "real" condition: a part of the
   proof of correctness of insertion sort. It requires propositional
   reasoning, uninterpreted functions, and a bit of integer arithmetic.

   Ideally, the proof of each lemma should consists only on
   induction/destruct followed by a call to [smt]. What we currently
   lack:
     - we have to provide all the needed lemmas and unfold all the
       definitions
     - it requires too much from uninterpreted functions even when it is
       not needed
     - it sometimes fails (may be realted to the previous item)
 *)

Require Import SMTCoq.SMTCoq.
Require Import ZArith List Bool.

Local Open Scope Z_scope.

(* This will improve when SMTCoq works with SSReflect! *)

Lemma impl_implb (a b:bool) : (a -> b) <-> (a ---> b).
Proof. auto using (reflect_iff _ _ (ReflectFacts.implyP a b)). Qed.

Lemma eq_false b : b = false <-> negb b.
Proof. case b; intuition. Qed.

Section InsertionSort.

  Fixpoint insert (x:Z) (l:list Z) : list Z :=
    match l with
    | nil => x::nil
    | y::ys => if (x <=? y)%Z then x::y::ys else y::(insert x ys)
    end.

  Fixpoint sort (l:list Z) : list Z :=
    match l with
    | nil => nil
    | x::xs => insert x (sort xs)
    end.

  Section Spec.

    Fixpoint is_sorted (l:list Z) : bool :=
      match l with
      | nil => true
      | x::xs =>
        match xs with
        | nil => true
        | y::_ => (x <=? y)%Z && (is_sorted xs)
        end
      end.

    Fixpoint smaller (x:Z) (l:list Z) : bool :=
      match l with
      | nil => true
      | y::ys => (x <=? y)%Z && (smaller x ys)
      end.

    Lemma is_sorted_smaller x y ys :
      (((x <=? y)%Z && is_sorted (y :: ys)) ---> is_sorted (x :: ys)).
    Proof.
      destruct ys as [ |z zs].
      - simpl. smt.
      - change (is_sorted (y :: z :: zs)) with ((y <=? z)%Z && (is_sorted (z::zs))).
        change (is_sorted (x :: z :: zs)) with ((x <=? z)%Z && (is_sorted (z::zs))).
        (* [smt] or [verit] fail? *)
        assert (H:forall b, (x <=? y)%Z && ((y <=? z) && b) ---> (x <=? z) && b) by smt.
        apply H.
    Qed.

    Lemma is_sorted_cons x xs :
      (is_sorted (x::xs)) <---> (is_sorted xs && smaller x xs).
    Proof.
      induction xs as [ |y ys IHys].
      - reflexivity.
      - change (is_sorted (x :: y :: ys)) with ((x <=? y)%Z && (is_sorted (y::ys))).
        change (smaller x (y :: ys)) with ((x <=? y)%Z && (smaller x ys)).
        generalize (is_sorted_smaller x y ys). revert IHys. rewrite !impl_implb.
        (* Idem *)
        assert (H:forall a b c d, (a <---> b && c) --->
                                  ((x <=? y) && d ---> a) --->
                                  ((x <=? y) && d <--->
                                  d && ((x <=? y) && c))) by smt.
        apply H.
    Qed.

    Lemma insert_keeps_smaller x y ys :
      smaller y ys ---> (y <=? x) ---> smaller y (insert x ys).
    Proof.
      induction ys as [ |z zs IHzs].
      - simpl. smt.
      - simpl. case (x <=? z).
        + simpl.
          (* [smt] or [verit] require [Compec (list Z)] but they should not *)
          assert (H:forall a, (y <=? z) && a ---> (y <=? x) ---> (y <=? x) && ((y <=? z) && a)) by smt.
          apply H.
        + simpl. revert IHzs. rewrite impl_implb.
          (* Idem *)
          assert (H:forall a b, (a ---> (y <=? x) ---> b) ---> (y <=? z) && a ---> (y <=? x) ---> (y <=? z) && b) by smt.
          apply H.
    Qed.

    Lemma insert_keeps_sorted x l : is_sorted l -> is_sorted (insert x l).
    Proof.
      induction l as [ |y ys IHys].
      - reflexivity.
      - intro H. simpl. case_eq (x <=? y); intro Heq.
        + change ((x <=? y)%Z && (is_sorted (y::ys))). rewrite Heq, H. reflexivity.
        + rewrite eq_false in Heq.
          rewrite (eqb_prop _ _ (is_sorted_cons _ _)) in H.
          rewrite (eqb_prop _ _ (is_sorted_cons _ _)).
          generalize (insert_keeps_smaller x y ys).
          revert IHys H Heq. rewrite !impl_implb.
          (* Idem *)
          assert (H: forall a b c d, (a ---> b) ---> a && c ---> negb (x <=? y) ---> (c ---> (y <=? x) ---> d) ---> b && d) by smt.
          apply H.
    Qed.

    Theorem sort_sorts l : is_sorted (sort l).
    Proof.
      induction l as [ |x xs IHxs].
      - reflexivity.
      - simpl. now apply insert_keeps_sorted.
    Qed.

  End Spec.

End InsertionSort.


Require Import SystemF.
Require Import List.
Require Import Eval.
Require Import Bisimulation.
Require Import Arith.

Section Contextual.

  Variable Delta : nat -> Term.
  Variable Xi : nat -> Ty.
  Variable Prog : forall n l m, Derivation Xi [n ; l |= F m @ Xi m] -> Derivation Xi [n ; l |= Delta m @ Xi m].
  Variable ProgTy : forall m, valid (Xi m) 0.

  Notation "t ~> t'" := (Ev Delta t t') (at level 60).
  Notation "t ~>+ t'" := (Evplus Delta t t') (at level 60).
  Notation "t ~>* t'" := (Evstar Delta t t') (at level 60).

  Notation " a :<: b " := (simulates Delta Xi a b) (at level 90).

CoInductive codiverges : Term -> Set :=
| codiverges_base : forall a b, a ~>+ b -> codiverges b -> codiverges a.

Axiom converges_or_diverges : forall a, converges Delta a + codiverges a.

Lemma weaken_one : forall t G n L ty xty,
  Derivation Xi [n; G ++ L |= t @ ty] ->
  Derivation Xi [n; G ++ xty :: L |= shift (length G) t @ ty].
Proof.
  induction t ; intros.
  (* F *)
  inversion H. subst.
  apply FunIntro.
  (* V *)
  apply shift_var; auto.
  (* App *)
  inversion H; subst.
  apply ImpElim with (xty:=xty0); fold shift ; auto.
  (* TApp *)
  inversion H; subst.
  apply AllElim ; fold shift; auto.
  (* Abs *)
  inversion H; subst.
  apply ImpIntro ; fold shift; auto.
  cut (length G + 1 = length (t :: G)) ; [ intros H0 | rewrite plus_comm ; auto].
  rewrite H0.
  cut (t :: G ++ xty :: L = (t :: G) ++ xty :: L) ; [intros H1 | auto].
  rewrite H1 ; auto.
  (* Lam *)
  inversion H ; subst.
  apply AllIntro ; fold shift ; auto.
  cut (map tyshift (G ++ xty :: L) = map tyshift G ++ (tyshift xty) :: map tyshift L) ; [ intros Heq | auto ].
  cut (length G = length (map tyshift G)) ; [intros Heq2 | auto ].
  rewrite Heq. rewrite Heq2. apply IHt.
  cut (map tyshift G ++ map tyshift L = map tyshift (G ++ L)); [ intros Heq3 | auto ].
  rewrite Heq3. auto.
    (* Heq3 *)
    rewrite map_app. auto.
    (* Heq2 *)
    rewrite map_length. auto.
    rewrite map_app. simpl. auto.
Defined.

Fixpoint shiftn (n: nat) (d : nat) (t : Term) : Term :=
  match n with
    | 0 => t
    | S n' => shift d (shiftn n' d t)
  end.

Lemma weaken : forall F G t n L ty,
  Derivation Xi [n; G ++ L |= t @ ty] ->
  Derivation Xi [n; G ++ F ++ L |= shiftn (length F) (length G) t @ ty].
Proof.
  induction F. intros. simpl. auto.
  intros.
  simpl.
  apply weaken_one. apply IHF. auto.
Defined.

Lemma var_shift : forall n0 n, n < (S n0) -> shift (S n0) (V n) = V n.
Proof.
  induction n0.
  intros. simpl. destruct n. auto.
  elimtype False.
  firstorder.
  intros.
  unfold shift.
  case_eq (le_lt_dec (S (S n0)) n).
  intros.
  elimtype False. firstorder.
  intros. auto.
Defined.

Lemma shift_id : forall a G A n m,
  length G <= n ->
  Derivation Xi [ m ; G |= a @ A ] ->
  shift n a = a.
Proof.
  induction a ; intros.
  (* F *)
  intros ; simpl ; auto.
  (* V *)
  inversion H0. subst.
  destruct n0.
    (* Z *)
    elimtype False. firstorder.
    (* S n0 *)
    apply var_shift.
    firstorder.
  (* App *)
  simpl.
  inversion H0 ; subst.
  rewrite IHa1 with (m:=m) (G:=G) (A:=Imp xty A) ; auto.
  rewrite IHa2 with (m:=m) (G:=G) (A:=xty) ; auto.
  (* TApp *)
  simpl.
  inversion H0 ; subst.
  rewrite IHa with (m:=m) (G:=G) (A:=All ty) ; auto.
  (* Abs *)
  simpl.
  inversion H0 ; subst.
  rewrite IHa with (m:=m) (G:=t::G) (A:=ty) ; auto.
  simpl. firstorder.
  (* Lam *)
  simpl.
  inversion H0 ; subst.
  rewrite IHa with (m:=S m) (G:=map tyshift G) (A:=ty) ; auto.
  rewrite map_length. auto.
Defined.

Lemma shiftn_id : forall a A m n,
  Derivation Xi [ 0 ; nil |= a @ A ] ->
  a= shiftn m n a.
Proof.
  induction m ; intros.
  (* Z *)
  simpl. auto.
  (* S m *)
  simpl.
  rewrite shift_id with (G:=nil) (A:=A) (m:=0).
  apply IHm. auto.
  simpl. firstorder.
  rewrite <- IHm. auto. auto.
Defined.

Theorem app_nil_r : forall A (l : list A), l = l ++ nil.
Proof.
  induction l ; firstorder.
Defined.

Lemma GammaCloseVar : forall G a t A B,
  Derivation Xi [ 0 ; (cons A G) |= t @ B ] ->
  Derivation Xi [ 0; nil |= a @ A ] ->
  Derivation Xi [ 0; G |= (sub t 0 a) @ B].
Proof.
  intros.
  cut (G = nil ++ G). intros. rewrite H1.
  apply sub_preservation with (xty:=A).
  auto.
  simpl; auto.
  simpl; auto.
  cut (G = nil ++ G ++ nil) ; [ intros Heq | idtac].
  cut (a = shiftn (length G) (length (A:=Ty) nil) a) ; [ intros Heq_shift | idtac ].
  intros. rewrite Heq ; rewrite Heq_shift.
  apply weaken.
  simpl. auto. simpl in *.
  rewrite <- shiftn_id with (A:=A) (m:=length G) (n:=0). auto. auto.
  apply app_nil_r. simpl. auto.
Defined.

Inductive GammaSub : Type
| gammaSub : forall list ty,

Theorem GammaClose : forall G a t A,
  Derivation Xi [ 0 ; G |= t @ B ] ->
  Derivation Xi [ 0; nil |= a @ A ] ->
  Derivation Xi [ 0; G |= (sub t 0 a) @ B].
Proof.

Lemma GammaClosure : forall G a t A B,
  Derivation Xi [ 0 ; (cons A G) |= t @ B ] ->
  Derivation Xi [ 0; G |= a @ A ] ->
  Derivation Xi [ 0; G |= (sub t 0 a) @ B].

Inductive OpenExtension : Set -> Type :=
| oe : forall R, Derivation Xi [ 0 ; nil |= t @ A] ->

Lemma app_diverges : forall f x A B,
  Derivation Xi [0 ; nil |= f @ Imp A B] ->
  Derivation Xi [0 ; nil |= x @ A] ->
  codiverges f ->
  codiverges (App f x).
Proof.
  refine (cofix app_diverges f x A B
    (Hf : Derivation Xi [0 ; nil |= f @ Imp A B])
    (Hx : Derivation Xi [0 ; nil |= x @ A])
    (Hfdiv : codiverges f)
    : codiverges (App f x) := _).
  inversion Hfdiv. subst.
  apply codiverges_base with (b:= (App b x)).
  apply evplus_app with (s:=x) in H. auto.
  apply app_diverges with (A:=A) (B:=B).
  apply evplus_preservation with (Xi:=Xi) (n:=0) (l:=nil) (ty:=Imp A B) in H ; auto using Prog, ProgTy.
  auto. auto.
Defined.

(*
Lemma app_equivalence : forall f g x y A B,
  Derivation Xi [0 ; nil |= f @ Imp A B] ->
  Derivation Xi [0 ; nil |= g @ Imp A B] ->
  f :<: g ->
  x :<: y ->
  App f x :<: App g y.
Proof.
  refine (cofix app_equivalence f g x y A B
    (Hf : Derivation Xi [0 ; nil |= f @ Imp A B])
    (Hg : Derivation Xi [0 ; nil |= g @ Imp A B])
    (Hfg : f :<: g)
    (Hxy : x :<: y) : App f x :<: App g y := _).

  (* Sim *)
  apply simulates_base.
  intros a' l Htrans.

  inversion Hfg. subst.

  cut (converges Delta f + codiverges f).
  intros Hcd.
  inversion Hcd.
  (* Converges *)
  inversion H. subst.
  inversion H0.
  assert (Hval := H1).
  apply evaluates_imp_value with (Xi:=Xi) (A:=Imp A B) in Hval.
  inversion Hval. subst. inversion H1. subst.
  apply evstar_preservation with (Xi:=Xi) (n:=0) (l:=nil) (ty:=Imp A B) in H2.

  inversion Hxy. subst. invesrion

  apply trans_app in H2.

  inversion Htrans.
  subst.
  generalize t2 l a' H0.
  refine (fix trans_ind t3 l0 a'0 (Htrans0 : trans Delta Xi t3 l0 a'0) : {b' : Term & trans Delta Xi (App g y) l0 b' & a'0 :<: b'} :=
    (match Htrans0 in (trans _ _ t3_ l0_ a'0_)
       return (t3 = t3_ -> l0 = l0_ -> a'0 = a'0_ -> {b' : Term & trans Delta Xi (App g y) l0 b' & a'0 :<: b'})
       with
       | trans_app t1 t2 A B Habs Hx => _
       | trans_tapp t ty A HLam Hv => _
       | trans_next l t1 t2 t3 Hev Htrans_next => _
     end) (refl_equal t3) (refl_equal l0) (refl_equal a'0)).

  intros Heqt Heql Heqa.

  inversion X.
  *)

Axiom app1_equivalence : forall f g x y A B,
  Derivation Xi [0 ; nil |= f @ Imp A B] ->
  Derivation Xi [0 ; nil |= g @ Imp A B] ->
  Derivation Xi [0 ; nil |= x @ Imp A B] ->
  Derivation Xi [0 ; nil |= y @ Imp A B] ->
  f :<: g ->
  x :<: y ->
  App f x :<: App g y.

(*
Theorem zero_false : forall t,(forall n, Xi n = Zero -> False) -> Derivation Xi [ 0 ; nil |= t @ Zero ] -> False.
Proof.
  intros. inversion H0. apply H with (n:=m). auto. subst.

Theorem trans_unit : forall l a', trans Delta Xi Unit l a' -> False.
Proof.
  intros. inversion H. subst.
  inversion H. subst.simpl in *.
*)

Lemma contextual_simulation : forall c a b A,
  Derivation Xi [0 ; nil |= a @ A] ->
  Derivation Xi [0 ; nil |= b @ A] ->
  a :<: b ->
  Derivation Xi [0 ; (cons A nil) |= c @ One] ->
  (sub c 0 b) :<: Unit ->
  (sub c 0 a) :<: Unit.
Proof.
  induction c ; intros a b A Htya Htyb Hsim Hctx Hsub.
  (* F *)
  simpl in Hsub. simpl. auto.
  (* V *)
  inversion Hctx. subst.
  destruct n ; simpl in *. subst.
  apply simulates_transitive with (t2:=b); auto. auto.
  (* App *)
  simpl in *.
  inversion Hctx. subst.
  inversion Hsub. subst.

  apply app1_equivalence.

  inversion Hsub. subst.
  apply simulates_base.

  intros a' l Htrans.
 *)

Axiom contextual_simulation : forall c a b A,
  Derivation Xi [0 ; nil |= a @ A] ->
  Derivation Xi [0 ; nil |= b @ A] ->
  a :<: b ->
  Derivation Xi [0 ; (cons A nil) |= c @ One] ->
  (sub c 0 b) ~>* Unit ->
  (sub c 0 a) ~>* Unit.

Notation " a :~: b " := (bisimulates Delta Xi a b) (at level 90).

Theorem contextual_equivalence : forall c a b A,
  Derivation Xi [0 ; nil |= a @ A] ->
  Derivation Xi [0 ; nil |= b @ A] ->
  a :~: b ->
  Derivation Xi [0 ; (cons A nil) |= c @ One] ->
  ((sub c 0 b) ~>* Unit ->
    (sub c 0 a) ~>* Unit) *
  ((sub c 0 a) ~>* Unit ->
    (sub c 0 b) ~>* Unit).
Proof.
  intros.
  split.
  intros.