(*  Title:      ZF/UNITY/ClientImpl.thy
    Author:     Sidi O Ehmety, Cambridge University Computer Laboratory
    Copyright   2002  University of Cambridge

Distributed Resource Management System:  Client Implementation.
*)

theory ClientImpl imports AllocBase Guar begin

abbreviation "ask == Var(Nil)" (* input history:  tokens requested *)
abbreviation "giv == Var([0])" (* output history: tokens granted *)
abbreviation "rel == Var([1])" (* input history: tokens released *)
abbreviation "tok == Var([2])" (* the number of available tokens *)

axiomatization where
  type_assumes:
  "type_of(ask) = list(tokbag) & type_of(giv) = list(tokbag) &
   type_of(rel) = list(tokbag) & type_of(tok) = nat" and
  default_val_assumes:
  "default_val(ask) = Nil & default_val(giv) = Nil &
   default_val(rel) = Nil & default_val(tok) = 0"

(*Array indexing is translated to list indexing as A[n] == nth(n-1,A). *)

definition
 (** Release some client_tokens **)
    "client_rel_act ==
     {<s,t> \<in> state*state.
      \<exists>nrel \<in> nat. nrel = length(s`rel) &
                   t = s(rel:=(s`rel)@[nth(nrel, s`giv)]) &
                   nrel < length(s`giv) &
                   nth(nrel, s`ask) \<le> nth(nrel, s`giv)}"

  (** Choose a new token requirement **)
  (** Including t=s suppresses fairness, allowing the non-trivial part
      of the action to be ignored **)
definition
  "client_tok_act == {<s,t> \<in> state*state. t=s |
                     t = s(tok:=succ(s`tok mod NbT))}"

definition
  "client_ask_act == {<s,t> \<in> state*state. t=s | (t=s(ask:=s`ask@[s`tok]))}"

definition
  "client_prog ==
   mk_program({s \<in> state. s`tok \<le> NbT & s`giv = Nil &
                       s`ask = Nil & s`rel = Nil},
                    {client_rel_act, client_tok_act, client_ask_act},
                   \<Union>G \<in> preserves(lift(rel)) Int
                         preserves(lift(ask)) Int
                         preserves(lift(tok)).  Acts(G))"

declare type_assumes [simp] default_val_assumes [simp]
(* This part should be automated *)

lemma ask_value_type [simp,TC]: "s \<in> state ==> s`ask \<in> list(nat)"
apply (unfold state_def)
apply (drule_tac a = ask in apply_type, auto)
done

lemma giv_value_type [simp,TC]: "s \<in> state ==> s`giv \<in> list(nat)"
apply (unfold state_def)
apply (drule_tac a = giv in apply_type, auto)
done

lemma rel_value_type [simp,TC]: "s \<in> state ==> s`rel \<in> list(nat)"
apply (unfold state_def)
apply (drule_tac a = rel in apply_type, auto)
done

lemma tok_value_type [simp,TC]: "s \<in> state ==> s`tok \<in> nat"
apply (unfold state_def)
apply (drule_tac a = tok in apply_type, auto)
done

(** The Client Program **)

lemma client_type [simp,TC]: "client_prog \<in> program"
apply (unfold client_prog_def)
apply (simp (no_asm))
done

declare client_prog_def [THEN def_prg_Init, simp]
declare client_prog_def [THEN def_prg_AllowedActs, simp]
declare client_prog_def [program]

declare  client_rel_act_def [THEN def_act_simp, simp]
declare  client_tok_act_def [THEN def_act_simp, simp]
declare  client_ask_act_def [THEN def_act_simp, simp]

lemma client_prog_ok_iff:
  "\<forall>G \<in> program. (client_prog ok G) \<longleftrightarrow>
   (G \<in> preserves(lift(rel)) & G \<in> preserves(lift(ask)) &
    G \<in> preserves(lift(tok)) &  client_prog \<in> Allowed(G))"
by (auto simp add: ok_iff_Allowed client_prog_def [THEN def_prg_Allowed])

lemma client_prog_preserves:
    "client_prog:(\<Inter>x \<in> var-{ask, rel, tok}. preserves(lift(x)))"
apply (rule Inter_var_DiffI, force)
apply (rule ballI)
apply (rule preservesI, safety, auto)
done

lemma preserves_lift_imp_stable:
     "G \<in> preserves(lift(ff)) ==> G \<in> stable({s \<in> state. P(s`ff)})"
apply (drule preserves_imp_stable)
apply (simp add: lift_def)
done

lemma preserves_imp_prefix:
     "G \<in> preserves(lift(ff))
      ==> G \<in> stable({s \<in> state. \<langle>k, s`ff\<rangle> \<in> prefix(nat)})"
by (erule preserves_lift_imp_stable)

(*Safety property 1 \<in> ask, rel are increasing: (24) *)
lemma client_prog_Increasing_ask_rel:
"client_prog: program guarantees Incr(lift(ask)) \<inter> Incr(lift(rel))"
apply (unfold guar_def)
apply (auto intro!: increasing_imp_Increasing
            simp add: client_prog_ok_iff Increasing.increasing_def preserves_imp_prefix)
apply (safety, force, force)+
done

declare nth_append [simp] append_one_prefix [simp]

lemma NbT_pos2: "0<NbT"
apply (cut_tac NbT_pos)
apply (rule Ord_0_lt, auto)
done

(*Safety property 2 \<in> the client never requests too many tokens.
With no Substitution Axiom, we must prove the two invariants simultaneously. *)

lemma ask_Bounded_lemma:
"[| client_prog ok G; G \<in> program |]
      ==> client_prog \<squnion> G \<in>
              Always({s \<in> state. s`tok \<le> NbT}  \<inter>
                      {s \<in> state. \<forall>elt \<in> set_of_list(s`ask). elt \<le> NbT})"
apply (rotate_tac -1)
apply (auto simp add: client_prog_ok_iff)
apply (rule invariantI [THEN stable_Join_Always2], force)
 prefer 2
 apply (fast intro: stable_Int preserves_lift_imp_stable, safety)
apply (auto dest: ActsD)
apply (cut_tac NbT_pos)
apply (rule NbT_pos2 [THEN mod_less_divisor])
apply (auto dest: ActsD preserves_imp_eq simp add: set_of_list_append)
done

(* Export version, with no mention of tok in the postcondition, but
  unfortunately tok must be declared local.*)
lemma client_prog_ask_Bounded:
    "client_prog \<in> program guarantees
                   Always({s \<in> state. \<forall>elt \<in> set_of_list(s`ask). elt \<le> NbT})"
apply (rule guaranteesI)
apply (erule ask_Bounded_lemma [THEN Always_weaken], auto)
done

(*** Towards proving the liveness property ***)

lemma client_prog_stable_rel_le_giv:
    "client_prog \<in> stable({s \<in> state. <s`rel, s`giv> \<in> prefix(nat)})"
by (safety, auto)

lemma client_prog_Join_Stable_rel_le_giv:
"[| client_prog \<squnion> G \<in> Incr(lift(giv)); G \<in> preserves(lift(rel)) |]
    ==> client_prog \<squnion> G \<in> Stable({s \<in> state. <s`rel, s`giv> \<in> prefix(nat)})"
apply (rule client_prog_stable_rel_le_giv [THEN Increasing_preserves_Stable])
apply (auto simp add: lift_def)
done

lemma client_prog_Join_Always_rel_le_giv:
     "[| client_prog \<squnion> G \<in> Incr(lift(giv)); G \<in> preserves(lift(rel)) |]
    ==> client_prog \<squnion> G  \<in> Always({s \<in> state. <s`rel, s`giv> \<in> prefix(nat)})"
by (force intro!: AlwaysI client_prog_Join_Stable_rel_le_giv)

lemma def_act_eq:
     "A == {<s, t> \<in> state*state. P(s, t)} ==> A={<s, t> \<in> state*state. P(s, t)}"
by auto

lemma act_subset: "A={<s,t> \<in> state*state. P(s, t)} ==> A<=state*state"
by auto

lemma transient_lemma:
"client_prog \<in>
  transient({s \<in> state. s`rel = k & <k, h> \<in> strict_prefix(nat)
   & <h, s`giv> \<in> prefix(nat) & h pfixGe s`ask})"
apply (rule_tac act = client_rel_act in transientI)
apply (simp (no_asm) add: client_prog_def [THEN def_prg_Acts])
apply (simp (no_asm) add: client_rel_act_def [THEN def_act_eq, THEN act_subset])
apply (auto simp add: client_prog_def [THEN def_prg_Acts] domain_def)
apply (rule ReplaceI)
apply (rule_tac x = "x (rel:= x`rel @ [nth (length (x`rel), x`giv) ]) " in exI)
apply (auto intro!: state_update_type app_type length_type nth_type, auto)
apply (blast intro: lt_trans2 prefix_length_le strict_prefix_length_lt)
apply (blast intro: lt_trans2 prefix_length_le strict_prefix_length_lt)
apply (simp (no_asm_use) add: gen_prefix_iff_nth)
apply (subgoal_tac "h \<in> list(nat)")
 apply (simp_all (no_asm_simp) add: prefix_type [THEN subsetD, THEN SigmaD1])
apply (auto simp add: prefix_def Ge_def)
apply (drule strict_prefix_length_lt)
apply (drule_tac x = "length (x`rel) " in spec)
apply auto
apply (simp (no_asm_use) add: gen_prefix_iff_nth)
apply (auto simp add: id_def lam_def)
done

lemma strict_prefix_is_prefix:
    "<xs, ys> \<in> strict_prefix(A) \<longleftrightarrow>  <xs, ys> \<in> prefix(A) & xs\<noteq>ys"
apply (unfold strict_prefix_def id_def lam_def)
apply (auto dest: prefix_type [THEN subsetD])
done

lemma induct_lemma:
"[| client_prog \<squnion> G \<in> Incr(lift(giv)); client_prog ok G; G \<in> program |]
  ==> client_prog \<squnion> G \<in>
  {s \<in> state. s`rel = k & <k,h> \<in> strict_prefix(nat)
   & <h, s`giv> \<in> prefix(nat) & h pfixGe s`ask}
        \<longmapsto>w {s \<in> state. <k, s`rel> \<in> strict_prefix(nat)
                          & <s`rel, s`giv> \<in> prefix(nat) &
                                  <h, s`giv> \<in> prefix(nat) &
                h pfixGe s`ask}"
apply (rule single_LeadsTo_I)
 prefer 2 apply simp
apply (frule client_prog_Increasing_ask_rel [THEN guaranteesD])
apply (rotate_tac [3] 2)
apply (auto simp add: client_prog_ok_iff)
apply (rule transient_lemma [THEN Join_transient_I1, THEN transient_imp_leadsTo, THEN leadsTo_imp_LeadsTo, THEN PSP_Stable, THEN LeadsTo_weaken])
apply (rule Stable_Int [THEN Stable_Int, THEN Stable_Int])
apply (erule_tac f = "lift (giv) " and a = "s`giv" in Increasing_imp_Stable)
apply (simp (no_asm_simp))
apply (erule_tac f = "lift (ask) " and a = "s`ask" in Increasing_imp_Stable)
apply (simp (no_asm_simp))
apply (erule_tac f = "lift (rel) " and a = "s`rel" in Increasing_imp_Stable)
apply (simp (no_asm_simp))
apply (erule client_prog_Join_Stable_rel_le_giv, blast, simp_all)
 prefer 2
 apply (blast intro: sym strict_prefix_is_prefix [THEN iffD2] prefix_trans prefix_imp_pfixGe pfixGe_trans)
apply (auto intro: strict_prefix_is_prefix [THEN iffD1, THEN conjunct1]
                   prefix_trans)
done

lemma rel_progress_lemma:
"[| client_prog \<squnion> G  \<in> Incr(lift(giv)); client_prog ok G; G \<in> program |]
  ==> client_prog \<squnion> G  \<in>
     {s \<in> state. <s`rel, h> \<in> strict_prefix(nat)
           & <h, s`giv> \<in> prefix(nat) & h pfixGe s`ask}
                      \<longmapsto>w {s \<in> state. <h, s`rel> \<in> prefix(nat)}"
apply (rule_tac f = "\<lambda>x \<in> state. length(h) #- length(x`rel)"
       in LessThan_induct)
apply (auto simp add: vimage_def)
 prefer 2 apply (force simp add: lam_def)
apply (rule single_LeadsTo_I)
 prefer 2 apply simp
apply (subgoal_tac "h \<in> list(nat)")
 prefer 2 apply (blast dest: prefix_type [THEN subsetD])
apply (rule induct_lemma [THEN LeadsTo_weaken])
    apply (simp add: length_type lam_def)
apply (auto intro: strict_prefix_is_prefix [THEN iffD2]
            dest: common_prefix_linear  prefix_type [THEN subsetD])
apply (erule swap)
apply (rule imageI)
 apply (force dest!: simp add: lam_def)
apply (simp add: length_type lam_def, clarify)
apply (drule strict_prefix_length_lt)+
apply (drule less_imp_succ_add, simp)+
apply clarify
apply simp
apply (erule diff_le_self [THEN ltD])
done

lemma progress_lemma:
"[| client_prog \<squnion> G \<in> Incr(lift(giv)); client_prog ok G; G \<in> program |]
 ==> client_prog \<squnion> G
       \<in> {s \<in> state. <h, s`giv> \<in> prefix(nat) & h pfixGe s`ask}
         \<longmapsto>w  {s \<in> state. <h, s`rel> \<in> prefix(nat)}"
apply (rule client_prog_Join_Always_rel_le_giv [THEN Always_LeadsToI],
       assumption)
apply (force simp add: client_prog_ok_iff)
apply (rule LeadsTo_weaken_L)
apply (rule LeadsTo_Un [OF rel_progress_lemma
                           subset_refl [THEN subset_imp_LeadsTo]])
apply (auto intro: strict_prefix_is_prefix [THEN iffD2]
            dest: common_prefix_linear prefix_type [THEN subsetD])
done

(*Progress property: all tokens that are given will be released*)
lemma client_prog_progress:
"client_prog \<in> Incr(lift(giv))  guarantees
      (\<Inter>h \<in> list(nat). {s \<in> state. <h, s`giv> \<in> prefix(nat) &
              h pfixGe s`ask} \<longmapsto>w {s \<in> state. <h, s`rel> \<in> prefix(nat)})"
apply (rule guaranteesI)
apply (blast intro: progress_lemma, auto)
done

lemma client_prog_Allowed:
     "Allowed(client_prog) =
      preserves(lift(rel)) \<inter> preserves(lift(ask)) \<inter> preserves(lift(tok))"
apply (cut_tac v = "lift (ask)" in preserves_type)
apply (auto simp add: Allowed_def client_prog_def [THEN def_prg_Allowed]
                      cons_Int_distrib safety_prop_Acts_iff)
done

end


theory Proof_4_13
  imports Proofs_4
begin

abbreviation s where "s s0 user_value pressure_value \<equiv>
  (toEnv
   (setPstate (setVarBool (setVarBool (setVarAny s0 user_value pressure_value) brake False) rotation True) ERROR
     Controller'rotating))"

theorem proof_4_13: "VC13 inv4 env s0 user_value pressure_value"
  apply(simp only: VC13_def inv4_def R4_def extraInv_def)
 apply(rule impI)
  apply(rule conjI)
   apply(rule conjI)
    apply simp
  apply((rule allI)+)
    apply(rule impI)
   apply(drule conjE)
    prefer 2
    apply assumption
   apply(drule conjE)
    prefer 2
    apply assumption
   apply(drule conjE)
    prefer 2
    apply assumption
   apply(drule conjE)
    prefer 2
    apply assumption
   apply(drule conjE)
    prefer 2
    apply assumption
  subgoal premises prems for s1 s2 s3
    using prems(1) prems(2) prems(3) prems(4) prems(5) prems(7)  apply (simp split: if_splits)
     apply(rule cut_rl[of "\<forall>s2 s3.
   toEnvP s2 \<and>
   toEnvP s3 \<and> substate s2 s3 \<and> substate s3 s0 \<and> toEnvNum s2 s3 = ERROR \<and> toEnvNum s2 s0 < ltime s0 ERROR \<longrightarrow>
   \<not> (getVarBool s2 rotation = True \<and> getVarBool s3 pressure)"])
      using prems(1) prems(2) prems(3) prems(4) prems(5) prems(7)  apply (simp split: if_splits)
        apply(rule cut_rl[of "toEnvNum s1 s0 < DELAY'TIMEOUT"])
         apply(drule allE[of _ s1])
          prefer 2
          apply assumption
         apply(drule allE[of _ s2])
          prefer 2
      apply assumption
         apply auto[1]
      using toEnvNum3[of s1 s2 s0] apply auto[1]
       apply(rule suspended_not_rotation_and_pressure[of _ s0])
       apply(rule conjI)
      using prems(6) apply fast
       apply(rule conjI)
      using substate_refl apply fast
       apply(rule conjI)
        apply auto[1]
      using prems(6) apply fast
      apply(rule cut_rl[of "substate s3 s0"])
      using prems apply meson
      using prems(2)  by (simp split: if_splits)


theory IpAddresses_Normalize
imports Common_Primitive_Lemmas
begin

subsection\<open>Normalizing IP Addresses\<close>
  fun normalized_src_ips :: "'i::len common_primitive match_expr \<Rightarrow> bool" where
    "normalized_src_ips MatchAny = True" |
    "normalized_src_ips (Match (Src (IpAddrRange _ _))) = False" |
    "normalized_src_ips (Match (Src (IpAddr _))) = False" |
    "normalized_src_ips (Match (Src (IpAddrNetmask _ _))) = True" |
    "normalized_src_ips (Match _) = True" |
    "normalized_src_ips (MatchNot (Match (Src _))) = False" |
    "normalized_src_ips (MatchNot (Match _)) = True" |
    "normalized_src_ips (MatchAnd m1 m2) = (normalized_src_ips m1 \<and> normalized_src_ips m2)" |
    "normalized_src_ips (MatchNot (MatchAnd _ _)) = False" |
    "normalized_src_ips (MatchNot (MatchNot _)) = False" |
    "normalized_src_ips (MatchNot (MatchAny)) = True"

  lemma normalized_src_ips_def2: "normalized_src_ips ms = normalized_n_primitive (is_Src, src_sel) normalized_cidr_ip ms"
    by(induction ms rule: normalized_src_ips.induct, simp_all add: normalized_cidr_ip_def)

  fun normalized_dst_ips :: "'i::len common_primitive match_expr \<Rightarrow> bool" where
    "normalized_dst_ips MatchAny = True" |
    "normalized_dst_ips (Match (Dst (IpAddrRange _ _))) = False" |
    "normalized_dst_ips (Match (Dst (IpAddr _))) = False" |
    "normalized_dst_ips (Match (Dst (IpAddrNetmask _ _))) = True" |
    "normalized_dst_ips (Match _) = True" |
    "normalized_dst_ips (MatchNot (Match (Dst _))) = False" |
    "normalized_dst_ips (MatchNot (Match _)) = True" |
    "normalized_dst_ips (MatchAnd m1 m2) = (normalized_dst_ips m1 \<and> normalized_dst_ips m2)" |
    "normalized_dst_ips (MatchNot (MatchAnd _ _)) = False" |
    "normalized_dst_ips (MatchNot (MatchNot _)) = False" |
    "normalized_dst_ips (MatchNot MatchAny) = True"

  lemma normalized_dst_ips_def2: "normalized_dst_ips ms = normalized_n_primitive (is_Dst, dst_sel) normalized_cidr_ip ms"
    by(induction ms rule: normalized_dst_ips.induct, simp_all add: normalized_cidr_ip_def)

  (*possible optimizations: remove the UNIV match on ip here!*)
  value "normalize_primitive_extract (is_Src, src_sel) Src ipt_iprange_compress
      (MatchAnd (MatchNot (Match ((Src_Ports (L4Ports TCP [(1,2)])):: 32 common_primitive))) (Match (Src_Ports (L4Ports TCP [(1,2)]))))"
  value "normalize_primitive_extract (is_Src, src_sel) Src ipt_iprange_compress
      (MatchAnd (MatchNot (Match (Src (IpAddrNetmask (10::ipv4addr) 2)))) (Match (Src_Ports (L4Ports TCP [(1,2)]))))"
  value "normalize_primitive_extract (is_Src, src_sel) Src ipt_iprange_compress
      (MatchAnd (Match (Src (IpAddrNetmask (10::ipv4addr) 2))) (MatchAnd (Match (Src (IpAddrNetmask 10 8))) (Match (Src_Ports (L4Ports TCP [(1,2)])))))"
  (*too many MatchAny*)
  value "normalize_primitive_extract (is_Src, src_sel) Src ipt_iprange_compress
      (MatchAnd (Match (Src (IpAddrNetmask (10::ipv4addr) 2))) (MatchAnd (Match (Src (IpAddrNetmask 192 8))) (Match (Src_Ports (L4Ports TCP [(1,2)])))))"

  definition normalize_src_ips :: "'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr list" where
    "normalize_src_ips = normalize_primitive_extract (common_primitive.is_Src, src_sel)
                                      common_primitive.Src ipt_iprange_compress"

  lemma ipt_iprange_compress_src_matching: "match_list (common_matcher, \<alpha>) (map (Match \<circ> Src) (ipt_iprange_compress ml)) a p \<longleftrightarrow>
         matches (common_matcher, \<alpha>) (alist_and (NegPos_map Src ml)) a p"
    proof -
      have "matches (common_matcher, \<alpha>) (alist_and (NegPos_map common_primitive.Src ml)) a p \<longleftrightarrow>
            (\<forall>m \<in> set (getPos ml). matches (common_matcher, \<alpha>) (Match (Src m)) a p) \<and>
            (\<forall>m \<in> set (getNeg ml). matches (common_matcher, \<alpha>) (MatchNot (Match (Src m))) a p)"
        by(induction ml rule: alist_and.induct) (auto simp add: bunch_of_lemmata_about_matches)
      also have "\<dots> \<longleftrightarrow>  p_src p \<in>  (\<Inter> ip \<in> set (getPos ml). ipt_iprange_to_set ip) - (\<Union> ip \<in> set (getNeg ml). ipt_iprange_to_set ip)"
       by(simp add: match_simplematcher_SrcDst match_simplematcher_SrcDst_not)
      also have "\<dots> \<longleftrightarrow> p_src p \<in> (\<Union> ip \<in> set (ipt_iprange_compress ml). ipt_iprange_to_set ip)" using ipt_iprange_compress
        by blast
      also have "\<dots> \<longleftrightarrow> (\<exists>ip \<in> set (ipt_iprange_compress ml). matches (common_matcher, \<alpha>) (Match (Src ip)) a p)"
       by(simp add: match_simplematcher_SrcDst)
      finally show ?thesis using match_list_matches by fastforce
  qed
  lemma normalize_src_ips: "normalized_nnf_match m \<Longrightarrow>
      match_list (common_matcher, \<alpha>) (normalize_src_ips m) a p = matches (common_matcher, \<alpha>) m a p"
    unfolding normalize_src_ips_def
    using normalize_primitive_extract[OF _ wf_disc_sel_common_primitive(3), where f=ipt_iprange_compress and \<gamma>="(common_matcher, \<alpha>)"]
      ipt_iprange_compress_src_matching by blast

  lemma normalize_src_ips_normalized_n_primitive: "normalized_nnf_match m \<Longrightarrow>
      \<forall>m' \<in> set (normalize_src_ips m). normalized_src_ips m'"
  unfolding normalize_src_ips_def
  unfolding normalized_src_ips_def2
  apply(rule normalize_primitive_extract_normalizes_n_primitive[OF _ wf_disc_sel_common_primitive(3)])
   by(simp_all add: ipt_iprange_compress_normalized_IpAddrNetmask)

  definition normalize_dst_ips :: "'i::len common_primitive match_expr \<Rightarrow> 'i common_primitive match_expr list" where
    "normalize_dst_ips = normalize_primitive_extract (common_primitive.is_Dst, dst_sel)
                                common_primitive.Dst ipt_iprange_compress"

  lemma ipt_iprange_compress_dst_matching: "match_list (common_matcher, \<alpha>) (map (Match \<circ> Dst) (ipt_iprange_compress ml)) a p \<longleftrightarrow>
         matches (common_matcher, \<alpha>) (alist_and (NegPos_map Dst ml)) a p"
    proof -
      have "matches (common_matcher, \<alpha>) (alist_and (NegPos_map common_primitive.Dst ml)) a p \<longleftrightarrow>
            (\<forall>m \<in> set (getPos ml). matches (common_matcher, \<alpha>) (Match (Dst m)) a p) \<and>
            (\<forall>m \<in> set (getNeg ml). matches (common_matcher, \<alpha>) (MatchNot (Match (Dst m))) a p)"
        by(induction ml rule: alist_and.induct) (auto simp add: bunch_of_lemmata_about_matches)
      also have "\<dots> \<longleftrightarrow>  p_dst p \<in>  (\<Inter> ip \<in> set (getPos ml). ipt_iprange_to_set ip) - (\<Union> ip \<in> set (getNeg ml). ipt_iprange_to_set ip)"
       by(simp add: match_simplematcher_SrcDst match_simplematcher_SrcDst_not)
      also have "\<dots> \<longleftrightarrow> p_dst p \<in> (\<Union> ip \<in> set (ipt_iprange_compress ml). ipt_iprange_to_set ip)" using ipt_iprange_compress by blast
      also have "\<dots> \<longleftrightarrow> (\<exists>ip \<in> set (ipt_iprange_compress ml). matches (common_matcher, \<alpha>) (Match (Dst ip)) a p)"
       by(simp add: match_simplematcher_SrcDst)
      finally show ?thesis using match_list_matches by fastforce
  qed
  lemma normalize_dst_ips: "normalized_nnf_match m \<Longrightarrow>
      match_list (common_matcher, \<alpha>) (normalize_dst_ips m) a p = matches (common_matcher, \<alpha>) m a p"
    unfolding normalize_dst_ips_def
    using normalize_primitive_extract[OF _ wf_disc_sel_common_primitive(4), where f=ipt_iprange_compress and \<gamma>="(common_matcher, \<alpha>)"]
      ipt_iprange_compress_dst_matching by blast

   text\<open>Normalizing the dst ips preserves the normalized src ips\<close>
   lemma "normalized_nnf_match m \<Longrightarrow> normalized_src_ips m \<Longrightarrow> \<forall>mn\<in>set (normalize_dst_ips m). normalized_src_ips mn"
   unfolding normalize_dst_ips_def normalized_src_ips_def2
   by(rule normalize_primitive_extract_preserves_unrelated_normalized_n_primitive)(simp_all add: wf_disc_sel_common_primitive)

  lemma normalize_dst_ips_normalized_n_primitive: "normalized_nnf_match m \<Longrightarrow>
    \<forall>m' \<in> set (normalize_dst_ips m). normalized_dst_ips m'"
  unfolding normalize_dst_ips_def normalized_dst_ips_def2
  by(rule normalize_primitive_extract_normalizes_n_primitive[OF _ wf_disc_sel_common_primitive(4)]) (simp_all add: ipt_iprange_compress_normalized_IpAddrNetmask)

end


theory InferDef
  imports AltFlatLemma InferVar
begin

    (* type inferencing constraints *)

datatype perm_crn =
  UnifyCrn s_type s_type
  | MemValCrn s_type s_type
  | LeqCrn x_perm s_perm
  | LeqTypeCrn s_type s_perm
  (*| EqTypeCrn s_type s_perm*)
  | DisjCrn x_perm x_perm
  | SemiDisjCrn x_perm x_perm

    (* constant / op "types":  *)

fun list_contain where
  "list_contain [] x = False"
| "list_contain (y # t) x = (x = y \<or> list_contain t x)"

fun fresh_in_list where
  "fresh_in_list [] = True"
| "fresh_in_list (x # t) = (\<not> list_contain t x \<and> fresh_in_list t)"

definition fresh_list where
  "fresh_list ds l = (fresh_in_list l \<and> (\<forall> x. list_contain l x \<longrightarrow> x \<notin> ds))"

fun const_scheme :: "p_const \<Rightarrow> nat set \<Rightarrow> s_type \<Rightarrow> perm_crn list \<Rightarrow> nat set \<Rightarrow> bool" where
  "const_scheme UnitConst ds tau c_list ds' = (tau = UnitScheme \<and> c_list = [] \<and> ds' = ds)"
| "const_scheme (IConst i) ds tau c_list ds' = (tau = IntScheme \<and> c_list = [] \<and> ds' = ds)"
| "const_scheme (BConst b) ds tau c_list ds' = (tau = BoolScheme \<and> c_list = [] \<and> ds' = ds)"
| "const_scheme FixConst ds tau c_list ds' = (\<exists> t t1 t2 p q. tau = pure_fun_s (pure_fun_s t t (AffVar q)) t (AffConst Prim) \<and>
  t = FunScheme (VarScheme t1) (VarScheme t2) (SVar p) (AffVar q) \<and> c_list = [LeqTypeCrn t (SPerm UsePerm)] \<and>
  fresh_list ds [t1, t2, p, q] \<and> ds' =  {t1, t2, p, q} \<union> ds )"
| "const_scheme EmptyArrayConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s UnitScheme (ArrayScheme (VarScheme t)) (AffConst Prim) \<and>
  c_list = [LeqTypeCrn (VarScheme t) (SPerm UsePerm)] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"
| "const_scheme ExtArrayConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s (ArrayScheme (VarScheme t))
  (FunScheme (VarScheme t) (ArrayScheme (VarScheme t)) (SPerm OwnPerm) (AffConst Ref)) (AffConst Prim) \<and>
  c_list = [LeqTypeCrn (VarScheme t) (SPerm UsePerm)] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"
| "const_scheme ReadConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s (ArrayScheme (VarScheme t)) (pure_fun_s IntScheme (VarScheme t) (AffConst Ref)) (AffConst Prim) \<and>
  c_list = [LeqTypeCrn (VarScheme t) (SPerm UsePerm)] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"
| "const_scheme WriteConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s (ArrayScheme (VarScheme t))
  (FunScheme (PairScheme IntScheme (VarScheme t) (SPerm OwnPerm)) UnitScheme (SPerm OwnPerm) (AffConst Ref)) (AffConst Prim) \<and>
  c_list = [LeqTypeCrn (VarScheme t) (SPerm UsePerm)] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"
| "const_scheme UnpackConst ds tau c_list ds' = (\<exists> t1 t2 tx p p'. tau = FunScheme (PairScheme (VarScheme t1) (VarScheme t2) (SVar p)) (FunScheme
  (FunScheme (VarScheme t1) (FunScheme (VarScheme t2) (VarScheme tx) (SVar p) (AffVar p'))
    (SVar p) (AffVar p')) (VarScheme tx) (SVar p') (AffVar p)) (SVar p) (AffConst Prim) \<and>
  c_list = [LeqCrn (XPerm (SVar p)) (SVar p')] \<and> fresh_list ds [t1, t2, tx, p, p'] \<and> ds' = {t1, t2, tx, p, p'} \<union> ds)"
| "const_scheme NewChanConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s UnitScheme (PairScheme (ChanScheme (VarScheme t) SEnd) (ChanScheme (VarScheme t) REnd)
  (SPerm OwnPerm)) (AffConst Prim) \<and> c_list = [] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"
| "const_scheme SendConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s (ChanScheme (VarScheme t) SEnd) (FunScheme (VarScheme t) UnitScheme
  (SPerm OwnPerm) (AffConst Ref)) (AffConst Prim) \<and> c_list = [] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"
| "const_scheme RecvConst ds tau c_list ds' = (\<exists> t. tau = pure_fun_s (ChanScheme (VarScheme t) REnd) (VarScheme t) (AffConst Prim) \<and>
    c_list = [] \<and> t \<notin> ds \<and> ds' = {t} \<union> ds)"
| "const_scheme ForkConst ds tau c_list ds' = (\<exists> p. tau = FunScheme (FunScheme UnitScheme UnitScheme (SPerm UsePerm) (AffVar p))
  UnitScheme (SPerm OwnPerm) (AffConst Prim) \<and> c_list = [] \<and> p \<notin> ds \<and> ds' = {p} \<union> ds)"

fun op_scheme :: "p_op \<Rightarrow> s_type" where
  "op_scheme (I2Op xop) = pure_fun_s IntScheme (pure_fun_s IntScheme IntScheme (AffConst Prim)) (AffConst Prim)"
| "op_scheme (I1Op xop) = pure_fun_s IntScheme IntScheme (AffConst Prim)"
| "op_scheme (C2Op xop) = pure_fun_s IntScheme (pure_fun_s IntScheme BoolScheme (AffConst Prim)) (AffConst Prim)"
| "op_scheme (C1Op xop) = pure_fun_s IntScheme BoolScheme (AffConst Prim)"
| "op_scheme (R2Op xop) = pure_fun_s BoolScheme (pure_fun_s BoolScheme BoolScheme (AffConst Prim)) (AffConst Prim)"
| "op_scheme (R1Op xop) = pure_fun_s BoolScheme BoolScheme (AffConst Prim)"

    (* inferencing definition *)

definition finite_dom where
  "finite_dom r_s l = (\<forall> x. r_s x \<noteq> XPerm (SPerm NoPerm) \<longrightarrow> list_contain l x)"

fun disj_crn where
  "disj_crn r_s1 r_s2 [] = []"
| "disj_crn r_s1 r_s2 (x # t) = (DisjCrn (r_s1 x) (r_s2 x)) # (disj_crn r_s1 r_s2 t)"

fun semi_disj_crn where
  "semi_disj_crn r_s1 r_s2 [] = []"
| "semi_disj_crn r_s1 r_s2 (x # t) = (SemiDisjCrn (r_s1 x) (r_s2 x)) # (semi_disj_crn r_s1 r_s2 t)"

fun fresh_in_type where
  "fresh_in_type (VarScheme b) a = (a \<noteq> b)"
| "fresh_in_type (ArrayScheme tau) a = (fresh_in_type tau a)"
| "fresh_in_type (PairScheme t1 t2 p) a = (fresh_in_type t1 a \<and> fresh_in_type t2 a)"
| "fresh_in_type (FunScheme t1 t2 p1 p2) a = (fresh_in_type t1 a \<and> fresh_in_type t2 a)"
| "fresh_in_type (ChanScheme tau c_end) a = (fresh_in_type tau a)"
| "fresh_in_type tau a = True"

definition fresh_tvar where
  "fresh_tvar env a = (\<forall> x. case env x of
    None \<Rightarrow> True
    | Some tau \<Rightarrow> fresh_in_type tau a
  )"

fun aff_crn where
  "aff_crn r_s a [] = Nil"
| "aff_crn r_s a (x # t) = (LeqCrn (r_s x) a) # (aff_crn r_s a t)"

fun var_val_crn where
  "var_val_crn (VarType x) tau tau_x = []"
| "var_val_crn (LocType x y) tau tau_x = [MemValCrn tau tau_x]"

fun infer_type :: "nat res_env \<Rightarrow> nat set \<Rightarrow> p_exp \<Rightarrow> s_type \<Rightarrow> perm_var_env \<Rightarrow> perm_var_env \<Rightarrow> perm_var_env \<Rightarrow> perm_crn list \<Rightarrow> nat set \<Rightarrow> bool" where
  "infer_type env ds (ConstExp c) tau r_s r_x r_m c_list ds' =
  (const_scheme c ds tau c_list ds' \<and> r_s = empty_var_env \<and> r_x = empty_var_env \<and> r_m = empty_var_env)"
| "infer_type env ds (OpExp xop) tau r_s r_x r_m c_list ds' = (tau = op_scheme xop \<and>
  r_s = empty_var_env \<and> r_x = empty_var_env \<and> r_m = empty_var_env \<and> c_list = [] \<and> ds = ds')"
| "infer_type env ds (VarExp x) tau r_s r_x r_m c_list ds' = (\<exists> a b. env (res_name x) = Some a \<and> tau = VarScheme a \<and> env (owner_name x) = Some b \<and>
  r_s = one_var_env (owner_name x) (XType b) \<and> r_x = r_s \<and> r_m = r_s \<and> c_list = var_val_crn x tau (VarScheme b) \<and> ds' = ds)"
  (*c_list = [LeqTypeCrn (VarScheme b) (SVar p)] @ (var_val_crn x tau (VarScheme b)) \<and>
  p \<notin> ds \<and> ds' = {p} \<union> ds)*)
| "infer_type env ds (PairExp e1 e2) tau r_s r_x r_m c_list ds' = (\<exists> t1 t2 p d r_s1 r_s2 r_x1 r_x2 r_m1 r_m2 cl1 cl2 ds2 ds3.
    infer_type env ds e1 t1 r_s1 r_x1 r_m1 cl1 ds2 \<and> infer_type env ds2 e2 t2 r_s2 r_x2 r_m2 cl2 ds3 \<and> tau = PairScheme t1 t2 (SVar p) \<and>
    r_s = comp_var_env (comp_var_env r_s1 (lift_var_env r_x1 (SVar p))) (comp_var_env r_s2 (lift_var_env r_x2 (SVar p))) \<and>
    r_x = ifz_var_env (XPerm (SVar p)) (comp_var_env (lift_var_env r_x1 (SVar p)) (lift_var_env r_x2 (SVar p))) \<and>
    r_m = comp_var_env r_m1 r_m2 \<and> finite_dom r_s d \<and>
    c_list = [LeqTypeCrn t1 (SVar p), LeqTypeCrn t2 (SVar p)] @(*
    (disj_crn (comp_var_env r_s1 (lift_var_env r_x1 (SVar p))) (comp_var_env r_s2 (lift_var_env r_x2 (SVar p))) d) @ cl1 @ cl2 \<and>*)
    (disj_crn (lift_var_env r_x1 (SVar p)) (lift_var_env r_x2 (SVar p)) d) @ (semi_disj_crn r_m2 r_x1 d) @ (semi_disj_crn r_m1 r_s2 d)
    (*(semi_disj_crn r_m2 (lift_var_env r_x1 (SVar p)) d) @ (semi_disj_crn r_m1 (comp_var_env r_s2 (lift_var_env r_x2 (SVar p))) d)*) @ cl1 @ cl2 \<and>
    p \<notin> ds3 \<and> ds' = {p} \<union> ds3
  )"
| "infer_type env ds (IfExp e1 e2 e3) tau r_s r_x r_m c_list ds' = (\<exists> t1 t2 t3 d r_s1 r_s2 r_s3 r_x1 r_x2 r_x3 r_m1 r_m2 r_m3 cl1 cl2 cl3 ds2 ds3.
    infer_type env ds e1 t1 r_s1 r_x1 r_m1 cl1 ds2 \<and> infer_type env ds2 e2 t2 r_s2 r_x2 r_m2 cl2 ds3 \<and> infer_type env ds3 e3 t3 r_s3 r_x3 r_m3 cl3 ds' \<and>
    r_s = comp_var_env r_s1 (comp_var_env r_s2 r_s3) \<and> r_x = comp_var_env r_x2 r_x3 \<and> r_m = comp_var_env r_m1 (comp_var_env r_m2 r_m3) \<and>
    finite_dom r_s d \<and> tau = t2 \<and>
    c_list = [UnifyCrn t1 BoolScheme, UnifyCrn t2 t3] @ (semi_disj_crn r_m1 (comp_var_env r_s2 r_s3) d) @ cl1 @ cl2 @ cl3)"
| "infer_type env ds (LamExp x e) tau r_s r_x r_m c_list ds' = (\<exists> t2 a p q d r_s' r_x' r_m' cl ds2.
  infer_type (add_env env (Var x) a) (ds \<union> {a}) e t2 r_s' r_x' r_m' cl ds2 \<and> tau = FunScheme (VarScheme a) t2 (SVar p) (AffVar q) \<and>
  r_s = rem_var_env r_s' (Var x) \<and> r_x = r_s \<and> r_m = empty_var_env \<and> x \<notin> ref_vars e \<and>
  finite_dom r_s d \<and> c_list = [LeqCrn (r_s' (Var x)) (SVar p)] @ (aff_crn r_s (SVar q) d) @ cl \<and>
  a \<notin> ds \<and> p \<noteq> q \<and> p \<notin> ds2 \<and> q \<notin> ds2 \<and> ds' = {p, q} \<union> ds2)"
| "infer_type env ds (AppExp e1 e2) tau r_s r_x r_m c_list ds' = (\<exists> tau_f t1 a p q d r_s1 r_s2 r_x1 r_x2 r_m1 r_m2 cl1 cl2 ds2 ds3.
    infer_type env ds e1 tau_f r_s1 r_x1 r_m1 cl1 ds2 \<and> infer_type env ds2 e2 t1 r_s2 r_x2 r_m2 cl2 ds3 \<and>
    tau = VarScheme a \<and> r_s = comp_var_env (comp_var_env r_s1 r_x1) (comp_var_env r_s2 (lift_var_env r_x2 (SVar p))) \<and>
    (*r_x = back_lift_var_env (SVar px) (comp_var_env r_s1 (lift_var_env r_s2 (SVar p))) \<and>*)
    r_x = ifz_var_env (XType a) (comp_var_env r_x1 (lift_var_env r_x2 (SVar p))) \<and>
    r_m = comp_var_env (comp_var_env r_m1 r_x1) (comp_var_env r_m2 (lift_var_env r_x2 (SVar p))) \<and> finite_dom r_s d \<and>
    c_list = [UnifyCrn (FunScheme t1 tau (SVar p) (AffVar q)) tau_f (*, EqTypeCrn (VarScheme a) (SVar p_a)*) ] @
    (disj_crn r_x1 (lift_var_env r_x2 (SVar p)) d) @ (semi_disj_crn r_m2 r_x1 d) @ (semi_disj_crn r_m1 r_s2 d) @ cl1 @ cl2 \<and>
    fresh_list ds3 [a, p, q] \<and> ds' = {a, p, q} \<union> ds3
  )"

    (* solution satisfaction *)

fun mini_disj_perm where
  "mini_disj_perm p q = (p = OwnPerm \<longrightarrow> q = NoPerm)"

fun mem_val_type where
  "mem_val_type (ArrayTy tau) = True"
| "mem_val_type (ChanTy tau c_end) = True"
| "mem_val_type tau = False"

fun dir_sol_crn :: "dir_type_subst \<Rightarrow> perm_subst \<Rightarrow> perm_crn \<Rightarrow> bool" where
  "dir_sol_crn t_sub p_sub (UnifyCrn t1 t2) = (\<exists> tau_x. dir_subst_type t_sub p_sub t1 tau_x \<and> dir_subst_type t_sub p_sub t2 tau_x)"
| "dir_sol_crn t_sub p_sub (MemValCrn tau tau_x) = (\<exists> t' tx'.
  dir_subst_type t_sub p_sub tau_x tx' \<and> dir_subst_type t_sub p_sub tau t' \<and> req_type tx' = Ref \<and> req_type t' = Ref)"
| "dir_sol_crn t_sub p_sub (LeqCrn p1 p2) = (leq_perm (dir_subst_permx t_sub p_sub p1) (sol_subst_perm p_sub p2))"
| "dir_sol_crn t_sub p_sub (LeqTypeCrn tau p) = (\<exists> tau_x.
  dir_subst_type t_sub p_sub tau tau_x \<and> aff_leq (req_type tau_x) (sol_subst_perm p_sub p))"
| "dir_sol_crn t_sub p_sub (DisjCrn p1 p2) = (mini_disj_perm (dir_subst_permx t_sub p_sub p1) (dir_subst_permx t_sub p_sub p2) \<and>
  mini_disj_perm (dir_subst_permx t_sub p_sub p2) (dir_subst_permx t_sub p_sub p1))"
| "dir_sol_crn t_sub p_sub (SemiDisjCrn p1 p2) = (mini_disj_perm (dir_subst_permx t_sub p_sub p1) (dir_subst_permx t_sub p_sub p2))"

fun dir_sol_sat :: "dir_type_subst \<Rightarrow> perm_subst \<Rightarrow> perm_crn list \<Rightarrow> bool" where
  "dir_sol_sat t_sub p_sub [] = True"
| "dir_sol_sat t_sub p_sub (c # c_t) = (dir_sol_crn t_sub p_sub c \<and> dir_sol_sat t_sub p_sub c_t)"

lemma sol_sat_append2: "\<lbrakk> dir_sol_sat t_sub p_sub (cl1 @ cl2) \<rbrakk> \<Longrightarrow> dir_sol_sat t_sub p_sub cl2"
  apply (induct cl1)
   apply (auto)
  done

lemma sol_sat_append1: "\<lbrakk> dir_sol_sat t_sub p_sub (cl1 @ cl2) \<rbrakk> \<Longrightarrow> dir_sol_sat t_sub p_sub cl1"
  apply (induct cl1)
   apply (auto)
  done

lemma sol_sat_disj_crn_elem: "\<lbrakk> dir_sol_sat t_sub p_sub (disj_crn r_x r_s d); list_contain d x \<rbrakk> \<Longrightarrow>
  mini_disj_perm (dir_subst_permx t_sub p_sub (r_x x)) (dir_subst_permx t_sub p_sub (r_s x))
  \<and> mini_disj_perm (dir_subst_permx t_sub p_sub (r_s x)) (dir_subst_permx t_sub p_sub (r_x x))"
  apply (induct d)
   apply (auto)
  done

lemma sol_sat_disj_use_env: "\<lbrakk> dir_sol_sat t_sub p_sub (disj_crn r_x r_s d); finite_dom r_x d; finite_dom r_s d \<rbrakk> \<Longrightarrow>
  disj_use_env (dir_subst_penv t_sub p_sub r_x) (dir_subst_penv t_sub p_sub r_s)"
  apply (simp add: disj_use_env_def)
  apply (simp add: mini_disj_use_env_def)
  apply (simp add: finite_dom_def)
  apply (auto)
   apply (case_tac "r_s x = XPerm (SPerm NoPerm)")
    apply (simp add: dir_subst_penv_def)
   apply (cut_tac p_sub="p_sub" and d="d" and x="x" in sol_sat_disj_crn_elem)
     apply (auto)
      apply (simp add: dir_subst_penv_def)
     apply (simp add: dir_subst_penv_def)
    apply (simp add: dir_subst_penv_def)
   apply (simp add: dir_subst_penv_def)
  apply (case_tac "r_x x = XPerm (SPerm NoPerm)")
   apply (simp add: dir_subst_penv_def)
  apply (cut_tac p_sub="p_sub" and d="d" and x="x" in sol_sat_disj_crn_elem)
    apply (auto)
     apply (simp add: dir_subst_penv_def)
    apply (simp add: dir_subst_penv_def)
   apply (simp add: dir_subst_penv_def)
  apply (simp add: dir_subst_penv_def)
  done

lemma sol_sat_mini_disj_crn_elem: "\<lbrakk> dir_sol_sat t_sub p_sub (semi_disj_crn r_x r_s d); list_contain d x \<rbrakk> \<Longrightarrow>
  mini_disj_perm (dir_subst_permx t_sub p_sub (r_x x)) (dir_subst_permx t_sub p_sub (r_s x))"
  apply (induct d)
   apply (auto)
  done

lemma sol_sat_mini_disj_use_env: "\<lbrakk> dir_sol_sat t_sub p_sub (semi_disj_crn r_x r_s d); finite_dom r_x d; finite_dom r_s d \<rbrakk> \<Longrightarrow>
  mini_disj_use_env (dir_subst_penv t_sub p_sub r_x) (dir_subst_penv t_sub p_sub r_s)"
  apply (simp add: mini_disj_use_env_def)
  apply (simp add: finite_dom_def)
  apply (auto)
  apply (case_tac "r_s x = XPerm (SPerm NoPerm)")
   apply (simp add: dir_subst_penv_def)
  apply (cut_tac p_sub="p_sub" and d="d" and x="x" in sol_sat_mini_disj_crn_elem)
    apply (auto)
   apply (simp add: dir_subst_penv_def)
  apply (simp add: dir_subst_penv_def)
  done

lemma sol_sat_aff_crn_elem: "\<lbrakk> dir_sol_sat t_sub p_sub (aff_crn r_s (SVar q) d); list_contain d x \<rbrakk> \<Longrightarrow>
  leq_perm (dir_subst_permx t_sub p_sub (r_s x)) (sol_subst_perm p_sub (SVar q))"
  apply (induct d)
   apply (auto)
  done

lemma sol_sat_aff_use_env: "\<lbrakk> dir_sol_sat t_sub p_sub (aff_crn r_s (SVar q) d); finite_dom r_s d \<rbrakk> \<Longrightarrow>
  aff_use_env (dir_subst_penv t_sub p_sub r_s) (sol_subst_aff p_sub (AffVar q))"
  apply (simp add: aff_use_env_def)
  apply (simp add: finite_dom_def)
  apply (case_tac "sol_subst_aff p_sub (AffVar q)")
    apply (auto)
   apply (simp add: weak_use_env_def)
   apply (auto)
   apply (cut_tac p_sub="p_sub" and q="q" and x="x" in sol_sat_aff_crn_elem)
     apply (auto)
    apply (simp add: dir_subst_penv_def)
    apply (case_tac "r_s x")
       apply (auto)
    apply (case_tac x1)
     apply (auto)
   apply (simp add: dir_subst_penv_def)
   apply (case_tac "p_sub q")
     apply (auto)
  apply (simp add: null_use_env_def)
  apply (auto)
  apply (case_tac "r_s x = XPerm (SPerm NoPerm)")
   apply (simp add: dir_subst_penv_def)
  apply (cut_tac p_sub="p_sub" and q="q" and x="x" in sol_sat_aff_crn_elem)
    apply (auto)
  apply (simp add: dir_subst_penv_def)
  apply (case_tac "p_sub q")
    apply (auto)
  apply (case_tac "dir_subst_permx t_sub p_sub (r_s x)")
    apply (auto)
  done

lemma sol_sat_aff_use_envx: "\<lbrakk> dir_sol_sat t_sub p_sub (aff_crn r_s (SVar q) d); finite_dom r_s d \<rbrakk> \<Longrightarrow>
  aff_use_env (dir_subst_penv t_sub p_sub r_s) (as_aff (p_sub q))"
  apply (simp add: aff_use_env_def)
  apply (simp add: finite_dom_def)
  apply (case_tac "sol_subst_aff p_sub (AffVar q)")
    apply (auto)
   apply (simp add: weak_use_env_def)
   apply (auto)
   apply (cut_tac p_sub="p_sub" and q="q" and x="x" in sol_sat_aff_crn_elem)
     apply (auto)
    apply (simp add: dir_subst_penv_def)
    apply (case_tac "r_s x")
       apply (auto)
    apply (case_tac x1)
     apply (auto)
   apply (simp add: dir_subst_penv_def)
   apply (case_tac "p_sub q")
     apply (auto)
  apply (simp add: null_use_env_def)
  apply (auto)
  apply (case_tac "r_s x = XPerm (SPerm NoPerm)")
   apply (simp add: dir_subst_penv_def)
  apply (cut_tac p_sub="p_sub" and q="q" and x="x" in sol_sat_aff_crn_elem)
    apply (auto)
  apply (simp add: dir_subst_penv_def)
  apply (case_tac "p_sub q")
    apply (auto)
  apply (case_tac "dir_subst_permx t_sub p_sub (r_s x)")
    apply (auto)
  done
(*
lemma sol_subst_var_type: "sol_subst_var_full t_sub p_sub tau_n a = sol_subst_type_full t_sub p_sub tau_n (VarScheme a)"
  apply (simp add: sol_subst_var_full_def)
  apply (simp add: sol_subst_type_full_def)
  apply (simp add: sol_subst_var_def)
  done
  *)
    (* ##### sub-domain lemmas *)

definition sub_dom where
  "sub_dom r_x r_s = (\<forall> x. r_s x = XPerm (SPerm NoPerm) \<longrightarrow> r_x x =  XPerm (SPerm NoPerm))"

lemma finite_sub_dom: "\<lbrakk> finite_dom r_s d; sub_dom r_x r_s \<rbrakk> \<Longrightarrow> finite_dom r_x d"
  apply (induct d)
   apply (auto)
   apply (simp add: sub_dom_def)
   apply (simp add: finite_dom_def)
  apply (simp add: sub_dom_def)
  apply (simp add: finite_dom_def)
  apply (auto)
  done

lemma id_sub_dom: "sub_dom r_s r_s"
  apply (simp add: sub_dom_def)
  done

lemma lift_sub_dom: "\<lbrakk> sub_dom r_x r_s \<rbrakk> \<Longrightarrow> sub_dom (lift_var_env r_x p) r_s"
  apply (simp add: sub_dom_def)
  apply (simp add: lift_var_env_def)
  done

lemma lift_sub_dom2: "\<lbrakk> sub_dom r_x r_s \<rbrakk> \<Longrightarrow> sub_dom r_x (lift_var_env r_s p)"
  apply (simp add: sub_dom_def)
  apply (simp add: lift_var_env_def)
  done

lemma dist_lift_sub_dom: "\<lbrakk> sub_dom r_x r_s \<rbrakk> \<Longrightarrow> sub_dom (lift_var_env r_x p) (lift_var_env r_s p)"
  apply (simp add: sub_dom_def)
  apply (simp add: lift_var_env_def)
  done

lemma dist_comp_sub_dom: "\<lbrakk> sub_dom r_xa r_s; sub_dom r_xb r_s \<rbrakk> \<Longrightarrow> sub_dom (comp_var_env r_xa r_xb) r_s"
  apply (simp add: sub_dom_def)
  apply (simp add: comp_var_env_def)
  done

lemma comp_sub_dom1: "\<lbrakk> sub_dom r_x r_sa \<rbrakk> \<Longrightarrow> sub_dom r_x (comp_var_env r_sa r_sb)"
  apply (simp add: sub_dom_def)
  apply (simp add: comp_var_env_def)
  done

lemma comp_sub_dom2: "\<lbrakk> sub_dom r_x r_sb \<rbrakk> \<Longrightarrow> sub_dom r_x (comp_var_env r_sa r_sb)"
  apply (simp add: sub_dom_def)
  apply (simp add: comp_var_env_def)
  done

lemma dist_rem_sub_dom: "\<lbrakk> sub_dom r_x r_s \<rbrakk> \<Longrightarrow> sub_dom (rem_var_env r_x x) (rem_var_env r_s x)"
  apply (simp add: sub_dom_def)
  apply (simp add: rem_var_env_def)
  done

lemma if_zero_sub_dom: "\<lbrakk> sub_dom r_x r_s \<rbrakk> \<Longrightarrow> sub_dom (ifz_var_env q r_x) r_s"
  apply (simp add: sub_dom_def)
  apply (simp add: ifz_var_env_def)
  done

lemma if_zero_sub_dom2: "\<lbrakk> sub_dom r_x r_s \<rbrakk> \<Longrightarrow> sub_dom r_x (ifz_var_env q r_s)"
  apply (simp add: sub_dom_def)
  apply (simp add: ifz_var_env_def)
  done

lemma infer_x_sub_dom: "\<lbrakk> infer_type env ds e tau r_s r_x r_m c_list ds' \<rbrakk> \<Longrightarrow> sub_dom r_x r_s"
  apply (induct e arbitrary: env ds tau r_s r_x r_m c_list ds')
        apply (auto)
    (* const + op + var case *)
        apply (rule_tac id_sub_dom)
       apply (rule_tac id_sub_dom)
      apply (rule_tac id_sub_dom)
    (* pair case *)
     apply (rule_tac if_zero_sub_dom)
     apply (rule_tac dist_comp_sub_dom)
      apply (rule_tac comp_sub_dom1)
      apply (rule_tac comp_sub_dom2)
      apply (rule_tac id_sub_dom)
     apply (rule_tac comp_sub_dom2)
     apply (rule_tac comp_sub_dom2)
     apply (rule_tac id_sub_dom)
    (* if case *)
    apply (rule_tac comp_sub_dom2)
    apply (rule_tac dist_comp_sub_dom)
     apply (rule_tac comp_sub_dom1)
     apply (simp)
    apply (rule_tac comp_sub_dom2)
    apply (simp)
    (* lam case *)
   apply (rule_tac dist_rem_sub_dom)
   apply (rule_tac id_sub_dom)
    (* app case *)
  apply (rule_tac if_zero_sub_dom)
  apply (rule_tac dist_comp_sub_dom)
   apply (rule_tac comp_sub_dom1)
   apply (rule_tac comp_sub_dom2)
   apply (rule_tac id_sub_dom)
  apply (rule_tac comp_sub_dom2)
  apply (rule_tac comp_sub_dom2)
  apply (rule_tac id_sub_dom)
  done

lemma infer_m_sub_dom: "\<lbrakk> infer_type env ds e tau r_s r_x r_m c_list ds' \<rbrakk> \<Longrightarrow> sub_dom r_m r_s"
  apply (induct e arbitrary: env ds tau r_s r_x r_m c_list ds')
        apply (auto)
    (* const + op + var case *)
        apply (rule_tac id_sub_dom)
       apply (rule_tac id_sub_dom)
      apply (rule_tac id_sub_dom)
    (* pair case *)
     apply (rule_tac dist_comp_sub_dom)
      apply (rule_tac comp_sub_dom1)
      apply (rule_tac comp_sub_dom1)
      apply (simp)
     apply (rule_tac comp_sub_dom2)
     apply (rule_tac comp_sub_dom1)
     apply (simp)
    (* if case *)
    apply (rule_tac dist_comp_sub_dom)
     apply (rule_tac comp_sub_dom1)
     apply (simp)
    apply (rule_tac dist_comp_sub_dom)
     apply (rule_tac comp_sub_dom2)
     apply (rule_tac comp_sub_dom1)
     apply (simp)
    apply (rule_tac comp_sub_dom2)
    apply (rule_tac comp_sub_dom2)
    apply (simp)
    (* lam case *)
   apply (simp add: sub_dom_def)
   apply (simp add: empty_var_env_def)
    (* app case *)
  apply (rule_tac dist_comp_sub_dom)
   apply (rule_tac comp_sub_dom1)
   apply (rule_tac dist_comp_sub_dom)
    apply (rule_tac comp_sub_dom1)
    apply (simp)
   apply (rule_tac comp_sub_dom2)
   apply (rule_tac id_sub_dom)
  apply (rule_tac comp_sub_dom2)
  apply (rule_tac dist_comp_sub_dom)
   apply (rule_tac comp_sub_dom1)
   apply (simp)
  apply (rule_tac comp_sub_dom2)
  apply (rule_tac id_sub_dom)
  done

    (* ##### general inferencing lemmas *)

lemma infer_x_leq_use_env: "\<lbrakk> infer_type env ds e tau r_s r_x r_m c_list ds' \<rbrakk> \<Longrightarrow>
  leq_use_env (dir_subst_penv t_sub p_sub r_x) (dir_subst_penv t_sub p_sub r_s)"
  apply (induct e arbitrary: env ds tau r_s r_x r_m c_list ds')
        apply (auto)
    (* const + op + var cases *)
        apply (rule_tac id_leq_use_env)
       apply (rule_tac id_leq_use_env)
      apply (rule_tac id_leq_use_env)
    (* pair case *)
     apply (rule_tac if_zero_leq_var_env)
     apply (rule_tac dist_comp_leq_var_env)
      apply (rule_tac comp_leq_var_env1)
      apply (rule_tac comp_leq_var_env2)
      apply (rule_tac id_leq_use_env)
     apply (rule_tac comp_leq_var_env2)
     apply (rule_tac comp_leq_var_env2)
     apply (rule_tac id_leq_use_env)
    (* if case *)
    apply (rule_tac comp_leq_var_env2)
    apply (rule_tac dist_comp_leq_var_env)
     apply (rule_tac comp_leq_var_env1)
     apply (auto)
    apply (rule_tac comp_leq_var_env2)
    apply (auto)
    (* lam + app case *)
   apply (rule_tac id_leq_use_env)
  apply (rule_tac if_zero_leq_var_env)
  apply (rule_tac dist_comp_leq_var_env)
   apply (rule_tac comp_leq_var_env1)
   apply (rule_tac comp_leq_var_env2)
   apply (rule_tac id_leq_use_env)
  apply (rule_tac comp_leq_var_env2)
  apply (rule_tac comp_leq_var_env2)
  apply (rule_tac id_leq_use_env)
  done

lemma infer_m_leq_use_env: "\<lbrakk> infer_type env ds e tau r_s r_x r_m c_list ds' \<rbrakk> \<Longrightarrow>
  leq_use_env (dir_subst_penv t_sub p_sub r_m) (dir_subst_penv t_sub p_sub r_s)"
  apply (induct e arbitrary: env ds tau r_s r_x r_m c_list ds')
        apply (auto)
    (* const + op + var cases *)
        apply (rule_tac id_leq_use_env)
       apply (rule_tac id_leq_use_env)
      apply (rule_tac id_leq_use_env)
    (* pair case *)
     apply (rule_tac dist_comp_leq_var_env)
      apply (rule_tac comp_leq_var_env1)
      apply (rule_tac comp_leq_var_env1)
      apply (auto)
     apply (rule_tac comp_leq_var_env2)
     apply (rule_tac comp_leq_var_env1)
     apply (auto)
    (* if case *)
    apply (rule_tac dist_comp_leq_var_env)
     apply (rule_tac comp_leq_var_env1)
     apply (auto)
    apply (rule_tac dist_comp_leq_var_env)
     apply (rule_tac comp_leq_var_env2)
     apply (rule_tac comp_leq_var_env1)
     apply (auto)
    apply (rule_tac comp_leq_var_env2)
    apply (rule_tac comp_leq_var_env2)
    apply (auto)
    (* lam + app case *)
   apply (rule_tac empty_leq_var_env)
  apply (rule_tac dist_comp_leq_var_env)
   apply (rule_tac comp_leq_var_env1)
   apply (rule_tac dist_comp_leq_var_env)
    apply (rule_tac comp_leq_var_env1)
    apply (auto)
   apply (rule_tac comp_leq_var_env2)
   apply (rule_tac id_leq_use_env)
  apply (rule_tac comp_leq_var_env2)
  apply (rule_tac dist_comp_leq_var_env)
   apply (rule_tac comp_leq_var_env1)
   apply (auto)
  apply (rule_tac comp_leq_var_env2)
  apply (rule_tac id_leq_use_env)
  done

    (* ##### special comp lemma *)

    (*
definition anti_norm_use_env where
  "anti_norm_use_env r_s r_x = (\<lambda> x. if r_x x \<noteq> NoPerm then NoPerm else r_s x)"
    *)
definition sub_norm_use_env where
  "sub_norm_use_env r_s r_x = (\<lambda> x. if r_x x = OwnPerm then NoPerm else r_s x)"

lemma decomp_use_env: "comp_use_env r_s r_x = comp_use_env r_s (sub_norm_use_env r_x r_s)"
  apply (case_tac "\<forall> x. comp_use_env r_s r_x x = comp_use_env r_s (sub_norm_use_env r_x r_s) x")
   apply (auto)
  apply (simp add: comp_use_env_def)
  apply (simp add: sub_norm_use_env_def)
  apply (auto)
  done

lemma mini_disj_sub_norm_use_env: "mini_disj_use_env r_s (sub_norm_use_env r_x r_s)"
  apply (simp add: mini_disj_use_env_def)
  apply (simp add: sub_norm_use_env_def)
  done

lemma well_typed_comp_perms_prec: "\<lbrakk> well_typed env r_s e tau (diff_use_env r_s r_ex) rx \<rbrakk> \<Longrightarrow>
  well_typed env (comp_use_env r_s r_x) e tau (diff_use_env (comp_use_env r_s r_x) r_ex) rx"
  apply (cut_tac r_s="r_s" and r_x="r_x" in decomp_use_env)
  apply (auto)
  apply (rule_tac r_c="comp_use_env (diff_use_env r_s r_ex) (sub_norm_use_env r_x r_s)" in well_typed_decr_end_perm)
    apply (rule_tac well_typed_comp_perms_gen)
     apply (simp)
    apply (rule_tac mini_disj_sub_norm_use_env)
   apply (rule_tac lhs_dist_dcl_use_env)
   apply (rule_tac dist_comp_leq_use_env)
    apply (rule_tac self_comp_leq_use_env1)
   apply (rule_tac comp_leq_use_env2)
   apply (rule_tac self_diff_leq_use_env)
  apply (rule_tac r_sb="diff_use_env r_s r_ex" in trans_leq_use_env)
   apply (rule_tac dist_diff_leq_use_env)
   apply (rule_tac self_comp_leq_use_env1)
  apply (rule_tac well_typed_perm_leqx)
  apply (auto)
  done

lemma well_typed_comp_perms_prec2: "\<lbrakk> well_typed env r_s e tau (diff_use_env r_s r_ex) rx  \<rbrakk> \<Longrightarrow>
  well_typed env (comp_use_env r_x r_s) e tau (diff_use_env (comp_use_env r_x r_s) r_ex) rx"
  apply (simp add: comm_comp_use_env)
  apply (rule_tac well_typed_comp_perms_prec)
   apply (auto)
  done

    (* ##### special lifting lemma *)

lemma spec_diff_comp_leq_use_env: "\<lbrakk> leq_use_env r_x r_sb; leq_use_env r_x (diff_use_env (comp_use_env r_sa r_sb) r_ex) \<rbrakk> \<Longrightarrow>
  leq_use_env r_x (diff_use_env r_sb r_ex)"
  apply (simp add: leq_use_env_def)
  apply (simp add: diff_use_env_def)
  apply (simp add: comp_use_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (erule_tac x="x" in allE)
  apply (case_tac "r_x x")
    apply (auto)
   apply (case_tac "r_ex x")
     apply (auto)
  apply (case_tac "r_ex x")
    apply (auto)
  done

lemma wtclp_leq_use_env: "\<lbrakk> leq_use_env r_xb r_sb;
  leq_use_env (comp_use_env r_xa r_xb) (diff_use_env (comp_use_env r_sa r_sb) r_ex) \<rbrakk>
    \<Longrightarrow> leq_use_env (comp_use_env r_xa (lift_use_env r_xb r))
        (diff_use_env (comp_use_env r_sa (lift_use_env r_sb r)) r_ex)"
  apply (rule_tac dist_comp_leq_use_env)
   apply (rule_tac r_sb="diff_use_env (comp_use_env r_sa r_sb) r_ex" in trans_leq_use_env)
    apply (rule_tac dist_diff_leq_use_env)
    apply (rule_tac dist_comp_leq_use_env)
     apply (rule_tac self_comp_leq_use_env1)
    apply (rule_tac comp_leq_use_env2)
    apply (rule_tac self_lift_leq_use_env)
   apply (rule_tac r_sb="comp_use_env r_xa r_xb" in trans_leq_use_env)
    apply (simp)
   apply (rule_tac self_comp_leq_use_env1)
  apply (rule_tac rhs_dist_dcl_use_env)
  apply (rule_tac comp_leq_use_env2)
  apply (simp add: lift_diff_use_env)
  apply (rule_tac dist_lift_leq_use_env)
  apply (rule_tac r_sa="r_sa" in spec_diff_comp_leq_use_env)
   apply (simp)
  apply (rule_tac r_sb="comp_use_env r_xa r_xb" in trans_leq_use_env)
   apply (auto)
  apply (rule_tac self_comp_leq_use_env2)
  done

lemma simp_lift_comp_leq_use_env: "\<lbrakk> leq_use_env r_x (comp_use_env r_sa r_sb) \<rbrakk> \<Longrightarrow> leq_use_env r_x (comp_use_env r_sa (lift_use_env r_sb r))"
  apply (rule_tac r_sb="comp_use_env r_sa r_sb" in trans_leq_use_env)
   apply (rule_tac dist_comp_leq_use_env)
    apply (rule_tac self_comp_leq_use_env1)
   apply (rule_tac comp_leq_use_env2)
   apply (rule_tac self_lift_leq_use_env)
  apply (simp)
  done

lemma well_typed_comp_lift_perms: "\<lbrakk> well_typed env (comp_use_env r_sa r_sb) e tau (comp_use_env r_xa r_xb) rx; leq_use_env r_xb r_sb \<rbrakk> \<Longrightarrow>
  well_typed env (comp_use_env r_sa (lift_use_env r_sb r)) e tau (comp_use_env r_xa (lift_use_env r_xb r)) rx"
  apply (induct e arbitrary: env r_sa r_sb tau r_xa r_xb rx)
        apply (auto)
    (* const + op cases *)
           apply (rule_tac dist_comp_leq_use_env)
            apply (rule_tac simp_lift_comp_leq_use_env)
            apply (rule_tac r_sb="comp_use_env r_xa r_xb" in trans_leq_use_env)
             apply (simp)
            apply (rule_tac self_comp_leq_use_env1)
           apply (rule_tac comp_leq_use_env2)
           apply (rule_tac dist_lift_leq_use_env)
           apply (simp)
          apply (rule_tac simp_lift_comp_leq_use_env)
          apply (simp)
         apply (rule_tac dist_comp_leq_use_env)
          apply (rule_tac simp_lift_comp_leq_use_env)
          apply (rule_tac r_sb="comp_use_env r_xa r_xb" in trans_leq_use_env)
           apply (simp)
          apply (rule_tac self_comp_leq_use_env1)
         apply (rule_tac comp_leq_use_env2)
         apply (rule_tac dist_lift_leq_use_env)
         apply (simp)
        apply (rule_tac simp_lift_comp_leq_use_env)
        apply (simp)
    (* var cases *)
       apply (rule_tac simp_lift_comp_leq_use_env)
       apply (simp)
      apply (rule_tac x="r_ex" in exI)
      apply (auto)
        apply (rule_tac wtclp_leq_use_env)
         apply (auto)
       apply (rule_tac simp_lift_comp_leq_use_env)
       apply (simp)
      apply (rule_tac simp_lift_comp_leq_use_env)
      apply (simp)
    (* pair case *)
     apply (cut_tac r_sc="r_xb" and r_sb="comp_use_env r_xa r_xb" and r_sa="r_s3" in trans_leq_use_env)
       apply (rule_tac r_sb="diff_use_env r_s3 r_ex" in trans_leq_use_env)
        apply (rule_tac self_diff_leq_use_env)
       apply (simp)
      apply (rule_tac self_comp_leq_use_env2)
     apply (cut_tac r_sc="r_xb" and r_sb="r_s3" and r_sa="r_s2" in trans_leq_use_env)
       apply (rule_tac well_typed_perm_leq)
       apply (auto)
     apply (rule_tac x="comp_use_env r_s2 (lift_use_env r_xb r)" in exI)
     apply (rule_tac x="comp_use_env r_s3 (lift_use_env r_xb r)" in exI)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
      apply (case_tac "\<not> well_typed env (comp_use_env r_sa r_sb) e1 t1 (comp_use_env r_s2 r_xb) rx1")
       apply (cut_tac r_s="r_s2" and r_x="r_xb" in cancel_comp_use_env2)
        apply (auto)
     apply (rule_tac x="rx2" in exI)
     apply (auto)
        apply (case_tac "\<not> well_typed env (comp_use_env r_s2 r_xb) e2 t2 (comp_use_env r_s3 r_xb) rx2")
         apply (cut_tac r_s="r_s3" and r_x="r_xb" in cancel_comp_use_env2)
          apply (simp_all)
         apply (cut_tac env="env" and r_c="comp_use_env r_s2 r_xb" and ?r_s1.0="r_s2" and e="e2" in well_typed_incr_start_perm)
           apply (auto)
         apply (rule_tac self_comp_leq_use_env1)
        apply (cut_tac r="r_xb" in id_leq_use_env)
        apply (auto)
       apply (rule_tac comp_leq_use_env1)
       apply (simp)
      apply (rule_tac comp_leq_use_env1)
      apply (simp)
     apply (rule_tac x="r_ex" in exI)
     apply (auto)
       apply (rule_tac wtclp_leq_use_env)
        apply (rule_tac id_leq_use_env)
       apply (rule_tac rhs_dist_dcl_use_env)
       apply (rule_tac comp_leq_use_env1)
       apply (simp)
      apply (rule_tac simp_lift_comp_leq_use_env)
      apply (simp)
     apply (rule_tac simp_lift_comp_leq_use_env)
     apply (simp)
    (* if case *)
    apply (rule_tac x="rx'" in exI)
    apply (rule_tac x="comp_use_env r_s2 (lift_use_env r_xb r)" in exI)
    apply (auto)
     apply (case_tac "\<not> well_typed env (comp_use_env r_sa r_sb) e1 BoolTy (comp_use_env r_s2 r_xb) rx'")
      apply (cut_tac r_s="r_s2" and r_x="r_xb" in cancel_comp_use_env2)
       apply (rule_tac r_sb="comp_use_env r_xa r_xb" in trans_leq_use_env)
        apply (rule_tac well_typed_perm_leq)
        apply (auto)
     apply (rule_tac self_comp_leq_use_env2)
    apply (cut_tac r="r_xb" in id_leq_use_env)
    apply (cut_tac r_s="r_s2" and r_x="r_xb" in self_comp_leq_use_env1)
    apply (rule_tac x="rx1" in exI)
    apply (auto)
     apply (cut_tac env="env" and ?r_s1.0="r_s2" and r_c="comp_use_env r_s2 r_xb" and e="e2" in well_typed_incr_start_perm)
       apply (auto)
    apply (rule_tac x="rx2" in exI)
    apply (auto)
    apply (cut_tac env="env" and ?r_s1.0="r_s2" and r_c="comp_use_env r_s2 r_xb" and e="e3" in well_typed_incr_start_perm)
      apply (auto)
    (* lam case *)
   apply (rule_tac x="rxa" in exI)
   apply (auto)
    apply (rule_tac simp_lift_comp_leq_use_env)
    apply (simp)
   apply (rule_tac x="r_ex" in exI)
   apply (auto)
     apply (rule_tac wtclp_leq_use_env)
      apply (auto)
    apply (rule_tac simp_lift_comp_leq_use_env)
    apply (simp)
   apply (rule_tac simp_lift_comp_leq_use_env)
   apply (simp)
    (* app case *)
  apply (cut_tac r_sc="r_xb" and r_sb="comp_use_env r_xa r_xb" and r_sa="r_s3" in trans_leq_use_env)
    apply (rule_tac r_sb="diff_use_env r_s3 (comp_use_env (comp_use_env rx1 (lift_use_env rx2 ra)) r_ex)" in trans_leq_use_env)
     apply (rule_tac self_diff_leq_use_env)
    apply (simp)
   apply (rule_tac self_comp_leq_use_env2)
  apply (cut_tac r_sc="r_xb" and r_sb="r_s3" and r_sa="r_s2" in trans_leq_use_env)
    apply (rule_tac well_typed_perm_leq)
    apply (auto)
  apply (cut_tac r="r_xb" in id_leq_use_env)
  apply (rule_tac x="t1" in exI)
  apply (rule_tac x="ra" in exI)
  apply (rule_tac x="a" in exI)
  apply (rule_tac x="comp_use_env r_s2 (lift_use_env r_xb r)" in exI)
  apply (rule_tac x="rx1" in exI)
  apply (auto)
   apply (case_tac "\<not> well_typed env (comp_use_env r_sa r_sb) e1 (FunTy t1 tau ra a) (comp_use_env r_s2 r_xb) rx1")
    apply (cut_tac r_s="r_s2" and r_x="r_xb" in cancel_comp_use_env2)
     apply (auto)
  apply (rule_tac x="rx2" in exI)
  apply (rule_tac x="comp_use_env r_s3 (lift_use_env r_xb r)" in exI)
  apply (auto)
   apply (case_tac "\<not> well_typed env (comp_use_env r_s2 r_xb) e2 t1 (comp_use_env r_s3 r_xb) rx2")
    apply (cut_tac r_s="r_s3" and r_x="r_xb" in cancel_comp_use_env2)
     apply (auto)
   apply (cut_tac env="env" and ?r_s1.0="r_s2" and r_c="comp_use_env r_s2 r_xb" and e="e2" in well_typed_incr_start_perm)
     apply (auto)
   apply (rule_tac self_comp_leq_use_env1)
  apply (rule_tac x="r_ex" in exI)
  apply (auto)
     apply (rule_tac wtclp_leq_use_env)
      apply (auto)
     apply (rule_tac rhs_dist_dcl_use_env)
     apply (rule_tac comp_leq_use_env1)
     apply (simp)
    apply (rule_tac comp_leq_use_env1)
    apply (simp)
   apply (rule_tac simp_lift_comp_leq_use_env)
   apply (simp)
  apply (rule_tac simp_lift_comp_leq_use_env)
  apply (simp)
  done

definition set_dom :: "string set \<Rightarrow> string list \<Rightarrow> bool" where
  "set_dom ds l = (\<forall> x. x \<in> ds \<longrightarrow> list_contain l x)"

fun max_length where
  "max_length [] = 0"
| "max_length (x # t) = max (length x) (max_length t)"

  (* how can we prove that the "nu-string" is not contained in l? inductively, we know that the lesser*)

lemma m_list_ex: "\<lbrakk> length x > max_length l \<rbrakk> \<Longrightarrow> \<not> list_contain l x"
  apply (induct l)
   apply (auto)
  done

lemma string_of_length: "\<exists> s :: string. length s = i"
  apply (rule_tac Ex_list_of_length)
  done

lemma fresh_list_ex_gen: "\<lbrakk> set_dom ds l; fresh_list ds t \<rbrakk> \<Longrightarrow> \<exists> a. fresh_list ds (a # t)"
  apply (simp add: fresh_list_def)
  apply (auto)
  apply (cut_tac i="(max (max_length l) (max_length t)) + 1" in string_of_length)
  apply (auto)
  apply (rule_tac x="s" in exI)
  apply (auto)
    (* t does not contain a by construction *)
   apply (cut_tac l="t" and x="s" in m_list_ex)
    apply (auto)
    (* l does not contain a by construction as well *)
  apply (simp add: set_dom_def)
  apply (erule_tac x="s" in allE)
  apply (cut_tac l="l" and x="s" in m_list_ex)
   apply (auto)
  done

lemma fresh_list_ex1: "\<lbrakk> set_dom ds l \<rbrakk> \<Longrightarrow> \<exists> a. fresh_list ds [a]"
  apply (rule_tac fresh_list_ex_gen)
   apply (auto)
  apply (simp add: fresh_list_def)
  done

lemma fresh_list_exl: "\<lbrakk> set_dom ds l \<rbrakk> \<Longrightarrow> \<exists> l'. fresh_list ds l' \<and> length l' = i"
  apply (induct i)
   apply (auto)
   apply (simp add: fresh_list_def)
  apply (cut_tac ds="ds" and t="l'" in fresh_list_ex_gen)
    apply (auto)
  done

lemma fresh_list_ex4: "\<lbrakk> set_dom ds l \<rbrakk> \<Longrightarrow> \<exists> a b c d. fresh_list ds [a, b, c, d]"
  apply (cut_tac ds="ds" and l="l" and i="4" in fresh_list_exl)
   apply (auto)
  apply (case_tac l')
   apply (auto)
  apply (case_tac list)
   apply (auto)
  apply (case_tac lista)
   apply (auto)
  apply (case_tac list)
   apply (auto)
  done

end