theory SolverP1b
  imports SolverP1
begin

fun perm_subst_perm where
  "perm_subst_perm rho (SPerm p) = SPerm p"
| "perm_subst_perm rho (SVar r) = (case rho r of
    None \<Rightarrow> SVar r
    | Some p \<Rightarrow> p
  )"

fun perm_subst_aff where
  "perm_subst_aff rho (AffConst a) = SPerm (as_perm a)"
| "perm_subst_aff rho (AffVar a) = (case rho a of
    None \<Rightarrow> SVar a
    | Some p \<Rightarrow> p
  )"

fun perm_subst_eq_list where
  "perm_subst_eq_list rho [] = []"
| "perm_subst_eq_list rho ((p1, p2) # p_t) = (perm_subst_perm rho p1, perm_subst_perm rho p2) # (perm_subst_eq_list rho p_t)"

fun pvar_perm_l where
  "pvar_perm_l (SVar r) = [r]"
  | "pvar_perm_l (SPerm p) = []"

fun pvar_eq_list where
  "pvar_eq_list [] = []"
| "pvar_eq_list ((p1, p2) # p_t) = union_list (union_list (pvar_perm_l p1) (pvar_perm_l p2)) (pvar_eq_list p_t)"

definition pvar_total where
  "pvar_total c_list = length (pvar_eq_list c_list)"

fun perm_cons :: "s_perm \<Rightarrow> nat" where
  "perm_cons (SPerm p) = 1"
| "perm_cons (SVar r) = 0"

fun pcons_list where
  "pcons_list [] = 0"
| "pcons_list ((p1, p2) # p_t) = (perm_cons p1) + (pcons_list p_t)"

definition p_unify_rel where
  "p_unify_rel = measures [pvar_total, pcons_list, length]"

lemma pvar_perm_fresh_list: "fresh_in_list (pvar_perm_l p)"
  apply (induct p)
   apply (auto)
  done

lemma pvar_eq_fresh_list: "fresh_in_list (pvar_eq_list p_list)"
  apply (induct p_list)
   apply (auto)
  apply (rule_tac union_fresh_list)
  apply (rule_tac union_fresh_list)
    apply (rule_tac pvar_perm_fresh_list)
   apply (rule_tac pvar_perm_fresh_list)
  apply (simp)
  done

lemma cons_less_pvar_total: "pvar_total p_list \<le> pvar_total (p # p_list)"
  apply (simp add: pvar_total_def)
  apply (case_tac p)
  apply (auto)
  apply (rule_tac sub_list_less_length)
   apply (rule_tac pvar_eq_fresh_list)
  apply (rule_tac union_sub_list2)
  apply (rule_tac id_sub_list)
  done

lemma simp_p_unify_rel: "(p_list, (x, y) # p_list) \<in> p_unify_rel"
  apply (simp add: p_unify_rel_def)
  apply (auto)
  apply (cut_tac p_list="p_list" and p="(x, y)" in cons_less_pvar_total)
  apply (auto)
  done

lemma orient_less_pvar_total: "pvar_total ((q, p) # p_list) \<le> pvar_total ((p, q) # p_list)"
  apply (simp add: pvar_total_def)
  apply (rule_tac sub_list_less_length)
   apply (rule_tac union_fresh_list)
    apply (rule_tac union_fresh_list)
     apply (rule_tac pvar_perm_fresh_list)
    apply (rule_tac pvar_perm_fresh_list)
   apply (rule_tac pvar_eq_fresh_list)
  apply (rule_tac dist_union_sub_list)
   apply (rule_tac union_sub_list1)
   apply (rule_tac dist_union_sub_list)
    apply (rule_tac union_sub_list2)
    apply (rule_tac id_sub_list)
   apply (rule_tac union_sub_list1)
   apply (rule_tac id_sub_list)
  apply (rule_tac union_sub_list2)
  apply (rule_tac id_sub_list)
  done

lemma orient_p_unify_rel: "\<lbrakk> \<forall> q. p \<noteq> SVar q \<rbrakk> \<Longrightarrow> ((SVar r, p) # p_list, (p, SVar r) # p_list) \<in> p_unify_rel"
  apply (simp add: p_unify_rel_def)
  apply (auto)
   apply (cut_tac q="SVar r" and p="p" and p_list="p_list" in orient_less_pvar_total)
   apply (auto)
  apply (case_tac p)
   apply (auto)
  done

lemma perm_subst_perm_sub_list: "\<lbrakk> sub_list (pvar_perm_l p) l; sub_list (pvar_perm_l q) l \<rbrakk> \<Longrightarrow>
  sub_list (pvar_perm_l (perm_subst_perm (add_env empty_env x q) p)) l"
  apply (induct p)
   apply (auto)
  apply (simp add: add_env_def)
  apply (simp add: empty_env_def)
  done

lemma perm_subst_sub_list: "\<lbrakk> sub_list (pvar_perm_l p) l; sub_list (pvar_eq_list p_list) l \<rbrakk> \<Longrightarrow>
  sub_list (pvar_eq_list (perm_subst_eq_list (add_env empty_env r p) p_list)) l"
  apply (induct p_list arbitrary: l)
   apply (auto)
  apply (cut_tac la="union_list (pvar_perm_l a) (pvar_perm_l b)" and lb="pvar_eq_list p_list" and lc="l" in union_sub_list_rev)
   apply (auto)
  apply (cut_tac la="pvar_perm_l a" and lb="pvar_perm_l b" and lc="l" in union_sub_list_rev)
   apply (auto)
  apply (rule_tac dist_union_sub_list)
   apply (rule_tac dist_union_sub_list)
    apply (rule_tac perm_subst_perm_sub_list)
     apply (auto)
  apply (rule_tac perm_subst_perm_sub_list)
   apply (auto)
  done

lemma perm_subst_perm_list_contain: "\<lbrakk> SVar r \<noteq> p \<rbrakk> \<Longrightarrow>
  \<not> list_contain (pvar_perm_l (perm_subst_perm (add_env empty_env r p) q)) r"
  apply (induct q)
   apply (auto)
  apply (simp add: add_env_def)
  apply (case_tac "r = x")
   apply (auto)
   apply (case_tac p)
    apply (auto)
  apply (simp add: empty_env_def)
  done

lemma perm_subst_list_contain: "\<lbrakk> SVar r \<noteq> p \<rbrakk> \<Longrightarrow>
  \<not> list_contain (pvar_eq_list (perm_subst_eq_list (add_env empty_env r p) p_list)) r"
  apply (induct p_list)
   apply (auto)
  apply (cut_tac ?l1.0="union_list (pvar_perm_l (perm_subst_perm (add_env empty_env r p) a)) (pvar_perm_l (perm_subst_perm (add_env empty_env r p) b))"
      and ?l2.0="pvar_eq_list (perm_subst_eq_list (add_env empty_env r p) p_list)" and x="r" in dist_union_list_contain)
   apply (auto)
  apply (cut_tac ?l1.0="pvar_perm_l (perm_subst_perm (add_env empty_env r p) a)"
      and ?l2.0="pvar_perm_l (perm_subst_perm (add_env empty_env r p) b)" and x="r" in dist_union_list_contain)
   apply (auto)
   apply (cut_tac p="p" and q="a" and r="r" in perm_subst_perm_list_contain)
    apply (auto)
  apply (cut_tac p="p" and q="b" and r="r" in perm_subst_perm_list_contain)
   apply (auto)
  done

lemma epur_less_pvar_total: "\<lbrakk> SVar r \<noteq> p \<rbrakk> \<Longrightarrow>
  length (pvar_eq_list (perm_subst_eq_list (add_env empty_env r p) p_list)) \<le>
  length (rem_list (union_list (add_list (pvar_perm_l p) r) (pvar_eq_list p_list)) r)"
  apply (rule_tac sub_list_less_length)
   apply (rule_tac pvar_eq_fresh_list)
  apply (rule_tac rem_sub_list)
   apply (rule_tac perm_subst_sub_list)
    apply (rule_tac union_sub_list1)
    apply (rule_tac add_sub_list)
    apply (rule_tac id_sub_list)
   apply (rule_tac union_sub_list2)
   apply (rule_tac id_sub_list)
  apply (rule_tac perm_subst_list_contain)
  apply (simp)
  done

