Set Implicit Arguments.

(* CoqIDE users: Run open.sh (in ./ln) to start coqide, then open this file. *)
Require Import LibLN.

(* ###################################################################### *)
(* ###################################################################### *)
(** * Definitions *)

(* ###################################################################### *)
(** ** Syntax *)

Parameter typ_label: Set.
Parameter mtd_label: Set.

Inductive label: Set :=
| label_typ: typ_label -> label
| label_mtd: mtd_label -> label.

Inductive avar : Set :=
  | avar_b : nat -> avar  (* bound var (de Bruijn index) *)
  | avar_f : var -> avar. (* free var ("name"), refers to store or ctx *)

Inductive typ : Set :=
  | typ_top  : typ
  | typ_bot  : typ
  | typ_tdec : typ_label -> typ -> typ -> typ (* { L: S..U } *)
  | typ_mdec : mtd_label -> typ -> typ -> typ (* { m: S->U } *)
  | typ_sel  : avar -> typ_label -> typ (* x.L *)
  | typ_and  : typ -> typ -> typ
  | typ_or   : typ -> typ -> typ.

Inductive trm: Set :=
  | trm_var : avar -> trm
  | trm_new : defs -> trm -> trm (* val x = new {...} in t *)
  | trm_call: trm -> mtd_label -> trm -> trm (* t1.m(t2) *)
with def : Set :=
  | def_typ : typ_label -> typ -> typ -> def (* same as dec_typ *)
  | def_mtd : mtd_label -> typ -> typ -> trm -> def (* one nameless argument *)
with defs : Set :=
  | defs_nil : defs
  | defs_cons : defs -> def -> defs.

(** *** Typing environment ("Gamma") *)
Definition ctx := env typ.

(** *** Value environment ("store") *)
Definition sto := env defs.

(** *** TODO Syntactic sugar *)

(* ###################################################################### *)
(** ** Definition list membership *)

Definition label_of_def(d: def): label := match d with
| def_typ L _ _ => label_typ L
| def_mtd m _ _ _ => label_mtd m
end.

Fixpoint get_def(l: label)(ds: defs): option def :=
match ds with
| defs_nil => None
| defs_cons ds' d => If label_of_def d = l then Some d else get_def l ds'
end.

Definition defs_has(ds: defs)(d: def) := get_def (label_of_def d) ds = Some d.
Definition defs_hasnt(ds: defs)(l: label) := get_def l ds = None.

(* ###################################################################### *)
(** ** Opening *)

(** Opening replaces in some syntax a bound variable with dangling index (k)
   by a free variable x. *)

Definition open_rec_avar (k: nat) (u: var) (a: avar) : avar :=
  match a with
  | avar_b i => If k = i then avar_f u else avar_b i
  | avar_f x => avar_f x
  end.

Fixpoint open_rec_typ (k: nat) (u: var) (T: typ): typ :=
  match T with
  | typ_top        => typ_top
  | typ_bot        => typ_bot
  | typ_tdec L T U => typ_tdec L (open_rec_typ k u T) (open_rec_typ k u U)
  | typ_mdec m T U => typ_mdec m (open_rec_typ k u T) (open_rec_typ k u U)
  | typ_sel x L    => typ_sel (open_rec_avar k u x) L
  | typ_and T1 T2  => typ_and (open_rec_typ k u T1) (open_rec_typ k u T2)
  | typ_or  T1 T2  => typ_or  (open_rec_typ k u T1) (open_rec_typ k u T2)
  end.

Fixpoint open_rec_trm (k: nat) (u: var) (t: trm): trm :=
  match t with
  | trm_var a      => trm_var (open_rec_avar k u a)
  | trm_call o m a => trm_call (open_rec_trm k u o) m (open_rec_trm k u a)
  | trm_new ds t   => trm_new (open_rec_defs (S k) u ds) (* self ref *)
                              (open_rec_trm (S k) u t)
  end
with open_rec_def (k: nat) (u: var) (d: def): def :=
  match d with
  | def_typ L Lo Hi => def_typ L (open_rec_typ k u Lo) (open_rec_typ k u Hi)
  | def_mtd m T1 T2 e => def_mtd m (open_rec_typ k u T1) (open_rec_typ k u T2)
                         (open_rec_trm (S k) u e)
  end
with open_rec_defs (k: nat) (u: var) (ds: defs): defs :=
  match ds with
  | defs_nil => defs_nil
  | defs_cons tl d => defs_cons (open_rec_defs k u tl) (open_rec_def k u d)
  end.

Definition open_avar u a := open_rec_avar  0 u a.
Definition open_typ  u t := open_rec_typ   0 u t.
Definition open_trm  u e := open_rec_trm   0 u e.
Definition open_def  u d := open_rec_def   0 u d.
Definition open_defs u l := open_rec_defs  0 u l.

(* ###################################################################### *)
(** ** Free variables *)

Definition fv_avar (a: avar) : vars :=
  match a with
  | avar_b i => \{}
  | avar_f x => \{x}
  end.

Fixpoint fv_typ (T: typ) : vars :=
  match T with
  | typ_top        => \{}
  | typ_bot        => \{}
  | typ_tdec L T U => (fv_typ T) \u (fv_typ U)
  | typ_mdec m T U => (fv_typ T) \u (fv_typ U)
  | typ_sel x L    => (fv_avar x)
  | typ_and T U    => (fv_typ T) \u (fv_typ U)
  | typ_or  T U    => (fv_typ T) \u (fv_typ U)
  end.

(* Since we define defs ourselves instead of using [list def], we don't have any
   termination proof problems: *)
Fixpoint fv_trm (t: trm) : vars :=
  match t with
  | trm_var x        => (fv_avar x)
  | trm_new ds t     => (fv_defs ds) \u (fv_trm t)
  | trm_call t1 m t2 => (fv_trm t1) \u (fv_trm t2)
  end
with fv_def (d: def) : vars :=
  match d with
  | def_typ _ T U   => (fv_typ T) \u (fv_typ U)
  | def_mtd _ T U u => (fv_typ T) \u (fv_typ U) \u (fv_trm u)
  end
with fv_defs(ds: defs) : vars :=
  match ds with
  | defs_nil         => \{}
  | defs_cons tl d   => (fv_defs tl) \u (fv_def d)
  end.

Definition fv_ctx_types(G: ctx): vars := (fv_in_values (fun T => fv_typ T) G).

(* ###################################################################### *)
(** ** Operational Semantics *)

(** Note: Terms given by user are closed, so they only contain avar_b, no avar_f.
    Whenever we introduce a new avar_f (only happens in red_new), we choose one
    which is not in the store, so we never have name clashes. *)
Inductive red : trm -> sto -> trm -> sto -> Prop :=
  (* computation rules *)
  | red_call: forall s x y m T U ds body,
      binds x ds s ->
      defs_has ds (def_mtd m T U body) ->
      red (trm_call (trm_var (avar_f x)) m (trm_var (avar_f y))) s
          (open_trm y body) s
  | red_new: forall s ds t x,
      x # s ->
      red (trm_new ds t) s
          (open_trm x t) (s & x ~ (open_defs x ds))
  (* congruence rules *)
  | red_call1 : forall s o m a s' o',
      red o s o' s' ->
      red (trm_call o  m a) s
          (trm_call o' m a) s'
  | red_call2 : forall s x m a s' a',
      red a s a' s' ->
      red (trm_call (trm_var (avar_f x)) m a ) s
          (trm_call (trm_var (avar_f x)) m a') s'.

(* ###################################################################### *)
(** ** Typing *)

(* "optimization" of typ_and (makes some proofs simpler). *)
Definition intersect_typ(T1 T2: typ): typ := match T1, T2 with
| typ_top, _ => T2
| _, typ_top => T1
| typ_bot, _ => typ_bot
| _, typ_bot => typ_bot
| _, _       => typ_and T1 T2
end.

Definition union_typ(T1 T2: typ): typ := match T1, T2 with
| typ_top, _ => typ_top
| _, typ_top => typ_top
| typ_bot, _ => T2
| _, typ_bot => T1
| _, _       => typ_or T1 T2
end.

(* If we run out of fuel or something goes wrong, we just return (typ_bot, typ_top).
   This should be sound because with such an {L: Bot..Top}, nothing useful can be done. *)
Fixpoint lookup_tdec(fuel1: nat)(G: ctx)(T: typ)(L: typ_label): (typ * typ) :=
match fuel1 with
| 0 => (typ_bot, typ_top)
| S fuel => match T with
  | typ_top => (typ_bot, typ_top)
  | typ_bot => (typ_top, typ_bot)
  | typ_tdec L1 T1 U1 => If L1 = L then (T1, U1) else (typ_bot, typ_top)
  | typ_mdec _ _ _ => (typ_bot, typ_top)
  | typ_sel a L1 => match a with
     | avar_f x =>
         match get x G with
         | Some X => let (Lo, Hi) := lookup_tdec fuel G X L1 in lookup_tdec fuel G Hi L
         | None => (typ_bot, typ_top)
         end
     | avar_b _ => (typ_bot, typ_top) (* T is not wf! *)
     end
  | typ_and T1 T2 =>
    let (Lo1, Hi1) := (lookup_tdec fuel G T1 L) in
    let (Lo2, Hi2) := (lookup_tdec fuel G T2 L) in
    ((union_typ Lo1 Lo2), (intersect_typ Hi1 Hi2))
  | typ_or T1 T2 =>
    let (Lo1, Hi1) := (lookup_tdec fuel G T1 L) in
    let (Lo2, Hi2) := (lookup_tdec fuel G T2 L) in
    ((intersect_typ Lo1 Lo2), (union_typ Hi1 Hi2))
  end
end.

(* For method member lookup, we have to be more careful than for type member lookup,
   because it has to agree with defs_has, so we can't just return {m: Bot->Top} if
   we don't find m or if something goes wrong, but we have to return None. *)
Fixpoint lookup_mdec(fuel1: nat)(G: ctx)(T: typ)(m: mtd_label): option (typ * typ) :=
match fuel1 with
| 0 => None
| S fuel => match T with
  | typ_top => None
  | typ_bot => Some (typ_top, typ_bot)
  | typ_tdec _ _ _ => None
  | typ_mdec m1 A1 R1 => If m1 = m then Some (A1, R1) else None
  | typ_sel a L => match a with
    | avar_f x => match get x G with
      | Some X => let (Lo, Hi) := (lookup_tdec fuel G X L) in lookup_mdec fuel G Hi m
      | None => None
      end
    | avar_b _ => None  (* T is not wf *)
    end
  | typ_and T1 T2 => match (lookup_mdec fuel G T1 m), (lookup_mdec fuel G T2 m) with
    | None, o2 => o2
    | o1, None => o1
    | Some (A1, R1), Some (A2, R2) => Some ((union_typ A1 A2), (intersect_typ R1 R2))
    end
  | typ_or T1 T2 => match (lookup_mdec fuel G T1 m), (lookup_mdec fuel G T2 m) with
    | None, o2 => None
    | o1, None => None
    | Some (A1, R1), Some (A2, R2) => Some ((intersect_typ A1 A2), (union_typ R1 R2))
    end
  end
end.

Definition typ_has_tdec(G: ctx)(T: typ)(L: typ_label)(Lo Hi: typ) :=
  exists minFuel, forall fuel, minFuel <= fuel -> lookup_tdec fuel G T L = (Lo, Hi).

Definition typ_has_mdec(G: ctx)(T: typ)(m: mtd_label)(A R: typ) :=
  exists minFuel, forall fuel, minFuel <= fuel -> lookup_mdec fuel G T m = Some (A, R).

Inductive subtyp: ctx -> typ -> typ -> Prop :=
  | subtyp_refl: forall G T,
      subtyp G T T
  | subtyp_top: forall G T,
      subtyp G T typ_top
  | subtyp_bot: forall G T,
      subtyp G typ_bot T
  | subtyp_tdec: forall G L T1 U1 T2 U2,
      subtyp G T2 T1 ->
      subtyp G U1 U2 ->
      subtyp G (typ_tdec L T1 U1) (typ_tdec L T2 U2)
  | subtyp_mdec: forall G m T1 U1 T2 U2,
      subtyp G T2 T1 ->
      subtyp G U1 U2 ->
      subtyp G (typ_mdec m T1 U1) (typ_mdec m T2 U2)
  | subtyp_sel_l: forall G x X L T U,
      binds x X G ->
      (*lookup_tdec fuel G X L = (T, U) ->*)
      typ_has_tdec G X L T U ->
      subtyp G T U -> (* <-- probably not needed, but keep for symmetry with subtyp_sel_r *)
      subtyp G (typ_sel (avar_f x) L) U
  | subtyp_sel_r: forall G x X L T U,
      binds x X G ->
      (* lookup_tdec fuel G X L = (T, U) -> *)
      typ_has_tdec G X L T U ->
      subtyp G T U -> (* <-- makes proofs a lot easier!! *)
      subtyp G T (typ_sel (avar_f x) L)
  | subtyp_and: forall G T U1 U2,
      subtyp G T U1 ->
      subtyp G T U2 ->
      subtyp G T (typ_and U1 U2)
  | subtyp_and_l: forall G T1 T2,
      subtyp G (typ_and T1 T2) T1
  | subtyp_and_r: forall G T1 T2,
      subtyp G (typ_and T1 T2) T2
  | subtyp_or: forall G T1 T2 U,
      subtyp G T1 U ->
      subtyp G T2 U ->
      subtyp G (typ_or T1 T2) U
  | subtyp_or_l: forall G T1 T2,
      subtyp G T1 (typ_or T1 T2)
  | subtyp_or_r: forall G T1 T2,
      subtyp G T2 (typ_or T1 T2)
  | subtyp_trans: forall G T1 T2 T3,
      subtyp G T1 T2 ->
      subtyp G T2 T3 ->
      subtyp G T1 T3.

Inductive ty_trm: ctx -> trm -> typ -> Prop :=
  | ty_var: forall G x T,
      binds x T G ->
      ty_trm G (trm_var (avar_f x)) T
  | ty_call: forall G t T m U1 U2 V u,
      ty_trm G t T ->
      (*lookup_mdec fuel G T m = Some (U2, V) ->*)
      typ_has_mdec G T m U2 V ->
      ty_trm G u U1 ->
      subtyp G U1 U2 -> (* <-- explicit subsumption *)
      ty_trm G (trm_call t m u) V
  | ty_new: forall L G ds T u U,
      (forall x, x \notin L ->
         ty_defs (G & x ~ T) (open_defs x ds) T) ->
      (forall x, x \notin L ->
         ty_trm (G & x ~ T) (open_trm x u) U) ->
      ty_trm G (trm_new ds u) U
with ty_def: ctx -> def -> typ -> Prop :=
  | ty_tdef: forall G L T U,
      subtyp G T U -> (* <-- only allow realizable bounds *)
      ty_def G (def_typ L T U) (typ_tdec L T U)
  | ty_mdef: forall L m G T U1 U2 u,
      (forall x, x \notin L -> ty_trm (G & x ~ T) (open_trm x u) U1) ->
      subtyp G U1 U2 ->  (* <-- explicit subsumption *)
      ty_def G (def_mtd m T U2 u) (typ_mdec m T U2)
with ty_defs: ctx -> defs -> typ -> Prop :=
  | ty_defs_nil: forall G,
      ty_defs G defs_nil typ_top
  | ty_defs_cons: forall G ds d T1 T2,
      ty_defs G ds T1 ->
      ty_def G d T2 ->
      defs_hasnt ds (label_of_def d) -> (* <-- no duplicates *)
      ty_defs G (defs_cons ds d) (typ_and T1 T2).

(** *** Well-formed store *)
Inductive wf_sto: sto -> ctx -> Prop :=
  | wf_sto_empty: wf_sto empty empty
  | wf_sto_push: forall s G x ds T,
      wf_sto s G ->
      x # s ->
      x # G ->
      (* Note that ds and T were already opened with x. *)
      ty_defs (G & x ~ T) ds T ->
      wf_sto (s & x ~ ds) (G & x ~ T).

(* ###################################################################### *)
(** ** Statements we want to prove *)

Definition progress := forall s G e T,
  wf_sto s G ->
  ty_trm G e T ->
  (
    (* can step *)
    (exists e' s', red e s e' s') \/
    (* or is a value *)
    (exists x o, e = (trm_var (avar_f x)) /\ binds x o s)
  ).

Definition preservation := forall s G e T e' s',
  wf_sto s G -> ty_trm G e T -> red e s e' s' ->
  (exists G', wf_sto s' G' /\ ty_trm G' e' T).

(* ###################################################################### *)
(* ###################################################################### *)
(** * Infrastructure *)

(* ###################################################################### *)
(** ** Induction principles *)

Scheme trm_mut  := Induction for trm  Sort Prop
with   def_mut  := Induction for def  Sort Prop
with   defs_mut := Induction for defs Sort Prop.
Combined Scheme trm_mutind from trm_mut, def_mut, defs_mut.

Scheme ty_trm_mut    := Induction for ty_trm    Sort Prop
with   ty_def_mut    := Induction for ty_def    Sort Prop
with   ty_defs_mut   := Induction for ty_defs   Sort Prop.
Combined Scheme ty_mutind from ty_trm_mut, ty_def_mut, ty_defs_mut.

(* ###################################################################### *)
(** ** Tactics *)

Ltac gather_vars :=
  let A := gather_vars_with (fun x : vars      => x         ) in
  let B := gather_vars_with (fun x : var       => \{ x }    ) in
  let C := gather_vars_with (fun x : ctx       => (dom x) \u (fv_ctx_types x)) in
  let D := gather_vars_with (fun x : sto       => dom x     ) in
  let E := gather_vars_with (fun x : avar      => fv_avar  x) in
  let F := gather_vars_with (fun x : trm       => fv_trm   x) in
  let G := gather_vars_with (fun x : def       => fv_def   x) in
  let H := gather_vars_with (fun x : defs      => fv_defs  x) in
  let I := gather_vars_with (fun x : typ       => fv_typ   x) in
  constr:(A \u B \u C \u D \u E \u F \u G \u H \u I).

Ltac pick_fresh x :=
  let L := gather_vars in (pick_fresh_gen L x).

Tactic Notation "apply_fresh" constr(T) "as" ident(x) :=
  apply_fresh_base T gather_vars x.

Hint Constructors subtyp ty_trm ty_def ty_defs.

Lemma fresh_push_eq_inv: forall A x a (E: env A),
  x # (E & x ~ a) -> False.
Proof.
  intros. rewrite dom_push in H. false H. rewrite in_union.
  left. rewrite in_singleton. reflexivity.
Qed.

(* ###################################################################### *)
(** ** Definition of var-by-var substitution *)

(** Note that substitution is not part of the definitions, because for the
    definitions, opening is sufficient. For the proofs, however, we also
    need substitution, but only var-by-var substitution, not var-by-term
    substitution. That's why we don't need a judgment asserting that a term
    is locally closed. *)

Definition subst_avar (z: var) (u: var) (a: avar) : avar :=
  match a with
  | avar_b i => avar_b i
  | avar_f x => If x = z then (avar_f u) else (avar_f x)
  end.

Fixpoint subst_typ (z: var) (u: var) (T: typ) { struct T } : typ :=
  match T with
  | typ_top        => typ_top
  | typ_bot        => typ_bot
  | typ_tdec L T U => typ_tdec L (subst_typ z u T) (subst_typ z u U)
  | typ_mdec m T U => typ_mdec m (subst_typ z u T) (subst_typ z u U)
  | typ_sel x L    => typ_sel (subst_avar z u x) L
  | typ_and T1 T2  => typ_and (subst_typ z u T1) (subst_typ z u T2)
  | typ_or  T1 T2  => typ_or  (subst_typ z u T1) (subst_typ z u T2)
  end.

Fixpoint subst_trm (z: var) (u: var) (t: trm) : trm :=
  match t with
  | trm_var x        => trm_var (subst_avar z u x)
  | trm_new ds t     => trm_new (subst_defs z u ds) (subst_trm z u t)
  | trm_call t1 m t2 => trm_call (subst_trm z u t1) m (subst_trm z u t2)
  end
with subst_def (z: var) (u: var) (d: def) : def :=
  match d with
  | def_typ L T1 T2   => def_typ L (subst_typ z u T1) (subst_typ z u T2)
  | def_mtd m T1 T2 b => def_mtd m (subst_typ z u T1) (subst_typ z u T2) (subst_trm z u b)
  end
with subst_defs (z: var) (u: var) (ds: defs) : defs :=
  match ds with
  | defs_nil => defs_nil
  | defs_cons rest d => defs_cons (subst_defs z u rest) (subst_def z u d)
  end.

Definition subst_ctx (z: var) (u: var) (G: ctx) : ctx := map (subst_typ z u) G.

(* ###################################################################### *)
(** ** Lemmas for var-by-var substitution *)

Lemma subst_fresh_avar: forall x y,
  (forall a: avar, x \notin fv_avar a -> subst_avar x y a = a).
Proof.
  intros. destruct* a. simpl. case_var*. simpls. notin_false.
Qed.

Lemma subst_fresh_typ: forall x y,
  (forall T : typ , x \notin fv_typ  T  -> subst_typ  x y T  = T ).
Proof.
  intros x y T. induction T; intros; simpls; f_equal*. apply* subst_fresh_avar.
Qed.

Lemma subst_fresh_trm_def_defs: forall x y,
  (forall t : trm , x \notin fv_trm  t  -> subst_trm  x y t  = t ) /\
  (forall d : def , x \notin fv_def  d  -> subst_def  x y d  = d ) /\
  (forall ds: defs, x \notin fv_defs ds -> subst_defs x y ds = ds).
Proof.
  intros x y. apply trm_mutind; intros; simpls; f_equal*;
    (apply* subst_fresh_avar || apply* subst_fresh_typ).
Qed.

Lemma invert_fv_ctx_types_push: forall x z T G,
  x \notin fv_ctx_types (G & z ~ T) -> x \notin fv_typ T /\ x \notin (fv_ctx_types G).
Proof.
  introv N.
  unfold fv_ctx_types in *.
  unfold fv_in_values in *.
  rewrite <- cons_to_push in *.
  rewrite values_def in *.
  unfold LibList.map in *.
  do 2 rewrite LibList.fold_right_cons in *.
  simpl in *.
  apply notin_union in N. exact N.
Qed.

Lemma subst_fresh_ctx: forall x y G,
  x \notin fv_ctx_types G -> subst_ctx x y G = G.
Proof.
  intros x y.
  apply (env_ind (fun G => x \notin fv_ctx_types G -> subst_ctx x y G = G)).
  + intro N. unfold subst_ctx. apply map_empty.
  + intros G z T IH N.
    apply invert_fv_ctx_types_push in N. destruct N as [N1 N2].
    unfold subst_ctx in *. rewrite map_push.
    rewrite (IH N2).
    rewrite (subst_fresh_typ _ _ N1).
    reflexivity.
Qed.

Definition subst_fvar(x y z: var): var := If x = z then y else z.

Lemma subst_open_commute_avar: forall x y u,
  (forall a: avar, forall n: Datatypes.nat,
    subst_avar x y (open_rec_avar n u a)
    = open_rec_avar n (subst_fvar x y u) (subst_avar  x y a)).
Proof.
  intros. unfold subst_fvar, subst_avar, open_avar, open_rec_avar. destruct a.
  + repeat case_if; auto.
  + case_var*.
Qed.

(* "open and then substitute" = "substitute and then open" *)
Lemma subst_open_commute_typ: forall x y u,
  (forall t : typ, forall n: nat,
     subst_typ x y (open_rec_typ n u t)
     = open_rec_typ n (subst_fvar x y u) (subst_typ x y t)).
Proof.
  intros. induction t; intros; simpl; f_equal*. apply subst_open_commute_avar.
Qed.

(* "open and then substitute" = "substitute and then open" *)
Lemma subst_open_commute_trm_def_defs: forall x y u,
  (forall t : trm, forall n: Datatypes.nat,
     subst_trm x y (open_rec_trm n u t)
     = open_rec_trm n (subst_fvar x y u) (subst_trm x y t)) /\
  (forall d : def , forall n: Datatypes.nat,
     subst_def x y (open_rec_def n u d)
     = open_rec_def n (subst_fvar x y u) (subst_def x y d)) /\
  (forall ds: defs, forall n: Datatypes.nat,
     subst_defs x y (open_rec_defs n u ds)
     = open_rec_defs n (subst_fvar x y u) (subst_defs x y ds)).
Proof.
  intros. apply trm_mutind; intros; simpl; f_equal*;
    (apply* subst_open_commute_avar || apply* subst_open_commute_typ).
Qed.

Lemma subst_open_commute_trm: forall x y u t,
  subst_trm x y (open_trm u t) = open_trm (subst_fvar x y u) (subst_trm x y t).
Proof.
  intros. apply* subst_open_commute_trm_def_defs.
Qed.

Lemma subst_open_commute_defs: forall x y u ds,
  subst_defs x y (open_defs u ds) = open_defs (subst_fvar x y u) (subst_defs x y ds).
Proof.
  intros. apply* subst_open_commute_trm_def_defs.
Qed.

(* "Introduce a substitution after open": Opening a term t with a var u is the
   same as opening t with x and then replacing x by u. *)
Lemma subst_intro_trm: forall x u t, x \notin (fv_trm t) ->
  open_trm u t = subst_trm x u (open_trm x t).
Proof.
  introv Fr. unfold open_trm. rewrite* subst_open_commute_trm.
  destruct (@subst_fresh_trm_def_defs x u) as [Q _]. rewrite* (Q t).
  unfold subst_fvar. case_var*.
Qed.

Lemma subst_intro_defs: forall x u ds, x \notin (fv_defs ds) ->
  open_defs u ds = subst_defs x u (open_defs x ds).
Proof.
  introv Fr. unfold open_trm. rewrite* subst_open_commute_defs.
  destruct (@subst_fresh_trm_def_defs x u) as [_ [_ Q]]. rewrite* (Q ds).
  unfold subst_fvar. case_var*.
Qed.

Lemma subst_intro_typ: forall x u T, x \notin (fv_typ T) ->
  open_typ u T = subst_typ x u (open_typ x T).
Proof.
  introv Fr. unfold open_typ. rewrite* subst_open_commute_typ.
  lets Q: (@subst_fresh_typ x u). rewrite* (Q T).
  unfold subst_fvar. case_var*.
Qed.

Lemma subst_undo_avar: forall x y,
  (forall a, y \notin fv_avar a -> (subst_avar y x (subst_avar x y a)) = a).
Proof.
  intros. unfold subst_avar, subst_fvar, open_avar, open_rec_avar; destruct a.
  + reflexivity.
  + unfold fv_avar in H. assert (y <> v) by auto. repeat case_if; reflexivity.
Qed.

Lemma subst_undo_typ: forall x y,
   (forall T , y \notin fv_typ  T  -> (subst_typ  y x (subst_typ  x y T )) = T ).
Proof.
  intros.
  induction T; intros; simpl; unfold fv_typ in *; f_equal*.
  apply* subst_undo_avar.
Qed.

Lemma subst_undo_trm_def_defs: forall x y,
   (forall t , y \notin fv_trm  t  -> (subst_trm  y x (subst_trm  x y t )) = t )
/\ (forall d , y \notin fv_def  d  -> (subst_def  y x (subst_def  x y d )) = d )
/\ (forall ds, y \notin fv_defs ds -> (subst_defs y x (subst_defs x y ds)) = ds).
Proof.
  intros.
  apply trm_mutind; intros; simpl; unfold fv_trm, fv_def, fv_defs in *; f_equal*;
    (apply* subst_undo_avar || apply* subst_undo_typ).
Qed.

Lemma subst_undo_trm: forall x y t,
  y \notin fv_trm t -> (subst_trm y x (subst_trm x y t)) = t.
Proof.
  apply* subst_undo_trm_def_defs.
Qed.

(* ###################################################################### *)
(** ** Looks like rules, but follows from the rules *)

(* take subtyp_and/or rules and replace "and" by "intersect", "or" by "union": *)

Lemma subtyp_intersect : forall (G : ctx) (S T1 T2 : typ),
  subtyp G S T1 -> subtyp G S T2 -> subtyp G S (intersect_typ T1 T2).
Proof.
  intros. destruct T1; destruct T2; simpl; auto.
Qed.

Lemma subtyp_intersect_l : forall (G : ctx) (T1 T2 : typ),
  subtyp G (intersect_typ T1 T2) T1.
Proof.
  intros.
  destruct T1; destruct T2; simpl; auto.
Qed.

Lemma subtyp_intersect_r : forall (G : ctx) (T1 T2 : typ),
  subtyp G (intersect_typ T1 T2) T2.
Proof.
  intros.
  destruct T1; destruct T2; simpl; auto.
Qed.

Lemma subtyp_union : forall (G : ctx) (T1 T2 S : typ),
  subtyp G T1 S -> subtyp G T2 S -> subtyp G (union_typ T1 T2) S.
Proof.
  intros.
  destruct T1; destruct T2; destruct S; simpl; auto.
Qed.

Lemma subtyp_union_l : forall (G : ctx) (T1 T2 : typ),
  subtyp G T1 (union_typ T1 T2).
Proof.
  intros.
  destruct T1; destruct T2; simpl; auto.
Qed.

Lemma subtyp_union_r: forall (G : ctx) (T1 T2 : typ),
  subtyp G T2 (union_typ T1 T2).
Proof.
  intros.
  destruct T1; destruct T2; simpl; auto.
Qed.

Hint Resolve subtyp_intersect subtyp_intersect_l subtyp_intersect_r
             subtyp_union     subtyp_union_l     subtyp_union_r.

Lemma typ_and_has_tdec: forall G T1 T2 L Lo1 Hi1 Lo2 Hi2,
  typ_has_tdec G T1 L Lo1 Hi1 ->
  typ_has_tdec G T2 L Lo2 Hi2 ->
  typ_has_tdec G (typ_and T1 T2) L (union_typ Lo1 Lo2) (intersect_typ Hi1 Hi2).
Proof.
  introv T1Has T2Has. unfold typ_has_tdec in *.
  destruct T1Has as [min1 T1Has].
  destruct T2Has as [min2 T2Has].
  exists (S (max min1 min2)). intros. destruct fuel as [|fuel]; [omega | idtac].
  specialize (T1Has fuel).
  specialize (T2Has fuel).

    repeat match goal with
    | Impl: ?Cond -> _ |- _ =>
        let HC := fresh in
        assert (HC: Cond) by (
          let M1 := fresh in let M2 := fresh in
          destruct (Max.max_spec min1 min2) as [[M1 M2] | [M1 M2]];
          omega
        );
        specialize (Impl HC);
        clear HC
    end.

  unfold lookup_tdec. fold lookup_tdec. rewrite T1Has, T2Has. reflexivity.
Qed.

Lemma typ_or_has_tdec: forall G L T1 Lo1 Hi1 T2 Lo2 Hi2,
  typ_has_tdec G T1 L Lo1 Hi1 ->
  typ_has_tdec G T2 L Lo2 Hi2 ->
  typ_has_tdec G (typ_or T1 T2) L (intersect_typ Lo1 Lo2) (union_typ Hi1 Hi2).
Proof.
  introv T1Has T2Has. unfold typ_has_tdec in *.
  destruct T1Has as [min1 T1Has].
  destruct T2Has as [min2 T2Has].
  exists (S (max min1 min2)). intros. destruct fuel as [|fuel]; [omega | idtac].
  specialize (T1Has fuel).
  specialize (T2Has fuel).

    repeat match goal with
    | Impl: ?Cond -> _ |- _ =>
        let HC := fresh in
        assert (HC: Cond) by (
          let M1 := fresh in let M2 := fresh in
          destruct (Max.max_spec min1 min2) as [[M1 M2] | [M1 M2]];
          omega
        );
        specialize (Impl HC);
        clear HC
    end.

  unfold lookup_tdec. fold lookup_tdec. rewrite T1Has, T2Has. reflexivity.
Qed.

Hint Resolve typ_and_has_tdec typ_or_has_tdec.

(* ###################################################################### *)
(** ** Weakening *)

Lemma weaken_subtyp_end: forall G1 G2 S U,
  ok (G1 & G2) ->
  subtyp G1        S U ->
  subtyp (G1 & G2) S U.
Admitted.

(* ###################################################################### *)
(** ** typ_has_tdec total and unique *)

(* The problem of "total typ_has" now becomes "lookup_tdec converges": *)
Lemma typ_has_tdec_total: forall G T L,
  exists Lo Hi, typ_has_tdec G T L Lo Hi.
Admitted. (* BIG TODO *)

Lemma typ_has_tdec_unique: forall G T L Lo1 Hi1 Lo2 Hi2,
  typ_has_tdec G T L Lo1 Hi1 ->
  typ_has_tdec G T L Lo2 Hi2 ->
  Lo1 = Lo2 /\ Hi1 = Hi2.
Proof.
  introv Has1 Has2. unfold typ_has_tdec in *.
  destruct Has1 as [min1 Has1].
  destruct Has2 as [min2 Has2].
  specialize (Has1 (S (max min1 min2))).
  specialize (Has2 (S (max min1 min2))).

    repeat match goal with
    | Impl: ?Cond -> _ |- _ =>
        let HC := fresh in
        assert (HC: Cond) by (
          let M1 := fresh in let M2 := fresh in
          destruct (Max.max_spec min1 min2) as [[M1 M2] | [M1 M2]];
          omega
        );
        specialize (Impl HC);
        clear HC
    end.

  rewrite Has1 in Has2. inversions Has2. auto.
Qed.

(*
Lemma more_fuel_increases_precision: forall G T L fuel2 Lo2 Hi2 fuel1 Lo1 Hi1,
  fuel2 <= fuel1 ->
  lookup_tdec fuel2 G T L = (Lo2, Hi2) ->
  lookup_tdec fuel1 G T L = (Lo1, Hi1) ->
  subtyp G Lo2 Lo1 /\ subtyp G Hi1 Hi2.
Admitted.
*)

(* ###################################################################### *)
(** ** Inversion lemmas for typ_has_tdec *)

Lemma invert_typ_or_has_tdec: forall G T1 T2 L Lo Hi,
  typ_has_tdec G (typ_or T1 T2) L Lo Hi ->
  exists Lo1 Hi1 Lo2 Hi2,
    typ_has_tdec G T1 L Lo1 Hi1 /\
    typ_has_tdec G T2 L Lo2 Hi2 /\
    Lo = intersect_typ Lo1 Lo2 /\
    Hi = union_typ Hi1 Hi2.
Proof.
  introv T12Has.
  destruct (typ_has_tdec_total G T1 L) as [Lo1 [Hi1 T1Has]].
  destruct (typ_has_tdec_total G T2 L) as [Lo2 [Hi2 T2Has]].
  exists Lo1 Hi1 Lo2 Hi2.
  apply (conj T1Has). apply (conj T2Has).

  unfold typ_has_tdec, lookup_tdec in T12Has, T1Has, T2Has.
  destruct T12Has as [min12 T12Has].
  destruct T1Has as [min1 T1Has].
  destruct T2Has as [min2 T2Has].
  specialize (T12Has (S (max min12 (max min1 min2)))).
  specialize (T1Has     (max min12 (max min1 min2)) ).
  specialize (T2Has     (max min12 (max min1 min2)) ).

    repeat match goal with
    | Impl: ?Cond -> _ |- _ =>
        let HC := fresh in
        assert (HC: Cond) by (
          let M1 := fresh in let M2 := fresh in
          destruct (Max.max_spec min1 min2) as [[M1 M2] | [M1 M2]];
          let M3 := fresh in let M4 := fresh in
          destruct (Max.max_spec min12 (max min1 min2)) as [[M3 M4] | [M3 M4]];
          omega
        );
        specialize (Impl HC);
        clear HC
    end.

  simpl in T12Has. fold lookup_tdec in *.
  rewrite T1Has, T2Has in T12Has. inversions T12Has.
  auto.
Qed.

(* ###################################################################### *)
(** ** subtyp-and-then-lookup_tdec to lookup_tdec-and-then-subdec *)

Lemma swap_sub_and_typ_has_tdec: forall G T1 T2 L Lo2 Hi2,
  subtyp G T1 T2 ->
  typ_has_tdec G T2 L Lo2 Hi2 ->
  exists Lo1 Hi1,
    typ_has_tdec G T1 L Lo1 Hi1 /\
    subtyp G Lo2 Lo1 /\
    subtyp G Hi1 Hi2.
Proof.
  introv St. gen L Lo2 Hi2. induction St; introv T2Has.
  + (* case subtyp_refl *)
    do 2 eexists. apply (conj T2Has). auto.
  + (* case subtyp_top *)
    rename T into T1. (* T2 = typ_top *)
    lets T1Has: (typ_has_tdec_total G T1 L). destruct T1Has as [Lo1 [Hi1 T1Has]].
                (******************)
    exists Lo1 Hi1.
    unfold typ_has_tdec in T2Has; unfold lookup_tdec in T2Has.
    destruct T2Has as [min2 T2Has]. specialize (T2Has (S min2) (Le.le_n_Sn min2)).
    simpl in T2Has. inversions T2Has. auto.
  + (* case subtyp_bot *)
    exists typ_top typ_bot. repeat split; auto.
    unfold typ_has_tdec. exists 1. intros. destruct fuel as [|fuel]; [omega | idtac].
    reflexivity.
  + (* case subtyp_tdec *)
    unfold typ_has_tdec in T2Has; unfold lookup_tdec in T2Has.
    destruct T2Has as [min2 T2Has]. specialize (T2Has (S min2) (Le.le_n_Sn min2)).
    simpl in T2Has.
    case_if.
    - inversions T2Has. exists T1 U1.
      repeat split; auto. unfold typ_has_tdec; unfold lookup_tdec.
      exists 1. intros. destruct fuel as [|fuel]; [omega | idtac].
      case_if. reflexivity.
    - inversions T2Has. exists typ_bot typ_top.
      repeat split; auto. unfold typ_has_tdec; unfold lookup_tdec.
      exists 1. intros. destruct fuel as [|fuel]; [omega | idtac].
      case_if. reflexivity.
  + (* case subtyp_mdec *)
    unfold typ_has_tdec in T2Has; unfold lookup_tdec in T2Has.
    destruct T2Has as [min2 T2Has]. specialize (T2Has (S min2) (Le.le_n_Sn min2)).
    simpl in T2Has. inversions T2Has.
    exists typ_bot typ_top. repeat split; auto.
    unfold typ_has_tdec; unfold lookup_tdec.
    exists 1. intros. destruct fuel as [|fuel]; [omega | idtac].
    reflexivity.
  + (* case subtyp_sel_l *)
    rename H into Bi, H0 into XHas.
    exists Lo2 Hi2. repeat split; auto.
    unfold typ_has_tdec, lookup_tdec in XHas. destruct XHas as [minX XHas].
    unfold typ_has_tdec, lookup_tdec in T2Has. destruct T2Has as [min2 T2Has].

    unfold typ_has_tdec, lookup_tdec.
    exists (S (S (max minX min2))). intros. destruct fuel as [|fuel]; [omega | idtac].
    rewrite Bi.
    destruct fuel as [|fuel]; [omega | idtac]. fold lookup_tdec.

    specialize (XHas (S fuel)).
    specialize (T2Has (S fuel)).

    repeat match goal with
    | Impl: ?Cond -> _ |- _ =>
        let HC := fresh in
        assert (HC: Cond) by (
          let M1 := fresh in let M2 := fresh in
          destruct (Max.max_spec minX min2) as [[M1 M2] | [M1 M2]];
          omega
        );
        specialize (Impl HC);
        clear HC
    end.

    simpl in *. fold lookup_tdec in *.
    rewrite XHas. exact T2Has.
  + (* case subtyp_sel_r *)
    rename H into Bi, H0 into XHas.
    apply IHSt. clear IHSt.

    unfold typ_has_tdec in XHas. destruct XHas as [minX XHas].
    unfold typ_has_tdec in T2Has; unfold lookup_tdec in T2Has.
    destruct T2Has as [min2 T2Has].

    unfold typ_has_tdec. exists (S (max minX min2)).
    intros.
    specialize (T2Has (S fuel)).
    specialize (XHas fuel).

    repeat match goal with
    | Impl: ?Cond -> _ |- _ =>
        let HC := fresh in
        assert (HC: Cond) by (
          let M1 := fresh in let M2 := fresh in
          destruct (Max.max_spec minX min2) as [[M1 M2] | [M1 M2]];
          omega
        );
        specialize (Impl HC);
        clear HC
    end.

    simpl in T2Has. rewrite Bi in T2Has. simpl in T2Has. fold lookup_tdec in T2Has.
    rewrite XHas in T2Has. exact T2Has.
  + (* case subtyp_and *)
    destruct (typ_has_tdec_total G U1 L) as [LoU1 [HiU1 U1Has]].
    destruct (typ_has_tdec_total G U2 L) as [LoU2 [HiU2 U2Has]].
    specialize (IHSt1 _ _ _ U1Has). destruct IHSt1 as [Lo1 [Hi1 [THas [StLoU1 StHiU1]]]].
    specialize (IHSt2 _ _ _ U2Has). destruct IHSt2 as [Lo1' [Hi1' [THas' [StLoU2 StHiU2]]]].
    destruct (typ_has_tdec_unique THas THas') as [Eq1 Eq2]. subst Lo1' Hi1'. clear THas'.
    unfold typ_has_tdec in U1Has, U2Has.
    destruct U1Has as [minU1 U1Has].
    destruct U2Has as [minU2 U2Has].

    unfold typ_has_tdec, lookup_tdec in T2Has. destruct T2Has as [min2 T2Has].
    specialize (T2Has (S (max min2 (max minU1 minU2)))).
    specialize (U1Has    (max min2 (max minU1 minU2)) ).
    specialize (U2Has    (max min2 (max minU1 minU2)) ).

    repeat match goal with
    | Impl: ?Cond -> _ |- _ =>
        let HC := fresh in
        assert (HC: Cond) by (
          let M1 := fresh in let M2 := fresh in
          destruct (Max.max_spec minU1 minU2) as [[M1 M2] | [M1 M2]];
          let M3 := fresh in let M4 := fresh in
          destruct (Max.max_spec min2 (max minU1 minU2)) as [[M3 M4] | [M3 M4]];
          omega
        );
        specialize (Impl HC);
        clear HC
    end.

    simpl in T2Has. fold lookup_tdec in T2Has.
    rewrite U1Has in T2Has. rewrite U2Has in T2Has.
    inversions T2Has.
    exists Lo1 Hi1. apply (conj THas).
    auto.
  + (* case subtyp_and_l *)
    rename Lo2 into Lo1, Hi2 into Hi1, T2Has into T1Has.
    destruct (typ_has_tdec_total G T2 L) as [Lo2 [Hi2 T2Has]].
    exists (union_typ Lo1 Lo2) (intersect_typ Hi1 Hi2).
    auto.
  + (* case subtyp_and_r *)
    destruct (typ_has_tdec_total G T1 L) as [Lo1 [Hi1 T1Has]].
    exists (union_typ Lo1 Lo2) (intersect_typ Hi1 Hi2).
    auto.
  + (* case subtyp_or *)
    rename T2Has into UHas.
    specialize (IHSt1 _ _ _ UHas). destruct IHSt1 as [LoT1 [HiT1 [T1Has [StLoT1 StHiT1]]]].
    specialize (IHSt2 _ _ _ UHas). destruct IHSt2 as [LoT2 [HiT2 [T2Has [StLoT2 StHiT2]]]].
    exists (intersect_typ LoT1 LoT2) (union_typ HiT1 HiT2).
    auto.
  + (* case subtyp_or_l *)
    rename T2Has into T12Has, Lo2 into Lo, Hi2 into Hi.
    apply invert_typ_or_has_tdec in T12Has.
    destruct T12Has as [Lo1 [Hi1 [Lo2 [Hi2 [T1Has [T2Has [Eq1 Eq2]]]]]]]. subst.
    exists Lo1 Hi1. auto.
  + (* case subtyp_or_r *)
    rename T2Has into T12Has, Lo2 into Lo, Hi2 into Hi.
    apply invert_typ_or_has_tdec in T12Has.
    destruct T12Has as [Lo1 [Hi1 [Lo2 [Hi2 [T1Has [T2Has [Eq1 Eq2]]]]]]]. subst.
    exists Lo2 Hi2. auto.
  + (* case subtyp_trans *)
    rename Lo2 into Lo3, Hi2 into Hi3, T2Has into T3Has.
    specialize (IHSt2 _ _ _ T3Has).
    destruct IHSt2 as [Lo2 [Hi2 [T2Has [StLo23 StHi23]]]].
    specialize (IHSt1 _ _ _ T2Has).
    destruct IHSt1 as [Lo1 [Hi1 [T1Has [StLo12 StHi12]]]].
    exists Lo1 Hi1. apply (conj T1Has). split.
    - apply (subtyp_trans StLo23 StLo12).
    - apply (subtyp_trans StHi12 StHi23).
Qed.

Print Assumptions swap_sub_and_typ_has_tdec. (* typ_has_tdec_total!! *)

(* ###################################################################### *)
(** ** Helpers *)

Lemma inc_fuel: forall fuel G T L Lo2 Hi2,
  lookup_tdec fuel G T L = (Lo2, Hi2) ->
  exists Lo1 Hi1,
    lookup_tdec (S fuel) G T L = (Lo1, Hi1) /\
    subtyp G Lo2 Lo1 /\
    subtyp G Hi1 Hi2.
Proof.
  intro fuel. induction fuel; introv Eq2.
  + unfold lookup_tdec in Eq2. inversions Eq2.
    remember (lookup_tdec 1 G T L) as p eqn: Eq1. destruct p as [Lo1 Hi1].
    exists Lo1 Hi1. auto.
  + unfold lookup_tdec in Eq2. fold lookup_tdec in Eq2. destruct T.
    - (* case typ_top   *) eauto.
    - (* case typ_bot   *) eauto.
    - (* case typ_tdec  *) eauto.
    - (* case typ_mdec  *) eauto.
    - (* case typ_sel   *)
      rename t into L0.
      destruct a; eauto. destruct (get v G) as [X|].
      * remember (lookup_tdec fuel G X L0) as p eqn: Eq1. destruct p as [Lo1 Hi1].
        symmetry in Eq1.
        destruct (IHfuel _ _ _ _ _ Eq1) as [Lo1' [Hi1' [Eq1' [StLo1 StHi1]]]].
        (* Now we want to say that if we replace Hi1 by Hi1' in Eq2, we get more
           precise Lo2'/Hi2'. But if StHi1 is a subtyping judgment with many path types,
           we waste fuel, so [lookup_tdec fuel G Hi1' L = (Lo2', Hi2') and Lo2 <: Lo2',
           Hi2' <: Hi2 does not hold as such.
           Problem: The subtyping in the conclusion of inc_fuel is too complicated, the
           precision gain that we get by increasing the fuel is never a subtyping over
           path types, but only over typ_and/typ_or or typ_bot/typ_top. *)
        admit.
      * inversions Eq2.
        remember (lookup_tdec (S (S fuel)) G (typ_sel (avar_f v) L0) L) as p eqn: Eq1.
        destruct p as [Lo1 Hi1]. eauto.
    - (* case typ_and   *) eauto.
    - (* case typ_or    *) eauto.

  remember (lookup_tdec (S fuel) G T L) as p eqn: Eq1. destruct p as [Lo1 Hi1].
  exists Lo1 Hi1. apply (conj eq_refl).
  symmetry in Eq1.
  unfold lookup_tdec in Eq1. fold lookup_tdec in Eq1.
Qed.

(* ###################################################################### *)
(** ** Narrowing *)

Lemma narrow_binds: forall G1 x0 S1 S2 G2 x T2,
  binds x T2 (G1 & x0 ~ S2 & G2) ->
  subtyp (G1 & x0 ~ S1) S1 S2 ->
  exists T1,
    binds x T1 (G1 & x0 ~ S1 & G2) /\
    subtyp (G1 & x0 ~ S1 & G2) T1 T2.
Proof.
  introv Bi StS.
  apply binds_middle_inv in Bi.
  destruct Bi as [Bi | [[xG2 [Eq1 Eq2]]|[xG2 [Ne Bi]]]].
  - (* case x in G2 *)
    apply (binds_concat_right (G1 & x0 ~ S1)) in Bi.
    exists T2. auto.
  - (* case x = x0 *)
    subst x0 T2. exists S1.
    assert (Ok1: ok (G1 & x ~ S1 & G2)) by admit.
    apply (conj (binds_middle_eq _ _ xG2)).
    apply (weaken_subtyp_end Ok1 StS).
  - (* case x in G1 *)
    exists T2. refine (conj _ (subtyp_refl _ _)).
    assert (xx0: x # (x0 ~ S1)) by auto.
    apply (binds_concat_left (binds_concat_left Bi xx0) xG2).
Qed.

(* Says "for all fuel amounts, exists Lo Hi", but we need
   "exists Lo Hi st. for all fuel amounts"!
Lemma narrow_lookup_tdec: forall fuel2 G1 x S1 S2 G2 T L Lo2 Hi2,
  lookup_tdec fuel2 (G1 & x ~ S2 & G2) T L = (Lo2, Hi2) ->
  subtyp (G1 & x ~ S1) S1 S2 ->
  exists fuel1 Lo1 Hi1,
    lookup_tdec fuel1 (G1 & x ~ S1 & G2) T L = (Lo1, Hi1) /\
    subtyp (G1 & x ~ S1 & G2) Lo2 Lo1 /\
    subtyp (G1 & x ~ S1 & G2) Hi1 Hi2.
Proof.
Admitted.*)

Lemma narrow_typ_has_tdec: forall G1 x S1 S2 G2 T L Lo2 Hi2,
  typ_has_tdec (G1 & x ~ S2 & G2) T L Lo2 Hi2 ->
  subtyp (G1 & x ~ S1) S1 S2 ->
  exists Lo1 Hi1,
    typ_has_tdec (G1 & x ~ S1 & G2) T L Lo1 Hi1 /\
    subtyp (G1 & x ~ S1 & G2) Lo2 Lo1 /\
    subtyp (G1 & x ~ S1 & G2) Hi1 Hi2.
(*
Proof.
  introv THas2 StS. unfold typ_has_tdec in THas2. destruct THas2 as [minF THas2].
  gen StS. gen THas2. gen G1 x S1 S2 G2 T L Lo2 Hi2. induction minF; introv THas2 StS.
  - specialize (THas2 0 (Le.le_refl _)). unfold lookup_tdec in THas2. inversions THas2.
    lets THas1: (typ_has_tdec_total (G1 & x ~ S1 & G2) T L).
                (******************)
    destruct THas1 as [Lo1 [Hi1 THas1]].
    exists Lo1 Hi1. apply (conj THas1). auto.
  -
*)
Proof.
  introv THas2 StS. unfold typ_has_tdec in THas2. destruct THas2 as [minF THas2].
  induction minF.
  - specialize (THas2 0 (Le.le_refl _)). unfold lookup_tdec in THas2. inversions THas2.
    lets THas1: (typ_has_tdec_total (G1 & x ~ S1 & G2) T L).
                (******************)
    destruct THas1 as [Lo1 [Hi1 THas1]].
    exists Lo1 Hi1. apply (conj THas1). auto.
  - apply IHminF. intros. destruct (classicT (minF = fuel)) as [Eq | Ne].
    * admit. (*???*)
    * assert (C: S minF <= fuel) by omega. apply (THas2 _ C).
Qed.

Lemma narrow_subtyp: forall G T1 T2, subtyp G T1 T2 ->
  forall G1 x S1 S2 G2,
    G = G1 & x ~ S2 & G2 ->
    subtyp (G1 & x ~ S1) S1 S2 ->
    subtyp (G1 & x ~ S1 & G2) T1 T2.
Proof.
  introv St. induction St; introv Eq StS; subst.
  + (* case subtyp_refl *) eauto.
  + (* case subtyp_top *) eauto.
  + (* case subtyp_bot *) eauto.
  + (* case subtyp_tdec *) eauto.
  + (* case subtyp_mdec *) eauto.
  + (* case subtyp_sel_l *)
    rename H into Bi2, H0 into X2Has2, X into X2.
    specialize (IHSt _ _ _ _ _ eq_refl StS).
    assert (Ok2: ok (G1 & x0 ~ S2 & G2)) by admit.
    assert (Ok1: ok (G1 & x0 ~ S1 & G2)) by admit.
    lets P: (narrow_binds Bi2 StS). destruct P as [X1 [Bi1 StX]].
    destruct (narrow_typ_has_tdec X2Has2 StS) as [T' [U' [X2Has1 [StT StU]]]].
    lets P: (swap_sub_and_typ_has_tdec StX X2Has1).
    destruct P as [T'' [U'' [X1Has [StT' StU']]]].
    assert (St': subtyp (G1 & x0 ~ S1 & G2) T'' U'') by admit. (* <--- !!! Will have
        to add good-bounds hyp to env, but do we always have this?? *)
    refine (subtyp_trans _ StU).
    refine (subtyp_trans _ StU').
    apply (subtyp_sel_l Bi1 X1Has St').
  + (* case subtyp_sel_r *)
    rename H into Bi2, H0 into X2Has2, X into X2.
    specialize (IHSt _ _ _ _ _ eq_refl StS).
    assert (Ok2: ok (G1 & x0 ~ S2 & G2)) by admit.
    assert (Ok1: ok (G1 & x0 ~ S1 & G2)) by admit.
    lets P: (narrow_binds Bi2 StS). destruct P as [X1 [Bi1 StX]].
    destruct (narrow_typ_has_tdec X2Has2 StS) as [T' [U' [X2Has1 [StT StU]]]].
    lets P: (swap_sub_and_typ_has_tdec StX X2Has1).
    destruct P as [T'' [U'' [X1Has [StT' StU']]]].
    assert (St': subtyp (G1 & x0 ~ S1 & G2) T'' U'') by admit. (* <--- !!! Will have
        to add good-bounds hyp to env, but do we always have this?? *)
    refine (subtyp_trans StT _).
    refine (subtyp_trans StT' _).
    apply (subtyp_sel_r Bi1 X1Has St').
  + (* case subtyp_and *) eauto.
  + (* case subtyp_and_l *) eauto.
  + (* case subtyp_and_r *) eauto.
  + (* case subtyp_or *) eauto.
  + (* case subtyp_or_l *) eauto.
  + (* case subtyp_or_r *) eauto.
  + (* case subtyp_trans *)
    apply subtyp_trans with T2; eauto.
Qed.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.
Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.SeparationLogic.Semantics.StrongSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Class SepconSemantics
      (L: Language)
      {sepconL: SepconLanguage L}
      (MD: Model)
      {kMD: KripkeModel MD}
      (M: Kmodel)
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      (SM: Semantics L MD): Type :=
  denote_sepcon: forall x y, Same_set _ (Kdenotation M (x * y)) (WeakSemantics.sepcon (Kdenotation M x) (Kdenotation M y)).

Class WandSemantics
      (L: Language)
      {wandL: WandLanguage L}
      (MD: Model)
      {kMD: KripkeModel MD}
      (M: Kmodel)
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      (SM: Semantics L MD): Type :=
  denote_wand: forall x y, Same_set _ (Kdenotation M (x -* y)) (WeakSemantics.wand (Kdenotation M x) (Kdenotation M y)).

Class EmpSemantics
      (L: Language)
      {empL: EmpLanguage L}
      (MD: Model)
      {kMD: KripkeModel MD}
      (M: Kmodel)
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      (SM: Semantics L MD): Type :=
  denote_emp: Same_set _ (Kdenotation M emp) WeakSemantics.emp.

Lemma sat_sepcon
      {L: Language}
      {sepconL: SepconLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {fsepconSM: SepconSemantics L MD M SM}:
  forall m x y,
    KRIPKE: M , m |= x * y <->
    exists m1 m2, join m1 m2 m /\
                  KRIPKE: M , m1 |= x /\
                  KRIPKE: M, m2 |= y.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_sepcon x y).
  split; [apply H | apply H0].
Qed.

Lemma sat_wand
      {L: Language}
      {wandL: WandLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {fwandSM: WandSemantics L MD M SM}:
  forall m x y,
    KRIPKE: M , m |= x -* y <->
    forall m1 m2, join m m1 m2 ->
                  KRIPKE: M , m1 |= x ->
                  KRIPKE: M, m2 |= y.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_wand x y).
  split; [apply H | apply H0].
Qed.

Lemma sat_emp
      {L: Language}
      {empL: EmpLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {fempSM: EmpSemantics L MD M SM}:
  forall (m: Kworlds M), KRIPKE: M, m |= emp <-> increasing m.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct denote_emp.
  split; [apply H | apply H0].
Qed.


Set Implicit Arguments.

Require Import util.
Require Import Le.
Require Import Plus.
Require Import Lt.
Require Import Arith.
Require Import monoid_expec.
Require Import List.
Require Import monads.
Require Import list_utils.
Require Import Coq.Program.Wf.
Require Import monoid_monad_trans.
Require Import nat_seqs.
Require Import monoid_tree_monad.
Require qs_definitions.
Require fix_measure_utils.
Require Import nat_below.
Require Coq.Vectors.Vector.

Import qs_definitions.mon_nondet.

Set Shrink Obligations.

Section contents.

  Variable M: Monad.

  Variables (X: Set) (pick: forall T: Set, ne_list.L T -> M T) (cmp: X -> X -> M comparison).

  Definition lowRecPart n (t: Vector.t X (S n)) (i: natBelow (S n)) (part: {p: Partitioning X |
          Permutation.Permutation (p Eq ++ p Lt ++ p Gt) (vec.remove t i)}) :=
    low <- qs cmp pick (proj1_sig part Lt);
    upp <- qs cmp pick (proj1_sig part Gt);
    ret (low ++ vec.nth t i :: proj1_sig part Eq ++ upp).

  Definition partitionPart n (t: Vector.t X (S n)) (i: natBelow (S n))
    := partition M cmp (vec.nth t i) (vec.remove t i) >>= lowRecPart t i.

  Definition selectPivotPart n (t: Vector.t X (S n)) := pick (ne_list.from_vec (vec.nats 0 (S n))) >>= partitionPart t.

  Lemma selectPivotPart_eq n m (t: Vector.t X (S n)) (t': Vector.t X (S m)): vec.to_list t = vec.to_list t' ->
    selectPivotPart t = selectPivotPart t'.
  Proof with auto.
    intros.
    pose proof (vec.length t).
    rewrite H in H0.
    rewrite vec.length in H0.
    inversion H0.
    subst. clear H0.
    rewrite (vec.eq_as_lists t t')...
  Qed.

  Definition body n (v: Vector.t X n) :=
    match v with
    | Vector.nil => ret nil
    | l => selectPivotPart l
    end.

  Definition raw_body (l0: list X) (qs: {l': list X | length l' < length l0} -> M (list X)) :=
    match l0 as l1 return (l1 = l0 -> M (list X)) with
    | nil => fun _ => ret nil
    | h :: t => fun e =>
      i <- pick (ne_list.from_vec (vec.nats 0 (length (h :: t))));
      part <- partition M cmp (vec.nth (h :: t) i) (vec.remove (h :: t) i);
      low <- qs (exist (fun l': list X => length l' < length l0) (proj1_sig part Lt) (qs_definitions.mon_nondet.qs_obligation_1 M (fun l H => qs (exist _ l H)) e i part));
      upp <- qs (exist (fun l': list X => length l' < length l0) (proj1_sig part Gt) (qs_definitions.mon_nondet.qs_obligation_2 M (fun l H => qs (exist _ l H)) e i part));
      ret (low ++ vec.nth (h :: t) i :: proj1_sig part Eq ++ upp)
    end refl_equal.

  Variable e: extMonad M.

  Definition raw_body_ext (l: list X) (qs qs': {l': list X | length l' < length l} -> M (list X)):
    (forall x y, proj1_sig x = proj1_sig y -> qs x = qs' y) -> raw_body l qs = raw_body l qs'.
  Proof with auto.
    unfold raw_body.
    intros.
    destruct l...
    apply e. intro.
    apply e. intro.
    apply bind_eqq...
    intro.
    apply bind_eqq...
    intro...
  Qed.

  Lemma bodies x0:
    raw_body x0 (fun y: {y: list X | length y < length x0} => qs (M:=M) cmp pick (proj1_sig y)) = body x0.
  Proof.
    intros.
    unfold raw_body, body, selectPivotPart, partitionPart, lowRecPart.
    destruct x0; reflexivity.
  Qed.

  Lemma toBody (l: list X): qs cmp pick l = body l.
  Proof with auto.
    unfold qs.
    fold raw_body.
    rewrite fix_measure_utils.unfold.
      rewrite <- bodies.
      unfold qs. fold raw_body...
    intros.
    apply raw_body_ext.
    intros.
    destruct x. destruct y.
    simpl in H0.
    subst...
  Qed.

  Lemma toBody_cons (n: nat) (v: Vector.t X (S n)): body v = selectPivotPart v.
    intros.
    rewrite (vec.eq_cons v).
    simpl.
    reflexivity.
  Qed.

  Lemma rect (Q: list X -> M (list X) -> Type):
    (Q nil (ret nil)) ->
    (forall n (v: Vector.t X (S n)), (forall y, length y < S n -> Q y (qs cmp pick y)) -> Q v (selectPivotPart v)) ->
      forall x, Q x (qs cmp pick x).
  Proof with auto.
    intros.
    unfold qs.
    match goal with
      |- context C [Fix_sub ?A ?R ?P ?p ?f ?x] =>
        let folded := context C [ Fix_sub A R P p raw_body x ] in
          change folded
    end.
    apply fix_measure_utils.rect.
      intros.
      apply raw_body_ext.
      intros.
      destruct x1. destruct y.
      simpl in H0.
      subst...
    intros.
    erewrite raw_body_ext.
      rewrite bodies.
      unfold body.
      destruct x0...
      simpl.
      rewrite <- (vec.list_round_trip (x0 :: x1)).
      apply X1.
      intros.
      unfold qs. fold raw_body...
    intros.
    unfold qs. fold raw_body.
    f_equal; assumption.
  Qed.

  Lemma rect_using_lists (Q: list X -> M (list X) -> Type):
    (Q nil (ret nil)) ->
    (forall h t, (forall y, length y <= length t -> Q y (qs cmp pick y)) -> Q (h::t) (selectPivotPart (h::t))) ->
      forall x, Q x (qs cmp pick x).
  Proof with auto with arith.
    intros.
    apply rect...
    intros.
    simpl in X1.
    rewrite (vec.eq_cons v).
    simpl.
    assert (forall y : list X, length y <= length (vec.to_list (vec.tail v)) -> Q y (qs cmp pick y)).
      intros.
      apply X2.
      rewrite vec.length in H...
    pose proof (X1 (vec.head v) (vec.tail v) X3).
    pose proof (selectPivotPart_eq (Vector.cons (vec.head v) (vec.from_list (vec.to_list (vec.tail v)))) (Vector.cons (vec.head v) (vec.tail v))).
    rewrite <- H...
    simpl.
    rewrite vec.list_round_trip...
  Qed.

End contents.


From Hammer Require Import Tactics Reflect Hints.
From Hammer Require Import Hammer.

From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat ssralg seq fintype tuple eqtype.

From Coq Require Import FunctionalExtensionality.
From Coq Require Import Relation_Definitions RelationClasses.

Require Import CoqArith.Utils.

Require Import Program.

Section Sigma_1_1_Skolem.

Definition SOctx := seq nat.
Definition FOctx := nat.

Inductive SkolemRingTerm {soctx : SOctx} {uni exi : FOctx} : Type :=
| SkolemRingUniVar : {m : nat | m < uni} -> SkolemRingTerm
| SkolemRingExiVar : {m : nat | m < exi} -> SkolemRingTerm
| SkolemRingFun : forall (i : {m : nat | m < length soctx}),
            ({m : nat | m < lnth soctx i} -> SkolemRingTerm) ->
            SkolemRingTerm
| SkolemRingMinusOne : SkolemRingTerm
| SkolemRingPlusOne : SkolemRingTerm
| SkolemRingZero : SkolemRingTerm
| SkolemRingPlus : SkolemRingTerm -> SkolemRingTerm -> SkolemRingTerm
| SkolemRingTimes : SkolemRingTerm -> SkolemRingTerm -> SkolemRingTerm
| SkolemRingInd : SkolemRingTerm -> SkolemRingTerm -> SkolemRingTerm.

Inductive SkolemPolyTerm {uni exi : FOctx} : Type :=
| SkolemPolyUniVar : {m : nat | m < uni} -> SkolemPolyTerm
| SkolemPolyExiVar : {m : nat | m < exi} -> SkolemPolyTerm
| SkolemPolyMinusOne : SkolemPolyTerm
| SkolemPolyPlusOne : SkolemPolyTerm
| SkolemPolyZero : SkolemPolyTerm
| SkolemPolyPlus : SkolemPolyTerm -> SkolemPolyTerm -> SkolemPolyTerm
| SkolemPolyTimes : SkolemPolyTerm -> SkolemPolyTerm -> SkolemPolyTerm.

Fixpoint SkolemPoly_SkolemRing {soctx : SOctx} {uni exi : FOctx}
  (r : @SkolemPolyTerm uni exi) : @SkolemRingTerm soctx uni exi :=
  match r with
  | SkolemPolyUniVar m => SkolemRingUniVar m
  | SkolemPolyExiVar m => SkolemRingExiVar m
  | SkolemPolyMinusOne => SkolemRingMinusOne
  | SkolemPolyPlusOne => SkolemRingPlusOne
  | SkolemPolyZero => SkolemRingZero
  | SkolemPolyPlus r1 r2 => SkolemRingPlus (SkolemPoly_SkolemRing r1) (SkolemPoly_SkolemRing r2)
  | SkolemPolyTimes r1 r2 => SkolemRingTimes (SkolemPoly_SkolemRing r1) (SkolemPoly_SkolemRing r2)
  end.

Inductive SkolemZerothOrderFormula {soctx : SOctx} {uni exi : FOctx} : Type :=
| SkolemZOTrue : SkolemZerothOrderFormula
| SkolemZOFalse : SkolemZerothOrderFormula
| SkolemZONot : SkolemZerothOrderFormula -> SkolemZerothOrderFormula
| SkolemZOAnd : SkolemZerothOrderFormula ->
                SkolemZerothOrderFormula ->
                SkolemZerothOrderFormula
| SkolemZOOr : SkolemZerothOrderFormula ->
               SkolemZerothOrderFormula ->
               SkolemZerothOrderFormula
| SkolemZOImp : SkolemZerothOrderFormula ->
                SkolemZerothOrderFormula ->
                SkolemZerothOrderFormula
| SkolemZOEq : @SkolemRingTerm soctx uni exi ->
               @SkolemRingTerm soctx uni exi ->
               SkolemZerothOrderFormula.

Inductive SkolemFirstOrderFormula {soctx : SOctx} {uni exi : FOctx} : Type :=
| SkolemZO : @SkolemZerothOrderFormula soctx uni exi -> SkolemFirstOrderFormula
| SkolemFOForall : @SkolemPolyTerm uni exi -> SkolemFirstOrderFormula (uni := uni.+1) -> SkolemFirstOrderFormula.

Inductive SkolemSecondOrderFormula {soctx : SOctx} {uni exi : FOctx} : Type :=
| SkolemFO : @SkolemFirstOrderFormula soctx uni exi -> SkolemSecondOrderFormula
| SkolemSOExists : forall (y : @SkolemPolyTerm uni exi) (bs : seq (@SkolemPolyTerm uni exi)),
                    SkolemSecondOrderFormula (soctx := length bs :: soctx) ->
                    SkolemSecondOrderFormula.

End Sigma_1_1_Skolem.

Section Sigma_1_1_Skolem_Denotation.

(*How to write this nicer?*)
Definition Rin_Denot_con (M : Sigma11Model)
  (v1 : seq (R M))
  (v2 : seq {y : (R M) &
            {bs : seq (R M) &
            (forall i : {m | m < length bs}, { r : R M | lt M r (lnth bs i) }) -> { r : R M | lt M r y }
            }}) :
  forall i : {m : nat | m < length [seq length (projT1 (projT2 i)) | i <- v2]},
  ({m : nat | m < lnth [seq length (projT1 (projT2 i0)) | i0 <- v2] i} -> option (R M))
  -> option (R M).
    move=> idx IH.
    rewrite map_lnth in IH.
    destruct (lnth _ _) as [y[bs f]]; simpl in IH.
    assert (forall i : {m : nat | m < length bs}, option {r : R M | lt M r (lnth bs i)}).
    * move=> i.
      apply (fun x => obind x (IH i)).
      intro r.
      destruct (lt_total M r (lnth bs i)).
      + apply Some; exists r; assumption.
      + exact None.
    clear IH.
    assert (forall i : {m : nat | m < length bs},
    option {r : R M | lt M r (nth 0%R bs (` i))}) as X'.
    move=>i.
    replace {r : R M | lt M r (nth 0%R bs (` i))}
       with {r : R M | lt M r (lnth bs i)}.
    apply X.
    f_equal.
    apply functional_extensionality=> x.
    f_equal.
    unfold lnth; rewrite (tnth_nth 0%R).
    by destruct i.
    clear X.
    apply (OptionArgs (B := fun x => {r : R M | lt M r (nth 0%R bs x)})) in X'.
    apply (fun x => obind x X'); clear X'.
    move=> x.
    assert (forall i : {m : nat | m < length bs}, {r : R M | lt M r (lnth bs i)}) as x'.
    move=> i.
    replace {r : R M | lt M r (lnth bs i)} with {r : R M | lt M r (nth 0%R bs (` i))}.
    apply x.
    f_equal; apply functional_extensionality=> x0; f_equal.
    unfold lnth; rewrite (tnth_nth 0%R); by destruct i. clear x.
    apply f in x'.
    exact (Some (` x')).
Defined.

(*Interpreting a ring term with free variables as a function from ring elems. and functions. *)
Program Fixpoint SkolemRing_Denote (M : Sigma11Model)
  (uv : seq (R M))
  (sf : seq ((length uv).-tuple (R M) -> R M))
  (v2 : seq {y : (R M) &
            {bs : seq (R M) &
            (forall i : {m | m < length bs}, { r : R M | lt M r (lnth bs i) }) -> { r : R M | lt M r y }
            }})
  (r : @SkolemRingTerm [seq length (projT1 (projT2 i)) | i <- v2] (length uv) (length sf)) :
  option (R M) :=
  match r with
  | SkolemRingUniVar m => Some (lnth uv m)
  | SkolemRingExiVar m => Some (lnth sf m (in_tuple uv))
  | SkolemRingFun i t => Rin_Denot_con M uv v2 i (fun x => SkolemRing_Denote M uv sf v2 (t x))
  | SkolemRingMinusOne => Some (-1)%R
  | SkolemRingPlusOne => Some 1%R
  | SkolemRingZero => Some 0%R
  | SkolemRingPlus r1 r2 =>
    (obind (fun r1 => obind (fun r2 => Some (r1 + r2)%R) (SkolemRing_Denote M uv sf v2 r2)) (SkolemRing_Denote M uv sf v2 r1))
  | SkolemRingTimes r1 r2 =>
    (obind (fun r1 => obind (fun r2 => Some (r1 * r2)%R) (SkolemRing_Denote M uv sf v2 r2)) (SkolemRing_Denote M uv sf v2 r1))
  | SkolemRingInd r1 r2 =>
    (obind (fun r1 => obind (fun r2 =>
      match lt_total M r1 r2 with
      | inl _ => Some 1%R
      | inr _ => Some 0%R
      end) (SkolemRing_Denote M uv sf v2 r2)) (SkolemRing_Denote M uv sf v2 r1))
  end.

Program Fixpoint Default_Extend {T} {n} {r} (d : T) (s : n.-tuple T) : (n + r).-tuple T :=
  match r with
  | 0 => s
  | r.+1 => cons_tuple d (Default_Extend (r := r) d s)
  end.
Next Obligation.
  hauto use: addn1, addSnnS inv: nat.
Qed.
Next Obligation.
  hauto use: addn1, addSnnS inv: nat.
Qed.

(*Interpreting a ring term with free variables as a function from ring elems. and functions. *)
Program Fixpoint SkolemPoly_Denote (M : Sigma11Model)
  (uv : seq (R M))
  {d} (sf : seq ((length uv + d).-tuple (R M) -> R M))
  (r : @SkolemPolyTerm (length uv) (length sf)) : R M :=
  match r with
  | SkolemPolyUniVar m => lnth uv m
  | SkolemPolyExiVar m => lnth sf m (Default_Extend 0%R (in_tuple uv))
  | SkolemPolyMinusOne => (-1)%R
  | SkolemPolyPlusOne => 1%R
  | SkolemPolyZero => 0%R
  | SkolemPolyPlus r1 r2 => SkolemPoly_Denote M uv sf r2 + SkolemPoly_Denote M uv sf r1
  | SkolemPolyTimes r1 r2 => SkolemPoly_Denote M uv sf r2 * SkolemPoly_Denote M uv sf r1
  end.

Fixpoint ZerothOrder_Denote (M : Sigma11Model)
  (v1 : seq (R M))
  (v2 : seq {y : (R M) &
            {bs : seq (R M) &
            (forall i : {m | m < length bs}, { r : R M | lt M r (lnth bs i) }) -> { r : R M | lt M r y }
            }})
  (f : @SkolemZerothOrderFormula [seq length (projT1 (projT2 i)) | i <- v2] (length v1)) : Prop :=
  match f with
  | SkolemZOTrue => true
  | SkolemZOFalse => false
  | SkolemZONot f => not (ZerothOrder_Denote M v1 v2 f)
  | SkolemZOAnd f1 f2 => (ZerothOrder_Denote M v1 v2 f1) /\ (ZerothOrder_Denote M v1 v2 f2)
  | SkolemZOOr f1 f2 => (ZerothOrder_Denote M v1 v2 f1) \/ (ZerothOrder_Denote M v1 v2 f2)
  | SkolemZOImp f1 f2 => (ZerothOrder_Denote M v1 v2 f1) -> (ZerothOrder_Denote M v1 v2 f2)
  | SkolemZOEq r1 r2 =>
    match SkolemRing_Denote M v1 v2 r1 with
    | None => false
    | Some r1 =>
      match SkolemRing_Denote M v1 v2 r2 with
      | None => false
      | Some r2 => r1 = r2
      end
    end
  end.

Fixpoint FirstOrder_Denote (M : Sigma11Model)
  (v1 : seq (R M))
  (v2 : seq {y : (R M) &
            {bs : seq (R M) &
            (forall i : {m | m < length bs}, { r : R M | lt M r (lnth bs i) }) -> { r : R M | lt M r y }
            }})
  (f : @SkolemFirstOrderFormula [seq length (projT1 (projT2 i)) | i <- v2] (length v1)) : Prop :=
  match f with
  | SkolemZO z => ZerothOrder_Denote M v1 v2 z
  | FOExists p f =>
    exists (r : R M),
      lt M r (SkolemPoly_Denote M v1 p) /\
      FirstOrder_Denote M (r :: v1) v2 f
  | FOForall p f =>
    forall (r : R M),
      lt M r (SkolemPoly_Denote M v1 p) ->
      FirstOrder_Denote M (r :: v1) v2 f
  end.

Fixpoint otraverse {T} (s : seq (option T)) : option (seq T) :=
  match s with
  | [::] => Some [::]
  | (x :: xs) =>
    obind (fun x => obind (fun xs => Some (x :: xs)) (otraverse xs)) x
  end.

(*Interpreting a ring term with free variables as a function from ring elems. and functions. *)
Program Fixpoint SecondOrder_Denote (M : Sigma11Model)
  (v1 : seq (R M))
  (v2 : seq {y : (R M) &
            {bs : seq (R M) &
            (forall i : {m | m < length bs}, { r : R M | lt M r (lnth bs i) }) -> { r : R M | lt M r y }
            }})
  (f : @SkolemSecondOrderFormula [seq length (projT1 (projT2 i)) | i <- v2] (length v1)) : Prop :=
  match f with
  | FO f => FirstOrder_Denote M v1 v2 f
  | SOExists y bs f =>
    let y' := SkolemPoly_Denote M v1 y in
    let bs' := [seq SkolemPoly_Denote M v1 i | i <- bs] in
    exists rf : (forall i : {m | m < length bs}, { r : R M | lt M r (lnth bs' i) })
              -> { r : R M | lt M r y' },
    SecondOrder_Denote M v1
    (existT _ y' (existT _ bs' rf) :: v2) f
  end.
Next Obligation.
  by rewrite map_length.
Qed.
Next Obligation.
  by rewrite map_length.
Qed.

End Sigma_1_1_Denotation.


Require Import List.
Require Import FMapFacts.
Require Import Omega.
Require Import ListUtils.
Require Import OrderedTypeEx.
Require Import MapUtils.
Require Import Mem.
Require Import Pred.
Require Import FunctionalExtensionality.

Module MapMem (OT : UsualOrderedType) (M : S with Module E := OT).

  Module Map := M.
  Module Defs := MapDefs OT.

  Section MapMemSec.

    Variable V : Type.
    Definition mem_type := @mem Map.key OT.eq_dec V.

    Definition mm (m : Map.t V) : mem_type := fun a => Map.find a m.

    Lemma find_add_eq : forall m a (v : V),
      Map.find a (Map.add a v m) = Some v.
    Proof.
      intros.
      erewrite M.find_1; eauto.
      apply M.add_1.
      reflexivity.
    Qed.

    Lemma find_add_ne : forall m a a' (v : V),
      a <> a' -> Map.find a (Map.add a' v m) = Map.find a m.
    Proof.
      intros.
      case_eq (Map.find a (Map.add a' v m)); intros.
      - apply M.find_2 in H0.
        eapply M.add_3 in H0; [| congruence ].
        erewrite M.find_1 with (e := v0); auto.
      - case_eq (Map.find a m); intros; eauto.
        eapply M.find_2 in H1.
        eapply M.add_2 with (x := a') (e' := v) in H1.
        eapply M.find_1 in H1; congruence.
        congruence.
    Qed.

    Lemma find_remove_eq : forall m a,
      @Map.find V a (Map.remove a m) = None.
    Proof.
      intros.
      case_eq (Map.find a (Map.remove a m)); eauto; intros.
      apply M.find_2 in H.
      exfalso.
      eapply M.remove_1; unfold M.In; try eauto.
      reflexivity.
    Qed.

    Lemma find_remove_ne : forall m a a',
      a <> a' -> @Map.find V a (Map.remove a' m) = Map.find a m.
    Proof.
      intros.
      case_eq (Map.find a (Map.remove a' m)); intros.
      - apply M.find_2 in H0.
        apply M.remove_3 in H0.
        erewrite M.find_1; eauto.
      - case_eq (Map.find a m); eauto; intros.
        eapply M.find_2 in H1.
        eapply M.remove_2 with (x := a') in H1.
        eapply M.find_1 in H1; congruence.
        congruence.
    Qed.

    Theorem mm_init :
      @emp _ OT.eq_dec _ (mm (Map.empty _)).
    Proof.
      unfold emp, mm; intros.
      case_eq (Map.find a (Map.empty V)); intros; auto.
      apply M.find_2 in H.
      exfalso.
      eapply M.empty_1; eauto.
    Qed.

    Theorem mm_add : forall m (F : @pred Map.key OT.eq_dec V) a v,
      Map.find a m = None ->
      F (mm m) ->
      (F * a |-> v)%pred (mm (Map.add a v m)).
    Proof.
      unfold_sep_star; intros; repeat deex.
      exists (mm m).
      unfold mm in *.
      exists (fun a' => if OT.eq_dec a' a then Some v else None).
      split; [|split].
      - apply functional_extensionality; intro.
        unfold mem_union; destruct (OT.eq_dec x a); unfold OT.eq in *; subst.
        rewrite find_add_eq; rewrite H; auto.
        rewrite find_add_ne by auto.
        destruct (Map.find x m); auto.
      - unfold mem_disjoint in *. intuition. repeat deex.
        destruct (OT.eq_dec a0 a); subst; intuition; pred.
      - intuition; eauto.
        unfold ptsto; intuition.
        destruct (OT.eq_dec a a); pred.
        destruct (OT.eq_dec a' a); pred.
    Qed.

    Theorem mm_replace : forall m (F : @pred Map.key OT.eq_dec V) a v0 v,
      (a |-> v0 * F)%pred (mm m) ->
      (a |-> v * F)%pred (mm (Map.add a v m)).
    Proof.
      unfold_sep_star; intros; repeat deex.
      exists (fun a' => if OT.eq_dec a' a then Some v else None).
      exists m2.
      unfold mm in *.
      split; [|split].
      - apply functional_extensionality; intro.
        unfold mem_union; destruct (OT.eq_dec x a); unfold OT.eq in *; subst; eauto.
        rewrite find_add_eq; eauto.
        rewrite find_add_ne by auto.
        destruct H1; repeat deex.
        apply equal_f with (x0 := x) in H0; rewrite H0.
        unfold mem_union. rewrite H2; auto.
      - unfold mem_disjoint in *. intuition. repeat deex.
        apply H.
        destruct H1; repeat deex.
        repeat eexists; eauto.
        destruct (OT.eq_dec a0 a); unfold OT.eq in *; subst; eauto.
        pred.
      - intuition eauto.
        unfold ptsto; intuition; unfold OT.eq in *.
        destruct (OT.eq_dec a a); pred.
        destruct (OT.eq_dec a' a); pred.
    Qed.

    Theorem mm_remove : forall m (F : @pred Map.key OT.eq_dec V) a v,
      (a |-> v * F)%pred (mm m) ->
      F (mm (Map.remove a m)).
    Proof.
      unfold_sep_star; unfold mm; intros; repeat deex.
      match goal with
      | [ |- F ?m ] => replace (m) with m2; eauto
      end.
      apply functional_extensionality; intro.
      destruct (OT.eq_dec x a); unfold OT.eq in *; subst.
      - rewrite find_remove_eq.
        unfold mem_disjoint in *.
        case_eq (m2 a); intros; try congruence.
        exfalso. apply H.
        exists a. exists v. exists v0.
        unfold ptsto in *; intuition.
      - rewrite find_remove_ne by auto.
        eapply equal_f in H0. rewrite H0.
        unfold mem_union.
        case_eq (m1 x); intros; try congruence.
        unfold ptsto in *; intuition.
        rewrite H5 in H2; eauto.
        congruence.
    Qed.

    Theorem mm_remove_none : forall m (F : @pred Map.key OT.eq_dec V) a,
      Map.find a m = None ->
      F (mm m) ->
      F (mm (Map.remove a m)).
    Proof.
      unfold mm; intros; repeat deex.
      match goal with
      | [ H: F ?m1 |- F ?m2 ] => replace m2 with m1; eauto; clear H
      end.
      apply functional_extensionality; intro.
      destruct (OT.eq_dec x a); unfold OT.eq in *; subst.
      - rewrite find_remove_eq; auto.
      - rewrite find_remove_ne by auto; auto.
    Qed.

    Theorem mm_find : forall m (F : @pred Map.key OT.eq_dec V) a v,
      (a |-> v * F)%pred (mm m) ->
      Map.find a m = Some v.
    Proof.
      unfold ptsto, mm; unfold_sep_star.
      intros; repeat deex.
      eapply equal_f in H0; rewrite H0.
      apply mem_union_addr; eauto.
    Qed.

    Theorem mm_add_upd: forall k v m,
    mm (Map.add k v m) = Mem.upd (mm m) k v.
    Proof.
      unfold Mem.upd, mm.
      intros.
      apply functional_extensionality. intros.
      destruct OT.eq_dec.
      erewrite M.find_1; [|apply M.add_1]; congruence.
      rewrite find_add_ne; congruence.
    Qed.

  End MapMemSec.

End MapMem.