(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(* $Id: FMapInterface.v 12640 2010-01-07 15:32:49Z letouzey $ *)

(** * Finite map library *)

(** This file proposes interfaces for finite maps *)

Require Export Bool DecidableType OrderedType.
Set Implicit Arguments.
Unset Strict Implicit.

(** When compared with Ocaml Map, this signature has been split in
    several parts :

   - The first parts [WSfun] and [WS] propose signatures for weak
     maps, which are maps with no ordering on the key type nor the
     data type.  [WSfun] and [WS] are almost identical, apart from the
     fact that [WSfun] is expressed in a functorial way whereas [WS]
     is self-contained. For obtaining an instance of such signatures,
     a decidable equality on keys in enough (see for example
     [FMapWeakList]). These signatures contain the usual operators
     (add, find, ...). The only function that asks for more is
     [equal], whose first argument should be a comparison on data.

   - Then comes [Sfun] and [S], that extend [WSfun] and [WS] to the
     case where the key type is ordered. The main novelty is that
     [elements] is required to produce sorted lists.

   - Finally, [Sord] extends [S] with a complete comparison function. For
     that, the data type should have a decidable total ordering as well.

   If unsure, what you're looking for is probably [S]: apart from [Sord],
   all other signatures are subsets of [S].

   Some additional differences with Ocaml:

    - no [iter] function, useless since Coq is purely functional
    - [option] types are used instead of [Not_found] exceptions
    - more functions are provided: [elements] and [cardinal] and [map2]

*)

Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true.

(** ** Weak signature for maps

    No requirements for an ordering on keys nor elements, only decidability
    of equality on keys. First, a functorial signature: *)

Module Type WSfun (E : DecidableType).

  Definition key := E.t.

  Parameter t : Type -> Type.
  (** the abstract type of maps *)

  Section Types.

    Variable elt:Type.

    Parameter empty : t elt.
    (** The empty map. *)

    Parameter is_empty : t elt -> bool.
    (** Test whether a map is empty or not. *)

    Parameter add : key -> elt -> t elt -> t elt.
    (** [add x y m] returns a map containing the same bindings as [m],
	plus a binding of [x] to [y]. If [x] was already bound in [m],
	its previous binding disappears. *)

    Parameter find : key -> t elt -> option elt.
    (** [find x m] returns the current binding of [x] in [m],
	or [None] if no such binding exists. *)

    Parameter remove : key -> t elt -> t elt.
    (** [remove x m] returns a map containing the same bindings as [m],
	except for [x] which is unbound in the returned map. *)

    Parameter mem : key -> t elt -> bool.
    (** [mem x m] returns [true] if [m] contains a binding for [x],
	and [false] otherwise. *)

    Variable elt' elt'' : Type.

    Parameter map : (elt -> elt') -> t elt -> t elt'.
    (** [map f m] returns a map with same domain as [m], where the associated
	value a of all bindings of [m] has been replaced by the result of the
	application of [f] to [a]. Since Coq is purely functional, the order
        in which the bindings are passed to [f] is irrelevant. *)

    Parameter mapi : (key -> elt -> elt') -> t elt -> t elt'.
    (** Same as [map], but the function receives as arguments both the
	key and the associated value for each binding of the map. *)

    Parameter map2 :
     (option elt -> option elt' -> option elt'') -> t elt -> t elt' ->  t elt''.
    (** [map2 f m m'] creates a new map whose bindings belong to the ones
        of either [m] or [m']. The presence and value for a key [k] is
        determined by [f e e'] where [e] and [e'] are the (optional) bindings
        of [k] in [m] and [m']. *)

    Parameter elements : t elt -> list (key*elt).
    (** [elements m] returns an assoc list corresponding to the bindings
        of [m], in any order. *)

    Parameter cardinal : t elt -> nat.
    (** [cardinal m] returns the number of bindings in [m]. *)

    Parameter fold : forall A: Type, (key -> elt -> A -> A) -> t elt -> A -> A.
    (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
	where [k1] ... [kN] are the keys of all bindings in [m]
	(in any order), and [d1] ... [dN] are the associated data. *)

    Parameter equal : (elt -> elt -> bool) -> t elt -> t elt -> bool.
    (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal,
      that is, contain equal keys and associate them with equal data.
      [cmp] is the equality predicate used to compare the data associated
      with the keys. *)

    Section Spec.

      Variable m m' m'' : t elt.
      Variable x y z : key.
      Variable e e' : elt.

      Parameter MapsTo : key -> elt -> t elt -> Prop.

      Definition In (k:key)(m: t elt) : Prop := exists e:elt, MapsTo k e m.

      Definition Empty m := forall (a : key)(e:elt) , ~ MapsTo a e m.

      Definition eq_key (p p':key*elt) := E.eq (fst p) (fst p').

      Definition eq_key_elt (p p':key*elt) :=
          E.eq (fst p) (fst p') /\ (snd p) = (snd p').

    (** Specification of [MapsTo] *)
      Parameter MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.

    (** Specification of [mem] *)
      Parameter mem_1 : In x m -> mem x m = true.
      Parameter mem_2 : mem x m = true -> In x m.

    (** Specification of [empty] *)
      Parameter empty_1 : Empty empty.

    (** Specification of [is_empty] *)
      Parameter is_empty_1 : Empty m -> is_empty m = true.
      Parameter is_empty_2 : is_empty m = true -> Empty m.

    (** Specification of [add] *)
      Parameter add_1 : E.eq x y -> MapsTo y e (add x e m).
      Parameter add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
      Parameter add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.

    (** Specification of [remove] *)
      Parameter remove_1 : E.eq x y -> ~ In y (remove x m).
      Parameter remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
      Parameter remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.

    (** Specification of [find] *)
      Parameter find_1 : MapsTo x e m -> find x m = Some e.
      Parameter find_2 : find x m = Some e -> MapsTo x e m.

    (** Specification of [elements] *)
      Parameter elements_1 :
        MapsTo x e m -> InA eq_key_elt (x,e) (elements m).
      Parameter elements_2 :
        InA eq_key_elt (x,e) (elements m) -> MapsTo x e m.
      (** When compared with ordered maps, here comes the only
         property that is really weaker: *)
      Parameter elements_3w : NoDupA eq_key (elements m).

    (** Specification of [cardinal] *)
      Parameter cardinal_1 : cardinal m = length (elements m).

    (** Specification of [fold] *)
      Parameter fold_1 :
	forall (A : Type) (i : A) (f : key -> elt -> A -> A),
        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.

    (** Equality of maps *)

    (** Caveat: there are at least three distinct equality predicates on maps.
      - The simpliest (and maybe most natural) way is to consider keys up to
        their equivalence [E.eq], but elements up to Leibniz equality, in
        the spirit of [eq_key_elt] above. This leads to predicate [Equal].
      - Unfortunately, this [Equal] predicate can't be used to describe
        the [equal] function, since this function (for compatibility with
        ocaml) expects a boolean comparison [cmp] that may identify more
        elements than Leibniz. So logical specification of [equal] is done
        via another predicate [Equivb]
      - This predicate [Equivb] is quite ad-hoc with its boolean [cmp],
        it can be generalized in a [Equiv] expecting a more general
        (possibly non-decidable) equality predicate on elements *)

     Definition Equal m m' := forall y, find y m = find y m'.
     Definition Equiv (eq_elt:elt->elt->Prop) m m' :=
         (forall k, In k m <-> In k m') /\
         (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
     Definition Equivb (cmp: elt->elt->bool) := Equiv (Cmp cmp).

     (** Specification of [equal] *)

     Variable cmp : elt -> elt -> bool.

     Parameter equal_1 : Equivb cmp m m' -> equal cmp m m' = true.
     Parameter equal_2 : equal cmp m m' = true -> Equivb cmp m m'.

    End Spec.
   End Types.

    (** Specification of [map] *)
      Parameter map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
        MapsTo x e m -> MapsTo x (f e) (map f m).
      Parameter map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
        In x (map f m) -> In x m.

    (** Specification of [mapi] *)
      Parameter mapi_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)
        (f:key->elt->elt'), MapsTo x e m ->
        exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
      Parameter mapi_2 : forall (elt elt':Type)(m: t elt)(x:key)
        (f:key->elt->elt'), In x (mapi f m) -> In x m.

    (** Specification of [map2] *)
      Parameter map2_1 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
	(x:key)(f:option elt->option elt'->option elt''),
	In x m \/ In x m' ->
        find x (map2 f m m') = f (find x m) (find x m').

     Parameter map2_2 : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
	(x:key)(f:option elt->option elt'->option elt''),
        In x (map2 f m m') -> In x m \/ In x m'.

  Hint Immediate MapsTo_1 mem_2 is_empty_2
    map_2 mapi_2 add_3 remove_3 find_2
    : map.
  Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1
    remove_2 find_1 fold_1 map_1 mapi_1 mapi_2
    : map.

End WSfun.

(** ** Static signature for Weak Maps

    Similar to [WSfun] but expressed in a self-contained way. *)

Module Type WS.
  Declare Module E : DecidableType.
  Include WSfun E.
End WS.

(** ** Maps on ordered keys, functorial signature *)

Module Type Sfun (E : OrderedType).
  Include WSfun E.
  Section elt.
  Variable elt:Type.
   Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p').
   (* Additional specification of [elements] *)
   Parameter elements_3 : forall m, sort lt_key (elements m).
   (** Remark: since [fold] is specified via [elements], this stronger
   specification of [elements] has an indirect impact on [fold],
   which can now be proved to receive elements in increasing order. *)
  End elt.
End Sfun.

(** ** Maps on ordered keys, self-contained signature *)

Module Type S.
  Declare Module E : OrderedType.
  Include Sfun E.
End S.

(** ** Maps with ordering both on keys and datas *)

Module Type Sord.

  Declare Module Data : OrderedType.
  Declare Module MapS : S.
  Import MapS.

  Definition t := MapS.t Data.t.

  Parameter eq : t -> t -> Prop.
  Parameter lt : t -> t -> Prop.

  Axiom eq_refl : forall m : t, eq m m.
  Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
  Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
  Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
  Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.

  Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end.

  Parameter eq_1 : forall m m', Equivb cmp m m' -> eq m m'.
  Parameter eq_2 : forall m m', eq m m' -> Equivb cmp m m'.

  Parameter compare : forall m1 m2, Compare lt eq m1 m2.
  (** Total ordering between maps. [Data.compare] is a total ordering
      used to compare data associated with equal keys in the two maps. *)

End Sord.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  Defining type safety, page 67.

*)

Set Implicit Arguments.
Require Export Cyclone_Formal_Syntax Cyclone_Static_Semantics_Kinding_And_Context_Well_Formedness.
Require Export Cyclone_Static_Semantics_Typing_Heap_Objects.
Require Export Cyclone_Classes Cyclone_Inductions Cyclone_LN_Tactics Cyclone_LN_Extra_Lemmas_And_Automation.
Require Export Cyclone_Well_Formedness_Lemmas.
Require Export ContextWeakeningProof.
Require Export Cyclone_LN_Types_Lemmas.
Close Scope list_scope.
Import LibEnvNotations.
Import LVPE.LibVarPathEnvNotations.

Lemma A_2_Term_Weakening_1 :
  forall (d: Delta) (u u' : Upsilon) (g g' : Gamma)
         (x : var) (p p' : Path) (tau tau' : Tau),
    LVPE.extends u u' ->
    extends g g' ->
    WFC d u g ->
    WFC d u' g' ->
    gettype u  x p tau p' tau' ->
    gettype u' x p tau p' tau'.
Proof.
  intros.
  unfold LVPE.extends, LVPE.binds in H.
  induction H3; auto.
  apply gettype_etype with (tau'':= tau''); auto.
Qed.

Lemma gettype_weakening:
  forall u u' x tau' p tau,
  gettype u x nil tau' p tau ->
  LVPE.extends u u' ->
  gettype u' x nil tau' p tau.
Proof.
  intros.
  unfold LVPE.extends, LVPE.binds in *.
  induction H; auto.
  apply gettype_etype with (tau'':= tau'');auto.
Qed.
Ltac gettype_weakening :=
  match goal with
    | H: gettype ?u' ?x' nil ?tau'' ?p' ?tau',
      I: LVPE.extends ?u' ?u''
    |- gettype ?u'' ?x' nil ?tau'' ?p' ?tau' =>
      apply gettype_weakening with (u:= u'); assumption
  end.
Hint Extern 1 (gettype _ _ nil _ _ _) => try gettype_weakening.

Lemma WFDG_gamma_K:
  forall d g,
    WFDG d g ->
    forall x tau,
      get x g = Some tau ->
      K d tau A.
Proof.
  introv WFDGd.
  induction WFDGd; intros.
  apply binds_empty_inv in H0.
  inversion H0.
  specialize (IHWFDGd x0 tau0).
  unfold binds in *.
  destruct(classicT(x0 = x)); subst.
  rewrite get_push in H3.
  case_var.
  inversion H3; subst; assumption.
  rewrite get_push in H3.
  case_var.
  auto.
Qed.
Ltac WFDG_gamma_K :=
  match goal with
   | H:  WFDG ?d' ?g',
     I: get ?x' ?g' = Some ?tau'
   |- K ?d' ?tau' A =>
    apply WFDG_gamma_K with (d:=d') (g:=g') (x:=x') (tau:=tau')
end.
Hint Extern 1 (K _ _ A) => WFDG_gamma_K.

Lemma WFC_gamma_K:
  forall d u g,
    WFC d u g ->
    forall x tau,
      get x g = Some tau ->
      K d tau A.
Proof.
  intros.
  inversion H; subst.
  apply WFDG_gamma_K with (g:= g) (x:=x); try assumption.
Qed.
Ltac WFC_gamma_K :=
  match goal with
    | H: WFC ?d' ?u' ?g',
      I: get ?x' ?g' = Some ?tau'
    |- K ?d' ?tau' A =>
    apply WFDG_gamma_K with (d:=d') (u:=u') (g:=g') (x:=x') (tau:=tau')
  end.
Hint Extern 1 (K _ _ A) => WFC_gamma_K.

Ltac simpl_get ::=
  idtac "simpl_get";
  trace_goal;
  timeout 2
  repeat
    match goal with
  | |- context [get ?a empty]           => trace_goal; rewrite~ get_empty
  | |- context [get ?a empty]           => trace_goal; rewrite~ get_empty
  | |- context [get ?a empty]           => trace_goal; rewrite~ get_empty
  | |- context [get ?a (_ & (_ ~ _)) ]      => trace_goal;
    rewrite~ get_push; try repeat case_var~

  | |- context [get ?a ((?b ~ _) & _)] => trace_goal;
    rewrite~ get_concat; try repeat case_var~

  | |- context [get ?a _ = None] => trace_goal;
   apply* get_none

  | H: context[get _ empty = Some _] |- _ =>
    rewrite get_empty in H; inversion H
end.

Ltac simpl_lvpe_get ::=
  trace_goal;
  timeout 2
  repeat
    match goal with
    | |- context [LVPE.V.get ?a LVPE.V.empty]    => trace_goal;
      rewrite~ LVPE.get_empty

  | |- context [LVPE.V.get ?a (?a ~p _) ]      => trace_goal;
    rewrite~ LVPE.get_single; try repeat case_var~
  | |- context [get ?a (?a ~ _) ]      => trace_goal;
    rewrite~ get_single; try repeat case_var~

  | |- context [LVPE.V.get ?a (_ &p (?a ~p _)) ]      => trace_goal;
    rewrite~ LVPE.get_push; try repeat case_var~
  | |- context [get ?a (_ & (?a ~ _)) ]      => trace_goal;
    rewrite~ get_push; try repeat case_var~

  | |- context [LVPE.V.get ?a (_ &p (_ ~p _)) ]      => trace_goal;
    rewrite~ LVPE.get_push; try repeat case_var~
  | |- context [LVPE.V.get ?a ((?b ~ _) & _)] => trace_goal;
    rewrite~ LVPE.get_concat; try repeat case_var~

  | H: context[LVPE.V.get _ empty = Some _] |- _ =>
    rewrite LVPE.get_empty in H; inversion H

  | H: context[LVPE.V.get _ LVPE.V.empty = Some _] |- _ =>
    rewrite LVPE.get_empty in H; inversion H
end.

Lemma WFU_upsilon_K:
  forall u,
    WFU u ->
    forall x p tau,
      LVPE.V.get (x,p) u = Some tau ->
      K empty tau A.
Proof.
  introv WFUd.
  induction WFUd.
  intros.
  auto.
  simpl_lvpe_get.
  intros.
  destruct(classicT((x0,p0) = (x,p))).
  rewrite LVPE.get_push in H2.
  rewrite If_l in H2.
  inversion H2.
  subst.
  assumption.
  rewrite If_l in H2; try assumption.
  rewrite LVPE.get_push in H2.
  rewrite If_r in H2; try assumption.
  apply IHWFUd with (x:=x0) (p:=p0); try assumption.
Qed.
Ltac WFU_upsilon_K :=
  match goal with
    | H: WFU ?u',
      I: LVPE.V.get (?x',?p') ?u' = Some ?tau'
      |-  K empty ?tau' A =>
      apply WFU_upsilon_K
end.
Hint Extern 1 (K empty _ A) => WFU_upsilon_K.

Lemma WFC_upsilon_K:
  forall d u g,
    WFC d u g ->
    forall x p tau,
      LVPE.V.get (x,p) u = Some tau ->
      K empty tau A.
Proof.
 introv WFCd.
 inversion WFCd; subst.
 apply WFU_upsilon_K; assumption.
Qed.
Ltac WFC_upsilon_K :=
  match goal with
    | H: WFC ?d' ?u' ?g',
      I: LVPE.V.get (?x',?p') ?u' = Some ?tau'
      |-  K empty ?tau' A =>
      apply WFU_upsilon_K
end.
Hint Extern 1 (K empty _ A) => WFC_upsilon_K.

Lemma WFDG_gamma_weakening:
  forall d g y tau,
    y \notin (fv_gamma g) ->
    K d tau A ->
    WFDG d g ->
    WFDG d (g & (y ~ tau)).
Proof.
  introv NI WFd.
  auto.
Qed.
Ltac WFDG_gamma_weakening :=
  match goal with
    | H: K ?d' ?tau' A,
      I: WFDG ?d' ?g'
    |-  WFDG ?d' (?g' & (?y' ~ ?tau')) =>
      apply WFDG_gamma_weakening with (tau:=tau');
      notin_solve
  end.
Hint Extern 1 (WFDG _ (_ & (_ ~ _))) => WFDG_gamma_weakening.

Lemma WFDG_delta_weakening:
  forall alpha d g k,
    alpha \notin fv_delta d ->
    WFDG d g ->
    WFDG (d & alpha ~ k) g.
Proof.
  lets: WFDG_gamma_weakening.
  introv ANI WFDGd.
  induction WFDGd; auto.
  assert(alpha \notin fv_delta d).
  auto.
  apply IHWFDGd in H4.
  constructor; try assumption.
  constructor; try assumption.
  apply A_1_Context_Weakening_1 with (d:= d); try assumption.
  auto.
  auto.
Qed.
Ltac WFDG_delta_weakening :=
  match goal with
    | H: ?alpha \notin _,
      I: WFDG ?d' ?g'
    |- WFDG (?d' & ?alpha ~ ?k) ?g' =>
      apply WFDG_delta_weakening; notin_solve
  end.
Hint Extern 1 (WFDG (_ & _ ~ _) _) => WFDG_delta_weakening.

Lemma get_fv_delta:
  forall v d k,
    get v d = Some k ->
    \{v} \c fv_delta d.
Proof.
  intros.
  unfold fv_delta.
  induction d using env_ind.
  rewrite get_empty in H.
  inversion H.
  rewrite get_push in H.
  case_var.
  inversion H.
  subst.
  rewrite dom_push.
  fset.
  apply IHd in H.
  rewrite dom_push.
  (* need some trivial set theory *)
Admitted.
Ltac get_fv_delta :=
  match goal with
  | H: get ?v ?d = Some ?k' |- \{?v} \c fv_delta ?d =>
    apply get_fv_delta with (k:= k'); assumption; auto with fset
end.
Hint Extern 1 (\{_} \c fv_delta _) => get_fv_delta.
Hint Extern 1 (T.fv _ \c fv_delta _) => simpl; get_fv_delta.

Lemma K_fv:
  forall tau d k,
    WFD d ->
    K d tau k ->
    T.fv tau \c fv_delta d.
Proof.
  intros tau.
  induction tau; intros; simpl; fset;
   try solve[try inversion H; subst; try inversion H0; subst;
             auto with fset].
  inversion H; subst.
Admitted.

Lemma K_empty_closed:
  forall tau k,
    K empty tau k ->
    T.fv tau = \{}.
Proof.
  intros.
  lets: K_fv tau (@empty Kappa).
  apply H0 in H.
  unfold fv_delta in H.
  rewrite dom_empty in H.
  admit. (* trivial set theory *)
  auto.
Qed.
Lemma ok_strengthing:
  forall (d' : Delta) y k,
    ok(d' & y ~ k) ->
    forall d,
      extends d d' ->
      ok(d & y ~ k).
Proof.
  intros.
  induction d using env_ind.
  apply* ok_push.
  apply ok_push.
  apply ok_push.
  inversion H.
Admitted.

Lemma K_weakening:
  forall tau d,
    K d tau A ->
    forall d',
      WFD d ->
      extends d d' ->
      K d'     tau A.
Proof.
  introv Kempty.
  induction Kempty; try solve[auto].
  intros.
  apply_fresh K_utype; intros.
  assert(I: y \notin L); auto.
  specialize (H y I ).
  apply ok_strengthing with (d:=d) in H3; auto.
  intros.
  apply_fresh K_etype; intros.
  assert(I: y \notin L); auto.
  specialize (H y I ).
  apply ok_strengthing with (d:=d) in H3; auto.
Qed.

(* The heart of the magic K.
 So either rtyp/ltyp/styp when they bind (write the store) or read (p_e (fevar x) p)
that type has to K empty ? A.

  So either Dan has failed to check this or its provable from type typing derivations.

  WFU checks this but nothing in the typing rules do.

  Assuming the thesis needs addition, rules that should check this are:
  SS 3.6 (or all rtyp)
  SS 3.7
  SS 3.8
  SL3.1
  SR 3.1
  SR 3.8 - has asgn.
  SR 3.11 - has ak
  SR 3.12 - has ak
*)

Lemma WFC_gamma_weakening:
  forall d u g,
    WFC d u g ->
    forall tau,
      K empty tau A ->  (* Magic K *)
      forall y,
        y \notin (fv_gamma g) ->
        WFC d u (g & (y ~ tau)).
Proof.
SearchAbout(_ -> K _ _ A).
  lets: WFDG_gamma_weakening.
  introv WFCd.
  inversion WFCd; subst.
  constructor; try assumption.
  constructor; auto.
  apply K_weakening with (d:= empty); auto.
Qed.
Ltac WFC_gamma_weakening :=
  match goal with
    | H: K ?d' ?tau' A,
      I: WFC ?d' ?u' ?g'
    |-  WFC ?d' ?u' (?g' & (?y' ~ ?tau')) =>
      apply WFC_gamma_weakening with (tau:=tau');
      notin_solve
  end.
Hint Extern 1 (WFC _ _ (_ & (_ ~ _))) => WFC_gamma_weakening.

Lemma WFDG_delta_gamma_weakening:
  forall alpha d g x k tau,
    alpha \notin fv_delta d ->
    x \notin  fv_gamma g ->
    K d tau A ->
    WFDG d g ->
    WFDG (d & alpha ~ k) (g & x ~ tau).
Proof.
  introv ANI XNI Kd WFCd.
  apply WFDG_delta_weakening; try assumption.
  apply WFDG_gamma_weakening; try assumption.
Qed.

Ltac WFDG_delta_gamma_weakening :=
  match goal with
    | H: ?alpha \notin _,
      I: ?x \notin _,
      J: WFDG ?d' ?g'
    |- WFDG (?d' & ?alpha ~ ?k) (?g' & ?x ~ ?tau)  =>
      apply WFDG_delta_gamma_weakening; notin_solve
  end.
Hint Extern 1 (WFDG (_ & _ ~ _) (_ & _ ~ _)) => WFDG_delta_gamma_weakening.

Lemma WFC_delta_weakening:
  forall alpha d u g k,
    alpha \notin fv_delta d ->
    WFC d u g ->
    WFC (d & alpha ~ k) u g.
Proof.
  lets: WFDG_delta_weakening.
  introv ANI WFCd.
  inversion WFCd; subst.
  auto.
Qed.
Ltac WFC_delta_weakening :=
  match goal with
    | H: ?alpha \notin _,
      J: WFC ?d' ?u ?g'
    |- WFC (?d' & ?alpha ~ ?k) _ ?g' =>
      apply WFC_delta_weakening; notin_solve; try assumption
  end.

Hint Extern 1 (WFC (_ & _ ~ _) _ _) => WFDG_delta_gamma_weakening.

Lemma WFC_delta_gamma_weakening:
  forall alpha d u g x k tau,
    alpha \notin fv_delta d ->
    x \notin fv_gamma g ->
    K d tau A ->
    WFC d u g ->
    WFC (d & alpha ~ k) u (g & x ~ tau).
Proof.
  lets: WFDG_delta_gamma_weakening.
  introv ANI XNI Kd WFCd.
  inversion WFCd; subst.
  auto.
Qed.
Ltac WFC_delta_gamma_weakening :=
  match goal with
    | H: ?alpha \notin _,
      I: ?x \notin _,
      J: WFC ?d' ?g' _
    |- WFC (?d' & ?alpha ~ ?k) _ (?g' & ?x ~ ?tau)  =>
      apply WFC_delta_gamma_weakening; notin_solve
  end.
Hint Extern 1 (WFC (_ & _ ~ _) _ (_ & _ ~ _)) => WFDG_delta_gamma_weakening.

Ltac solve_styp :=
  match goal with
  | H : get ?x _ = Some ?t, I: gettype _ ?x nil ?t _ _  |-  ltyp _ _ _ (p_e (fevar ?x) _) _ =>
   apply SL_3_1 with (tau':= t); auto

  | H : ltyp _ _ _ ?e (cross ?t ?t') |-  ltyp _ _ _ (dot ?e zero_pe) ?t =>
   apply SL_3_3 with (t1:= t'); auto; idtac "t" t

  | H : ltyp _ _ _ ?e (cross ?t ?t') |-  ltyp _ _ _ (dot ?e one_pe) ?t' =>
   apply SL_3_4 with (t0:= t); auto

  | H: context[rtyp ?d0 _ _ ?e ?tau']
  |- styp ?d0 _ _ (letx ?e _) _ =>
    apply_fresh styp_let_3_6  with type tau'; auto

  | H: context[styp (_ & _ ~ ?k) _ _ (TTM.open_rec_st _ _ (TM.open_rec_st _ _ ?s0)) _],
    I: context[rtyp ?d0 _ _ ?e ?tau']
  |- styp ?d0 _ _ (openx ?e ?s0) ?tau =>
    apply_fresh styp_open_3_7 with type tau' kind k; intros; auto

  | H: context[styp (_ & _ ~ ?k) _ _ (TTM.open_rec_st _ _ (TM.open_rec_st _ _ ?s0)) _],
    I: context[ltyp ?d0 _ _ ?e ?tau']
  |- styp ?d0 _ _ (openstar ?e ?s0) ?tau =>
    apply_fresh styp_openstar_3_8 with type tau' kind k; intros; auto

  | H: context[styp ?d0 _ _ (TM.open_rec_st _ _ ?s0) ?tau']
  |- styp ?d0 _ _ (TM.open_rec_st _ _ ?s0) ?tau' =>
    applys* H
  end.

Ltac solve_rtyp :=
  match goal with
  | H : get ?x _ = Some ?t, I: gettype _ ?x nil ?t _ _  |-  rtyp _ _ _ (p_e (fevar ?x) _) _ =>
    apply SR_3_1 with (tau':= t); auto

  | H : rtyp _ _ _ ?e (cross ?t ?t') |-  rtyp _ _ _ (dot ?e zero_pe) ?t =>
    apply SR_3_3 with (t1:= t'); auto; idtac "t" t

  | H : rtyp _ _ _ ?e (cross ?t ?t') |-  rtyp _ _ _ (dot ?e one_pe) ?t' =>
    apply SR_3_4 with (t0:= t); auto

  | H : rtyp _ _ _ ?e1 (arrow ?t' ?tau) |- rtyp _ _ _ (appl ?e1 ?e2) ?tau =>
    apply SR_3_9 with (tau':= t'); auto

  | H:  rtyp _ _ _ ?e (utype ?k' ?t') |- rtyp _ _ _ (inst ?e _) _ =>
    apply SR_3_11 with (k:=k') (tau':= t'); auto

  | |- rtyp _ _ _ (pack _ _ (etype ?p ?k ?tau)) (etype ?p ?k ?tau) =>
   apply_fresh SR_3_12; auto

  | |- rtyp _ _ _ (f_e (dfun ?tau ?tau' _)) (arrow ?tau ?tau') =>
    apply_fresh SR_3_13; auto

 | |- rtyp _ _ _ (f_e (ufun ?k _)) (utype ?k _) =>
    apply_fresh SR_3_14; auto

 |  H : context[rtyp ?d0 _ _ ?e (T.open_rec _ ?tau' ?tau)]
 |- rtyp ?d0 _ _ ?e (T.open_rec _ ?tau' ?tau) =>
    applys* H
end.

Ltac solve_ltyp :=
  match goal with
  | H : get ?x _ = Some ?t, I: gettype _ ?x nil ?t _ _  |- ltyp _ _ _ (p_e (fevar ?x) _) _ =>
    apply SL_3_1 with (tau':= t); auto
  | H : ltyp _ _ _ ?e (cross ?t ?t') |-  ltyp _ _ _ (dot ?e zero_pe) ?t =>
    apply SL_3_3 with (t1:= t'); auto; idtac "t" t
  | H : ltyp _ _ _ ?e (cross ?t ?t') |-  ltyp _ _ _ (dot ?e one_pe) ?t' =>
    apply SL_3_4 with (t0:= t); auto
end.

Ltac solve_typ := repeat (try solve_styp; try solve_rtyp; try solve_ltyp).
(* Not ready for prime time.
Hint Extern 3 (rtyp _ _ _ _ _) => try solve_rtyp.
Hint Extern 3 (ltyp _ _ _ _ _) => try solve_ltyp.
Hint Extern 3 (styp _ _ _ _ _) => try solve_styp.
*)

Lemma needed:
  forall d u g,
    WFC d u g ->
    forall x tau',
      get x g = Some tau' ->
      forall tau p,
        gettype u x nil tau' p tau ->
        K d tau' A ->
        LVPE.V.get (x, p) u = Some tau.
Admitted.

(* Will I need this for other typings? *)
Lemma ltyp_K_A:
  forall d u g,
    WFC d u g ->
    forall e tau,
      ltyp d u g e tau ->
      K d tau A.
Proof.
  introv WFCd ltypd.
  induction ltypd; auto.
  apply A_1_Context_Weakening_2 with (u:= u) (x:=x) (p:=p).
  inversions* WFCd.
  inversions* WFCd.
  apply needed with (d:= d) (g:=g) (tau':=tau'); auto.

  apply IHltypd in WFCd.
  inversion WFCd; subst.
  assumption.
  inversion WFCd; subst.
  assumption.
  inversion H.

  apply IHltypd in WFCd.
  inversion WFCd; subst.
  assumption.
  inversion WFCd; subst.
  assumption.
  inversion H.
Qed.
(* Hint Immediate ltyp_K_A. *)

Lemma WFC_WFU:
  forall d u g,
    WFC d u g ->
    WFU u.
Proof.
  introv WFCd.
  inversion WFCd; auto.
Qed.
Hint Immediate WFC_WFU.

Lemma WFC_WFDG:
  forall d u g,
    WFC d u g ->
    WFDG d g.
Proof.
  introv WFCd.
  inversion WFCd; auto.
Qed.
Hint Immediate WFC_WFDG.

Lemma wfc_ok_delta:
  forall d u g,
    WFC d u g ->
    ok d.
Proof.
  introv WFCd.
  inversion WFCd; auto.
Qed.
Hint Immediate wfc_ok_delta.

Lemma wfc_ok_upsilon:
  forall d u g,
    WFC d u g ->
    LVPE.okp u.
Proof.
  introv WFCd.
  inversion WFCd; auto.
Qed.
Hint Immediate wfc_ok_upsilon.

Lemma wfc_ok_gamma:
  forall d u g,
    WFC d u g ->
    ok g.
Proof.
  introv WFCd.
  inversion WFCd; auto.
Qed.
Hint Immediate wfc_ok_gamma.

(* Perhaps. *)
Lemma store_types_are_K_empty_A:
  forall d u g,
    WFC d u g ->
    forall x tau',
     get x g = Some tau' ->
     forall p tau,
       gettype u x nil tau' p tau ->
       K empty tau A.
Proof.
  introv WFCd getd gettyped.
  induction gettyped.
  SearchAbout(K empty _ A).
Admitted.

Lemma rtyp_K_empty_ptr_A:
  forall d u g,
    WFC d u g ->
    forall e tau,
      rtyp d u g e (ptype tau) ->
      K empty tau A.
Proof.
  introv WFCd rtypd.
  inversions* rtypd.
  apply store_types_are_K_empty_A
   with (d:=d) (u:=u) (g:=g) (x:=x)(tau':= tau') (p:= p); try assumption.
  admit.
  admit.
  admit.
  admit.
  admit.
  admit.
  admit.
  (* mutual induction required! *)
Admitted.

Lemma ltyp_K_empty_A:
  forall d u g,
    WFC d u g ->
    forall e tau,
      ltyp d u g e tau ->
      K empty tau A.
Proof.
  introv WFCd ltypd.
  induction ltypd; try solve[auto].
  apply store_types_are_K_empty_A
   with (d:=d)(u:=u)(g:=g)(x:=x)(tau':=tau')(p:=p); auto.
Admitted.
(*
  apply rtyp_K_empty_ptr_A with (d:=d) (u:=u) (g:=g)(e:= e).

  apply IHltypd in WFCd.
  inversions* WFCd.
  inversion H.
  apply IHltypd in WFCd.
  inversions* WFCd.
  inversion H.
Qed.
*)
Hint Immediate ltyp_K_A.

(* WFC d u g is not in the thesis theorem which drops the magic Ks down to 1.
   As we an extension to d' u g' and it's valid, WFC d u g is derivable. So
  the theorem statement is valid. *)

(* Dan assumes this in the theorem statements. *)
Lemma WFU_extension_WFU:
  forall u',
    WFU u' ->
    forall u,
      LVPE.extends u u' ->
      WFU u.
Proof.
  introv WFUd.
  induction u.
  intros.
  rewrite <- LVPE.V.empty_def.
  auto.
  unfold LVPE.extends.
  intros.
  destruct a.
  (* have to learn to rewrite lists and flip them into envs. *)
  (* should prove. *)
Admitted.

Lemma WFC_extension_WFC:
  forall d' u' g',
    WFC d' u' g' ->
    forall d u g,
      extends d d' ->
      LVPE.extends u u'->
      extends g g' ->
      WFC d u g.
Proof.
  introv WFCd.
  induction WFCd.
  intros.
  auto.
Admitted.

Function A_2_Term_Weakening_prop (In : Type) (H : TypJudgement In)
         (d : Delta) (u : Upsilon) (g : Gamma) (s : In) (t : Tau)
         (st : typ' d u g s t) :=
    typ' d u g s t ->
    (* WFC d u g ->  *)
      forall (u' : Upsilon) (g' : Gamma),
        WFC d u' g' ->
        LVPE.extends u u' ->
        extends g g' ->
        typ' d u' g' s t.
Hint Unfold A_2_Term_Weakening_prop.

Lemma A_2_Term_Weakening_2_ltyp:
  forall (d : Delta) (u : Upsilon) (g : Gamma) (s : E) (t : Tau) (ty : typ' d u g s t),
   A_2_Term_Weakening_prop LtypJudgement d u g s t ty.
Proof.
  intros.
  Typ_Induction ltyp_ind_mutual A_2_Term_Weakening_prop;
  intros; try solve[auto].

  try solve[solve_typ].
  apply_fresh styp_open_3_7 with type tau' kind k; try assumption.
  intros.
  eapply H; try assumption; try solve[notin_solve].
  assert(alpha  \notin L); auto.
  assert(x \notin L); admit. (* This shows an automation bug, working wfc from notin*)
  apply* extends_push_both.
  auto.

  apply_fresh styp_openstar_3_8 with type tau' kind k; try assumption.
  intros.
  eapply H; try assumption; try solve[notin_solve].
  assert(alpha  \notin L); auto.
  assert(x \notin L); admit. (* This shows an automation bug, working wfc from notin*)
  apply* extends_push_both.
  auto.

  try solve[solve_typ].
  try solve[solve_typ].
  try solve[solve_typ].
  try solve[solve_typ].
  try solve[solve_typ].
  try solve[solve_typ].
  try solve[solve_typ].
  try solve[solve_typ].
  try solve[solve_typ].
  apply_fresh SR_3_13.
  eapply H; try assumption; try solve[notin_solve].
  assert(y \notin L); auto.
  apply WFC_gamma_weakening; try assumption; try solve[notin_solve].
  admit. (* magic k *)
  apply* extends_push_both.
  auto.

  apply_fresh SR_3_14; try assumption.
  eapply H; try assumption; try solve[notin_solve].
  assert(y \notin L); auto.
  apply WFC_delta_weakening; try assumption; try solve[notin_solve].
Qed.

(* Just to test that the screwed up K is not different for rtyp or styp. *)
Lemma A_2_Term_Weakening_3:
  forall (d : Delta) (u : Upsilon) (g : Gamma) (s : E) (t : Tau) (ty : typ' d u g s t),
   A_2_Term_Weakening_prop RtypJudgement d u g s t ty.
Proof.
  intros.
  Typ_Induction rtyp_ind_mutual A_2_Term_Weakening_prop;
  intros; try solve[auto].
Admitted.

Lemma A_2_Term_Weakening_4:
  forall (d : Delta) (u : Upsilon) (g : Gamma) (s : St) (t : Tau) (ty : typ' d u g s t),
   A_2_Term_Weakening_prop StypJudgement d u g s t ty.
Proof.
  intros.
  Typ_Induction styp_ind_mutual A_2_Term_Weakening_prop;
  intros; try solve[auto].
Admitted.
(* And they are. *)

Lemma A_3_Heap_Weakening_1:
  forall u g u' g',
    LVPE.extends u u' ->
    extends g g' ->
    WFC empty u' g' ->
    forall h g'',
      htyp u g h g'' ->
      htyp u' g' h g''.
Proof.
  introv Euu' Egg' WFCd H.
  induction H; auto.
  specialize (IHhtyp Euu' Egg').
  constructor; try assumption.
  lets* T: A_2_Term_Weakening_3.
Qed.

Lemma A_3_Heap_Weakening_2:
  forall h u,
    refp h u ->
    forall h',
      extends h h' ->
      refp h' u.
Proof.
  introv R.
  induction R; intros; auto.
  apply refp_pack with (tau:=tau) (k:=k)(v:=v)(v':=v'); auto.
Qed.

Lemma subset_weakening:
  forall A (a : fset A) b c,
    a \c c ->
    a \c b \u c.
Admitted.

Lemma get_dom:
  forall A alpha (d : env A)  k,
    get alpha d = Some k ->
    \{alpha} \c dom d.
Proof.
  intros.
  induction d using env_ind.
  rewrite get_empty in H.
  inversion H.
  destruct (classicT(alpha = x)).
  subst.
  rewrite dom_push.
  fset.
  rewrite get_push in H.
  rewrite* If_r in H.
  apply IHd in H.
  rewrite dom_push.
  apply* subset_weakening.
Qed.
Ltac get_dom :=
  match goal with
  | H: get ?a ?d = Some ?k'
  |- \{?a} \c dom ?d =>
    apply get_dom with (k:= k')
  end.
Hint Extern 1 (\{_} \c dom _) => get_dom.

Lemma singleton_empty:
  forall A (v :A),
    \{v} = \{} -> False.
Admitted.

Lemma fv_subst:
  forall tau alpha tau',
    T.fv tau' = \{} ->
    T.subst tau alpha tau' = tau'.
Proof.
  intros.
  induction tau'; auto;
    try solve[simpl in H; simpl; fequals*].
  simpl in H.
  apply singleton_empty in H.
  inversion H.

  simpl in H.
  simpl.
  assert(T.fv tau'1 = \{}). admit.
  assert(T.fv tau'2 = \{}). admit.
  fequals*.

  simpl in H.
  simpl.
  assert(T.fv tau'1 = \{}). admit.
  assert(T.fv tau'2 = \{}). admit.
  fequals*.
Qed.

Lemma open_rec_fv:
  forall alpha tau n,
    T.fv (T.open_rec n (ftvar alpha) tau) = T.fv tau \u \{alpha} \/
    T.fv (T.open_rec n (ftvar alpha) tau) = T.fv tau.
Proof.
  intros.
  induction tau; simpl; auto.
  case_nat.
  simpl.
  left.
  rewrite* union_empty_l.

  simpl.
  right*.
  admit.
  admit.
Admitted.

Lemma K_fv_delta:
  forall tau d k,
    ok d ->
    K d tau k ->
    T.fv tau \c dom d.
Proof.
  introv OKd Kd.
  induction Kd; simpl; auto with fset.
  admit.
  admit.
  pick_fresh alpha.
  lets I: open_rec_fv alpha tau 0.
  assert(ANI: alpha \notin L); auto.
  assert(KO: ok( d & alpha ~ k)); auto.
  specialize (H0 alpha ANI KO KO).
  inversion I.
  rewrite H1 in H0.
  rewrite dom_push in H0.
  admit. (* set *)
Admitted. (* should work *)

Lemma punt:
  forall d alpha alpha' k k' tau tau0,
    alpha' \notin T.fv tau ->
    K (d & alpha' ~ k) (T.open_rec 0 (ftvar alpha') tau) k' -> (* perhaps exists k' *)
    T.subst tau0 alpha (T.open_rec 0 (ftvar alpha') tau) =
                        T.open_rec 0 (ftvar alpha') tau ->
    T.subst tau0 alpha tau = tau.
Proof.
  intros.
  induction tau; auto; simpl; fequals;
  try solve[simpl in H1;
  inversion H1;
  inversion H0; subst;
  try apply IHtau1; auto;
  try apply IHtau1; auto;
  try apply IHtau2; auto;
  try apply IHtau2; auto;
  inversion H2].

  simpl in H0.
  inversion H0; subst.
  apply IHtau; auto.
  inversion H2; subst.
Admitted.

Lemma A_4_Useless_Substitutions_1':
  forall alpha d,
    alpha \notin dom d ->
    ok d ->
    forall tau',
     (exists k, K d tau' k) ->
      forall tau,
        T.subst tau alpha tau' = tau'.
Proof.
  intros.
  induction tau'; auto.
  intros.
  simpl.
  case_var*.
  inversion H1; subst.
(*
  rewrite get_none in H4; auto.
  inversion H4.
  inversion H2; subst.
  rewrite get_none in H5; auto.
  inversion H5.

  admit.
  admit.
  simpl; fequals.
  inversion H1; subst.
  admit. (* exists k problem ?*)
  admit.
  admit.
  simpl; fequals.
  apply IHtau'.
  inversion H1; subst.
  Admitted.
*)
  (* Stuck here too. *)
Admitted.

Lemma A_4_Useless_Substitutions_1:
  forall alpha d,
    alpha \notin dom d ->
    ok d ->
    forall tau' k,
      K d tau' k ->
      forall tau,
        T.subst tau alpha tau' = tau'.
Proof.
  introv NI OKd Kd.
  induction Kd; intros;
  try solve[simpl; auto; try case_var*;
            try solve[rewrite* get_none in H; inversion H]; fequals*].
  (* is this an induction problem with L needing to be d ? *)
  simpl.
  fequals.
  pick_fresh alpha'.
  assert(N: alpha' \notin L); auto.
  assert(O: alpha' # d); auto.
  assert(P: ok (d & alpha' ~ k)); auto.
  assert(Q: alpha # d & alpha' ~ k); auto.
  specialize (H alpha' N P).
  specialize (H0 alpha' N P Q P tau0).
  assert(R: alpha' \notin (T.fv tau)).
  auto.

  apply punt with (d:= d) (alpha':=alpha') (k:= k) (k':= A); try assumption.
Admitted.

Lemma A_4_Useless_Substitutions_2:
  forall alpha d g,
    alpha \notin dom d ->
    WFDG d g ->
    forall tau,
      EnvOps.map (fun tau' =>  (T.subst tau alpha tau')) g = g.
Proof.
  introv NI WFDGd.
  induction WFDGd.
  intros.
  rewrite* map_empty.
  intros.
  rewrite map_push.
  rewrite* IHWFDGd.
  rewrite A_4_Useless_Substitutions_1 with (d:=d) (k:=A); auto.
Qed.

(* This formulation builds a useless induction principle. *)
(* A formulation of the theorem as above is necessary. *)
Lemma A_4_Useless_Substitutions_3:
  forall u,
    WFU u ->
    forall tau alpha,
      LVPE.V.map (fun tau' => (T.subst tau alpha tau')) u = u.
Proof.
  introv WFUd.
  induction WFUd; intros.
  rewrite* LVPE.map_empty.

  rewrite LVPE.map_push.
  rewrite IHWFUd.
  rewrite A_4_Useless_Substitutions_1 with (d:= empty) (k:=A); auto.
Qed.

Lemma subst_var:
  forall t1 v,
    T.subst t1 v (ftvar v) = t1.
Proof.
  intros; simpl; case_var*.
Qed.

Lemma A_5_Commuting_Substitutions:
  forall beta t2,
    beta \notin T.fv t2 ->
    forall t0 t1 alpha,
      (T.subst t2 alpha (T.subst t1 beta t0)) =
      (T.subst (T.subst t2 alpha t1) beta (T.subst t2 alpha t0)).
Proof.
  induction t0; intros; try solve[auto]; try solve[simpl;try case_var*; fequals*].
  admit. (* Var case wrong? Theorem wrong? *)
Qed.

Require Export Coq.Program.Equality.

(* Dependent induction does OK but it puts me into JMeq which I'd rather avoid,
 and has to have functional equivalence of environments. *)
Lemma A_6_Subsititution_JMeq:
  forall d t k,
    AK d t k ->
    forall alpha t' k',
      K (d & alpha ~ k) t' k' ->
      K d (T.subst t alpha t') k'.
Proof.
  introv AKd Kd.
  dependent induction Kd;
    try solve[simpl; auto; try apply K_cross; try apply K_arrow;
              try applys* IHKd1;
              try applys* IHKd2].
  simpl.
  case_var.
  rewrite get_push in H.
  case_var.
  inversion H.
  inversions* AKd.
  inversion H4.
  apply K_B.
  (* What's my automation?*)
  rewrite get_push in H.
  case_var*.

  admit.
  admit.

  simpl.
  apply_fresh K_utype; intros.
  assert(NI: y \notin L); auto.
  assert(D: ok (d & alpha ~ k & y ~ k0)).
  admit.
  assert(AK': AK (d & y ~ k0) t k).
  admit.
  assert(Q:  d & alpha ~ k & y ~ k0 ~= d & y ~ k0 & y ~ k).
  admit. (* doubtful *)
  lets SOV: TP.subst_open_var alpha y.
  rewrite <- SOV.
  specialize (H0 y NI D (d & y ~ k0) k AK' alpha).
  apply H0.
  (* Works but modulo JMeq on misordered d, which is functionally equivalent. *)
Admitted.

(* Trying specialized induction schema, but going to prove the general one first. *)

Lemma K_ind_proven:
  forall P : Delta -> Tau -> Kappa -> Prop,
    (forall d : Delta, P d cint B) ->
    (forall (d : Delta) (alpha : var), get alpha d = Some B -> P d (ftvar alpha) B) ->
    (forall (d : Delta) (alpha : var),
        get alpha d = Some A -> P d (ptype (ftvar alpha)) B) ->
    (forall (d : Delta) (t0 t1 : Tau),
        K d t0 A -> P d t0 A -> K d t1 A -> P d t1 A -> P d (cross t0 t1) A) ->
    (forall (d : Delta) (t0 t1 : Tau),
        K d t0 A -> P d t0 A -> K d t1 A -> P d t1 A -> P d (arrow t0 t1) A) ->
    (forall (d : Delta) (tau : Tau), K d tau A -> P d tau A -> P d (ptype tau) B) ->
    (forall (L : vars) (d : Delta) (k : Kappa) (tau : Tau),
        (forall alpha : var,
            alpha \notin L ->
            ok (d & alpha ~ k) -> K (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau) A) ->
        (forall alpha : var,
            alpha \notin L ->
            ok (d & alpha ~ k) -> P (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau) A) ->
        P d (utype k tau) A) ->
    (forall (L : vars) (d : Delta) (k : Kappa) (tau : Tau) (p : Phi),
        (forall alpha : var,
            alpha \notin L ->
            ok (d & alpha ~ k) -> K (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau) A) ->
        (forall alpha : var,
            alpha \notin L ->
            ok (d & alpha ~ k) -> P (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau) A) ->
        P d (etype p k tau) A) ->
    (forall (d : Delta) (tau : Tau), K d tau B -> P d tau B -> P d tau A) ->
    forall (d : Delta) (t : Tau) (k : Kappa), K d t k -> P d t k.
Proof.
  intros.
  induction H8; auto.
  pick_fresh alpha.
  applys* H5.
  pick_fresh alpha.
  applys* H6.
Qed.

Lemma K_dep_ind:
  forall P : Delta -> Tau -> Kappa -> var -> Kappa -> Prop,
    (forall (d : Delta) beta k',
         P d cint B beta k') ->
    forall (d : Delta) (t : Tau) (k : Kappa),
      AK d t k ->
      forall beta k',
        K (d & beta ~ k) t k' -> P d t k' beta k.
Proof.
Admitted.

(* Does not work inside the induction hypotheses. *)
Lemma tst:
  forall d' d t alpha k,
    AK d t k ->
    d' = (d & alpha ~ k) ->
    forall t',
      K d' t' k ->
      K d t' k.
Proof.
  introv AKd d'd Kd.
  induction Kd.
  Focus 7.
Admitted.

Check K_ind.

(* I'm just not buying that this should be so hard. *)
Lemma K_dep_ind2:
  forall P : Delta -> Tau -> Kappa -> var -> Kappa -> Prop,
    (forall (d : Delta) t t' k beta k',
      AK d t k ->
      K (d & beta ~ k) t' k' ->
      P d cint B beta k') ->
    (forall (d : Delta) (alpha : var) beta k',
        get alpha d = Some B ->
        P d (ftvar alpha) B beta k') ->
    forall (d : Delta) (t : Tau) (k : Kappa),
      AK d t k ->
      forall beta k',
        K (d & beta ~ k) t k' ->
        P d t k' beta k.
Proof.
Admitted.

(* Also failing as d' is larger because I am not
  substituting everything in.
Lemma A_6_Subsititution_ind3:
  forall d t k,
      AK d t k ->
      forall d',
        extends d d' ->
        forall t' k',
          K d' t' k' ->
          forall alpha,
          K d (T.subst t alpha t') k'.
Proof.
  introv AKd Ed Kd.
  induction Kd; intros; auto.
  simpl; case_var.
Admitted.
*)

Function P d t (k : Kappa) alpha k':=
  forall t',
    K d (T.subst t alpha t') k'.

Lemma A_6_Subsititution_ind2:
  forall d t k alpha k',
      AK d t k ->
        forall t',
          K (d & alpha ~ k) t' k' ->
          K d (T.subst t alpha t') k'.
Proof.
  introv AKd Kd.
(*  apply (K_dep_ind2  P). *)
Admitted.

Lemma K_dep_ind3:
  forall P : Delta -> Tau -> Kappa -> var -> Tau -> Kappa -> Prop,
    (forall d beta t' k',
         P d cint B beta t' k') ->
    (forall d alpha beta t' k',
        get alpha d = Some A -> P d (ptype (ftvar alpha)) B beta t' k') ->
    (forall (d : Delta) beta t' k' (alpha : var),
        get alpha d = Some B ->
        P d (ftvar alpha) B beta t' k') ->
    (forall d t0 t1 beta t' k',
        K d t0 A -> P d t0 A beta t' k'->
        K d t1 A -> P d t1 A beta t' k'-> P d (cross t0 t1) A beta t' k') ->
    (forall d t0 t1 beta t' k',
        K d t0 A -> P d t0 A beta t' k'->
        K d t1 A -> P d t1 A beta t' k'-> P d (arrow t0 t1) A beta t' k') ->
    (forall d tau beta t' k',
        K d tau A -> P d tau A beta t' k' -> P d (ptype tau) B beta t' k') ->
    (forall (L : vars) (d : Delta) (k : Kappa) (tau : Tau) beta t' k',
        (forall alpha : var,
            alpha \notin L ->
            ok (d & alpha ~ k) ->
            K (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau) A) ->
        (forall alpha : var,
            alpha \notin L ->
            ok (d & alpha ~ k) ->
            P (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau) A beta t' k') ->
        P d (utype k tau) A beta t' k') ->
    (forall (L : vars) (d : Delta) (k : Kappa) (tau : Tau) (p : Phi) beta t' k',
        (forall alpha : var,
            alpha \notin L ->
            ok (d & alpha ~ k) ->
            K (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau) A) ->
        (forall alpha : var,
            alpha \notin L ->
            ok (d & alpha ~ k) ->
            P (d & alpha ~ k) (T.open_rec 0 (ftvar alpha) tau) A beta t' k') ->
        P d (etype p k tau) A beta t' k') ->
    (forall d tau beta t' k', K d tau B -> P d tau B beta t' k' -> P d tau A beta t' k') ->
    forall (d : Delta) (t : Tau) (k : Kappa),
       K d t k ->
       forall t' k' k'' beta,
        K (d & beta ~ k) t' k' ->
        P d t k'' beta t' k'.
Proof.
  introv P H0 H1 H2 H3 H4 H5 H6 H7.
  intros d t k Kd.
  induction Kd; intros.
  admit.
  admit.
  admit.
  admit.
  admit.
  (* case ptype tau *)
  assert(FOO: P0 d (ptype tau) B beta t' k').
  apply* H4.
  apply* IHKd.
  (* but beta B vs beta A in the context issue. *)
(*
(* can solve binding cases. *)
  pick_fresh alpha.
  applys H5; intros.
  assert(NI: alpha \notin L); auto.
  apply* H8.
  apply* H10.
  admit. (* K weakening. *)

  skip.

  apply* H7.
  apply* IHK.
  admit. (* B_A conversion of some type. *)

  apply H7.
*)
Admitted.

(* Works bug fugly, custom induction keeping AK around.  *)
Lemma A_6_Subsititution_ind3:
  forall d t k,
      AK d t k ->
      forall alpha t' k',
        K (d & alpha ~ k) t' k' ->
        K d (T.subst t alpha t') k'.
Proof.
  Function P3 d t (k : Kappa):=
      AK d t k ->
      forall alpha t' k',
        K (d & alpha ~ k) t' k' ->
        K d (T.subst t alpha t') k'.
(* Works
  lets I: K_dep_ind3.
  specialize (I P3).
  apply I.
  unfold P3.
*)
(*
  apply (K_dep_ind3 P3); unfold P3 in *; auto; intros.
  Focus 3.
  (* non-axiom case = non simple, done by induction on t' *)
  induction t'0; auto.

  assert(NIE: alpha \notin L). admit.
  assert(OK: ok (d0 & alpha ~k0)). admit.
  specialize (H alpha NIE OK).
  apply AK_AK_K in H.
  assert(KWeakend: K (d0 & alpha ~ k0 & beta ~ A) (btvar n) k'0). admit.
  (* from H2 and alpha # *)
  specialize (H0 alpha NIE OK H KWeakend).
  simpl.
  simpl in H0.

  SearchAbout(_ -> K _ _ _).
  admit. (* K strengthening *)
  (* not sure I can prove things but its interesting. *)
  assert(NIE: alpha \notin L). admit.
  assert(OK: ok (d0 & alpha ~k0)). admit.
  specialize (H alpha NIE OK).
  apply AK_AK_K in H.
  assert(KWeakend: K (d0 & alpha ~ k0 & beta ~ A) (ftvar v) k'0). admit.
  (* from H2 and alpha # *)
  specialize (H0 alpha NIE OK H KWeakend).
  simpl.
  case_var.
  simpl in H0.
  case_var.
  admit. (* not sure *)
  simpl in H0.
  case_var.
  admit. (* From H0 strengthend free. *)

*)

(*
 Is this really nested induction AK -> K ? NO.

Lemma A_6_Subsititution_nested_induction:
  forall d t k,
      AK d t k ->
      forall alpha t' k',
        K (d & alpha ~ k) t' k' ->
        K d (T.subst t alpha t') k'.
Proof.
  introv AKd.
  induction AKd; introv Kd.
induction Kd; intros.
  admit.
  (* No loss of K d/d0 again. *)
*)
Admitted.

Check K_ind.

(* This remembers the d connection but one of the IH requires a false assumption. *)
Lemma A_6_Subsititution_4:
  forall d t k,
      AK d t k ->
      forall alpha t' k',
        K (d & alpha ~ k) t' k' ->
        K d (T.subst t alpha t') k'.
Proof.
  introv AKd Kd.
  inversions AKd.
  remember (d & alpha ~ k) as d'.
  induction Kd; subst; auto.
  admit.
  admit.
  simpl.
  apply_fresh K_utype; intros.
  assert(NI: y \notin L); auto.
  assert(OK: ok (d & alpha ~ k & y ~ k0)). admit.
  specialize (H0 y NI OK).
  SearchAbout (T.open_rec _ _ (T.subst _ _ _)).
  rewrite <- TP.subst_open_var.
Admitted.

(* No, alpha ~ k lost. *)

Lemma A_6_Subsititution_5:
  forall d t k,
      AK d t k ->
      forall alpha t' k',
        extends d (d & alpha ~k) ->
        K (d & alpha ~ k) t' k' ->
        K d (T.subst t alpha t') k'.
Proof.
  introv AKd E Kd.
  remember (d & alpha ~ k) as d'.
  inversions AKd.
  induction Kd; subst; auto.
Admitted.

Inductive extends1 : Delta -> var -> Kappa -> Delta -> Prop :=
  | extends_1:
      forall alpha k d d',
        d = d' ->
        extends1 d alpha k (d' & alpha ~ k).

Lemma A_6_Subsititution_6:
  forall d t k,
      AK d t k ->
      forall alpha d',
        extends1 d alpha k d' ->
        forall  t' k',
          K d' t' k' ->
          K d (T.subst t alpha t') k'.
Proof.
  introv AKd Ed Kd.
  induction Kd; auto.
  admit.
  admit.
  inversions Ed.
  (* Where is extends1 d' alpha k (d' & alpha ~ k & alpha1 ~ k0)  in utype/etype
   coming from? It's not in the K definition so it's in K_ind.*)
Admitted.

Section GetProperties.
Variable A B' : Type.
Implicit Types E F : env A.
Implicit Types x : var.
Implicit Types v : A.

(** Constructor forms *)

Lemma get_empty_inv : forall x v,
  get x empty = Some v -> False.
Proof using.
  introv H. rewrite get_empty in H. false.
Qed.

Lemma get_single_eq : forall x v,
  get x (x ~ v) = Some v.
Proof using.
  intros.  rewrite get_single. case_if~.
Qed.

Lemma get_single_inv : forall x1 x2 v1 v2,
  get x1 (x2 ~ v2) = Some v1 ->
  x1 = x2 /\ v1 = v2.
Proof using.
   introv H. rewrite get_single in H.
  case_if; inversions~ H.
Qed.

Lemma get_push_inv : forall x1 v1 x2 v2 E,
  get x1 (E & x2 ~ v2) = Some v1 ->
     (x1 = x2 /\ v1 = v2)
  \/ (x1 <> x2 /\ get x1 E = Some v1).
Proof using.
  introv H.  rewrite get_push in H. case_if.
  inverts~ H. auto.
Qed.

Lemma get_push_eq : forall x v E,
  get x (E & x ~ v) = Some v.
Proof using. intros.  rewrite get_push. case_if~. Qed.

Lemma get_push_eq_inv : forall x v1 v2 E,
  get x (E & x ~ v2) = Some v1 -> v1 = v2.
Proof using.
  introv H. forwards [|]: get_push_inv H. autos*. intros [? _]. false.
Qed.

Lemma get_push_neq_inv : forall x1 x2 v1 v2 E,
  get x1 (E & x2 ~ v2) = Some v1 -> x1 <> x2 -> get x1 E = Some v1.
Proof using.
  introv H. forwards [|]: get_push_inv H.
  intros [? ?] ?. false. autos*.
Qed.

Lemma get_tail : forall x v E,
  get x (E & x ~ v) = Some v.
Proof using. intros. rewrite get_push. cases_if~. Qed.

Lemma get_push_neq : forall x1 x2 v1 v2 E,
  get x1 E = Some v1 -> x1 <> x2 -> get x1 (E & x2 ~ v2) = Some v1.
Proof using.
  introv H N.  rewrite get_push. case_if~.
Qed.

Lemma get_concat_inv : forall x v E1 E2,
  get x (E1 & E2) = Some v ->
     (get x E2 = Some v)
  \/ (x # E2 /\ get x E1 = Some v).
Proof using.
  introv H. induction E2 using env_ind.
  rewrite~ concat_empty_r in H.
  rewrite concat_assoc in H.
   forwards [[? ?]|[? M]]: get_push_inv H.
     subst. left. apply get_tail.
     forwards [?|[? ?]]: IHE2 M.
       left. applys~ get_push_neq.
       right.
       auto.
Qed.

(* Typing env vs list issues.
Lemma get_map : forall x v (f : A -> B) E,
  get x E = Some v -> get x (map f E) = Some (f v).
Proof using.
  introv H.  rew_env_defs.
  induction E as [|[x' v'] E']; simpls.
  false.
  cases_if~. inverts~ H.
Qed.
*)

Lemma get_func : forall x v1 v2 E,
  get x E = Some v1 -> get x E = Some v2 -> v1 = v2.
Proof using.
  introv H1 H2.
  induction E as [|E' x' v'] using env_ind.
  rewrite get_empty in H1. false.
  rewrite get_push in H1,H2. case_if~.
   inverts H1. inverts~ H2.
Qed.

Lemma get_fresh_inv : forall x v E,
  get x E = Some v -> x # E -> False.
Proof using.
  introv H F.
  induction E as [|E' x' v'] using env_ind.
  rewrite get_empty in H. false.
  rewrite get_push in H. case_if~. subst.
   simpl_dom; notin_false.
Qed.

(** Derived forms *)

Lemma get_single_eq_inv : forall x v1 v2,
  get x (x ~ v2) = Some v1 ->
  v1 = v2.
Proof using.
  introv H. rewrite get_single in H.
  case_if. inverts~ H.
Qed.

Lemma get_concat_left : forall x v E1 E2,
  get x E1 = Some v ->
  x # E2 ->
  get x (E1 & E2) = Some v.
Proof using.
  introv H F. induction E2 using env_ind.
  rewrite~ concat_empty_r.
  rewrite concat_assoc.
  applys~ get_push_neq.
  subst.
  simpl_dom.
  apply notin_union in F.
  inversion F.
  apply notin_same in H0.
  inversion H0.
Qed.

Lemma get_concat_left_ok : forall x v E1 E2,
  ok (E1 & E2) ->
  get x E1 = Some v ->
  get x (E1 & E2) = Some v.
Proof using.
  introv O H. induction E2 using env_ind.
  rewrite~ concat_empty_r.
  rewrite concat_assoc in O|-*. lets [_ ?]: ok_push_inv O.
  applys~ get_push_neq. subst. applys~ get_fresh_inv H.
Qed.

Lemma get_concat_left_inv : forall x v E1 E2,
  get x (E1 & E2) = Some v ->
  x # E2 ->
  get x E1 = Some v.
Proof using.
  introv H F. lets~ [M|[? ?]]: get_concat_inv H.
    false. applys~ get_fresh_inv M.
Qed.

Lemma get_concat_right : forall x v E1 E2,
  get x E2 = Some v ->
  get x (E1 & E2) = Some v.
Proof using.
  introv H. induction E2 using env_ind.
  Check get_empty_inv.
  false. apply get_empty_inv with (x:=x) (v:=v); auto.
  rewrite concat_assoc. lets [[? ?]|[? ?]]: get_push_inv H.
    subst. applys get_tail.
    applys* get_push_neq.
Qed.

Lemma get_concat_right_inv : forall x v E1 E2,
  get x (E1 & E2) = Some v ->
  x # E1 ->
  get x E2 = Some v.
Proof using.
  introv H F. lets~ [?|[? M]]: get_concat_inv H.
    false. applys~ get_fresh_inv M.
Qed.

Lemma get_middle_eq : forall x E1 E2 v,
  x # E2 ->
  get x (E1 & x ~ v & E2) = Some v.
Proof using.
  introv F. applys~ get_concat_left.
Qed.

(** Metatheory proof forms *)

(** Interaction between binds and the insertion of bindings.
  In theory we don't need this lemma since it would suffice
  to use the get_cases tactics, but since weakening is a
  very common operation we provide a lemma for it. *)

Lemma get_weaken : forall x a E F G,
  get x (E & G) = Some a -> ok (E & F & G) ->
  get x (E & F & G) = Some a.
Proof using.
  introv H O. lets [?|[? ?]]: get_concat_inv H.
    applys~ get_concat_right.
    applys~ get_concat_left. applys~ get_concat_left_ok.
Qed.

Lemma get_remove : forall E2 E1 E3 x v,
  get x (E1 & E2 & E3) = Some v ->
  x # E2 ->
  get x (E1 & E3) = Some v.
Proof using.
  introv H F. lets [?|[? M]]: get_concat_inv H.
    applys~ get_concat_right.
    forwards: get_concat_left_inv M; auto.
    applys~ get_concat_left.
Qed.

Lemma get_subst : forall x2 v2 x1 v1 E1 E2,
  get x1 (E1 & x2 ~ v2 & E2) = Some v1 ->
  x1 <> x2 ->
  get x1 (E1 & E2) = Some v1.
Proof using.
  introv H N.
  applys~ get_remove H.
  unfolds.
  rewrite dom_single.
  rewrite in_singleton.
  assumption.
Qed.

Lemma get_middle_eq_inv : forall x E1 E2 v1 v2,
  get x (E1 & x ~ v2 & E2) = Some v1 ->
  ok (E1 & x ~ v2 & E2) ->
  v1 = v2.
Proof using.
  introv H O. lets [? ?]: ok_middle_inv O.
  forwards~ M: get_concat_left_inv H.
  applys~ get_push_eq_inv M.
Qed.

Lemma get_middle_inv : forall x1 v1 x2 v2 E1 E2,
  get x1 (E1 & x2 ~ v2 & E2) = Some v1 ->
     (get x1 E2 = Some v1)
  \/ (x1 # E2 /\ x1 = x2 /\ v1 = v2)
  \/ (x1 # E2 /\ x1 <> x2 /\ get x1 E1 = Some v1).
Proof using.
  introv H. lets [?|[? M]]: (get_concat_inv H).
    left~.
    right. lets [N|[? N]]: (get_concat_inv M).
      lets [? ?]: (get_single_inv N). subst~.
      right. simpl_dom. split~.
      apply notin_singleton in H1.
      contradiction.
Qed.

Lemma get_not_middle_inv : forall x v E1 E2 E3,
  get x (E1 & E2 & E3) = Some v ->
  x # E2 ->
     (get x E3 = Some v)
  \/ (x # E3 /\ get x E1 = Some v).
Proof using.
  introv H F. lets [?|[? M]]: (get_concat_inv H).
    left~.
    right. forwards~ N: (get_concat_left_inv M).
Qed.

Lemma fv_in_values_binds : forall y fv x v E,
  get x E = Some v -> y \notin fv_in_values fv E -> y \notin fv v.
Proof using.
  unfold fv_in_values. introv H.
  induction E using env_ind; introv M.
  false. apply get_empty_inv with (x:= x) (v:= v); auto.
  rewrite values_def in M,IHE.
  rewrite concat_def, single_def in M. rew_list in M. simpl in M.
  lets [[? ?]|[? ?]]: (get_push_inv H); subst~.
Qed.

End GetProperties.

Lemma ok_commutes:
forall A (E : env A) F G,
  ok (E & F & G) = ok (E & (F & G)).
Admitted.

Lemma K_context_commutes:
forall E F G tau k,
  K (E & F & G) tau k = K (E & (F & G)) tau k.
Admitted.

Lemma K__lc:
  forall d t k,
    K d t k ->
    T.lc t.
Admitted.

Lemma A_6_Subsititution_7:
  forall d d' t k,
      ok (d & d') ->
      K (d & d') t k ->
      forall alpha t' k',
        ok (d & alpha ~ k & d') ->
        K (d & alpha ~ k & d') t' k' ->
        K (d & d')  (T.subst t alpha t') k'.
Proof.
  introv okdd' Kd okdakd' Kdakd'.
  gen_eq G: (d & alpha ~ k & d'). gen d'.
  induction Kdakd'; intros; subst; auto.
  simpl.
  case_var.
  apply get_middle_eq_inv in H; subst; auto.
  apply get_subst in H; subst; auto.

  simpl.
  case_var.
  apply K_ptype.
  (* yes k is A! *)
  admit.
  apply K_star_A.
  admit.

  apply get_middle_eq_inv in H; subst; auto.
  apply get_subst in H; subst; auto.

  simpl.
  apply_fresh K_utype.
  intros.
  assert(NI: y \notin L). admit.
  assert(OKB: ok (d & alpha ~ k & d' & y ~ k0)). admit.
  specialize (H y NI OKB).
  specialize (H0 y NI OKB OKB (d' & y ~ k0)).
  rewrite <- ok_commutes in H0.
  rewrite <- K_context_commutes in H0.
  rewrite <- K_context_commutes in H0.
  assert(KW: K (d & d' & y ~ k0) t k). admit. (* k weakening *)
  assert(CC: d & alpha ~ k & d' & y ~ k0 = d & alpha ~ k & (d' & y ~ k0)). admit.
  (* contexts commute, meta theorem I must accept. *)
  specialize (H0 H1 KW CC).
  rewrite* <- TP.subst_open_var.
  apply K__lc with (d:= (d&d')) (k:=k); auto.
  apply K_B_A.
  apply* IHKdakd'.
Qed.


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

From QArithSternBrocot Require Export Qpositive_sub.

Inductive Q : Set :=
  | Zero : Q
  | Qpos : Qpositive -> Q
  | Qneg : Qpositive -> Q.

Definition Qone := Qpos One.

Definition Qpositive_le_dec :
  forall w w' : Qpositive, {Qpositive_le w w'} + {~ Qpositive_le w w'}.
intros w w'; unfold Qpositive_le in |- *; case (Qpositive_le_bool w w'); auto.
Defined.

Ltac Case' f :=
  match constr:(f) with
  | (Qpositive_le_dec ?X1 ?X2) =>
      case f;
       [ idtac
       | intros Dummy;
          generalize (not_Qpositive_le_not_eq _ _ Dummy)
           (not_Qpositive_le_Qpositive_le' _ _ Dummy) Dummy;
          clear Dummy ]
  | _ => case f
  end.

Definition Qpositive_eq_dec : forall w w' : Qpositive, {w = w'} + {w <> w'}.
intros w; elim w; intros until w'; case w';
 try (auto; right; discriminate; fail);
 (intros w'1; elim (H w'1);
   [ intros H1; left; rewrite H1; auto
   | intros H1; right; red in |- *; intros H2; elim H1; injection H2; auto ]).
Defined.

Definition Qplus (x y : Q) :=
  match x, y with
  | Qpos x', Qpos y' => Qpos (Qpositive_plus x' y')
  | Qpos x', Qneg y' =>
      match Qpositive_le_dec x' y' with
      | left h =>
          match Qpositive_eq_dec x' y' with
          | left h => Zero
          | right h => Qneg (Qpositive_sub y' x')
          end
      | right h => Qpos (Qpositive_sub x' y')
      end
  | Qneg x', Qneg y' => Qneg (Qpositive_plus x' y')
  | Qneg x', Qpos y' =>
      match Qpositive_le_dec x' y' with
      | left h =>
          match Qpositive_eq_dec x' y' with
          | left h => Zero
          | right h => Qpos (Qpositive_sub y' x')
          end
      | right h => Qneg (Qpositive_sub x' y')
      end
  | Qneg x', Zero => Qneg x'
  | Qpos x', Zero => Qpos x'
  | Zero, x => x
  end.

Definition Qmult (x y : Q) :=
  match x, y with
  | Qpos x', Qpos y' => Qpos (Qpositive_mult x' y')
  | Qpos x', Qneg y' => Qneg (Qpositive_mult x' y')
  | Qneg x', Qpos y' => Qneg (Qpositive_mult x' y')
  | Qneg x', Qneg y' => Qpos (Qpositive_mult x' y')
  | _, _ => Zero
  end.

Definition Qopp (x : Q) :=
  match x with
  | Zero => Zero
  | Qpos x' => Qneg x'
  | Qneg x' => Qpos x'
  end.

Theorem Qplus_sym : forall a b : Q, Qplus a b = Qplus b a.
intros a b; case a; case b; simpl in |- *; auto;
 try
  (intros a' b';
    apply f_equal with (f := Qpos) || apply f_equal with (f := Qneg);
    apply Qpositive_plus_sym).
intros b' a'; case (Qpositive_le_dec a' b').
case (Qpositive_eq_dec a' b').
case (Qpositive_le_dec b' a').
case (Qpositive_eq_dec b' a').
auto.
intros H; intros; elim H; auto.
intros H H1; intros; elim H; rewrite H1; apply Qpositive_le_refl.
case (Qpositive_le_dec b' a').
case (Qpositive_eq_dec b' a').
intros H H1 H2; elim H2; auto.
intros H; intros; elim H; apply Qpositive_le_antisym; auto.
auto.
case (Qpositive_le_dec b' a').
case (Qpositive_eq_dec b' a').
intros H H1 H2; elim H2; rewrite H; apply Qpositive_le_refl.
auto.
intros H1 H2; elim (Qpositive_le_total a' b'); intros H3;
 (elim H1; exact H3) || (elim H2; exact H3).
intros b' a'; case (Qpositive_le_dec a' b'); case (Qpositive_le_dec b' a').
intros H H1; case (Qpositive_eq_dec a' b').
case (Qpositive_eq_dec b' a'); auto.
intros H2 H3; elim H2; auto.
intros H2; elim H2; apply Qpositive_le_antisym; auto.
case (Qpositive_eq_dec a' b'); intros H H1 H2.
elim H1; rewrite H; apply Qpositive_le_refl.
auto.
case (Qpositive_eq_dec b' a').
intros H H1 H2; elim H2; rewrite H; apply Qpositive_le_refl.
auto.
elim (Qpositive_le_total a' b'); intros H;
 repeat (intros Dummy; try (elim Dummy; auto; fail); clear Dummy).
Qed.

Theorem Qplus_zero_left : forall n : Q, Qplus Zero n = n.
intros n; case n; auto.
Qed.

Theorem add_sub_le1 :
 forall a b c : Qpositive,
 a <> b ->
 Qpositive_le b a ->
 Qpositive_le (Qpositive_sub a b) c -> Qpositive_le a (Qpositive_plus b c).
intros a b c H H0 H1.
rewrite <- (Qpositive_sub_correct2 a b); auto.
rewrite (Qpositive_plus_sym b).
apply Qpositive_le_add.
auto.
Qed.

Theorem add_sub_le2 :
 forall a b c : Qpositive,
 a <> b ->
 Qpositive_le b a ->
 Qpositive_le a (Qpositive_plus b c) -> Qpositive_le (Qpositive_sub a b) c.
intros a b c H H1 H2; rewrite <- (Qpositive_sub_correct c b).
apply Qpositive_le_sub_r; auto with *.
rewrite Qpositive_plus_sym; apply sym_not_equal; apply Qpositive_plus_diff.
rewrite Qpositive_plus_sym; apply Qpositive_plus_le.
rewrite Qpositive_plus_sym; auto.
Qed.

Theorem add_sub_eq1 :
 forall a b c : Qpositive, a = Qpositive_plus b c -> Qpositive_sub a b = c.
intros a b c H; rewrite H; rewrite Qpositive_plus_sym;
 rewrite Qpositive_sub_correct; auto.
Qed.

Theorem add_sub_eq2 :
 forall a b c : Qpositive,
 a <> b ->
 Qpositive_le b a -> c = Qpositive_sub a b -> Qpositive_plus b c = a.
intros a b c H H0 H1; rewrite H1; rewrite Qpositive_plus_sym;
 rewrite Qpositive_sub_correct2; auto with *.
Qed.

Theorem Qplus_assoc_two_neg :
 forall (n : Q) (m' p' : Qpositive),
 Qplus n (Qplus (Qneg m') (Qneg p')) = Qplus (Qplus n (Qneg m')) (Qneg p').
intros n; case n.

(* Focus 1 *)
intros; repeat rewrite Qplus_zero_left; auto.
(* Focus 2 *)
simpl in |- *; intros n' m' p'.
Case' (Qpositive_le_dec n' (Qpositive_plus m' p')).
case (Qpositive_eq_dec n' (Qpositive_plus m' p')).
Case' (Qpositive_le_dec n' m').
case (Qpositive_eq_dec n' m').
intros e q e0; elim (Qpositive_plus_diff n' p').
pattern n' at 2 in |- *; rewrite e; auto.
intros n0 q e q0; elim n0; apply Qpositive_le_antisym; auto.
rewrite e; apply Qpositive_plus_le.
intros H H0 H1 e q; simpl in |- *.
Case' (Qpositive_le_dec (Qpositive_sub n' m') p').
case (Qpositive_eq_dec (Qpositive_sub n' m') p'); auto with *.
rewrite e; intros H2; elim H2.
rewrite Qpositive_plus_sym; rewrite Qpositive_sub_correct; auto.
rewrite e; intros H2; elim H2.
rewrite Qpositive_plus_sym; rewrite Qpositive_sub_correct; auto.
Case' (Qpositive_le_dec n' m').
case (Qpositive_eq_dec n' m').
simpl in |- *.
rewrite Qpositive_plus_sym.
intros e q n0 q0; rewrite e; rewrite Qpositive_sub_correct; auto with *.
simpl in |- *.
intros; rewrite Qpositive_plus_sub_assoc; auto.
simpl in |- *.
Case' (Qpositive_le_dec (Qpositive_sub n' m') p').
case (Qpositive_eq_dec (Qpositive_sub n' m') p').
intros e q H H0 H1 n0 q0; elim n0.
symmetry  in |- *; apply add_sub_eq2; auto with *.
intros; rewrite Qpositive_sub_sub_assoc; auto.
rewrite Qpositive_plus_sym; auto.
intros H H0 H3 H1 H2 H4 n0 q; elim H3.
apply add_sub_le2; auto.
Case' (Qpositive_le_dec n' m').
case (Qpositive_eq_dec n' m').
intros e q H H0 H1; elim H1; rewrite e; apply Qpositive_plus_le.
simpl in |- *.
intros n0 q H H0 H1; elim H1; apply Qpositive_le_trans with m'; auto with *.
apply Qpositive_plus_le.
simpl in |- *.
Case' (Qpositive_le_dec (Qpositive_sub n' m') p').
case (Qpositive_eq_dec (Qpositive_sub n' m') p').
intros e q H H0 H2 H1; elim H1.
symmetry  in |- *; apply add_sub_eq2; auto with *.
intros n0 q H H0 H3 H1 H2 H4; elim H4; apply add_sub_le1; auto with *.
intros; rewrite Qpositive_sub_sub_assoc_l; auto with *.

(* Focus 3 *)
intros m' n' p'; simpl in |- *.
rewrite Qpositive_plus_assoc; auto with *.
Qed.

Theorem Qplus_assoc_one_neg :
 forall n' m' p' : Qpositive,
 Qplus (Qpos n') (Qplus (Qpos m') (Qneg p')) =
 Qplus (Qplus (Qpos n') (Qpos m')) (Qneg p').
simpl in |- *; intros n' m' p'.
Case' (Qpositive_le_dec m' p').
intros Hle; case (Qpositive_eq_dec m' p').
intros Heq; Case' (Qpositive_le_dec (Qpositive_plus n' m') p').
intros Hle1.
elim (Qpositive_plus_diff p' n').
apply Qpositive_le_antisym.
apply Qpositive_plus_le.
generalize Hle1; rewrite Heq; rewrite Qpositive_plus_sym; auto.
intros H H0 H1; rewrite <- Heq.
rewrite Qpositive_sub_correct; auto.
Case' (Qpositive_le_dec n' (Qpositive_sub p' m')).
case (Qpositive_eq_dec n' (Qpositive_sub p' m')).
intros e q n0; Case' (Qpositive_le_dec (Qpositive_plus n' m') p').
case (Qpositive_eq_dec (Qpositive_plus n' m') p').
auto.
intros n1 q0.
elim n1; rewrite e.
rewrite Qpositive_sub_correct2; auto.
intros Hnot1 Hle' Hnot; elim Hnot; rewrite e.
rewrite Qpositive_sub_correct2; auto.
apply Qpositive_le_refl.
Case' (Qpositive_le_dec (Qpositive_plus n' m') p').
case (Qpositive_eq_dec (Qpositive_plus n' m') p').
intros e q n0 q0 n1.
elim n0.
rewrite <- e.
rewrite Qpositive_sub_correct; auto.
intros e q n0 q0 n1.
rewrite Qpositive_sub_sub_assoc_l; auto.
rewrite Qpositive_plus_sym; auto.
rewrite Qpositive_plus_sym; auto.
rewrite <- (Qpositive_sub_correct2 p' m'); auto.
rewrite (Qpositive_plus_sym m'); apply Qpositive_le_add; auto with *.
intros H H0 H1 n0 q n1.
elim n0; apply Qpositive_le_antisym; auto.
rewrite <- (Qpositive_sub_correct n' m').
apply Qpositive_le_sub_r; auto.
rewrite Qpositive_plus_sym; apply sym_not_equal; apply Qpositive_plus_diff.
rewrite Qpositive_plus_sym; apply Qpositive_plus_le.
Case' (Qpositive_le_dec (Qpositive_plus n' m') p').
case (Qpositive_eq_dec (Qpositive_plus n' m') p').
intros e q H H0 H1 n0.
elim H1; rewrite <- e; rewrite Qpositive_sub_correct; apply Qpositive_le_refl.
intros n0 q H H0 H1 n1.
elim H1.
rewrite <- (Qpositive_sub_correct n' m').
apply Qpositive_le_sub_r; auto with *.
apply sym_not_equal; rewrite Qpositive_plus_sym; apply Qpositive_plus_diff.
rewrite Qpositive_plus_sym; apply Qpositive_plus_le.
intros H H0 H3 H1 H2 H4 n0.
rewrite Qpositive_sub_sub_assoc; auto with *.
Case' (Qpositive_le_dec (Qpositive_plus n' m') p').
case (Qpositive_eq_dec (Qpositive_plus n' m') p').
intros e q H H0 H1.
elim H1.
rewrite <- e; rewrite Qpositive_plus_sym; apply Qpositive_plus_le.
intros n0 q H H0 H1.
elim H1.
apply Qpositive_le_trans with (Qpositive_plus n' m'); auto.
rewrite Qpositive_plus_sym; apply Qpositive_plus_le.
intros H H0 H3 H1 H2 H4.
rewrite Qpositive_plus_sym.
rewrite Qpositive_plus_sub_assoc; auto with *.
rewrite Qpositive_plus_sym; auto.
Qed.

Theorem Qplus_assoc_one_neg' :
 forall (n m : Q) (p' : Qpositive),
 Qplus n (Qplus m (Qneg p')) = Qplus (Qplus n m) (Qneg p').
intros n m; case m.
(* Focus 1 *)
intros; try rewrite <- (Qplus_sym Zero); repeat rewrite Qplus_zero_left;
 auto with *.
(* Focus 2 *)
case n.
(* 2.2 *)
2: intros n' m' p'; apply Qplus_assoc_one_neg.
intros m' p'; repeat rewrite Qplus_zero_left; auto.
intros n' m' p'.
repeat rewrite (Qplus_sym (Qneg n')).
repeat rewrite <- Qplus_assoc_two_neg.
repeat rewrite (Qplus_sym (Qneg n')).
auto.
(* Focus 3 *)
intros m' p'; apply Qplus_assoc_two_neg.
Qed.

Theorem Qplus_assoc :
 forall n m p : Q, Qplus n (Qplus m p) = Qplus (Qplus n m) p.
intros n m p; case p.
(* Focus 1 *)
intros; repeat rewrite <- (Qplus_sym Zero); repeat rewrite Qplus_zero_left;
 auto with *.
(* Focus 2 *)
intros p'; case m.
(* 2.1 *)
intros; try rewrite <- (Qplus_sym Zero); repeat rewrite Qplus_zero_left;
 auto with *.
(* 2.2 *)
intros m'; case n.
2: intros n'; simpl in |- *; rewrite Qpositive_plus_assoc; auto.
repeat rewrite Qplus_zero_left; auto.
intros n'; repeat rewrite (Qplus_sym (Qneg n'));
 repeat rewrite <- (Qplus_sym (Qpos p')).
rewrite Qplus_assoc_one_neg; auto.
(* 2.3 *)
intros m'; repeat rewrite <- (Qplus_sym (Qpos p')).
repeat rewrite Qplus_assoc_one_neg'.
rewrite (Qplus_sym n); auto.
(* Focus 3 *)
intros p'; apply Qplus_assoc_one_neg'.
Qed.


Require Import msl.base.
Require Import msl.ageable.
Require Import msl.sepalg.
Require Import msl.sepalg_generators.
Require Import msl.age_sepalg.
Require Import msl.predicates_hered.
Require Import msl.predicates_sl.
Require Import msl.subtypes.

Local Open Scope pred.

Lemma unfash_derives {A} `{agA : ageable A}:
  forall {P Q}, (P |-- Q) -> @derives A _ (! P) (! Q).
Proof.
intros. intros w ?. simpl in *. apply H. auto.
Qed.

Lemma subp_sepcon {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall G P P' Q Q',
  G |-- P >=> P' ->
  G |-- Q >=> Q' ->
  G |-- P * Q >=> P' * Q'.
Proof.
  pose proof I.
  repeat intro.
  specialize (H0 _ H2).
  specialize (H1 _ H2).
  clear G H2.
  destruct H5 as [w1 [w2 [? [? ?]]]].
  exists w1; exists w2; split; auto.
  split.
  eapply H0; auto.
  assert (level w1 = level a').
  apply comparable_fashionR.  eapply join_sub_comparable; eauto.
 apply necR_level in H4. omega.
  eapply H1; auto.
  assert (level w2 = level a').
  apply comparable_fashionR. eapply join_sub_comparable; eauto.
 apply necR_level in H4. omega.
Qed.

Lemma sub_wand {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall G P P' Q Q',
  G |-- P' >=> P ->
  G |-- Q >=> Q' ->
  G |-- (P -* Q) >=> (P' -* Q').
Proof.
  pose proof I.
  repeat intro.
  specialize (H0 _ H2); specialize (H1 _ H2); clear G H2; pose (H2:=True).
  eapply H0 in H8; try apply necR_refl.
  eapply H1; try apply necR_refl.
  apply necR_level in H4. apply necR_level in H6. apply join_comparable in H7.
  apply comparable_fashionR in H7. unfold fashionR in H7. omega.
  eapply H5; eauto.
  apply necR_level in H4. apply necR_level in H6.
   apply join_comparable2 in H7.
  apply comparable_fashionR in H7. unfold fashionR in H7. omega.
Qed.

Lemma find_superprecise {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
   forall Q, Q |-- EX P:_, P && !(P >=> Q) && !!superprecise (P).
Proof.
intros.
intros w ?.
exists (exactly w).
split; auto.
split; auto.
hnf; apply necR_refl.
intros w' ? w'' ? ?.
hnf in H2.
apply pred_nec_hereditary with w; auto.
do 3 red.
apply superprecise_exactly.
Qed.

Lemma sepcon_subp' {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A}:
  forall (P P' Q Q' : pred A) (st: nat),
    (P >=> P') st ->
    (Q >=> Q') st ->
    (P * Q >=> P' * Q') st.
Proof.
 pose proof I.
intros.
intros w' ? w'' ? [w1 [w2 [? [? ?]]]].
destruct (nec_join4 _ _ _ _ H4 H3) as [w1' [w2' [? [? ?]]]].
exists w1; exists w2; repeat split; auto.
eapply (H0 w1'); eauto.
simpl in *.
subst.
replace (level w1') with (level w'); auto.
symmetry; apply comparable_fashionR; eapply join_comparable; eauto.
eapply (H1 w2'); eauto.
replace (level w2') with (level w'); auto.
symmetry. apply comparable_fashionR.
eapply join_comparable; eauto.
Qed.

Lemma subp_refl'  {A} `{agA : ageable A} :  forall (Q: pred A) (st: nat), (Q >=> Q) st.
Proof.
intros.
intros ? ? ? ?; auto.
Qed.

Lemma subp_trans' {A} `{agA : ageable A}:
  forall (B C D: pred A) (w: nat), (B >=> C)%pred w -> (C >=> D)% pred w -> (B >=> D)%pred w.
Proof.
intros.
intros w' ? w'' ? ?.
eapply H0; eauto.
eapply H; eauto.
Qed.

Lemma andp_subp'  {A} `{agA : ageable A} :
 forall (P P' Q Q': pred A) (w: nat), (P >=> P') w -> (Q >=> Q') w -> (P && Q >=> P' && Q') w.
Proof.
intros.
intros w' ? w'' ? [? ?]; split.
eapply H; eauto.
eapply H0; eauto.
Qed.

Lemma allp_subp' {A} `{agA : ageable A}: forall T (F G: T -> pred A) (w: nat),
   (forall x,  (F x >=> G x) w) -> (allp (fun x:T => (F x >=> G x)) w).
Proof.
intros.
intro x; apply H; auto.
Qed.

Lemma pred_eq_e1 {A} `{agA : ageable A}: forall (P Q: pred A) w,
       ((P <=> Q) w -> (P >=> Q) w).
Proof.
intros.
intros w' ? w'' ? ?.
eapply H; eauto.
Qed.

Lemma pred_eq_e2 {A} `{agA : ageable A}: forall (P Q: pred A)  w,
     ((P <=> Q) w -> (Q >=> P) w).
Proof.
Proof.
intros.
intros w' ? w'' ? ?.
eapply H; eauto.
Qed.

Hint Resolve @sepcon_subp'.
Hint Resolve @subp_refl'.
Hint Resolve @andp_subp'.
Hint Resolve @allp_subp'.
Hint Resolve @derives_subp.
Hint Resolve @pred_eq_e1.
Hint Resolve @pred_eq_e2.

Lemma allp_imp2_later_e2 {B}{A}{agA: ageable A}:
   forall (P Q: B -> pred A) (y: B) ,
      (ALL x:B, |> P x <=> |> Q x) |-- |> Q y >=> |> P y.
Proof.
  intros.  intros w ?. specialize (H y). apply pred_eq_e2. auto.
Qed.
Lemma allp_imp2_later_e1 {B}{A}{agA: ageable A}:
   forall (P Q: B -> pred A) (y: B) ,
      (ALL x:B, |> P x <=> |> Q x) |-- |> P y >=> |> Q y.
Proof.
  intros.  intros w ?. specialize (H y). apply pred_eq_e1. auto.
Qed.

(*
Lemma subp_later {A} `{agA:  ageable A} (SS: natty A):
 forall (P Q: pred A), |> (P >=> Q) |-- |> P >=> |> Q.
Proof.
intros.
rewrite later_fash; auto.
apply fash_derives.
apply axiomK.
Qed.
*)

Lemma extend_unfash {A} {JA: Join A}{PA: Perm_alg A}{SA: Sep_alg A}{AG: ageable A}{XA: Age_alg A} : forall (P: pred nat), boxy extendM (! P).
Proof.
intros.
apply boxy_i; auto; intros.
unfold unfash in *.
simpl in H. destruct H.
hnf in H0|-*.
replace (level w') with (level w); auto.
apply comparable_fashionR.
eapply join_comparable; eauto.
Qed.

Hint Resolve @extend_unfash.

Lemma subp_unfash {A} `{Age_alg A}:
  forall (P Q : pred nat) (n: nat), (P >=> Q) n -> ( ! P >=> ! Q) n.
Proof.
intros.
intros w ?. specialize (H0 _ H1).
intros w' ? ?. apply (H0 _ (necR_level' H2)).
auto.
Qed.
Hint Resolve @subp_unfash.

Lemma unfash_sepcon_distrib:
        forall {T}{agT: ageable T}{JoinT: Join T}{PermT: Perm_alg T}{SepT: Sep_alg T}{AgeT: Age_alg T}
           (P: pred nat) (Q R: pred T),
               unfash P && (Q*R) = (unfash P && Q) * (unfash P && R).
Proof.
intros.
apply pred_ext.
intros w [? [w1 [w2 [? [? ?]]]]].
exists w1; exists w2; repeat split; auto.
apply join_level in H0. destruct H0.
hnf in H|-*. congruence.
apply join_level in H0. destruct H0.
hnf in H|-*. congruence.
intros w [w1 [w2 [? [[? ?] [? ?]]]]].
split.
apply join_level in H. destruct H.
hnf in H0|-*. congruence.
exists w1; exists w2; repeat split; auto.
Qed.


From Coq Require Export Ascii String NArith.
From stdpp Require Import gmap.

#[global] Open Scope N_scope.

Set Implicit Arguments.
Set Contextual Implicit.

(* Parsing *)

Declare Custom Entry edge.

Notation "'input' e1 .. en" := (cons e1 .. (cons en nil) ..)
  (at level 200, e1 custom edge, en custom edge).

Notation "x '-' y" := (x%string, y%string)
  (in custom edge at level 1, x constr at level 0, y constr at level 0).

Definition Input : Type := list (string * string).

Definition example : Input := input
"start"-"A"
"start"-"b"
"A"-"c"
"A"-"b"
"b"-"d"
"A"-"end"
"b"-"end"
.

(* Graphs *)

Section G.

Context (V : Type) `{Countable V}.

Definition graph : Type := gmap V (list V).

Definition add_edge (x y : V) (g : graph) : graph :=
  let alt ys := Some match ys with None => [y] | Some ys => (y :: ys) end in
  partial_alter alt x g.

Definition get_edges (x : V) (g : graph) : list V :=
  match lookup x g with
  | None => []
  | Some ys => ys
  end.

Definition adj_list (xs : list (V * V)) : graph :=
  fold_left (fun g '(x, y) => add_edge x y (add_edge y x g)) xs empty.

End G.

Arguments graph : clear implicits.
Arguments graph V {_ _}.

(* Recursion and memoization *)

Definition endo (X : Type) : Type := (X -> X).

Class Monad M : Type :=
  { ret : forall {A}, A -> M A
  ; bind : forall {A B}, M A -> (A -> M B) -> M B
  }.

Declare Scope monad_scope.
#[global] Open Scope monad_scope.

Notation "'let*' x ':=' u 'in' v" := (bind u (fun x => v)) (at level 200) : monad_scope.

Fixpoint traverse {M} `{Monad M} {A B} (f : A -> M B) (xs : list A) : M (list B) :=
  match xs with
  | [] => ret []
  | x :: xs =>
    let* y := f x in
    let* ys := traverse f xs in
    ret (y :: ys)
  end.

Record identity (A : Type) : Type := Mk_identity { run_identity : A }.

Instance Monad_identity : Monad identity :=
  {| ret _ x := Mk_identity x
  ;  bind _ _ u k := k (run_identity u)
  |}.

Fixpoint naive_fix (fuel : nat) {A R} (r0 : R) (gf : endo (A -> identity R)) : A -> R :=
  fun x =>
    run_identity (gf (fun x => Mk_identity match fuel with
        | O => r0
        | S fuel => naive_fix fuel r0 gf x
        end) x).

Record state (S A : Type) : Type := Mk_state { run_state : S -> S * A }.

Instance Monad_state {S} : Monad (state S) :=
  {| ret _ x := Mk_state (fun s => (s, x))
  ;  bind _ _ u k := Mk_state (fun s =>
       let '(s, x) := run_state u s in
       run_state (k x) s) |}.

Definition memom (A R : Type) `{Countable A} : Type -> Type := state (gmap A R).

Fixpoint _memo_fix (fuel : nat) {A R} `{Countable A}
  (r0 : R) (gf : endo (A -> state (gmap A R) R)) : A -> state (gmap A R) R :=
  fun x => Mk_state (fun s =>
    match lookup x s with
    | Some y => (s, y)
    | None =>
      let __memo_fix x := match fuel with O => ret r0 | S fuel => _memo_fix fuel r0 gf x end in
      let '(s, y) := run_state (gf __memo_fix x) s in
      (insert x y s, y)
    end).

Definition memo_fix (fuel : nat) {A R} `{Countable A}
  (r0 : R) (gf : endo (A -> state (gmap A R) R)) : A -> R :=
  fun x => snd (run_state (_memo_fix fuel r0 gf x) empty).

(* DFS *)

Definition isSome {A} (x : option A) :=
  match x with
  | Some _ => true
  | None => false
  end.

(* [gset] insertion (as [fun x s => union (singleton x) s]) is slow,
   so we redefine our own sets from maps which have fast [insert]. *)
Notation set X := (gmap X unit).
Notation insert_set x s := (insert x tt s).
Notation elem_set x s := (isSome (lookup x s)).

Notation v := string (only parsing).

Definition is_big (x : v) : bool :=
  match x with
  | ""%string => false
  | String c _ => ((N_of_ascii "A" <=? N_of_ascii c) && (N_of_ascii c <=? N_of_ascii "Z"))
  end.

Definition visit (x : v) (visited : set v) : option (set v) :=
  if is_big x then Some visited
  else if elem_set x visited then None
  else Some (insert_set x visited).

Definition start_from (x : v) : set v * v :=
  (insert_set x empty, x).

Definition sum_N (xs : list N) : N :=
  fold_left N.add xs 0.

Definition _count_paths {M} `{Monad M} {VISITED} (_visit : v -> VISITED -> option VISITED)
  (g : graph v) : endo (VISITED * v -> M N) := fun __count_paths '(visited, x) =>
  if String.eqb x "end" then ret 1 else
  let search x := match _visit x visited with
    | None => ret 0
    | Some visited => __count_paths (visited, x)
    end in
  let* ns := traverse search (get_edges x g) in
  ret (sum_N ns).

(* The maximum length can be up to twice the number of nodes, because we can revisit big nodes.
   An implicit assumption is that there are no adjacent big nodes, so a long path must consist
   of an alternation of big and small nodes, and each small node is visited once, hence the bound. *)
Definition count_paths (g : graph v) : N :=
  memo_fix (2 * size g) 0 (_count_paths visit g) (start_from "start").

Definition solve (xs : Input) : N :=
  count_paths (adj_list xs).

(* Compute solve example. *)

Definition visit2 (x : v) '((may_revisit, visited) : bool * set v) : option (bool * set v) :=
  if is_big x then Some (may_revisit, visited)
  else if elem_set x visited then
    if negb (String.eqb x "start") && may_revisit then Some (false, visited) else None
  else Some (may_revisit, insert_set x visited).

Definition start_from2 (x : v) : ((bool * set v) * v) :=
  ((true, insert_set x empty), x).

Definition count_paths2 (g : graph v) : N :=
  memo_fix (2 * S (size g)) 0 (_count_paths visit2 g) (start_from2 "start").

Definition solve2 (xs : Input) : N :=
  count_paths2 (adj_list xs).

(* Compute solve2 example. *)

Definition solve12 xs := (solve xs, solve2 xs).


Require Import Logic List ListSet Arith Peano_dec Omega.
Require Import Relation_Operators.
Require Import strictorder set_rep_equiv util.
Require Import finite_set_builder.
Require Import LibTactics.

Require Import strandspace strandlib.

Section SimpleSpaces.

Hypothesis PModel : PenetratorModel = StandardPenetrator.

Open Scope list_scope.
Import ListNotations.
Open Scope ss_scope.

(* Proposition 3.3
   "Let C be a bundle, and let k be a Key s.t. ~ k in Kp,
   If k never originates on a regular node, then K is not
   a subterm of term(n) for any node n in C. In particular,
   for any penetrator node p in C, k is not a subterm
   of the term of p." *)
Theorem non_origin_imp_non_subterm : forall B k,
set_In k HKeys ->
(forall n, Origin (#k) n -> ~ RegularNode n) ->
(forall n, set_In n (Nodes B) -> ~ (#k) <st term(n)).
Proof with eauto.
  intros B k notInKp noOrigin n nInN st.
  remember B as bundle.
  destruct bundle as [N E ndN ndE valE predIncl Txincl uniqtx acyc]; simpl in *.
  assert (N = Nodes B) as NB. subst B. simpl; reflexivity.
  clear Heqbundle.
  assert (forall x : Node, {(#k) <st term x} + {~ (#k) <st term x})
         as Pdec.
    intros x. apply st_dec.
  remember (fun n => if Pdec n then true else false) as f.
  destruct (ex_filter_set Node (fun x => (#k) <st term x) Pdec (Nodes B))
    as [N' [N'incl N'P]].
  destruct N' as [| x N'].
   Case "Empty_set".
    forwards: (N'P n). apply H. split. congruence. auto.
  Case "non-empty".
    edestruct (bundle_subset_minimal B) as [min Hmin].
      subst N. eauto. intros contra. tryfalse.
    forwards: (min_origin B (x :: N') min (#k)).
    intros m [mIn mst]. rewrite <- NB in *.
    destruct (N'P m) as [inImpst stImpIn].
    forwards: (stImpIn). auto. auto.
    split. auto. apply N'P. auto. auto.
    forwards: origin_tx. eassumption.
    forwards: origin_st. eassumption.
    forwards: (noOrigin). eassumption. forwards: nonreg_imp_pen. eauto. forwards: (penetrator_behaviour).
    eassumption.
    rewrite PModel in *.
    (* Case analysis on standard penetrator variants *)
    edestruct (SP_disjunction (strand min))
      as [[g [tunk seq]] |
          [[g seq] |
          [[g seq] |
          [[g [h seq]] |
          [[g [h seq]] |
          [[k' [kunk seq]] |
          [[h [k' seq]] |
          [k' [k'' [g [inv seq]]]]]]]]]]]. auto.
    SCase "M & F".
      rewrite (particular_min_term seq) in *... eauto.
    SCase "T".
      forwards: no_origin_after_rx. eauto.
      edestruct (node_strand_3height_opts) as [rxg | txg]. eauto.
      forwards: tx_rx_false... forwards: node_sterm_term_tx...
      forwards: (equiv_disjunct). eassumption.
      edestruct (strand_prev_imp_succ [] min (-g) [(+g); (+g)])
        as [pred [plt psterm]]. auto. auto. eauto.
      forwards: (origin_nosucc_st). eassumption. eassumption.
      erewrite (node_sterm_term_tx min g) in *.
      rewrite (node_sterm_term_rx pred g) in *. contradiction.
      auto. auto. auto. auto.
    SCase "C".
      forwards*: no_origin_after_rx.
      edestruct (node_strand_3height_opts) as [rxg | [rxh | txgh]]...
      edestruct (strand_prev_imp_succ [] min (-g) [(-h); (+g * h)])
        as [pred [plt psterm]]...
      forwards*: (origin_nosucc_st).
      edestruct (strand_prev_imp_succ [(-g)] min (-h) [(+g * h)])
        as [pred2 [p2lt p2sterm]]...
      forwards*: (origin_nosucc_st).
      rewrite (node_sterm_term_tx min (g * h)) in *.
      rewrite (node_sterm_term_rx pred g) in *.
      rewrite (node_sterm_term_rx pred2 h) in *.
      apply (no_st_l_r g h (#k))... auto. auto. auto.
    SCase "S".
      forwards*: no_origin_after_rx.
      edestruct (node_strand_3height_opts) as [rxg | [rxh | txgh]]...
      edestruct (strand_prev_imp_succ [] min (-g * h) [(+g); (+h)])
        as [pred [plt psterm]]...
      forwards*: (origin_nosucc_st).
      rewrite (node_sterm_term_rx pred (g * h)) in *.
      rewrite (node_sterm_term_tx min (g)) in *... auto.
      edestruct (strand_prev_imp_succ [] min (-g * h) [(+g); (+h)])
        as [pred [plt psterm]]...
      forwards*: (origin_nosucc_st).
      rewrite (node_sterm_term_rx pred (g * h)) in *.
      rewrite (node_sterm_term_tx min (h)) in *... auto.
    SCase "K".
      rewrite (particular_min_term seq) in *. simpl in *.
      forwards*: (key_st_key k k'). subst. contradiction.
    SCase "E".
      edestruct (node_strand_3height_opts) as [rxk | [rxh | txhk]]...
      edestruct (strand_prev_imp_succ [(-(#k'))] min (-h) [(+{h}^[k'])])
        as [pred [plt psterm]]...
      forwards*: (origin_nosucc_st).
      rewrite (node_sterm_term_rx pred (h)) in *.
      rewrite (node_sterm_term_tx min {h}^[k']) in *.
      forwards*: (no_encr_st (#k) h). auto. auto.
    SCase "D".
      edestruct (node_strand_3height_opts) as [rxk | [rxh | txhk]]...
      edestruct (strand_prev_imp_succ [(-(#k'))]
                                      min
                                      (-{g }^[ k''])
                                      [(+g)])
        as [pred [plt psterm]]. auto. eauto. eauto.
      forwards*: (origin_nosucc_st).
      rewrite (node_sterm_term_rx pred ({g}^[k''])) in *.
      rewrite (node_sterm_term_tx min g) in *...
      auto.
Grab Existential Variables. auto.
Qed.

(*
Definition 6.1 immediate implication:

g <st h iff h in (kIdeal g I)
*)
Lemma subterm_ideal_member : forall g h I K,
IdealK I K g ->
(g <st h <-> set_In h I).
Proof.
  intros g h I K Ikg.
  split; intros H.
  destruct Ikg as [Ik [gInI smallest]].
  unfold Ideal in Ik.
  destruct h. inversion H. congruence. inversion H. congruence.
  induction H. auto.
  eapply (Ik l). auto. eapply (Ik r). auto.
  apply Ik. apply IHSubterm. auto. auto.

destruct H.
  induction H; subst; auto.
  eapply (Ik l). apply IHSubterm. auto. auto.
  eapply (Ik r). apply IHSubterm. auto. auto.
  destruct K.
  eapply (Ik t). apply IHSubterm. auto. auto.

  eapply Ik.

End SimpleSpaces.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj16eqsynthconj2 : forall  (lv0 : natural), (@eq natural (Succ lv0) (plus (Succ lv0) Zero)).
Admitted.
QuickChick conj16eqsynthconj2.