lemma elim_p_unify_rel: "\<lbrakk> SVar r \<noteq> p \<rbrakk> \<Longrightarrow>
  (perm_subst_eq_list (add_env empty_env r p) p_list, (SVar r, p) # p_list) \<in> p_unify_rel"
  apply (case_tac "\<not> length (pvar_eq_list (perm_subst_eq_list (add_env empty_env r p) p_list))
     < length (union_list (add_list (pvar_perm_l p) r) (pvar_eq_list p_list))")
   apply (cut_tac r="r" and p="p" and p_list="p_list" in epur_less_pvar_total)
    apply (simp)
   apply (cut_tac l="union_list (add_list (pvar_perm_l p) r) (pvar_eq_list p_list)" and x="r" in contain_rem_list_length)
    apply (rule_tac union_list_contain1)
    apply (simp add: add_list_def)
   apply (auto)
  apply (simp add: p_unify_rel_def)
  apply (auto)
    apply (simp_all add: pvar_total_def)
  done

lemma perm_subst_perm_eq: "\<lbrakk> p_sub r = sol_subst_perm p_sub p \<rbrakk> \<Longrightarrow>
 sol_subst_perm p_sub (perm_subst_perm (add_env empty_env r p) a) = sol_subst_perm p_sub a"
  apply (case_tac a)
   apply (auto)
  apply (simp add: add_env_def)
  apply (simp add: empty_env_def)
  apply (auto)
  done

lemma perm_subst_perm_eq_sat: "\<lbrakk> perm_eq_sat_f p_sub p_list; p_sub r = sol_subst_perm p_sub p \<rbrakk> \<Longrightarrow>
  perm_eq_sat_f p_sub (perm_subst_eq_list (add_env empty_env r p) p_list)"
  apply (induct p_list)
   apply (auto)
  apply (simp add: perm_subst_perm_eq)
  done

lemma perm_subst_perm_eq_sat_rev: "\<lbrakk> perm_eq_sat_f p_sub (perm_subst_eq_list (add_env empty_env r p) p_list);
  p_sub r = sol_subst_perm p_sub p \<rbrakk> \<Longrightarrow> perm_eq_sat_f p_sub p_list"
  apply (induct p_list)
   apply (auto)
  apply (simp add: perm_subst_perm_eq)
  done

function unify_perm where
  "unify_perm [] = Some empty_env"
| "unify_perm ((p1, p2) # p_t) = (case (p1, p2) of
    (SVar r, p) \<Rightarrow>
      if p = SVar r then unify_perm p_t
      else (case unify_perm (perm_subst_eq_list (add_env empty_env r p) p_t) of
        None \<Rightarrow> None
        | Some rho \<Rightarrow> Some (add_env rho r (perm_subst_perm rho p))
      )
    | (p, SVar r) \<Rightarrow> unify_perm ((SVar r, p) # p_t)
    | (SPerm p, SPerm q) \<Rightarrow> if p = q then unify_perm p_t else None
  )"
  by pat_completeness auto
termination
  apply (relation "p_unify_rel")
                      apply (auto)
    (* simple cases *)
      apply (simp add: p_unify_rel_def)
     apply (simp_all add: simp_p_unify_rel)
   apply (simp add: orient_p_unify_rel)
  apply (simp add: elim_p_unify_rel)
  done

lemma unify_perm_unsat: "\<lbrakk> unify_perm p_list = None \<rbrakk> \<Longrightarrow> \<not> perm_eq_sat p_sub p_list"
  apply (induct rule: wf_induct [where r=p_unify_rel])
   apply (auto)
   apply (simp add: p_unify_rel_def)
  apply (case_tac x)
   apply (auto)
    (* elim case *)
  apply (case_tac "\<exists> r. a = SVar r")
   apply (auto)
   apply (simp add: perm_eq_sat_def)
   apply (case_tac "b = SVar r")
    apply (auto)
    apply (simp add: simp_p_unify_rel)
   apply (case_tac "unify_perm (perm_subst_eq_list (add_env empty_env r b) list)")
    apply (auto)
   apply (erule_tac x="perm_subst_eq_list (add_env empty_env r b) list" in allE)
   apply (simp add: elim_p_unify_rel)
   apply (simp add: perm_subst_perm_eq_sat)
     (* orient case *)
  apply (case_tac "\<exists> r. b = SVar r")
   apply (auto)
   apply (erule_tac x=" (SVar r, a) # list" in allE)
   apply (simp add: orient_p_unify_rel)
   apply (case_tac a)
    apply (auto)
   apply (simp add: perm_eq_sat_def)
    (* decomp case *)
  apply (case_tac a)
   apply (auto)
  apply (case_tac b)
   apply (auto)
  apply (erule_tac x="list" in allE)
  apply (simp add: simp_p_unify_rel)
  apply (simp add: perm_eq_sat_def)
  done

definition spec_perm_env where
  "spec_perm_env p_sub p_sub' = (\<forall> x. case p_sub x of
    None \<Rightarrow> True
    | Some p \<Rightarrow> (case p of
      SPerm p \<Rightarrow> p_sub' x = p
      | SVar r \<Rightarrow> p_sub' x = p_sub' r
    )
  )"

lemma unify_perm_gen: "\<lbrakk> unify_perm p_list = Some p_sub; perm_eq_sat p_subx p_list \<rbrakk> \<Longrightarrow> spec_perm_env p_sub p_subx"
  apply (induct arbitrary: p_sub rule: wf_induct [where r=p_unify_rel])
   apply (simp add: p_unify_rel_def)
  apply (case_tac x)
   apply (auto)
   apply (simp add: p_unify_rel_def)
   apply (simp add: pvar_total_def)
   apply (simp add: spec_perm_env_def)
   apply (simp add: empty_env_def)
    (* var case *)
  apply (case_tac "\<exists> r. a = SVar r")
   apply (auto)
   apply (simp add: perm_eq_sat_def)
    (* - delete case *)
   apply (case_tac "b = SVar r")
    apply (auto)
    apply (erule_tac x="list" in allE)
    apply (simp add: simp_p_unify_rel)
    (* - elim case *)
   apply (case_tac "unify_perm (perm_subst_eq_list (add_env empty_env r b) list)")
    apply (auto)
   apply (erule_tac x="perm_subst_eq_list (add_env empty_env r b) list" in allE)
   apply (auto)
     apply (simp add: elim_p_unify_rel)
    apply (simp add: perm_subst_perm_eq_sat)
    (* > we want to show that p_sub(b) is a specialization of p_subx, we start with case analysis over b *)
   apply (simp add: spec_perm_env_def)
   apply (simp add: add_env_def)
   apply (case_tac b)
    apply (auto)
    (* > the main case is the var case. if a substitution occurs, specialization still holds since p_sub <: p_subx *)
   apply (case_tac "a x2")
    apply (auto)
   apply (erule_tac x="x2" in allE)
    apply (auto)
   apply (case_tac aa)
    apply (auto)
    (* orient case *)
  apply (case_tac "\<exists> r. b = SVar r")
   apply (auto)
   apply (erule_tac x="(SVar r, a) # list" in allE)
   apply (simp add: orient_p_unify_rel)
   apply (case_tac a)
    apply (auto)
   apply (simp add: perm_eq_sat_def)
    (* decomp case *)
  apply (case_tac a)
   apply (auto)
  apply (case_tac b)
   apply (auto)
  apply (erule_tac x="list" in allE)
  apply (simp add: simp_p_unify_rel)
  apply (simp add: perm_eq_sat_def)
  done

    (*
lemma unify_perm_sat: "\<lbrakk> unify_perm p_list = Some p_sub; spec_perm_env p_sub p_subx \<rbrakk> \<Longrightarrow> perm_eq_sat p_subx p_list"
  apply (induct arbitrary: p_sub rule: wf_induct [where r=p_unify_rel])
   apply (simp add: p_unify_rel_def)
  apply (case_tac x)
   apply (auto)
    (* var case *)
   apply (case_tac "\<exists> r. a = SVar r")
    apply (auto)
    (* - delete case *)
    apply (case_tac "b = SVar r")
     apply (auto)
    apply (erule_tac x="list" in allE)
    apply (simp add: simp_p_unify_rel)
    apply (case_tac "unify_perm (perm_subst_eq_list (add_env empty_env r b) list)")
     apply (auto)
    *)

lemma add_spec_perm_env_rev: "\<lbrakk> spec_perm_env (add_env p_sub r p) p_sub'; p_sub r = None \<rbrakk> \<Longrightarrow> spec_perm_env p_sub p_sub'"
  apply (simp add: spec_perm_env_def)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (case_tac "p_sub x")
   apply (auto)
  apply (simp add: add_env_def)
  apply (case_tac "r = x")
   apply (auto)
  done

fun pvar_eq_set where
  "pvar_eq_set [] = {}"
| "pvar_eq_set ((p1, p2) # p_t) = pvar_set_perm p1 \<union> pvar_set_perm p2 \<union> pvar_eq_set p_t"

lemma add_pvar_perm: "\<lbrakk> x \<notin> pvar_set_perm p; x \<notin> pvar_set_perm q \<rbrakk> \<Longrightarrow>
    x \<notin> pvar_set_perm (perm_subst_perm (add_env empty_env r p) q)"
  apply (case_tac q)
   apply (auto)
  apply (simp add: add_env_def)
  apply (case_tac "r = x2")
   apply (auto)
  apply (simp add: empty_env_def)
  done

lemma add_pvar_eq_set: "\<lbrakk> x \<notin> pvar_set_perm p; x \<notin> pvar_eq_set p_list \<rbrakk> \<Longrightarrow> x \<notin> pvar_eq_set (perm_subst_eq_list (add_env empty_env r p) p_list)"
  apply (induct p_list)
   apply (auto)
   apply (simp add: add_pvar_perm)
  apply (simp add: add_pvar_perm)
  done

lemma perm_subst_pvar_perm: "\<lbrakk> p \<noteq> SVar r \<rbrakk> \<Longrightarrow> r \<notin> pvar_set_perm (perm_subst_perm (add_env empty_env r p) q)"
  apply (case_tac q)
   apply (auto)
  apply (simp add: add_env_def)
  apply (case_tac "r = x2")
   apply (auto)
   apply (case_tac p)
    apply (auto)
  apply (simp add: empty_env_def)
  done

lemma perm_subst_pvar_eq_set: "\<lbrakk> p \<noteq> SVar r \<rbrakk> \<Longrightarrow> r \<notin> pvar_eq_set (perm_subst_eq_list (add_env empty_env r p) p_list)"
  apply (induct p_list)
   apply (auto)
   apply (simp add: perm_subst_pvar_perm)
  apply (simp add: perm_subst_pvar_perm)
  done

definition perm_sub_range where
  "perm_sub_range p_sub = { x | x. \<exists> y. case p_sub y of None \<Rightarrow> False | Some p \<Rightarrow> x \<in> pvar_set_perm p }"

definition uppr_res where
  "uppr_res p_sub x = (p_sub x = None \<and> x \<notin> perm_sub_range p_sub)"

lemma unify_perm_pvar_range_ih: "\<lbrakk> unify_perm p_list = Some p_sub; x \<notin> pvar_eq_set p_list \<rbrakk> \<Longrightarrow> uppr_res p_sub x"
  apply (induct arbitrary: p_sub rule: wf_induct [where r=p_unify_rel])
   apply (simp add: p_unify_rel_def)
  apply (case_tac xa)
   apply (auto)
   apply (simp add: uppr_res_def)
   apply (simp add: perm_sub_range_def)
   apply (simp add: empty_env_def)
    (* var case *)
  apply (case_tac "\<exists> r. a = SVar r")
   apply (auto)
    (* - delete case *)
   apply (case_tac "b = SVar r")
    apply (auto)
    apply (erule_tac x="list" in allE)
    apply (simp add: simp_p_unify_rel)
    (* - elim case *)
   apply (case_tac "unify_perm (perm_subst_eq_list (add_env empty_env r b) list)")
    apply (auto)
   apply (erule_tac x="perm_subst_eq_list (add_env empty_env r b) list" in allE)
   apply (auto)
     apply (simp add: elim_p_unify_rel)
    apply (simp add: add_pvar_eq_set)
   apply (simp add: add_env_def)
   apply (simp add: uppr_res_def)
   apply (simp add: perm_sub_range_def)
   apply (auto)
   apply (case_tac b)
    apply (auto)
   apply (erule_tac x="x2" in allE)
   apply (case_tac "a x2")
    apply (auto)
    (* orient case *)
  apply (case_tac "\<exists> r. b = SVar r")
   apply (auto)
   apply (erule_tac x="(SVar r, a) # list" in allE)
   apply (simp add: orient_p_unify_rel)
   apply (case_tac a)
    apply (auto)
    (* decomp case *)
  apply (case_tac a)
   apply (auto)
  apply (case_tac b)
   apply (auto)
  apply (erule_tac x="list" in allE)
  apply (simp add: simp_p_unify_rel)
  apply (case_tac "x1 = x1a")
   apply (auto)
  done

lemma unify_perm_pvar_range: "\<lbrakk> unify_perm p_list = Some p_sub; x \<notin> pvar_eq_set p_list \<rbrakk> \<Longrightarrow> x \<notin> perm_sub_range p_sub"
  apply (cut_tac unify_perm_pvar_range_ih)
    apply (auto)
  apply (simp add: uppr_res_def)
  done

lemma unify_perm_pvar_dom: "\<lbrakk> unify_perm p_list = Some p_sub; x \<notin> pvar_eq_set p_list \<rbrakk> \<Longrightarrow> p_sub x = None"
  apply (cut_tac unify_perm_pvar_range_ih)
    apply (auto)
  apply (simp add: uppr_res_def)
  done

lemma unify_perm_sat: "\<lbrakk> unify_perm p_list = Some p_sub; spec_perm_env p_sub p_subx \<rbrakk> \<Longrightarrow> perm_eq_sat p_subx p_list"
  apply (induct arbitrary: p_sub rule: wf_induct [where r=p_unify_rel])
   apply (simp add: p_unify_rel_def)
  apply (case_tac x)
   apply (auto)
   apply (simp add: perm_eq_sat_def)
    (* var case *)
  apply (case_tac "\<exists> r. a = SVar r")
   apply (auto)
    (* - delete case *)
   apply (case_tac "b = SVar r")
    apply (auto)
    apply (erule_tac x="list" in allE)
    apply (simp add: simp_p_unify_rel)
    apply (simp add: perm_eq_sat_def)
    (* - elim case *)
   apply (case_tac "unify_perm (perm_subst_eq_list (add_env empty_env r b) list)")
    apply (auto)
   apply (erule_tac x="perm_subst_eq_list (add_env empty_env r b) list" in allE)
   apply (auto)
     apply (simp add: elim_p_unify_rel)
    apply (cut_tac p_sub="a" and r="r" and p="perm_subst_perm a b" and p_sub'="p_subx" in add_spec_perm_env_rev)
      apply (auto)
    apply (cut_tac p_sub="a" and x="r" and p_list="perm_subst_eq_list (add_env empty_env r b) list" in unify_perm_pvar_dom)
      apply (auto)
    apply (simp add: perm_subst_pvar_eq_set)
    (* > prelim: p_subx r = sol_subst_perm p_subx b. the idea is that r is assigned a value in p_subx.
        in the original a, it is assigned b. if b is a permission, this is straightforward. *)
   apply (case_tac "\<not> p_subx r = sol_subst_perm p_subx b")
    apply (case_tac "\<not> (case add_env a r (perm_subst_perm a b) r of None \<Rightarrow> True | Some (SPerm pa) \<Rightarrow> p_subx r = pa | Some (SVar ra) \<Rightarrow> p_subx r = p_subx ra)")
     apply (simp add: spec_perm_env_def)
    apply (case_tac b)
     apply (auto)
     apply (simp add: add_env_def)
     (* > if b is a var, then the var it evaluates to should be equal to r *)
    apply (simp add: add_env_def)
    apply (case_tac "a x2")
     apply (auto)
    apply (simp add: spec_perm_env_def)
    apply (erule_tac x="x2" in allE)
    apply (auto)
    apply (case_tac aa)
     apply (auto)
      (* > unroll satisfiability definition *)
   apply (simp add: perm_eq_sat_def)
   apply (simp add: perm_subst_perm_eq_sat_rev)
    (* orient case *)
  apply (case_tac "\<exists> r. b = SVar r")
   apply (auto)
   apply (erule_tac x="(SVar r, a) # list" in allE)
   apply (simp add: orient_p_unify_rel)
   apply (case_tac a)
    apply (auto)
   apply (simp add: perm_eq_sat_def)
    (* decomp case *)
  apply (case_tac a)
   apply (auto)
  apply (case_tac b)
   apply (auto)
  apply (erule_tac x="list" in allE)
  apply (simp add: simp_p_unify_rel)
  apply (case_tac "x1 = x1a")
   apply (auto)
  apply (simp add: perm_eq_sat_def)
  done

fun def_req_type where
  "def_req_type rho (ArrayScheme tau) = SPerm UsePerm"
| "def_req_type rho (ChanScheme tau c_end) = SPerm UsePerm"
| "def_req_type rho (PairScheme t1 t2 p) = perm_subst_perm rho p"
| "def_req_type rho (FunScheme t1 t2 p a) = perm_subst_aff rho a"
| "def_req_type rho tau = SPerm NoPerm"

fun subst_req_type where
  "subst_req_type sigma rho (ArrayScheme tau) = SPerm UsePerm"
| "subst_req_type sigma rho (ChanScheme tau c_end) = SPerm UsePerm"
| "subst_req_type sigma rho (PairScheme t1 t2 p) = perm_subst_perm rho p"
| "subst_req_type sigma rho (FunScheme t1 t2 p a) = perm_subst_aff rho a"
| "subst_req_type sigma rho (VarScheme a) = (case sigma a of
    None \<Rightarrow> SPerm NoPerm
    | Some tau' \<Rightarrow> def_req_type rho tau'
  )"
| "subst_req_type sigma rho tau = SPerm NoPerm"

fun full_subst_permx where
  "full_subst_permx sigma rho (XPerm p) = XPerm (perm_subst_perm rho p)"
| "full_subst_permx sigma rho (XType a) = XPerm (subst_req_type sigma rho (VarScheme a))"
| "full_subst_permx sigma rho (XComp px qx) = XComp (full_subst_permx sigma rho px) (full_subst_permx sigma rho qx)"
| "full_subst_permx sigma rho (XLift px q) = XLift (full_subst_permx sigma rho px) (perm_subst_perm rho q)"
| "full_subst_permx sigma rho (XIfZero px qx) = XIfZero (full_subst_permx sigma rho px) (full_subst_permx sigma rho qx)"

fun reduce_subst_crn where
  "reduce_subst_crn sigma rho (UnifyCrn t1 t2) = []"
| "reduce_subst_crn sigma rho (LeqCrn px q) = [LeqCrn2 (full_subst_permx sigma rho px) (perm_subst_perm rho q)]"
| "reduce_subst_crn sigma rho (LeqTypeCrn tau q) = [LeqCrn2 (XPerm (subst_req_type sigma rho tau)) (perm_subst_perm rho q)]"
| "reduce_subst_crn sigma rho (DisjCrn px qx) = [DisjCrn2 (full_subst_permx sigma rho px) (full_subst_permx sigma rho qx)]"
| "reduce_subst_crn sigma rho (SemiDisjCrn px qx) = [MiniDisjCrn2 (full_subst_permx sigma rho px) (full_subst_permx sigma rho qx)]"
| "reduce_subst_crn sigma rho (MemValCrn tau tau') = []"

fun reduce_subst_list where
  "reduce_subst_list sigma rho [] = []"
| "reduce_subst_list sigma rho (c # c_t) = (reduce_subst_crn sigma rho c @ reduce_subst_list sigma rho c_t)"

fun no_mv_crn where
  "no_mv_crn [] = True"
| "no_mv_crn (c # c_t) = (case c of
    MemValCrn tau tau' \<Rightarrow> False
    | c' \<Rightarrow> no_mv_crn c_t
  )"

definition reduce_crn_list :: "perm_crn list \<Rightarrow> (perm_crn2 list) option" where
  "reduce_crn_list c_list = (case unify_type (unify_subset c_list) of
    None \<Rightarrow> None
    | Some (sigma, p_eq) \<Rightarrow> (case unify_perm p_eq of
      None \<Rightarrow> None
      | Some rho \<Rightarrow> Some (reduce_subst_list sigma rho c_list)
    )
  )"

lemma reduce_crn_list_unsat: "\<lbrakk> reduce_crn_list c_list = None \<rbrakk> \<Longrightarrow> \<not> dir_sol_sat t_sub p_sub c_list"
  apply (simp add: reduce_crn_list_def)
  apply (auto)
  apply (cut_tac t_sub="t_sub" and p_sub="p_sub" and c_list="c_list" in dir_sol_type_eq_sat)
   apply (auto)
  apply (case_tac "unify_type (unify_subset c_list)")
   apply (auto)
   apply (cut_tac t_sub="indir_sub t_sub" and p_sub="p_sub" and c_list="unify_subset c_list" in unify_type_unsat)
    apply (simp_all)
  apply (case_tac "unify_perm b")
   apply (auto)
  apply (cut_tac p_list="b" and p_sub="p_sub" in unify_perm_unsat)
   apply (auto)
  apply (cut_tac t_sub="a" and t_subx="indir_sub t_sub" and c_list="unify_subset c_list" and p_eq="b" and p_sub="p_sub" in unify_type_sat)
    apply (auto)
  apply (simp add: uts_res_def)
  done

lemma sol_sat_append_split: "\<lbrakk> sol_sat2 p_sub cl1; sol_sat2 p_sub cl2 \<rbrakk> \<Longrightarrow> sol_sat2 p_sub (cl1 @ cl2)"
  apply (induct cl1)
   apply (auto)
  done

lemma sol_sat_rev1: "\<lbrakk>sol_sat2 p_sub (cl1 @ cl2) \<rbrakk> \<Longrightarrow> sol_sat2 p_sub cl1"
  apply (induct cl1)
   apply (auto)
  done

lemma sol_sat_rev2: "\<lbrakk>sol_sat2 p_sub (cl1 @ cl2) \<rbrakk> \<Longrightarrow> sol_sat2 p_sub cl2"
  apply (induct cl1)
   apply (auto)
  done

lemma eval_sol_subst_perm: "\<lbrakk> spec_perm_env p_sub p_subx \<rbrakk> \<Longrightarrow>
  eval_perm p_subx (perm_subst_perm p_sub p) = sol_subst_perm p_subx p"
  apply (case_tac p)
   apply (auto)
  apply (case_tac "p_sub x2")
   apply (auto)
  apply (simp add: spec_perm_env_def)
  apply (erule_tac x="x2" in allE)
  apply (auto)
  apply (case_tac a)
   apply (auto)
  done

lemma eval_sol_subst_aff: "\<lbrakk> spec_perm_env p_sub p_subx \<rbrakk> \<Longrightarrow>
  leq_perm (eval_perm p_subx (perm_subst_aff p_sub a)) (as_perm (sol_subst_aff p_subx a))"
  apply (case_tac a)
   apply (auto)
   apply (case_tac "as_perm x1")
     apply (auto)
  apply (case_tac "p_sub x2")
   apply (auto)
   apply (case_tac "p_subx x2")
     apply (auto)
  apply (simp add: spec_perm_env_def)
  apply (erule_tac x="x2" in allE)
  apply (auto)
  apply (case_tac aa)
   apply (auto)
   apply (case_tac "p_subx x2")
     apply (auto)
  apply (case_tac "p_subx x2a")
    apply (auto)
  done

lemma eval_req_leq_perm: "\<lbrakk> t_sub x = Some tau_v; t_subx x = Some tau; spec_perm_env p_sub p_subx;
  equiv_sub (perm_compose p_subx (subst_compose t_sub t_sub')) (perm_compose p_subx (indir_sub t_subx)) \<rbrakk> \<Longrightarrow>
  leq_perm (eval_perm p_subx (def_req_type p_sub tau_v)) (as_perm (req_type tau))"
  apply (simp add: equiv_sub_def)
  apply (erule_tac x="x" in allE)
  apply (simp add: perm_compose_def)
  apply (simp add: subst_compose_def)
  apply (simp add: indir_sub_def)
  apply (case_tac tau_v)
    apply (auto)
     apply (case_tac tau)
           apply (auto)
    apply (case_tac tau)
          apply (auto)
    apply (rule_tac t="as_perm (as_aff (sol_subst_perm p_subx x63))" and s="sol_subst_perm p_subx x63" in subst)
     apply (case_tac "sol_subst_perm p_subx x63")
       apply (auto)
    apply (simp add: eval_sol_subst_perm)
    apply (case_tac "sol_subst_perm p_subx x63")
      apply (auto)
   apply (case_tac tau)
         apply (auto)
   apply (simp add: eval_sol_subst_aff)
  apply (case_tac tau)
        apply (auto)
  done

lemma eval_req_leq_perm2: "\<lbrakk> spec_perm_env p_sub p_subx; dir_subst_type t_subx p_subx tau_v tau;
  equiv_sub (perm_compose p_subx (subst_compose t_sub t_sub')) (perm_compose p_subx (indir_sub t_subx)) \<rbrakk> \<Longrightarrow>
  leq_perm (eval_perm p_subx (subst_req_type t_sub p_sub tau_v)) (as_perm (req_type tau))"
  apply (case_tac "\<exists> a. tau_v = VarScheme a")
    apply (auto)
   apply (case_tac "t_sub a")
    apply (auto)
   apply (rule_tac eval_req_leq_perm)
      apply (auto)
  apply (case_tac tau_v)
         apply (auto)
   apply (rule_tac t="as_perm (as_aff (sol_subst_perm p_subx x63))" and s="sol_subst_perm p_subx x63" in subst)
    apply (case_tac "sol_subst_perm p_subx x63")
      apply (auto)
   apply (simp add: eval_sol_subst_perm)
   apply (case_tac "sol_subst_perm p_subx x63")
     apply (auto)
  apply (simp add: eval_sol_subst_aff)
  done

lemma eval_dir_leq_permx: "\<lbrakk> equiv_sub (perm_compose p_subx (subst_compose t_sub t_sub')) (perm_compose p_subx (indir_sub t_subx));
  spec_perm_env p_sub p_subx \<rbrakk> \<Longrightarrow>
  leq_perm (eval_permx p_subx (full_subst_permx t_sub p_sub px)) (dir_subst_permx t_subx p_subx px)"
  apply (induct px)
      apply (auto)
    (* perm case *)
       apply (simp add: eval_sol_subst_perm)
       apply (case_tac "sol_subst_perm p_subx x")
         apply (auto)
    (* type case. first we check if t_sub x \<noteq> None, while t_subx x = None*)
      apply (case_tac "t_sub x")
       apply (auto)
      apply (case_tac "t_subx x")
       apply (auto)
    (* - for this to happen, a must be a variable, meaning def_req_type will give None *)
       apply (simp add: equiv_sub_def)
       apply (erule_tac x="x" in allE)
       apply (case_tac "perm_compose p_subx (indir_sub t_subx) x \<noteq> None")
        apply (simp add: perm_compose_def)
        apply (simp add: indir_sub_def)
       apply (auto)
       apply (case_tac "\<not> (\<exists> a'. t_sub x = Some (VarScheme a')) ")
        apply (auto)
       apply (simp add: perm_compose_def)
       apply (simp add: subst_compose_def)
       apply (simp add: indir_sub_def)
       apply (case_tac a)
              apply (auto)
    (* - otherwise, both of them have a known type. *)
      apply (rule_tac eval_req_leq_perm)
         apply (auto)
    (* comp case *)
     apply (rule_tac dist_union_leq_perm)
      apply (rule_tac union_leq_perm1)
      apply (simp)
     apply (rule_tac union_leq_perm2)
     apply (simp)
    (* lift case *)
    apply (simp add: eval_sol_subst_perm)
    (* if zero case 1 *)
   apply (case_tac "eval_permx p_subx (full_subst_permx t_sub p_sub px)")
     apply (auto)
    (* if zero case 2 *)
  apply (case_tac "eval_permx p_subx (full_subst_permx t_sub p_sub px1)")
    apply (auto)
  done

lemma reduce_dir_sol_crn2: "\<lbrakk> dir_sol_crn t_subx p_subx c;
  equiv_sub (perm_compose p_subx (subst_compose t_sub t_sub')) (perm_compose p_subx (indir_sub t_subx));
  spec_perm_env p_sub p_subx \<rbrakk>  \<Longrightarrow> sol_sat2 p_subx (reduce_subst_crn t_sub p_sub c)"
  apply (case_tac c)
       apply (auto)
    (* leq case *)
             apply (rule_tac q="dir_subst_permx t_subx p_subx x31" in trans_leq_perm)
              apply (rule_tac eval_dir_leq_permx)
               apply (auto)
             apply (simp add: eval_sol_subst_perm)
    (* leq_type case *)
            apply (rule_tac q="as_perm (req_type tau_x)" in trans_leq_perm)
             apply (rule_tac eval_req_leq_perm2)
               apply (auto)
            apply (simp add: eval_sol_subst_perm)
            apply (case_tac "req_type tau_x")
              apply (auto)
             apply (case_tac "sol_subst_perm p_subx x42")
               apply (auto)
            apply (case_tac "sol_subst_perm p_subx x42")
              apply (auto)
    (* disj crn. first half *)
           apply (cut_tac px="x51" in eval_dir_leq_permx)
             apply (auto)
           apply (case_tac "dir_subst_permx t_subx p_subx x51")
             apply (auto)
          apply (cut_tac px="x52" in eval_dir_leq_permx)
            apply (auto)
          apply (case_tac "dir_subst_permx t_subx p_subx x52")
            apply (auto)
         apply (cut_tac px="x51" in eval_dir_leq_permx)
           apply (auto)
        apply (cut_tac px="x51" in eval_dir_leq_permx)
          apply (auto)
        apply (case_tac "eval_permx p_subx (full_subst_permx t_sub p_sub x51)")
          apply (auto)
    (* disj crn. second half *)
       apply (cut_tac px="x52" in eval_dir_leq_permx)
         apply (auto)
       apply (case_tac "eval_permx p_subx (full_subst_permx t_sub p_sub x52)")
         apply (auto)
      apply (cut_tac px="x52" in eval_dir_leq_permx)
        apply (auto)
     apply (cut_tac px="x51" in eval_dir_leq_permx)
       apply (auto)
    apply (cut_tac px="x51" in eval_dir_leq_permx)
      apply (auto)
    apply (case_tac "eval_permx p_subx (full_subst_permx t_sub p_sub x51)")
      apply (auto)
    (* mini disj crn. *)
   apply (cut_tac px="x61" in eval_dir_leq_permx)
     apply (auto)
   apply (case_tac "dir_subst_permx t_subx p_subx x61")
     apply (auto)
  apply (cut_tac px="x62" in eval_dir_leq_permx)
    apply (auto)
  apply (case_tac "eval_permx p_subx (full_subst_permx t_sub p_sub x62)")
    apply (auto)
  done

lemma reduce_dir_sol_sat2: "\<lbrakk> dir_sol_sat t_subx p_subx c_list;
  equiv_sub (perm_compose p_subx (subst_compose t_sub t_sub')) (perm_compose p_subx (indir_sub t_subx));
  spec_perm_env p_sub p_subx \<rbrakk> \<Longrightarrow> sol_sat2 p_subx (reduce_subst_list t_sub p_sub c_list)"
  apply (induct c_list)
   apply (auto)
  apply (rule_tac sol_sat_append_split)
   apply (auto)
  apply (rule_tac reduce_dir_sol_crn2)
    apply (auto)
  done

lemma reduce_crn_list_sat: "\<lbrakk> reduce_crn_list c_list = Some c_listx; dir_sol_sat t_sub p_sub c_list; no_mv_crn c_list \<rbrakk> \<Longrightarrow> sol_sat2 p_sub c_listx"
  apply (simp add: reduce_crn_list_def)
  apply (case_tac "unify_type (unify_subset c_list)")
   apply (auto)
  apply (cut_tac t_sub="t_sub" and p_sub="p_sub" and c_list="c_list" in dir_sol_type_eq_sat)
   apply (auto)
  apply (cut_tac t_sub="a" and t_subx="indir_sub t_sub" and c_list="unify_subset c_list" and p_eq="b" and p_sub="p_sub" in unify_type_sat)
    apply (auto)
  apply (simp add: uts_res_def)
  apply (case_tac "unify_perm b")
   apply (auto)
  apply (cut_tac p_list="b" and p_sub="aa" and p_subx="p_sub" in unify_perm_gen)
    apply (auto)
  apply (rule_tac reduce_dir_sol_sat2)
    apply (auto)
  done

definition wf_psub where
  "wf_psub p_sub = (\<forall> x. case p_sub x of
    None \<Rightarrow> True
    | Some p \<Rightarrow> (\<forall> y. case p_sub y of
      None \<Rightarrow> True
      | Some q \<Rightarrow> x \<notin> pvar_set_perm q
    )
  )"

definition def_perm_env where
  "def_perm_env p_sub = (\<lambda> x. case p_sub x of
    None \<Rightarrow> NoPerm
    | Some p \<Rightarrow> (case p of
      SPerm p \<Rightarrow> p
      | SVar r \<Rightarrow> NoPerm
    )
  )"

lemma def_spec_perm_env: "\<lbrakk> wf_psub p_sub \<rbrakk> \<Longrightarrow> spec_perm_env p_sub (def_perm_env p_sub)"
  apply (simp add: spec_perm_env_def)
  apply (auto)
  apply (case_tac "p_sub x")
   apply (auto)
  apply (case_tac a)
   apply (auto)
   apply (simp add: def_perm_env_def)
  apply (simp add: def_perm_env_def)
  apply (case_tac "p_sub x2")
   apply (auto)
  apply (simp add: wf_psub_def)
  apply (erule_tac x="x2" in allE)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (auto)
  done

lemma unify_perm_wf_psub: "\<lbrakk> unify_perm p_list = Some p_sub \<rbrakk> \<Longrightarrow> wf_psub p_sub"
  apply (induct arbitrary: p_sub rule: wf_induct [where r=p_unify_rel])
   apply (simp add: p_unify_rel_def)
  apply (case_tac x)
   apply (auto)
   apply (simp add: wf_psub_def)
   apply (simp add: empty_env_def)
    (* var case *)
  apply (case_tac "\<exists> r. a = SVar r")
   apply (auto)
    (* - delete case *)
   apply (case_tac "b = SVar r")
    apply (auto)
    apply (erule_tac x="list" in allE)
    apply (simp add: simp_p_unify_rel)
    (* - elim case *)
   apply (case_tac "unify_perm (perm_subst_eq_list (add_env empty_env r b) list)")
    apply (auto)
   apply (erule_tac x="perm_subst_eq_list (add_env empty_env r b) list" in allE)
   apply (auto)
    apply (simp add: elim_p_unify_rel)
   apply (simp add: wf_psub_def)
   apply (auto)
    (* > prelim: r is not present in the range of a *)
   apply (cut_tac p_sub="a" and p_list="perm_subst_eq_list (add_env empty_env r b) list" and x="r" in unify_perm_pvar_range)
     apply (auto)
    apply (cut_tac r="r" and p="b" and p_list="list" in perm_subst_pvar_eq_set)
     apply (auto)
    (* x = r, r = y. checks that r won't show up in b after applying a. *)
   apply (case_tac "x = r")
    apply (simp add: add_env_def)
    apply (auto)
     apply (case_tac b)
      apply (auto)
     apply (simp add: perm_sub_range_def)
     apply (erule_tac x="x2" in allE)
     apply (erule_tac x="x2" in allE)
     apply (case_tac "a x2")
      apply (auto)
    (* x = r, r \<noteq> y. checks that r won't show up anywhere else *)
    apply (case_tac "a y")
     apply (auto)
    apply (simp add: perm_sub_range_def)
    apply (erule_tac x="y" in allE)
    apply (erule_tac x="y" in allE)
    apply (auto)
    (* x \<noteq> r, y = r. checks that any other x won't show up in a b. this is true because say that b was some variable b'.
        since b' appears on the right-hand side, a b' = None. this means substitution yields nothing *)
   apply (simp add: add_env_def)
   apply (case_tac "a x")
    apply (auto)
   apply (simp add: add_env_def)
   apply (auto)
    apply (case_tac b)
     apply (auto)
    apply (case_tac "a x2")
     apply (auto)
    apply (erule_tac x="x" in allE)
    apply (auto)
    apply (erule_tac x="x2" in allE)
    apply (auto)
    (* x \<noteq> r, y \<noteq> r *)
   apply (erule_tac x="x" in allE)
   apply (auto)
    (* orient case *)
  apply (case_tac "\<exists> r. b = SVar r")
   apply (auto)
   apply (erule_tac x="(SVar r, a) # list" in allE)
   apply (simp add: orient_p_unify_rel)
   apply (case_tac a)
    apply (auto)
    (* decomp case *)
  apply (case_tac a)
   apply (auto)
  apply (case_tac b)
   apply (auto)
  apply (erule_tac x="list" in allE)
  apply (simp add: simp_p_unify_rel)
  apply (case_tac "x1 = x1a")
   apply (auto)
  done

definition tsub_complete where
  "tsub_complete t_sub p_sub tau_n = (\<lambda> x. case t_sub x of
    None \<Rightarrow> Some tau_n
    | Some tau_v \<Rightarrow> Some (full_subst_type empty_env p_sub tau_n tau_v)
  )"

definition psub_compose where
  "psub_compose p_sub p_subx = (\<lambda> x. case p_sub x of
    None \<Rightarrow> p_subx x
    | Some p \<Rightarrow> (case p of
      SPerm p' \<Rightarrow> p'
      | SVar r \<Rightarrow> p_subx r
    )
  )"

lemma complete_full_dir_subst_type: "dir_subst_type (tsub_complete t_sub p_sub tau_n) p_sub tau
  (full_subst_type (tsub_complete t_sub p_sub tau_n) p_sub tau_n tau)"
  apply (simp add: full_subst_type_def)
  apply (induct tau)
         apply (auto)
  apply (simp add: tsub_complete_def)
  apply (case_tac "t_sub x")
   apply (auto)
  done

lemma psub_compose_full_subst_type: "full_subst_type_f empty_env p_sub tau_n tau =
  full_subst_type_f empty_env empty_use_env tau_n (perm_subst_type p_sub tau)"
  apply (induct tau)
         apply (auto)
  done

lemma reduce_full_subst_type: "
  full_subst_type (tsub_complete t_sub p_sub tau_n) p_sub tau_n tau =
  full_subst_type empty_env empty_use_env tau_n (perm_subst_type p_sub (sol_subst_type t_sub tau))"
  apply (simp add: full_subst_type_def)
  apply (induct tau)
         apply (auto)
    (* var case *)
  apply (simp add: tsub_complete_def)
  apply (case_tac "t_sub x")
   apply (auto)
   apply (simp add: empty_env_def)
  apply (simp add: full_subst_type_def)
  apply (rule_tac psub_compose_full_subst_type)
  done

lemma psub_compose_spec_perm_env: "\<lbrakk> wf_psub p_sub \<rbrakk> \<Longrightarrow> spec_perm_env p_sub (psub_compose p_sub p_subx)"
  apply (simp add: spec_perm_env_def)
  apply (auto)
  apply (case_tac "p_sub x")
   apply (auto)
  apply (case_tac a)
   apply (auto)
   apply (simp add: psub_compose_def)
    (* say that p_sub contains a var. we want to show that after composition, they go to the same place. *)
  apply (simp add: psub_compose_def)
  apply (case_tac "p_sub x2")
   apply (auto)
    (* p_sub x2 cannot go anywhere, since this breaks well-formedness *)
  apply (simp add: wf_psub_def)
  apply (erule_tac x="x2" in allE)
  apply (auto)
  apply (erule_tac x="x" in allE)
  apply (auto)
  done

lemma compose_sol_eval_perm: "sol_subst_perm (psub_compose p_sub p_subx) p = eval_perm p_subx (perm_subst_perm p_sub p)"
  apply (case_tac p)
   apply (auto)
  apply (simp add: psub_compose_def)
  apply (case_tac "p_sub x2")
   apply (auto)
  apply (case_tac a)
   apply (auto)
  done

lemma compose_aff_eval_perm: "leq_perm (as_perm (sol_subst_aff (psub_compose p_sub p_subx) a)) (eval_perm p_subx (perm_subst_aff p_sub a))"
  apply (case_tac a)
   apply (auto)
   apply (case_tac x1)
     apply (auto)
  apply (simp add: psub_compose_def)
  apply (case_tac "p_sub x2")
   apply (auto)
   apply (case_tac "p_subx x2")
     apply (auto)
  apply (case_tac aa)
   apply (auto)
   apply (case_tac x1)
     apply (auto)
  apply (case_tac "p_subx x2a")
    apply (auto)
  done

lemma complete_dir_eval_permx: "leq_perm (dir_subst_permx (tsub_complete t_sub (psub_compose p_sub p_subx) IntTy) (psub_compose p_sub p_subx) px)
   (eval_permx p_subx (full_subst_permx t_sub p_sub px))"
  apply (induct px)
      apply (auto)
    (* perm case *)
       apply (simp add: compose_sol_eval_perm)
       apply (case_tac "eval_perm p_subx (perm_subst_perm p_sub x)")
         apply (auto)
    (* type case *)
      apply (simp add: tsub_complete_def)
      apply (case_tac "t_sub x")
       apply (auto)
      apply (simp add: full_subst_type_def)
      apply (case_tac a)
             apply (auto)
        apply (simp add: empty_env_def)
       apply (rule_tac t="as_perm (as_aff (sol_subst_perm (psub_compose p_sub p_subx) x63))" and
          s="sol_subst_perm (psub_compose p_sub p_subx) x63" in subst)
        apply (case_tac "sol_subst_perm (psub_compose p_sub p_subx) x63")
          apply (auto)
       apply (simp add: compose_sol_eval_perm)
       apply (case_tac "eval_perm p_subx (perm_subst_perm p_sub x63)")
         apply (auto)
      apply (rule_tac compose_aff_eval_perm)
    (* comp case *)
     apply (rule_tac dist_union_leq_perm)
      apply (rule_tac union_leq_perm1)
      apply (simp)
     apply (rule_tac union_leq_perm2)
     apply (simp)
    (* lift case *)
    apply (cut_tac p_sub="p_sub" and p_subx="p_subx" and p="x2a" in compose_sol_eval_perm)
    apply (auto)
    (* if zero case *)
   apply (case_tac "dir_subst_permx (tsub_complete t_sub (psub_compose p_sub p_subx) IntTy) (psub_compose p_sub p_subx) px")
     apply (auto)
  apply (case_tac "dir_subst_permx (tsub_complete t_sub (psub_compose p_sub p_subx) IntTy) (psub_compose p_sub p_subx) px1")
    apply (auto)
  done

lemma aff_leq_perm: "\<lbrakk> leq_perm (as_perm a) p \<rbrakk> \<Longrightarrow> aff_leq a p"
  apply (case_tac "a")
    apply (auto)
   apply (case_tac p)
     apply (auto)
  apply (case_tac p)
    apply (auto)
  done

lemma full_subst_aff_leq: "\<lbrakk> leq_perm (eval_perm p_subx (def_req_type p_sub tau_v)) p;
                full_subst_type_f empty_env (psub_compose p_sub p_subx) IntTy tau_v = tau \<rbrakk>
               \<Longrightarrow> aff_leq (req_type tau) p"
  apply (rule_tac aff_leq_perm)
  apply (auto)
  apply (case_tac tau_v)
         apply (auto)
    apply (simp add: empty_env_def)
   apply (simp add: compose_sol_eval_perm)
   apply (case_tac "eval_perm p_subx (perm_subst_perm p_sub x63)")
     apply (auto)
  apply (rule_tac q="eval_perm p_subx (perm_subst_aff p_sub x74)" in trans_leq_perm)
   apply (rule_tac compose_aff_eval_perm)
  apply (simp)
  done

lemma complete_eval_aff_leq: "\<lbrakk> leq_perm (eval_perm p_subx (subst_req_type t_sub p_sub tau)) (eval_perm p_subx (perm_subst_perm p_sub p)) \<rbrakk>
   \<Longrightarrow> aff_leq (req_type (full_subst_type (tsub_complete t_sub (psub_compose p_sub p_subx) IntTy) (psub_compose p_sub p_subx) IntTy tau))
           (sol_subst_perm (psub_compose p_sub p_subx) p)"
  apply (simp add: full_subst_type_def)
  apply (case_tac tau)
         apply (auto)
    (* var case *)
      apply (case_tac "tsub_complete t_sub (psub_compose p_sub p_subx) IntTy x4")
       apply (auto)
      apply (case_tac "t_sub x4")
       apply (auto)
       apply (simp add: tsub_complete_def)
      apply (simp add: tsub_complete_def)
      apply (simp add: compose_sol_eval_perm)
      apply (simp add: full_subst_type_def)
      apply (rule_tac full_subst_aff_leq)
       apply (auto)
    (* array case *)
     apply (simp add: compose_sol_eval_perm)
     apply (rule_tac aff_leq_perm)
     apply (auto)
    (* pair case *)
    apply (simp add: compose_sol_eval_perm)
    apply (rule_tac aff_leq_perm)
    apply (case_tac "eval_perm p_subx (perm_subst_perm p_sub x63)")
      apply (auto)
    (* fun case *)
   apply (simp add: compose_sol_eval_perm)
   apply (rule_tac aff_leq_perm)
   apply (rule_tac q="eval_perm p_subx (perm_subst_aff p_sub x74)" in trans_leq_perm)
    apply (rule_tac compose_aff_eval_perm)
   apply (simp)
    (* chan case *)
  apply (simp add: compose_sol_eval_perm)
  apply (rule_tac aff_leq_perm)
  apply (auto)
  done

lemma reduce_subst_crn_corr: "\<lbrakk> sol_sat2 p_subx (reduce_subst_crn t_sub p_sub c);
  \<forall> t1 t2. c \<noteq> UnifyCrn t1 t2 \<and> c \<noteq> MemValCrn t1 t2; wf_psub p_sub \<rbrakk> \<Longrightarrow>
  dir_sol_crn (tsub_complete t_sub (psub_compose p_sub p_subx) IntTy) (psub_compose p_sub p_subx) c"
  apply (cut_tac p_sub="p_sub" and p_subx="p_subx" in psub_compose_spec_perm_env)
   apply (auto)
  apply (case_tac c)
       apply (auto)
    (* ordering constraint *)
             apply (rule_tac q="eval_permx p_subx (full_subst_permx t_sub p_sub x31)" in trans_leq_perm)
              apply (rule_tac complete_dir_eval_permx)
             apply (simp add: compose_sol_eval_perm)
    (* type order constraint *)
            apply (rule_tac x="full_subst_type (tsub_complete t_sub (psub_compose p_sub p_subx) IntTy) (psub_compose p_sub p_subx) IntTy x41" in exI)
            apply (auto)
             apply (rule_tac complete_full_dir_subst_type)
            apply (rule_tac complete_eval_aff_leq)
            apply (simp)
    (* disjointness first half *)
           apply (cut_tac t_sub="t_sub" and p_sub="p_sub" and p_subx="p_subx" and px="x51" in complete_dir_eval_permx)
           apply (auto)
           apply (case_tac "eval_permx p_subx (full_subst_permx t_sub p_sub x51)")
             apply (auto)
          apply (cut_tac t_sub="t_sub" and p_sub="p_sub" and p_subx="p_subx" and px="x52" in complete_dir_eval_permx)
          apply (auto)
          apply (case_tac "eval_permx p_subx (full_subst_permx t_sub p_sub x52)")
            apply (auto)
         apply (cut_tac t_sub="t_sub" and p_sub="p_sub" and p_subx="p_subx" and px="x51" in complete_dir_eval_permx)
         apply (auto)
        apply (cut_tac t_sub="t_sub" and p_sub="p_sub" and p_subx="p_subx" and px="x51" in complete_dir_eval_permx)
        apply (auto)
        apply (case_tac "dir_subst_permx (tsub_complete t_sub (psub_compose p_sub p_subx) IntTy) (psub_compose p_sub p_subx) x51")
          apply (auto)
    (* disjointness second half *)
       apply (cut_tac t_sub="t_sub" and p_sub="p_sub" and p_subx="p_subx" and px="x52" in complete_dir_eval_permx)
       apply (auto)
       apply (case_tac "dir_subst_permx (tsub_complete t_sub (psub_compose p_sub p_subx) IntTy) (psub_compose p_sub p_subx) x52")
         apply (auto)
      apply (cut_tac t_sub="t_sub" and p_sub="p_sub" and p_subx="p_subx" and px="x52" in complete_dir_eval_permx)
      apply (auto)
     apply (cut_tac t_sub="t_sub" and p_sub="p_sub" and p_subx="p_subx" and px="x51" in complete_dir_eval_permx)
     apply (auto)
    apply (cut_tac t_sub="t_sub" and p_sub="p_sub" and p_subx="p_subx" and px="x51" in complete_dir_eval_permx)
    apply (auto)
    apply (case_tac "dir_subst_permx (tsub_complete t_sub (psub_compose p_sub p_subx) IntTy) (psub_compose p_sub p_subx) x51")
      apply (auto)
    (* semi-disjointness *)
   apply (cut_tac t_sub="t_sub" and p_sub="p_sub" and p_subx="p_subx" and px="x61" in complete_dir_eval_permx)
   apply (auto)
   apply (case_tac "eval_permx p_subx (full_subst_permx t_sub p_sub x61)")
     apply (auto)
  apply (cut_tac t_sub="t_sub" and p_sub="p_sub" and p_subx="p_subx" and px="x62" in complete_dir_eval_permx)
  apply (auto)
  apply (case_tac "dir_subst_permx (tsub_complete t_sub (psub_compose p_sub p_subx) IntTy) (psub_compose p_sub p_subx) x62")
    apply (auto)
  done

lemma reduce_subst_list_corr: "\<lbrakk> sol_sat2 p_subx (reduce_subst_list t_sub p_sub c_list); no_mv_crn c_list;
  type_eq_sat t_sub (psub_compose p_sub p_subx) (unify_subset c_list); wf_psub p_sub \<rbrakk> \<Longrightarrow>
  dir_sol_sat (tsub_complete t_sub (psub_compose p_sub p_subx) IntTy) (psub_compose p_sub p_subx) c_list"
  apply (induct c_list)
   apply (auto)
   apply (simp add: type_eq_sat_def)
    (* unification case *)
   apply (case_tac "\<exists> t1 t2. a = UnifyCrn t1 t2")
    apply (auto)
    apply (rule_tac x="full_subst_type (tsub_complete t_sub (psub_compose p_sub p_subx) IntTy) (psub_compose p_sub p_subx) IntTy t1" in exI)
    apply (auto)
     apply (rule_tac complete_full_dir_subst_type)
    apply (rule_tac t="full_subst_type (tsub_complete t_sub (psub_compose p_sub p_subx) IntTy) (psub_compose p_sub p_subx) IntTy t1"
      and s="full_subst_type (tsub_complete t_sub (psub_compose p_sub p_subx) IntTy) (psub_compose p_sub p_subx) IntTy t2" in subst)
     apply (simp add: reduce_full_subst_type)
    apply (rule_tac complete_full_dir_subst_type)
    (* misc constraints *)
   apply (rule_tac reduce_subst_crn_corr)
     apply (rule_tac sol_sat_rev1)
     apply (auto)
    (* induction *)
  apply (cut_tac p_sub="p_subx" and ?cl2.0="reduce_subst_list t_sub p_sub c_list" in sol_sat_rev2)
   apply (auto)
  apply (case_tac "\<not> no_mv_crn c_list")
   apply (auto)
   apply (case_tac a)
        apply (auto)
  apply (case_tac "\<not> type_eq_sat t_sub (psub_compose p_sub p_subx) (unify_subset c_list)")
   apply (case_tac a)
        apply (auto)
  apply (simp add: type_eq_sat_def)
  done

    (* in this lemma we state that if a constratint list is successfully reduced,
      and the reduced list can be solved, then the original constraint list also has a solution.
    *)
lemma reduce_crn_list_satx: "\<lbrakk> reduce_crn_list c_list = Some c_listx; sol_sat2 p_sub c_listx; no_mv_crn c_list \<rbrakk> \<Longrightarrow>
  (\<exists> t_subx p_subx. dir_sol_sat t_subx p_subx c_list)"
  apply (simp add: reduce_crn_list_def)
  apply (case_tac "unify_type (unify_subset c_list)")
   apply (auto)
  apply (case_tac "unify_perm b")
   apply (auto)
    (* permission unification returns a valid permission substitution *)
  apply (cut_tac p_subx="psub_compose aa p_sub" and p_list="b" and p_sub="aa" in unify_perm_sat)
    apply (simp)
   apply (rule_tac psub_compose_spec_perm_env)
   apply (rule_tac unify_perm_wf_psub)
   apply (auto)
    (* this means type unification can be used to construct a valid solution to the unification subset *)
  apply (cut_tac c_list="unify_subset c_list" and t_sub="a" and p_eq="b" in unify_type_satx)
    apply (auto)
    (* our overall claim is that we can solve using the main type substitution + a composition of p_sub with p_eq's solution *)
  apply (rule_tac x="tsub_complete a (psub_compose aa p_sub) IntTy" in exI)
  apply (rule_tac x="psub_compose aa p_sub" in exI)
  apply (rule_tac reduce_subst_list_corr)
     apply (auto)
  apply (rule_tac unify_perm_wf_psub)
  apply (auto)
  done

end


(* Author: Nan Jiang *)

section \<open>The specification of computing dominators\<close>

theory Cfg
imports Main
begin

text \<open>The specification of computing dominators is defined.
      For fast data flow analysis presented by CHK \<^cite>\<open>"Dominance_Algorithm"\<close>,
      a directed graph with explicit node list and sets of initial nodes is defined.
      Each node refers to its rPO (reverse PostOrder) number w.r.t a DFST, and
      related properties as assumptions are handled using a locale.\<close>

type_synonym 'a digraph = "('a \<times>'a) set"

record 'a graph_rec =
  g_V  :: "'a list"
  g_V0 :: "'a set"
  g_E  :: "'a digraph"

  tail :: "'a \<times> 'a \<Rightarrow> 'a"
  head :: "'a \<times> 'a \<Rightarrow> 'a"

definition wf_cfg :: "'a graph_rec \<Rightarrow> bool" where
  "wf_cfg G \<equiv> g_V0 G \<subseteq> set( g_V G)"

type_synonym node = nat

locale cfg_doms =
  \<comment>\<open>Nodes are rPO numbers\<close>
  fixes G :: "nat graph_rec" (structure)

  \<comment>\<open>General properties\<close>
  assumes wf_cfg: "wf_cfg G"
  assumes tail[simp]: "e = (u,v) \<Longrightarrow> tail G e = u"
  assumes head[simp]: "e = (u,v) \<Longrightarrow> head G e = v"
  assumes tail_in_verts[simp]: "e \<in> g_E G \<Longrightarrow> tail G e \<in> set (g_V G)"
  assumes head_in_verts[simp]: "e \<in> g_E G \<Longrightarrow> head G e \<in> set (g_V G)"

  \<comment>\<open>Properties of a cfg where nodes are rPO numbers\<close>
  assumes entry0:    "g_V0 G = {0}"
  assumes dfst:      "\<forall>v \<in> set (g_V G) - {0}. \<exists>prev. (prev, v) \<in> g_E G \<and> prev < v"
  assumes reachable: "\<forall>v \<in> set (g_V G). v \<in> (g_E G)\<^sup>* `` {0}"
  assumes verts:     "g_V G = [0 ..< (length (g_V G))]"

 \<comment>\<open>It is required that the entry node has an immediate successor which is not itself;
    Otherwise, no need to compute dominators
    It is required for proving the lemma: "wf\_dom start (unstables r step start)".\<close>
  assumes succ_of_entry0: "\<exists>s. (0,s) \<in> g_E G \<and> s \<noteq> 0"

begin

inductive path_entry :: "nat digraph \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> bool" for E where
  path_entry0: "path_entry E [] 0"
| path_entry_prepend: "\<lbrakk> (u,v)\<in> E; path_entry E l u \<rbrakk> \<Longrightarrow> path_entry E (u#l) v"

lemma path_entry0_empty_conv: "path_entry E [] v \<longleftrightarrow> v = 0"
 by (auto intro: path_entry0 elim: path_entry.cases)

inductive_cases path_entry_uncons: "path_entry E (u'#l) w"
inductive_simps path_entry_cons_conv: "path_entry E (u'#l) w"

lemma single_path_entry: "path_entry E [p] w \<Longrightarrow> p = 0"
  by (simp add: path_entry_cons_conv path_entry0_empty_conv)

lemma path_entry_append:
  "\<lbrakk> path_entry E l v; (v,w)\<in>E \<rbrakk> \<Longrightarrow> path_entry E (v#l) w"
  by (rule path_entry_prepend)

lemma entry_rtrancl_is_path:
  assumes "(0,v) \<in> E\<^sup>*"
  obtains p where "path_entry E p v"
    using assms
    by induct (auto intro:path_entry0 path_entry_prepend)

lemma path_entry_is_trancl:
  assumes "path_entry E l v"
  and "l \<noteq> []"
  shows "(0,v)\<in>E\<^sup>+"
  using assms
  apply induct
  apply auto []
  apply (case_tac l)
  apply (auto simp add:path_entry0_empty_conv)
  done

lemma tail_is_vert: "(u,v) \<in> g_E G  \<Longrightarrow> u \<in> set (g_V G)"
  by (auto dest: tail_in_verts[of "(u,v)"])

lemma head_is_vert: "(u,v) \<in> g_E G  \<Longrightarrow> v \<in> set (g_V G)"
  by (auto dest: head_in_verts[of "(u,v)"])

lemma tail_is_vert2: "(u,v) \<in> (g_E G)\<^sup>+ \<Longrightarrow> u \<in> set (g_V G)"
  by (induct rule:trancl.induct)(auto dest: tail_in_verts)

lemma head_is_vert2: "(u,v) \<in> (g_E G)\<^sup>+  \<Longrightarrow> v \<in> set (g_V G)"
  by (induct rule:trancl.induct)(auto dest: head_in_verts)

lemma verts_set: "set (g_V G) = {0 ..< length (g_V G)}"
proof-
  from verts have "set (g_V G) = set [0 ..< (length (g_V G))]" by simp
  also have "set [0 ..< (length (g_V G))] = {0 ..< (length (g_V G))}" by simp
  ultimately show ?thesis by auto
qed

lemma fin_verts: "finite (set (g_V G))"
  by (auto)

lemma zero_in_verts: "0 \<in> set (g_V G)"
  using wf_cfg entry0 by (unfold wf_cfg_def)  auto

lemma verts_not_empty: "g_V G \<noteq> []"
  using zero_in_verts by auto

lemma len_verts_gt0: "length (g_V G) > 0"
  by (simp add:verts_not_empty)

lemma len_verts_gt1: "length (g_V G) > 1"
proof-
  from succ_of_entry0 obtain s where "s \<in> set (g_V G)" and "s \<noteq> 0" using head_is_vert by auto
  with zero_in_verts have "{0,s} \<subseteq> set (g_V G)" and c: "card {0, s} > 1" by auto
  then have "card {0, s} \<le> card (set (g_V G))" by (auto simp add:card_mono)
  with c have "card (set (g_V G)) > 1" by simp
  then show ?thesis using card_length[of "g_V G"] by auto
qed

lemma verts_ge_Suc0 : "\<not> [0..<length (g_V G)] = [0]"
proof
  assume "[0..<length (g_V G)] = [0]"
  then have "length [0..<length (g_V G)] = 1" by simp
  with len_verts_gt1 show False by auto
qed

lemma distinct_verts1: "distinct [0..<length (g_V G)] "
  by simp

lemma distinct_verts2: "distinct (g_V G)"
  by (insert distinct_verts1 verts)  simp

lemma single_entry: "is_singleton (g_V0 G)"
  by (simp add:entry0)

lemma entry_is_0: "the_elem (g_V0 G) = 0"
  by (simp add: entry0)

lemma wf_digraph: "cfg_doms G" by intro_locales

lemma path_entry_prepend_conv: "path_entry (g_E G) p n \<Longrightarrow> p \<noteq> [] \<Longrightarrow> \<exists>v. path_entry (g_E G) (tl p) v \<and> (v, n) \<in> (g_E G)"
proof (induct rule:path_entry.induct)
  case path_entry0 then show ?case by auto
next
  case (path_entry_prepend u v l)
  then show ?case by auto
qed

lemma path_verts: "path_entry (g_E G) p n \<Longrightarrow> n \<in> set (g_V G)"
proof (cases "p = []")
  case True
  assume "path_entry (g_E G) p n" and "p = []"
  then show ?thesis by (simp add:path_entry0_empty_conv zero_in_verts)
next
  case False
  assume "path_entry (g_E G) p n" and "p \<noteq> []"
  then have "(0,n)\<in>(g_E G)\<^sup>+" by (auto simp add:path_entry_is_trancl)
  then show ?thesis using head_is_vert2 by simp
qed

lemma path_in_verts:
  assumes "path_entry (g_E G) l v"
    shows "set l \<subseteq> set (g_V G)"
  using assms
proof (induct rule:path_entry.induct)
  case path_entry0 then show ?case by auto
next
  case (path_entry_prepend u v l)
  then show ?case using path_verts by auto
qed

lemma any_node_exits_path:
  assumes "v \<in> set (g_V G) "
    shows "\<exists>p. path_entry (g_E G) p v"
  using assms
proof (cases "v = 0")
  assume "v \<in> set (g_V G)" and "v = 0"
  have "path_entry (g_E G) [] 0" by (auto simp add:path_entry0)
  then show ?thesis using \<open>v = 0\<close> by auto
next
  assume "v \<in> set (g_V G)" and "v \<noteq> 0"
  with reachable have "v \<in> (g_E G)\<^sup>* `` {0}" by auto
  then have "(0,v) \<in> (g_E G)\<^sup>*"  by (simp add:Image_iff)
  then show ?thesis by (auto intro:entry_rtrancl_is_path)
qed

lemma entry0_path: "path_entry (g_E G) [] 0"
  by (auto simp add:path_entry.path_entry0)

definition reachable :: "node \<Rightarrow> bool"
  where "reachable v \<equiv> v \<in> (g_E G)\<^sup>* `` {0}"

lemma path_entry_reachable:
  assumes "path_entry (g_E G) p n"
    shows "reachable n"
  using assms reachable
  by (fastforce intro:path_verts simp add:reachable_def)

lemma nin_nodes_reachable: "n \<notin> set (g_V G) \<Longrightarrow> \<not> reachable n"
proof(rule ccontr)
  assume "n \<notin> set (g_V G)" and nn: " \<not> \<not> reachable n"
  from \<open>n \<notin> set (g_V G)\<close> have "n \<noteq> 0" using verts_set len_verts_gt0 entry0  by auto
  from nn have "reachable n" by auto
  then have "n \<in> (g_E G)\<^sup>* `` {0}" by (simp add: reachable_def)
  then have " (0, n) \<in> (g_E G)\<^sup>* " by (auto simp add:Image_def)
  with \<open>n \<noteq> 0\<close> have "\<exists>n'. (0,n') \<in> (g_E G)\<^sup>* \<and> (n', n) \<in> (g_E G)" by (auto intro:rtranclE)
  then obtain n' where "(0,n') \<in> (g_E G)\<^sup>* " and " (n', n) \<in> (g_E G)"by auto
  then have "n \<in> set (g_V G)" using head_is_vert by auto
  with \<open>n \<notin> set (g_V G)\<close> show False
    by auto
qed

lemma reachable_path_entry: "reachable n \<Longrightarrow> \<exists>p. path_entry (g_E G) p n"
proof-
  assume "reachable n"
  then have "(0,n) \<in> (g_E G)\<^sup>*" by (auto simp add:reachable_def Image_iff)
  then have "0 = n \<or> 0 \<noteq> n \<and> (0,n) \<in> (g_E G)\<^sup>+" by (auto simp add: rtrancl_eq_or_trancl)
  then show ?thesis
  proof
    assume "0 = n"
    have "path_entry (g_E G) [] 0" by (simp add:path_entry0)
    with \<open>0 = n\<close> show ?thesis by auto
  next
    assume "0 \<noteq> n \<and> (0,n) \<in> (g_E G)\<^sup>+"
    then have "(0,n) \<in> (g_E G)\<^sup>+"  by (auto simp add:rtranclpD)
    then have "n \<in> set (g_V G)" by (simp add:head_is_vert2)
    then show ?thesis by (rule any_node_exits_path)
  qed
qed

lemma path_entry_unconc:
  assumes "path_entry (g_E G) (la@lb) w"
  obtains v where "path_entry (g_E G) lb v"
  using assms
  apply (induct "la@lb" w arbitrary:la lb rule: path_entry.induct)
   apply (fastforce intro:path_entry.intros)
  by (auto intro:path_entry.intros iff add: Cons_eq_append_conv)

lemma path_entry_append_conv:
  "path_entry (g_E G) (v#l) w \<longleftrightarrow> (path_entry (g_E G) l v \<and> (v,w) \<in> (g_E G))"
proof
  assume "path_entry (g_E G) (v # l) w "
  then show "path_entry (g_E G) l v \<and> (v, w) \<in> g_E G"
    by (auto simp add:path_entry_cons_conv)
next
  assume "path_entry (g_E G) l v \<and> (v, w) \<in> g_E G"
  then show "path_entry (g_E G) (v # l) w " by (fastforce intro: path_entry_append)
qed

lemma takeWhileNot_path_entry:
  assumes "path_entry E p x"
      and "v \<in> set p"
      and "takeWhile ((\<noteq>) v) (rev p) = c"
    shows "path_entry E (rev c) v"
  using assms
proof (induct rule: path_entry.induct)
  case path_entry0
  then show ?case by auto
next
  case (path_entry_prepend u va l)
  then show ?case
  proof(cases "v \<in> set l")
    case True note v_in = this
    then have "takeWhile ((\<noteq>) v) (rev (u # l)) = takeWhile ((\<noteq>) v) (rev l)" by auto
    with path_entry_prepend.prems(2) have "takeWhile ((\<noteq>) v) (rev l) = c" by simp
    with v_in show ?thesis using path_entry_prepend.hyps(3) by auto
  next
    case False note v_nin = this
    with path_entry_prepend.prems(1) have v_u: "v = u" by auto
    then have take_eq: "takeWhile ((\<noteq>) v) (rev (u # l)) = takeWhile ((\<noteq>) v) ((rev l) @ [u])"  by auto
    from v_nin have "\<And>x. x \<in> set (rev l) \<Longrightarrow> ((\<noteq>) v) x" by auto
    then have "takeWhile ((\<noteq>) v) ((rev l) @ [u]) = (rev l) @ takeWhile ((\<noteq>) v) [u]"
      by (rule takeWhile_append2) simp
    with v_u take_eq have "takeWhile ((\<noteq>) v) (rev (u # l)) = (rev l)" by simp
    then show ?thesis using path_entry_prepend.prems(2) path_entry_prepend.hyps(2) v_u by auto
  qed
qed

lemma path_entry_last: "path_entry (g_E G) p n \<Longrightarrow> p \<noteq> [] \<Longrightarrow> last p = 0"
  apply (induct rule: path_entry.induct)
   apply simp
  apply (simp add: path_entry_cons_conv neq_Nil_conv)
  apply (auto simp add:path_entry0_empty_conv)
  done

lemma path_entry_loop:
  assumes n_path: "path_entry (g_E G) p n"
      and n:      "n \<in> set p "
    shows "\<exists>p'.   path_entry (g_E G) p' n \<and> n \<notin> set p'"
  using assms
proof -
  let ?c = "takeWhile ((\<noteq>) n) (rev ( p))"
  have "\<forall>z \<in> set ?c. z \<noteq> n" by (auto dest: set_takeWhileD)
  then have n_nin: "n \<notin> set (rev ?c)" by auto

  from n_path  obtain v where "path_entry (g_E G) ( p) v" using path_entry_prepend_conv by auto
  with n have "path_entry (g_E G) (rev ?c) n" by (auto intro:takeWhileNot_path_entry)
  with n_nin show ?thesis by fastforce
qed

lemma path_entry_hd_edge:
  assumes "path_entry (g_E G) pa p "
      and "pa \<noteq> []"
    shows "(hd pa, p) \<in> (g_E G)"
  using assms
  by (induct rule: path_entry.induct) auto

lemma path_entry_edge:
  assumes "pa \<noteq> [] "
      and "path_entry (g_E G) pa p "
    shows "\<exists>u\<in>set pa. (path_entry (g_E G) (rev (takeWhile ((\<noteq>) u) (rev pa))) u) \<and> (u,p) \<in> (g_E G)"
  using assms
proof-
  from assms have 1: "path_entry (g_E G) (rev (takeWhile ((\<noteq>) (hd pa)) (rev pa))) (hd pa)" by (auto intro:takeWhileNot_path_entry)
  from assms have 2: "(hd pa, p)\<in> (g_E G)" by (auto intro: path_entry_hd_edge)
  have "hd pa \<in> set pa" using assms(1) by auto
  with 1 2 show ?thesis by auto
qed

definition is_tail :: "node \<Rightarrow> node \<times> node \<Rightarrow> bool"
  where "is_tail v e = (v = tail G e)"

definition is_head :: "node \<Rightarrow> node \<times> node \<Rightarrow> bool"
  where "is_head v e = (v = head G e)"

definition succs:: "node \<Rightarrow> node set"
  where "succs v = (g_E G) `` {v}"

lemma succ_in_verts: "s \<in> succs n \<Longrightarrow> {s,n} \<subseteq> set (g_V G)"
  by( simp add:succs_def tail_is_vert head_is_vert)

lemma succ0_not_nil: "succs 0 \<noteq> {}"
  using succ_of_entry0 by (auto simp add:succs_def)

definition prevs:: "node \<Rightarrow> node set" where
  "prevs v = (converse (g_E G))`` {v}"

lemma "v \<in> succs u \<longleftrightarrow> u \<in> prevs v"
  by (auto simp add:succs_def prevs_def)

lemma succ_edge: "\<forall>v \<in> succs n. (n,v) \<in> g_E G"
  by (auto simp add:succs_def)

lemma prev_edge: "u \<in> set (g_V G) \<Longrightarrow> \<forall>v \<in> prevs u. (v, u) \<in> g_E G"
  by (auto simp add:prevs_def)

lemma succ_in_G: "\<forall>v \<in> succs n. v \<in> set (g_V G)"
  by (auto simp add: succs_def dest:head_in_verts)

lemma succ_is_subset_of_verts: "\<forall>v \<in> set (g_V G). succs v \<subseteq> set(g_V G)"
  by (insert succ_in_G) auto

lemma fin_succs: "\<forall>v \<in> set (g_V G). finite (succs v)"
  by (insert succ_is_subset_of_verts) (auto intro:rev_finite_subset)

lemma fin_succs': "v < length (g_V G) \<Longrightarrow> finite (succs v)"
  by (subgoal_tac "v \<in> set (g_V G)")
   (auto simp add: fin_succs verts_set)

lemma succ_range: "\<forall>v \<in> succs n. v < length (g_V G)"
  by (insert succ_in_G verts_set) auto

lemma path_entry_gt:
  assumes "\<forall>p. path_entry E p n \<longrightarrow> d \<in> set p"
      and "\<forall>p. path_entry E p n' \<longrightarrow> n \<in> set p"
    shows "\<forall>p. path_entry E p n' \<longrightarrow> d \<in> set p"
  using assms
proof (intro strip)
  fix p
  let ?npath = "takeWhile ((\<noteq>) n) (rev p)"
  have sub: "set ?npath \<subseteq> set p" apply (induct p) by (auto dest:set_takeWhileD)

  assume ass: "path_entry E p n' "
  with assms(2) have n_in_p: "n \<in> set p" by auto
  then have "n \<in> set (rev p)" by auto
  with ass have "path_entry E (rev ?npath) n"
    using takeWhileNot_path_entry by auto
  with assms(1) have "d \<in> set ?npath" by fastforce
  with sub show "d \<in> set p" by auto
qed

definition dominate :: "nat \<Rightarrow> nat \<Rightarrow> bool"
  where "dominate n1 n2 \<equiv>
         \<forall>pa. path_entry (g_E G) pa n2 \<longrightarrow>
         (n1 \<in> set pa \<or> n1 = n2)"

definition strict_dominate:: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  "strict_dominate n1 n2 \<equiv>
   \<forall>pa. path_entry (g_E G) pa n2 \<longrightarrow>
   (n1 \<in> set pa \<and> n1 \<noteq> n2)"

lemma any_dominate_unreachable: "\<not> reachable n \<Longrightarrow> dominate d n"
proof(unfold reachable_def dominate_def)
  assume ass: "n \<notin> (g_E G)\<^sup>* `` {0}"

  have "\<not> (\<exists>p. path_entry (g_E G) p n)"
  proof (rule ccontr)
    assume " \<not> (\<not> (\<exists>p. path_entry (g_E G) p n))"
    then obtain p where p: "path_entry (g_E G) p n" by auto
    then have "n = 0 \<or> reachable n" by (auto intro:path_entry_reachable)
    then show False
    proof
      assume "n = 0"
      then show False using ass by auto
    next
      assume "reachable n"
      then show False using ass by (auto simp add:reachable_def)
    qed
  qed
  then show "\<forall>pa. path_entry (g_E G) pa n \<longrightarrow> d \<in> set pa \<or> d = n" by auto
qed

lemma any_sdominate_unreachable: "\<not> reachable n \<Longrightarrow> strict_dominate d n"
proof(unfold reachable_def strict_dominate_def)
  assume ass:"n \<notin> (g_E G)\<^sup>* `` {0} "

  have "\<not> (\<exists>p. path_entry (g_E G)  p n)"
  proof (rule ccontr)
    assume " \<not> (\<not> (\<exists>p. path_entry (g_E G) p n))"
    then obtain p where p: "path_entry (g_E G) p n" by auto
    then have "n = 0 \<or> reachable n" by (auto intro:path_entry_reachable)
    then show False
    proof
      assume "n = 0"
      then show False using ass by auto
    next
      assume "reachable n"
      then show False using ass by (auto simp add:reachable_def)
    qed
  qed
  then show "\<forall>pa. path_entry (g_E G)  pa n \<longrightarrow> d \<in> set pa \<and> d \<noteq> n" by auto
qed

lemma dom_reachable: "reachable n \<Longrightarrow> dominate d n \<Longrightarrow> reachable d"
proof -
  assume reach_n: "reachable n"
     and dom_n: "dominate d n"
  from reach_n have "\<exists>p. path_entry (g_E G)  p n" by (rule reachable_path_entry)
  then obtain p where p: "path_entry (g_E G) p n" by auto

  show "reachable d"
  proof (cases "d \<noteq> n")
    case True
    with dom_n p have d_in: "d \<in> set p" by (auto simp add:dominate_def)
    let ?pa = "takeWhile ((\<noteq>) d) (rev p)"
    from d_in p have "path_entry (g_E G) (rev ?pa) d" using takeWhileNot_path_entry by auto
    then show ?thesis using path_entry_reachable by auto
  next
    case False
    with reach_n show ?thesis by auto
  qed
qed

lemma dominate_refl: "dominate n n"
  by (simp add:dominate_def)

lemma entry0_dominates_all: "\<forall>p \<in> set (g_V G). dominate 0 p"
proof(intro strip)
  fix p
  assume "p \<in> set (g_V G)"
  show "dominate 0 p"
  proof (cases "p = 0")
    case True
    then show ?thesis by (auto simp add:dominate_def)
  next
    case False
    assume p_neq0: "p \<noteq> 0"
    have "\<forall>pa. path_entry (g_E G) pa p \<longrightarrow> 0 \<in> set pa"
    proof (intro strip)
      fix pa
      assume path_p: "path_entry (g_E G) pa p"
      show "0 \<in> set pa"
      proof (cases "pa \<noteq> []")
        case True note pa_n_nil = this
        with path_p have last_pa: "last pa = 0" using path_entry_last by auto
        from pa_n_nil have "last pa \<in> set pa" by simp
        with last_pa show ?thesis by simp
      next
        case False
        with path_p have "p = 0" by (simp add:path_entry0_empty_conv)
        with p_neq0 show ?thesis by auto
      qed
    qed
    then show ?thesis by (auto simp add:dominate_def)
  qed
qed

lemma "strict_dominate i j \<Longrightarrow> j \<in> set (g_V G) \<Longrightarrow> i \<noteq> j"
  using  any_node_exits_path
  by (auto simp add:strict_dominate_def)

definition non_strict_dominate:: "nat \<Rightarrow> nat \<Rightarrow> bool" where
  "non_strict_dominate n1 n2 \<equiv> \<exists>pa. path_entry (g_E G) pa n2 \<and> (n1 \<notin> set pa)"

lemma any_sdominate_0: "n \<in> set (g_V G) \<Longrightarrow> non_strict_dominate n 0"
  apply (simp add:non_strict_dominate_def)
  by (auto intro:path_entry0)

(*
lemma non_strict_dominate_refl: "n \<in> set (g_V G) \<Longrightarrow> non_strict_dominate n n"
proof(unfold non_strict_dominate_def)
  assume n_in: "n \<in> set (g_V G)"
  then obtain p where p_n: "path_entry (g_E G) p n" using any_node_exits_path by auto

  have pa0: "path_entry (g_E G) [] 0" by (rule path_entry0)

  show "\<exists>pa. path_entry (g_E G) pa n \<and> n \<notin> set pa"
  proof(cases "n = 0")
    case True
    then show ?thesis using pa0 by (auto simp add:non_strict_dominate_def)
  next
    case False note n_neq_0 = this
    with p_n have "p \<noteq> []" using path_entry0_empty_conv by auto
    then show ?thesis using p_n by (auto intro: path_entry_loop)
  qed
qed
*)
lemma non_sdominate_succ: "(i,j ) \<in> g_E G \<Longrightarrow> k \<noteq> i \<Longrightarrow> non_strict_dominate k i \<Longrightarrow> non_strict_dominate k j"
proof -
  assume i_j: "(i,j ) \<in> g_E G" and k_neq_i: "k \<noteq> i" and "non_strict_dominate k i"
  then obtain pa where "path_entry (g_E G) pa i" and k_nin_pa: "k \<notin> set pa" by (auto simp add:non_strict_dominate_def)
  with i_j have "path_entry (g_E G) (i#pa) j" by (auto simp add:path_entry_prepend)
  with k_neq_i k_nin_pa show ?thesis by (auto simp add:non_strict_dominate_def)
qed

lemma any_node_non_sdom0: "non_strict_dominate k 0"
  by (auto intro:entry0_path simp add:non_strict_dominate_def)

lemma nonstrict_eq: "non_strict_dominate i j \<Longrightarrow> \<not> strict_dominate i j"
  by (auto simp add:non_strict_dominate_def strict_dominate_def)

lemma dominate_trans:
  assumes "dominate n1 n2"
      and "dominate n2 n3"
    shows "dominate n1 n3"
  using assms
proof(cases "n1 = n2")
  case True
  then show ?thesis using assms(2) by auto
next
  case False
  then show "dominate n1 n3"
  proof (cases "n1 = n3")
    case True
    then show ?thesis by (auto simp add:dominate_def)
  next
    case False
    show "dominate n1 n3"
    proof (cases "n2 = n3")
      case True
      then show ?thesis using assms(1) by auto
    next
      case False
      with \<open>n1 \<noteq> n2\<close> \<open>n1 \<noteq> n3\<close> show ?thesis
      proof (auto simp add: dominate_def)
        fix pa
        assume "n1 \<noteq> n2" and "n1 \<noteq> n3" and "n2 \<noteq> n3"
        from \<open>n1 \<noteq> n2\<close> assms(1) have n1_n2_pa: "\<forall>pa. path_entry (g_E G) pa n2 \<longrightarrow> n1 \<in> set pa"
          by (auto simp add:dominate_def)
        from \<open>n2 \<noteq> n3\<close> assms(2) have "\<forall>pa. path_entry (g_E G) pa n3 \<longrightarrow> n2 \<in> set pa"
          by (auto simp add:dominate_def)
        with n1_n2_pa have "\<forall>pa. path_entry (g_E G) pa n3 \<longrightarrow> n1 \<in> set pa"
          by (rule path_entry_gt)
        then show "\<And>pa. path_entry (g_E G) pa n3 \<Longrightarrow> n1 \<in> set pa" by auto
      qed
    qed
  qed
qed

lemma len_takeWhile_lt: "x \<in> set xs \<Longrightarrow> length (takeWhile ((\<noteq>) x) xs) < length xs"
  by (induct xs) auto

lemma len_takeWhile_comp:
  assumes "n1 \<in> set xs"
      and "n2 \<in> set xs"
      and "n1 \<noteq> n2"
    shows "length (takeWhile ((\<noteq>) n1) xs) \<noteq> length (takeWhile ((\<noteq>) n2) xs)"
  using assms
  by (induct xs) auto

lemma len_takeWhile_comp1:
  assumes "n1 \<in> set xs"
      and "n2 \<in> set xs"
      and "n1 \<noteq> n2"
    shows "length (takeWhile ((\<noteq>) n1) (rev (x # xs))) \<noteq> length (takeWhile ((\<noteq>) n2) (rev (x # xs)))"
  using assms len_takeWhile_comp[of "n1" "rev xs" "n2"] by fastforce

lemma len_takeWhile_comp2:
  assumes "n1 \<in> set xs"
      and "n2 \<notin> set xs"
    shows "length (takeWhile ((\<noteq>) n1) (rev (x # xs))) \<noteq> length (takeWhile ((\<noteq>) n2) (rev (x # xs)))"
  using assms
proof-
  let ?xs1 = "takeWhile ((\<noteq>) n1) (rev (x # xs))"
  let ?xs2 = "takeWhile ((\<noteq>) n2) (rev (x # xs))"
  from assms have len1: "length (takeWhile ((\<noteq>) n1) (rev xs)) < length (rev xs)"
    using len_takeWhile_lt[of _"rev xs"] by auto

  from assms(1) have "?xs1 = takeWhile ((\<noteq>) n1) (rev xs)" by auto
  then have len2: "length ?xs1 < length (rev xs)" using len1 by auto

  from assms(2) have "takeWhile ((\<noteq>) n2) (rev xs @ [x]) = (rev xs) @ takeWhile ((\<noteq>) n2) [x]"
    by (fastforce intro:takeWhile_append2)
  then have "?xs2 = (rev xs) @ takeWhile ((\<noteq>) n2) [x]" by simp
  then show ?thesis using len2 by auto
qed

lemma len_compare1:
  assumes "n1 = x" and "n2 \<noteq> x"
    shows "length (takeWhile ((\<noteq>) n1) (rev (x # xs))) \<noteq> length (takeWhile ((\<noteq>) n2) (rev (x # xs)))"
  using assms
proof(cases "n1 \<in> set xs \<and> n2 \<in> set xs")
  case True
  with assms show ?thesis using len_takeWhile_comp1 by fastforce
next
  let ?xs1 = "takeWhile ((\<noteq>) n1) (rev (x # xs))"
  let ?xs2 = "takeWhile ((\<noteq>) n2) (rev (x # xs))"

  case False
  then have "n1 \<in> set xs \<and> n2 \<notin> set xs \<or> n1 \<notin> set xs \<and> n2 \<in> set xs \<or> n1 \<notin> set xs \<and> n2 \<notin>  set xs" by auto
  then show ?thesis
  proof
    assume "n1 \<in> set xs \<and> n2 \<notin> set xs"
    then show ?thesis by (fastforce dest: len_takeWhile_comp2)
  next
    assume "n1 \<notin> set xs \<and> n2 \<in> set xs \<or> n1 \<notin> set xs \<and> n2 \<notin> set xs"
    then show ?thesis
    proof
      assume "n1 \<notin> set xs \<and> n2 \<in> set xs"
      then have n1: "n1 \<notin> set xs" and n2: "n2 \<in> set xs" by auto
      have "length ?xs2 \<noteq> length ?xs1" using len_takeWhile_comp2[OF n2 n1] by auto
      then show ?thesis by simp
    next
      assume "n1 \<notin> set xs \<and> n2 \<notin> set xs"
      then have n1_nin: "n1 \<notin> set xs" and n2_nin: "n2 \<notin> set xs" by auto
      then  have t1: "takeWhile ((\<noteq>) n1) (rev xs @ [x]) = (rev xs) @ takeWhile  ((\<noteq>) n1) [x]"
             and     "takeWhile ((\<noteq>) n2) (rev xs @ [x]) = (rev xs) @ takeWhile  ((\<noteq>) n2) [x]"
        by (fastforce intro:takeWhile_append2)+
      with \<open>n1 = x\<close> \<open>n2 \<noteq> x\<close>  have t1': "takeWhile ((\<noteq>) n1) (rev xs @ [x]) = rev xs"
                               and      "takeWhile ((\<noteq>) n2) (rev xs @ [x]) = (rev xs) @ [x]" by auto
      then have "length (takeWhile ((\<noteq>) n2) (rev xs @ [x])) = length ((rev xs) @ [x])"
        using arg_cong[of "takeWhile ((\<noteq>) n2) (rev xs @ [x])" "rev xs @ [x]" "length"] by fastforce
      with t1' show ?thesis by auto
    qed
  qed
qed

lemma len_compare2:
  assumes "n1 \<in> set xs"
      and "n1 \<noteq> n2"
    shows "length (takeWhile ((\<noteq>) n1) (rev (x # xs))) \<noteq> length (takeWhile ((\<noteq>) n2) (rev (x # xs)))"
  using assms
  apply(case_tac "n2 \<in> set xs")
   apply (fastforce dest: len_takeWhile_comp1 )
  apply (fastforce dest:len_takeWhile_comp2)
  done

lemma len_takeWhile_set:
  assumes "length (takeWhile ((\<noteq>) n1) xs) > length (takeWhile ((\<noteq>) n2) xs)"
      and "n1 \<noteq> n2"
      and "n1 \<in> set xs"
      and "n2 \<in> set xs"
    shows "set (takeWhile ((\<noteq>) n2) xs)  \<subseteq> set (takeWhile ((\<noteq>) n1) xs)"
  using assms
proof (induct xs)
  case Nil then show ?case by auto
next
  case (Cons y ys)
  note ind_hyp = Cons(1)
  note len_n2_lt_n1_y_ys = Cons(2)
  note n1_n_n2 = Cons(3)
  note n1_in_y_ys = Cons(4)
  note n2_in_y_ys = Cons(5)

  let ?ys1_take = "takeWhile ((\<noteq>) n1) ys"
  let ?ys2_take = "takeWhile ((\<noteq>) n2) ys"

  show ?case
  proof(cases "n1 \<in> set ys")
    case True note n1_in_ys = this
    show ?thesis
    proof(cases "n2 \<in> set ys")
      case True note n2_in_ys = this
      show ?thesis
      proof (cases "n1 \<noteq> y")
        case True note n1_neq_y = this
        show ?thesis
        proof (cases "n2 \<noteq> y")
          case True note n2_neq_y = this
          from len_n2_lt_n1_y_ys have "length ?ys2_take < length ?ys1_take"
            using n1_n_n2 n1_in_ys n2_in_ys n1_neq_y n2_neq_y by (induct ys) auto
          from ind_hyp[OF this n1_n_n2 n1_in_ys n2_in_ys]
          have "set (takeWhile ((\<noteq>) n2) ys) \<subseteq> set (takeWhile ((\<noteq>) n1) ys)" by auto
          then show ?thesis using n1_neq_y n2_neq_y by (induct ys) auto
        next
          case False
          with n1_n_n2 show ?thesis by auto
        qed
      next
        case False
        with n1_n_n2 show ?thesis using len_n2_lt_n1_y_ys by auto
      qed
    next
      case False
      with n2_in_y_ys have "n2 = y" by auto
      then show ?thesis by auto
    qed
  next
    case False
    with n1_in_y_ys have "n1 = y" by auto
    with n1_n_n2 show ?thesis using len_n2_lt_n1_y_ys by auto
  qed
qed

lemma reachable_dom_acyclic:
  assumes "reachable n2"
      and "dominate n1 n2"
      and "dominate n2 n1"
    shows "n1 = n2"
  using assms
proof -
  from assms(1) assms(2) have "reachable n1" by (auto intro: dom_reachable)
  then have "\<exists>pa. path_entry (g_E G) pa n1" by (auto intro: reachable_path_entry)
  then obtain pa where pa: "path_entry (g_E G) pa n1" by auto

  let ?n_take_n1 = "takeWhile ((\<noteq>) n1) (rev pa)"
  let ?n_take_n2 = "takeWhile ((\<noteq>) n2) (rev pa)"

  show "n1 = n2"
  proof(rule ccontr)
    assume n1_neq_n2:  "n1 \<noteq> n2"
    then have pa_n1_n2: "\<forall>pa. path_entry (g_E G) pa n2 \<longrightarrow> n1 \<in> set pa"
          and pa_n2_n1: "\<forall>pa. path_entry (g_E G)  pa n1 \<longrightarrow> n2 \<in> set pa" using assms(2) assms(3)
      by (auto simp add:dominate_def)
    then have n1_n1_pa: "\<forall>pa. path_entry (g_E G)  pa n1 \<longrightarrow> n1 \<in> set pa" by (rule path_entry_gt)
    with pa pa_n2_n1 have n1_in_pa: "n1 \<in> set pa"
                      and n2_in_pa: "n2 \<in> set pa" by auto
    with n1_neq_n2 have len_neq: "length ?n_take_n1 \<noteq> length ?n_take_n2"
      by (auto simp add: len_takeWhile_comp)

    from pa n1_in_pa n2_in_pa have path1: "path_entry (g_E G) (rev ?n_take_n1) n1"
                               and path2: "path_entry (g_E G) (rev ?n_take_n2) n2"
      using takeWhileNot_path_entry by auto

    have n1_not_in: "n1 \<notin> set ?n_take_n1" by (auto dest: set_takeWhileD[of _ _ "rev pa"])
    have n2_not_in: "n2 \<notin> set ?n_take_n2" by (auto dest: set_takeWhileD[of _ _ "rev pa"])

    show False
    proof(cases "length ?n_take_n1 > length ?n_take_n2")
      case True
      then have "set ?n_take_n2 \<subseteq> set ?n_take_n1"
        using n1_in_pa n2_in_pa by (auto dest: len_takeWhile_set[of _ "rev pa"])
      then have "n1 \<notin> set ?n_take_n2 " using n1_not_in by auto
      with path2 show False using pa_n1_n2 by auto
    next
      case False
      with len_neq have "length ?n_take_n2 > length ?n_take_n1" by auto
      then have "set ?n_take_n1 \<subseteq> set ?n_take_n2"
        using n1_neq_n2 n2_in_pa n1_in_pa  by (auto dest: len_takeWhile_set)
      then have "n2 \<notin> set ?n_take_n1 " using n2_not_in by auto
      with path1 show False using pa_n2_n1 by auto
    qed
  qed
qed

lemma sdom_dom: "strict_dominate n1 n2 \<Longrightarrow> dominate n1 n2"
  by (auto simp add:strict_dominate_def dominate_def)

lemma dominate_sdominate: "dominate n1 n2 \<Longrightarrow> n1 \<noteq> n2 \<Longrightarrow> strict_dominate n1 n2"
  by (auto simp add:strict_dominate_def dominate_def)

lemma sdom_neq:
  assumes "reachable n2"
      and "strict_dominate n1 n2"
    shows "n1 \<noteq> n2"
  using assms
proof -
  from assms(1) have "\<exists>p. path_entry (g_E G)  p n2" by (rule reachable_path_entry)
  then obtain p where "path_entry (g_E G)  p n2" by auto
  with assms(2) show ?thesis by (auto simp add:strict_dominate_def)
qed

lemma reachable_dom_acyclic2:
  assumes "reachable n2 "
      and "strict_dominate n1 n2"
    shows "\<not> dominate n2 n1"
  using assms
proof -
  from assms have n1_dom_n2: "dominate n1 n2" and n1_neq_n2: "n1 \<noteq> n2"
    by (auto simp add:sdom_dom sdom_neq)
  with assms(1) have "dominate n2 n1 \<Longrightarrow> n1 = n2" using reachable_dom_acyclic by auto
  with n1_neq_n2 show ?thesis by auto
qed

lemma not_dom_eq_not_sdom: "\<not> dominate n1 n2 \<Longrightarrow> \<not> strict_dominate n1 n2"
  by (auto simp add:strict_dominate_def dominate_def)

lemma reachable_sdom_acyclic:
  assumes "reachable n2"
      and "strict_dominate n1 n2"
    shows "\<not> strict_dominate n2 n1"
  using assms
  apply (insert reachable_dom_acyclic2[OF assms(1) assms(2)])
  by (auto simp add:not_dom_eq_not_sdom)

lemma strict_dominate_trans1:
  assumes "strict_dominate n1 n2"
      and "dominate n2 n3"
    shows "strict_dominate n1 n3"
  using assms
proof (cases "reachable n2")
  case True note reach_n2 = this
  with assms(1) have n1_dom_n2: "dominate n1 n2" and n1_neq_n2: "n1 \<noteq> n2"
    by (auto simp add:sdom_dom sdom_neq)
  with assms(2) have n1_dom_n3: "dominate n1 n3" by (auto intro: dominate_trans)
  have n1_neq_n3: "n1 \<noteq> n3"
  proof (rule ccontr)
    assume "\<not> n1 \<noteq> n3" then have "n1 = n3" by simp
    with assms(2) have n2_dom_n1: "dominate n2 n1" by simp
    with reach_n2 n1_dom_n2 have "n1 = n2" by (auto dest:reachable_dom_acyclic)
    with n1_neq_n2 show False by auto
  qed
  with n1_dom_n3 show ?thesis by (simp add:strict_dominate_def dominate_def)
next
  case False note not_reach_n2 = this
  have "\<not> reachable n3"
  proof (rule ccontr)
    assume "\<not> \<not> reachable n3 "
    with assms(2) have "reachable n2" by (auto intro: dom_reachable)
    with not_reach_n2 show False by auto
  qed
  then show ?thesis by (auto intro:any_sdominate_unreachable)
qed

lemma strict_dominate_trans2:
  assumes "dominate n1 n2"
      and "strict_dominate n2 n3"
    shows "strict_dominate n1 n3"
  using assms
proof (cases "reachable n3")
  case True
  with assms(2) have n2_dom_n3: "dominate n2 n3" and n1_neq_n2: "n2 \<noteq> n3"
    by (auto simp add:sdom_dom sdom_neq)
  with assms(1) have n1_dom_n3: "dominate n1 n3" by (auto intro: dominate_trans)
  have n1_neq_n3: "n1 \<noteq> n3"
  proof (rule ccontr)
    assume "\<not> n1 \<noteq> n3" then have "n1 = n3" by simp
    with assms(1) have "dominate n3 n2" by simp
    with \<open>reachable n3\<close> n2_dom_n3 have "n2 = n3" by (auto dest:reachable_dom_acyclic)
    with n1_neq_n2 show False by auto
  qed
  with n1_dom_n3 show ?thesis by (simp add:strict_dominate_def dominate_def)
next
  case False
  then have "\<not> reachable n3" by simp
  then show ?thesis by (auto intro:any_sdominate_unreachable)
qed

lemma strict_dominate_trans:
  assumes "strict_dominate n1 n2"
      and "strict_dominate n2 n3"
    shows "strict_dominate n1 n3"
  using assms
  apply(subgoal_tac "dominate n2 n3")
   apply(rule strict_dominate_trans1)
  apply (auto simp add: strict_dominate_def dominate_def)
  done

lemma sdominate_dominate_succs:
  assumes i_sdom_j:    "strict_dominate i j"
      and j_in_succ_k: "j \<in> succs k"
    shows              "dominate i k"
proof (rule ccontr)
  assume ass:"\<not> dominate i k"
  then obtain p where path_k: "path_entry (g_E G)  p k" and i_nin_p: "i \<notin> set p" by (auto simp add:dominate_def)
  with j_in_succ_k i_sdom_j have i: "i = k \<or> i = j" by (auto intro:path_entry_append simp add:succs_def strict_dominate_def)

  from j_in_succ_k have "reachable j" using succ_in_verts reachable by (auto simp add:reachable_def)
  with i_sdom_j have "i \<noteq> j" by (auto simp add: sdom_neq)
  with i have "i = k" by auto
  then have "dominate i k" by (auto simp add:dominate_refl)
  with ass show False by auto
qed

end

end