           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                 August 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2005         |
            |                October 2005  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2009-2       |
            |                October 2010  (modified)   |
            |                                           |
            |        CSP-Prover on Isabelle2016         |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory Set_F_cms
imports Set_F RS
begin

(*****************************************************************

         1.
         2.
         3.
         4.

 *****************************************************************)

(*  The following simplification rules are deleted in this theory file *)
(*  because they unexpectly rewrite UnionT and InterT.                 *)
(*                  Union (B ` A) = (UN x:A. B x)                      *)
(*                  Inter (B ` A) = (INT x:A. B x)                     *)
(*
declare Union_image_eq [simp del]
declare Inter_image_eq [simp del]
*)
declare Sup_image_eq [simp del]
declare Inf_image_eq [simp del]

(*********************************************************
                 Restriction in Set_F
 *********************************************************)

(* Isabelle 2009-1
instance setF :: (type) ms0
by (intro_classes)
*)

definition
  restF      :: "'a setF => nat => 'a failure set" ("_ restF _" [84,900] 84)
  where
 restF_def :
   "F restF n == {(s, X) |s X. (s, X) :f F &
                  (lengtht s < n |
                   lengtht s = n & (EX s'. s = s' ^^^ <Tick> & noTick s'))}"

definition
  LimitF     :: "'a setF infinite_seq => 'a failure set"
  where
  LimitF_def :
   "LimitF Fs == {(s, X) |s X.
           ((s, X) :f Fs (Suc (lengtht s)) |
            (s, X) :f Fs (lengtht s) & (EX s'. s = s' ^^^ <Tick> & noTick s'))}"

definition
  Limit_setF :: "'a setF infinite_seq => 'a setF"
  where
  Limit_setF_def :
   "Limit_setF Fs == Abs_setF (LimitF Fs)"

(* isabelle 2009-2 *)

instantiation setF :: (type) rs0
begin

definition
  rest_setF_def : "F .|. n == Abs_setF (F restF n)"

  instance ..

end

(* isabelle 2009-1
defs (overloaded)
  rest_setF_def : "F .|. n == Abs_setF (F restF n)"
*)

(*--------------------------------------------------------*
 |  The reason why restF deals specially with [Tick]      |
 |  can be found in the proof of lemma "restFpair_T3_F4"  |
 |  in Domain_F_cms.thy.                                  |
 *--------------------------------------------------------*)

(*********************************************************
              Lemmas (Restriction in Set_F)
 *********************************************************)

(*** restF_def in setF ***)

lemma restF_in[simp] : "F restF n : setF"
apply (simp add: restF_def)
apply (simp add: setF_def HC_F2_def)
apply (intro allI impI)
apply (elim conjE)
apply (rule memF_F2)
by (simp_all)

(*********************************************************
                     .|. on setF
 *********************************************************)

lemma rest_setF_iff: "F .|. n =
                  {f. EX s X. f = (s, X) & (s, X) :f F &
                  (lengtht s < n |
                   lengtht s = n & (EX s'. s = s' ^^^ <Tick> & noTick s'))}f"
apply (simp add: rest_setF_def)
apply (subgoal_tac
    "{(s, X).
     (s, X) :f F &
     (lengtht s < n |
      lengtht s = n & (EX s'. s = s' ^^^ <Tick> & noTick s'))} : setF")
apply (simp add: Abs_setF_inject)
apply (simp add: restF_def)
apply (insert restF_in[simplified restF_def])
apply (auto)
done

lemma in_rest_setF: "(s, X) :f F .|. n =
                 ((s, X) :f F &
                (lengtht s < n |
                 lengtht s = n & (EX s'. s = s' ^^^ <Tick> & noTick s')))"
apply (simp add: memF_def rest_setF_def)
apply (simp add: Abs_setF_inverse)
apply (simp add: memF_def restF_def)
done

lemma rest_setF_eq_iff:
   "(F .|. n = E .|. m) =
    (ALL s X.
         ((s, X) :f F &
          (lengtht s < n |
           lengtht s = n & (EX s'. s = s' ^^^ <Tick> & noTick s')))
       = ((s, X) :f E &
          (lengtht s < m |
           lengtht s = m & (EX s'. s = s' ^^^ <Tick> & noTick s'))))"
apply (simp add: rest_setF_def Abs_setF_inject)
apply (simp add: restF_def)
by (auto)

(*** F .|. = E .|. --> F = E ***)

lemma rest_setF_eq:
  "[| (s, X) :f F ; F restF Suc (lengtht s) =
                    E restF Suc (lengtht s) |]
   ==> (s, X) :f E"
by (auto simp add: restF_def)

(*********************************************************
                     SetF --> RS
 *********************************************************)

(*******************************
        zero_eq_rs_setF
 *******************************)

(*** (contra) restF 0 ***)

lemma contra_zero_setF: "(F::'a setF) restF n ~= {} ==> 0 < n"
apply (simp add: restF_def)
apply (elim conjE exE)
apply (erule disjE)
apply (simp)

apply (elim conjE exE)
by (simp)

(*** restF 0 ***)

lemma zero_setF: "(F::'a setF) restF 0 = {}"
apply (insert contra_zero_setF[of F 0])
apply (case_tac "F restF 0 = {}")
by (simp_all)

(*** zero_eq_rs_setF ***)

lemma zero_rs_setF: "(F::'a setF) .|. 0 = {}f"
apply (simp add: rest_setF_def empF_def Abs_setF_inject)
apply (simp add: zero_setF)
done

lemma zero_eq_rs_setF: "(F::'a setF) .|. 0 = E .|. 0"
by (simp add: zero_rs_setF)

(*******************************
         min_rs_setF
 *******************************)

lemma min_rs_setF:
  "((F::'a setF) .|. m) .|. n = F .|. (min m n)"
apply (simp add: rest_setF_eq_iff)
apply (simp add: in_rest_setF)
apply (intro allI)
apply (rule iffI)

apply (elim conjE exE disjE)
apply (simp_all add: min_is)
apply (rule_tac x="s'" in exI, simp)+

apply (elim conjE exE disjE)
apply (simp_all)

apply (case_tac "m < n")
apply (simp add: min_is)
apply (rule_tac x="s'" in exI, simp)

apply (case_tac "m = n")
apply (simp add: min_is)
apply (rule_tac x="s'" in exI, simp)

apply (case_tac "n < m")
apply (simp add: min_is)
apply (rule_tac x="s'" in exI, simp)

by (force)

(*******************************
        diff_rs_setF
 *******************************)

(*** contra <= ***)

lemma contra_diff_rs_setF_left:
  "(ALL n. (F::'a setF) .|. n = E .|. n) ==> F <= E"
apply (simp add: rest_setF_eq_iff)
apply (rule subsetFI)
apply (drule_tac x="Suc (lengtht s)" in spec)
apply (drule_tac x="s" in spec)
apply (drule_tac x="X" in spec)
by (simp)

(*** contra = ***)

lemma contra_diff_rs_setF:
  "(ALL n. (F::'a setF) .|. n = E .|. n) ==> F = E"
apply (rule order_antisym)
by (simp_all add: contra_diff_rs_setF_left)

(*** diff_rs_setF ***)

lemma diff_rs_setF:
  "(F::'a setF) ~= E ==> (EX (n::nat). F .|. n ~= E .|. n)"
apply (erule contrapos_np)
apply (rule contra_diff_rs_setF)
by (simp)

(***************************************************************
                        setF ==> RS
 ***************************************************************)

instance setF :: (type) rs
apply (intro_classes)
apply (simp add: zero_eq_rs_setF)
apply (simp add: min_rs_setF)
apply (simp add: diff_rs_setF)
done

(************************************************************
                        setF ==> MS
 ************************************************************)

instantiation setF :: (type) ms0
begin

definition
  setF_distance_def:
     "distance (FF::('a setF * 'a setF)) = distance_rs FF"
  instance ..
end

instance setF :: (type) ms
apply (intro_classes)
apply (simp_all add: setF_distance_def)
apply (simp add: diagonal_rs)
apply (simp add: symmetry_rs)
apply (simp add: triangle_inequality_rs)
done

(************************************************************
                 i.e.  setF ==> MS & RS
 ************************************************************)

instance setF :: (type) ms_rs
apply (intro_classes)
apply (simp add: setF_distance_def)
done

(***********************************************************
                      lemmas (Limit)
 ***********************************************************)

(*** normal_seq lemma ***)

lemma normal_seq_setF_less:
  "[| normal (Fs::'a setF infinite_seq) ; lengtht s < n |]
   ==> ((s,X) :f Fs (Suc (lengtht s))) = ((s,X) :f Fs n)"
apply (simp add: normal_def)
apply (drule_tac x="Suc (lengtht s)" in spec)
apply (drule_tac x="n" in spec)
apply (simp add: to_distance_rs)
apply (simp add: distance_rs_le_1[THEN sym])
apply (simp add: min_is)

apply (simp add: rest_setF_eq_iff)
apply (drule_tac x="s" in spec)
apply (drule_tac x="X" in spec)
by (simp)

lemma normal_seq_setF_less_only_if:
  "[| normal (Fs::'a setF infinite_seq) ; lengtht s < n ;
      (s,X) :f Fs (Suc (lengtht s)) |]
   ==> ((s,X) :f Fs n)"
by (simp add: normal_seq_setF_less)

(*** normal_seq lemma (Tick)***)

lemma normal_seq_setF_Tick:
  "[| normal (Fs::'a setF infinite_seq) ; lengtht (s' ^^^ <Tick>) <= n ;
      noTick s' |]
   ==> ((s' ^^^ <Tick>,X) :f Fs (lengtht (s' ^^^ <Tick>))) =
       ((s' ^^^ <Tick>,X) :f Fs n)"
apply (simp add: normal_def)
apply (drule_tac x="lengtht (s' ^^^ <Tick>)" in spec)
apply (drule_tac x="n" in spec)
apply (simp add: to_distance_rs)
apply (simp add: distance_rs_le_1[THEN sym])
apply (simp add: min_is)

apply (simp add: rest_setF_eq_iff)
apply (drule_tac x="s' ^^^ <Tick>" in spec)
apply (drule_tac x="X" in spec)
apply (simp)

apply (rule)
 apply (erule iffE)
 apply (drule mp)
 apply (rule conjI)
 apply (simp)
 apply (simp)
 apply (rule_tac x="s'" in exI)
 apply (simp)
 apply (simp)

 apply (erule iffE)
 apply (rotate_tac -1)
 apply (drule mp)
 apply (rule conjI)
 apply (simp)
 apply (simp)
 apply (rule_tac x="s'" in exI)
 apply (simp)
 apply (simp)
done

lemma normal_seq_setF_Tick_only_if:
  "[| normal (Fs::'a setF infinite_seq) ; lengtht (s' ^^^ <Tick>) <= n ;
      (s' ^^^ <Tick>,X) :f Fs (lengtht (s' ^^^ <Tick>)) ; noTick s' |]
   ==> ((s' ^^^ <Tick>,X) :f Fs n)"
by (simp only: normal_seq_setF_Tick)

lemma normal_seq_setF_Tick_only_ifE:
  "[| (s' ^^^ <Tick>,X) :f Fs n ;
      normal (Fs::'a setF infinite_seq) ; lengtht (s' ^^^ <Tick>) <= n ; noTick s' ;
      (s' ^^^ <Tick>,X) :f Fs (lengtht (s' ^^^ <Tick>)) ==> R |]
   ==> R"
by (simp only: normal_seq_setF_Tick)

(*** LimitF_def in setF ***)

lemma LimitF_in[simp]:
  "LimitF (Fs::'a setF infinite_seq) : setF"
apply (simp add: LimitF_def)
apply (simp add: setF_def HC_F2_def)
apply (intro allI impI)
apply (erule conjE)
apply (erule disjE)

apply (rule disjI1)
apply (rule memF_F2)
apply (simp_all)

apply (elim conjE exE)
apply (rule disjI2)
apply (rule memF_F2)
apply (simp_all)
done

(*** Limit_setF_memF ***)

lemma Limit_setF_memF:
  "((s, X) :f Limit_setF Fs) =
   ((s, X) :f Fs (Suc (lengtht s)) |
    (s, X) :f Fs (lengtht s) & (EX s'. s = s' ^^^ <Tick> & noTick s'))"
apply (simp add: Limit_setF_def memF_def)
apply (simp add: Abs_setF_inverse)
apply (simp add: LimitF_def memF_def)
done

(*** Limit_setF lemma ***)

lemma Limit_setF_Limit_lm:
  "normal (Fs::'a setF infinite_seq)
   ==> (ALL n. (Limit_setF Fs) .|. n = (Fs n) .|. n)"
apply (simp add: rest_setF_eq_iff)
apply (intro allI)
apply (simp add: Limit_setF_memF)
apply (rule iffI)

(* => *)
apply (elim conjE disjE)
apply (simp_all add: normal_seq_setF_less)

apply (elim conjE exE)
apply (simp)
apply (erule normal_seq_setF_Tick_only_ifE)
apply (simp_all)

apply (elim conjE exE)
apply (simp)
apply (rule normal_seq_setF_Tick_only_if)
apply (simp_all)

(* <= *)
apply (elim conjE disjE)
apply (simp add: normal_seq_setF_less)
apply (simp)
done

(*** (normal) Fs converges to (Limit_setF Fs) ***)

lemma Limit_setF_Limit:
  "normal (Fs::'a setF infinite_seq) ==> Fs convergeTo (Limit_setF Fs)"
by (simp add: to_distance_rs Limit_setF_Limit_lm rest_Limit)

(*** (cauchy) Fs converges to (Limit_setF NF Fs) ***)

lemma cauchy_Limit_setF_Limit:
  "cauchy (Fs::'a setF infinite_seq) ==> Fs convergeTo (Limit_setF (NF Fs))"
apply (simp add: normal_form_seq_same_Limit)
apply (simp add: Limit_setF_Limit normal_form_seq_normal)
done

(************************************
    SetF --> Complete Metric Space
 ************************************)

lemma setF_cms:
  "cauchy (Fs::'a setF infinite_seq) ==> (EX F. Fs convergeTo F)"
apply (rule_tac x="Limit_setF (NF Fs)" in exI)
by (simp add: cauchy_Limit_setF_Limit)

(************************************************************
                   setF ==> CMS and RS
 ************************************************************)

instance setF :: (type) cms
apply (intro_classes)
by (simp add: setF_cms)

instance setF :: (type) cms_rs
by (intro_classes)

(*** (normal) Limit Fs = Limit_setF Fs ***)

lemma Limit_setF_Limit_eq:
  "normal (Fs::'a setF infinite_seq) ==> Limit Fs = Limit_setF Fs"
apply (insert unique_convergence[of Fs "Limit Fs" "Limit_setF Fs"])
by (simp add:  Limit_setF_Limit Limit_is normal_cauchy)

(*----------------------------------------------------------*
 |                                                          |
 |                       cms rs order                       |
 |                                                          |
 *----------------------------------------------------------*)

instance setF :: (type) ms_rs_order0
apply (intro_classes)
done

instance setF :: (type) ms_rs_order
apply (intro_classes)
apply (intro allI)
apply (rule iffI)
apply (simp add: rest_setF_def)
apply (simp add: subsetF_def)
apply (simp add: Abs_setF_inverse)
apply (fold subsetF_def)
apply (rule)
apply (drule_tac x="Suc (lengtht s)" in spec)
apply (simp add: restF_def)
apply (erule subsetE)
apply (simp)

apply (intro allI)
apply (simp add: rest_setF_def)
apply (simp add: subsetF_def)
apply (simp add: Abs_setF_inverse)
apply (fold subsetF_def)
apply (rule)
apply (simp add: restF_def)
apply (force)
done

instance setF :: (type) cms_rs_order
by (intro_classes)

(*----------------------------------------------------------*
 |                                                          |
 |  i.e. lemma "continuous_rs (Ref_fun (S::'a setF))"       |
 |       by (simp add: continuous_rs_Ref_fun)               |
 |                                                          |
 |  see RS.thy                                              |
 |                                                          |
 *----------------------------------------------------------*)

(****************** to add them again ******************)
(*
declare Union_image_eq [simp]
declare Inter_image_eq [simp]
*)
declare Sup_image_eq [simp]
declare Inf_image_eq [simp]

end


section\<open>Firewall Basic Syntax\<close>
theory Firewall_Common
imports Main "../Simple_Firewall/Firewall_Common_Decision_State"
  "Common/Repeat_Stabilize"
begin

text\<open>
Our firewall model supports the following actions.
\<close>
datatype action = Accept | Drop | Log | Reject | Call string | Return | Goto string | Empty | Unknown

text\<open>
We support the following algebra over primitives of type @{typ 'a}.
The type parameter @{typ 'a} denotes the primitive match condition. For example, matching
on source IP address or on protocol.
We lift the primitives to an algebra. Note that we do not have an Or expression.
\<close>
datatype 'a match_expr = Match 'a
                       | MatchNot "'a match_expr"
                       | MatchAnd "'a match_expr" "'a match_expr"
                       | MatchAny

definition MatchOr :: "'a match_expr \<Rightarrow> 'a match_expr \<Rightarrow> 'a match_expr" where
  "MatchOr m1 m2 = MatchNot (MatchAnd (MatchNot m1) (MatchNot m2))"

text\<open>A firewall rule consists of a match expression and an action.\<close>
datatype 'a rule = Rule (get_match: "'a match_expr") (get_action: action)

lemma rules_singleton_rev_E:
  "[Rule m a] = rs\<^sub>1 @ rs\<^sub>2 \<Longrightarrow>
   (rs\<^sub>1 = [Rule m a] \<Longrightarrow> rs\<^sub>2 = [] \<Longrightarrow> P m a) \<Longrightarrow>
   (rs\<^sub>1 = [] \<Longrightarrow> rs\<^sub>2 = [Rule m a] \<Longrightarrow> P m a) \<Longrightarrow> P m a"
by (cases rs\<^sub>1) auto

section\<open>Basic Algorithms\<close>
text\<open>These algorithms should be valid for all firewall semantics.
     The corresponding proofs follow once the semantics are defined.\<close>

text\<open>The actions Log and Empty do not modify the packet processing in any way. They can be removed.\<close>
fun rm_LogEmpty :: "'a rule list \<Rightarrow> 'a rule list" where
  "rm_LogEmpty [] = []" |
  "rm_LogEmpty ((Rule _ Empty)#rs) = rm_LogEmpty rs" |
  "rm_LogEmpty ((Rule _ Log)#rs) = rm_LogEmpty rs" |
  "rm_LogEmpty (r#rs) = r # rm_LogEmpty rs"

lemma rm_LogEmpty_filter: "rm_LogEmpty rs = filter (\<lambda>r. get_action r \<noteq> Log \<and> get_action r \<noteq> Empty) rs"
 by(induction rs rule: rm_LogEmpty.induct) (simp_all)

lemma rm_LogEmpty_seq: "rm_LogEmpty (rs1@rs2) = rm_LogEmpty rs1 @ rm_LogEmpty rs2"
  by(simp add: rm_LogEmpty_filter)

text\<open>Optimize away MatchAny matches\<close>
fun opt_MatchAny_match_expr_once :: "'a match_expr \<Rightarrow> 'a match_expr" where
  "opt_MatchAny_match_expr_once MatchAny = MatchAny" |
  "opt_MatchAny_match_expr_once (Match a) = (Match a)" |
  "opt_MatchAny_match_expr_once (MatchNot (MatchNot m)) = (opt_MatchAny_match_expr_once m)" |
  "opt_MatchAny_match_expr_once (MatchNot m) = MatchNot (opt_MatchAny_match_expr_once m)" |
  "opt_MatchAny_match_expr_once (MatchAnd MatchAny MatchAny) = MatchAny" |
  "opt_MatchAny_match_expr_once (MatchAnd MatchAny m) = (opt_MatchAny_match_expr_once m)" |
  (*note: remove recursive call to opt_MatchAny_match_expr_once to make it probably faster*)
  "opt_MatchAny_match_expr_once (MatchAnd m MatchAny) = (opt_MatchAny_match_expr_once m)" |
  "opt_MatchAny_match_expr_once (MatchAnd _ (MatchNot MatchAny)) = (MatchNot MatchAny)" |
  "opt_MatchAny_match_expr_once (MatchAnd (MatchNot MatchAny) _) = (MatchNot MatchAny)" |
  "opt_MatchAny_match_expr_once (MatchAnd m1 m2) = MatchAnd (opt_MatchAny_match_expr_once m1) (opt_MatchAny_match_expr_once m2)"
(* without recursive call: need to apply multiple times until it stabelizes *)

text\<open>It is still a good idea to apply @{const opt_MatchAny_match_expr_once} multiple times. Example:\<close>
lemma "MatchNot (opt_MatchAny_match_expr_once (MatchAnd MatchAny (MatchNot MatchAny))) = MatchNot (MatchNot MatchAny)" by simp
lemma "m = (MatchAnd (MatchAnd MatchAny MatchAny) (MatchAnd MatchAny MatchAny)) \<Longrightarrow>
  (opt_MatchAny_match_expr_once^^2) m \<noteq> opt_MatchAny_match_expr_once m" by(simp add: funpow_def)

definition opt_MatchAny_match_expr :: "'a match_expr \<Rightarrow> 'a match_expr" where
  "opt_MatchAny_match_expr m \<equiv> repeat_stabilize 2 opt_MatchAny_match_expr_once m"

text\<open>Rewrite @{const Reject} actions to @{const Drop} actions.
      If we just care about the filtering decision (@{const FinalAllow} or @{const FinalDeny}), they should be equal.\<close>
fun rw_Reject :: "'a rule list \<Rightarrow> 'a rule list" where
  "rw_Reject [] = []" |
  "rw_Reject ((Rule m Reject)#rs) = (Rule m Drop)#rw_Reject rs" |
  "rw_Reject (r#rs) = r # rw_Reject rs"

text\<open>We call a ruleset simple iff the only actions are @{const Accept} and @{const Drop}\<close>
  definition simple_ruleset :: "'a rule list \<Rightarrow> bool" where
    "simple_ruleset rs \<equiv> \<forall>r \<in> set rs. get_action r = Accept \<or> get_action r = Drop"

  lemma simple_ruleset_tail: "simple_ruleset (r#rs) \<Longrightarrow> simple_ruleset rs" by (simp add: simple_ruleset_def)

  lemma simple_ruleset_append: "simple_ruleset (rs\<^sub>1 @ rs\<^sub>2) \<longleftrightarrow> simple_ruleset rs\<^sub>1 \<and> simple_ruleset rs\<^sub>2"
    by(simp add: simple_ruleset_def, blast)

text\<open>Structural properties about match expressions\<close>
  fun has_primitive :: "'a match_expr \<Rightarrow> bool" where
    "has_primitive MatchAny = False" |
    "has_primitive (Match a) = True" |
    "has_primitive (MatchNot m) = has_primitive m" |
    "has_primitive (MatchAnd m1 m2) = (has_primitive m1 \<or> has_primitive m2)"

  text\<open>Is a match expression equal to the @{const MatchAny} expression?
        Only applicable if no primitives are in the expression.\<close>
  fun matcheq_matchAny :: "'a match_expr \<Rightarrow> bool" where
    "matcheq_matchAny MatchAny \<longleftrightarrow> True" |
    "matcheq_matchAny (MatchNot m) \<longleftrightarrow> \<not> (matcheq_matchAny m)" |
    "matcheq_matchAny (MatchAnd m1 m2) \<longleftrightarrow> matcheq_matchAny m1 \<and> matcheq_matchAny m2" |
    "matcheq_matchAny (Match _) = undefined"

  fun matcheq_matchNone :: "'a match_expr \<Rightarrow> bool" where
    "matcheq_matchNone MatchAny = False" |
    "matcheq_matchNone (Match _) = False" |
    "matcheq_matchNone (MatchNot MatchAny) = True" |
    "matcheq_matchNone (MatchNot (Match _)) = False" |
    "matcheq_matchNone (MatchNot (MatchNot m)) = matcheq_matchNone m" |
    "matcheq_matchNone (MatchNot (MatchAnd m1 m2)) \<longleftrightarrow> matcheq_matchNone (MatchNot m1) \<and> matcheq_matchNone (MatchNot m2)" |
    "matcheq_matchNone (MatchAnd m1 m2) \<longleftrightarrow>  matcheq_matchNone m1 \<or> matcheq_matchNone m2"

  lemma matachAny_matchNone: "\<not> has_primitive m \<Longrightarrow> matcheq_matchAny m \<longleftrightarrow> \<not> matcheq_matchNone m"
    by(induction m rule: matcheq_matchNone.induct)(simp_all)

  lemma matcheq_matchNone_no_primitive: "\<not> has_primitive m \<Longrightarrow> matcheq_matchNone (MatchNot m) \<longleftrightarrow> \<not> matcheq_matchNone m"
    by(induction m rule: matcheq_matchNone.induct) (simp_all)

text\<open>optimizing match expressions\<close>

fun optimize_matches_option :: "('a match_expr \<Rightarrow> 'a match_expr option) \<Rightarrow> 'a rule list \<Rightarrow> 'a rule list" where
  "optimize_matches_option _ [] = []" |
  "optimize_matches_option f (Rule m a#rs) = (case f m of None \<Rightarrow> optimize_matches_option f rs | Some m \<Rightarrow> (Rule m a)#optimize_matches_option f rs)"

lemma optimize_matches_option_preserves:
  "(\<And> r m. r \<in> set rs \<Longrightarrow> f (get_match r) = Some m \<Longrightarrow> P m) \<Longrightarrow>
    \<forall> r \<in> set (optimize_matches_option f rs). P (get_match r)"
  apply(induction rs rule: optimize_matches_option.induct)
   apply(simp; fail)
  apply(simp split: option.split)
  by fastforce
(*
lemma optimize_matches_option_preserves':
  "\<forall> m \<in> set rs. P (get_match m) \<Longrightarrow> \<forall>m. P m \<longrightarrow> (\<forall>m'. f m = Some m' \<longrightarrow> P m') \<Longrightarrow> \<forall>m \<in> set (optimize_matches_option f rs). P (get_match m)"
  using optimize_matches_option_preserves[simplified] by metis
*)
lemma optimize_matches_option_append: "optimize_matches_option f (rs1@rs2) = optimize_matches_option f rs1 @ optimize_matches_option f rs2"
  proof(induction rs1 rule: optimize_matches_option.induct)
  qed(simp_all split: option.split)

definition optimize_matches :: "('a match_expr \<Rightarrow> 'a match_expr) \<Rightarrow> 'a rule list \<Rightarrow> 'a rule list" where
  "optimize_matches f rs =  optimize_matches_option (\<lambda>m. (if matcheq_matchNone (f m) then None else Some (f m))) rs"

lemma optimize_matches_append: "optimize_matches f (rs1@rs2) = optimize_matches f rs1 @ optimize_matches f rs2"
  by(simp add: optimize_matches_def optimize_matches_option_append)

(*Warning: simplifier loops with this lemma*)
lemma optimize_matches_fst: "optimize_matches f (r#rs) = optimize_matches f [r]@optimize_matches f rs"
by(cases r)(simp add: optimize_matches_def)

lemma optimize_matches_preserves: "(\<And> r. r \<in> set rs \<Longrightarrow> P (f (get_match r))) \<Longrightarrow>
    \<forall> r \<in> set (optimize_matches f rs). P (get_match r)"
  unfolding optimize_matches_def
  apply(rule optimize_matches_option_preserves)
  by(auto split: if_split_asm)

lemma optimize_matches_simple_ruleset: "simple_ruleset rs \<Longrightarrow> simple_ruleset (optimize_matches f rs)"
  by(simp add: optimize_matches_def optimize_matches_option_simple_ruleset)

definition optimize_matches_a :: "(action \<Rightarrow> 'a match_expr \<Rightarrow> 'a match_expr) \<Rightarrow> 'a rule list \<Rightarrow> 'a rule list" where
  "optimize_matches_a f rs = map (\<lambda>r. Rule (f (get_action r) (get_match r)) (get_action r)) rs"

lemma optimize_matches_a_simple_ruleset: "simple_ruleset rs \<Longrightarrow> simple_ruleset (optimize_matches_a f rs)"
  by(simp add: optimize_matches_a_def simple_ruleset_def)

lemma optimize_matches_a_simple_ruleset_eq:
  "simple_ruleset rs \<Longrightarrow> (\<And> m a. a = Accept \<or> a = Drop \<Longrightarrow> f1 a m = f2 a m) \<Longrightarrow> optimize_matches_a f1 rs = optimize_matches_a f2 rs"
apply(induction rs)
 apply(simp add: optimize_matches_a_def)
apply(simp add: optimize_matches_a_def)
apply(simp add: simple_ruleset_def)
done

lemma optimize_matches_a_preserves: "(\<And> r. r \<in> set rs \<Longrightarrow> P (f (get_action r) (get_match r)))
    \<Longrightarrow> \<forall> r \<in> set (optimize_matches_a f rs). P (get_match r)"
  by(induction rs)(simp_all add: optimize_matches_a_def)

end


(*  Title:      HOL/Eisbach/Examples.thy
    Author:     Daniel Matichuk, NICTA/UNSW
*)

section \<open>Basic Eisbach examples\<close>

theory Examples
imports MainRLT Eisbach_Tools
begin

subsection \<open>Basic methods\<close>

method my_intros = (rule conjI | rule impI)

lemma "P \<and> Q \<longrightarrow> Z \<and> X"
  apply my_intros+
  oops

method my_intros' uses intros = (rule conjI | rule impI | rule intros)

lemma "P \<and> Q \<longrightarrow> Z \<or> X"
  apply (my_intros' intros: disjI1)+
  oops

method my_spec for x :: 'a = (drule spec[where x="x"])

lemma "\<forall>x. P x \<Longrightarrow> P x"
  apply (my_spec x)
  apply assumption
  done

subsection \<open>Focusing and matching\<close>

method match_test =
  (match premises in U: "P x \<and> Q x" for P Q x \<Rightarrow>
    \<open>print_term P,
     print_term Q,
     print_term x,
     print_fact U\<close>)

lemma "\<And>x. P x \<and> Q x \<Longrightarrow> A x \<and> B x \<Longrightarrow> R x y \<Longrightarrow> True"
  apply match_test  \<comment> \<open>Valid match, but not quite what we were expecting..\<close>
  back  \<comment> \<open>Can backtrack over matches, exploring all bindings\<close>
  back
  back
  back
  back
  back  \<comment> \<open>Found the other conjunction\<close>
  back
  back
  back
  oops

text \<open>Use matching to avoid "improper" methods\<close>

lemma focus_test:
  shows "\<And>x. \<forall>x. P x \<Longrightarrow> P x"
  apply (my_spec "x :: 'a", assumption)?  \<comment> \<open>Wrong x\<close>
  apply (match conclusion in "P x" for x \<Rightarrow> \<open>my_spec x, assumption\<close>)
  done

text \<open>Matches are exclusive. Backtracking will not occur past a match\<close>

method match_test' =
  (match conclusion in
    "P \<and> Q" for P Q \<Rightarrow>
      \<open>print_term P, print_term Q, rule conjI[where P="P" and Q="Q"]; assumption\<close>
    \<bar> "H" for H \<Rightarrow> \<open>print_term H\<close>)

text \<open>Solves goal\<close>
lemma "P \<Longrightarrow> Q \<Longrightarrow> P \<and> Q"
  apply match_test'
  done

text \<open>Fall-through case never taken\<close>
lemma "P \<and> Q"
  apply match_test'?
  oops

lemma "P"
  apply match_test'
  oops

method my_spec_guess =
  (match conclusion in "P (x :: 'a)" for P x \<Rightarrow>
    \<open>drule spec[where x=x],
     print_term P,
     print_term x\<close>)

lemma "\<forall>x. P (x :: nat) \<Longrightarrow> Q (x :: nat)"
  apply my_spec_guess
  oops

method my_spec_guess2 =
  (match premises in U[thin]:"\<forall>x. P x \<longrightarrow> Q x" and U':"P x" for P Q x \<Rightarrow>
    \<open>insert spec[where x=x, OF U],
     print_term P,
     print_term Q\<close>)

lemma "\<forall>x. P x \<longrightarrow> Q x \<Longrightarrow> Q x \<Longrightarrow> Q x"
  apply my_spec_guess2?  \<comment> \<open>Fails. Note that both "P"s must match\<close>
  oops

lemma "\<forall>x. P x \<longrightarrow> Q x \<Longrightarrow> P x \<Longrightarrow> Q x"
  apply my_spec_guess2
  apply (erule mp)
  apply assumption
  done

subsection \<open>Higher-order methods\<close>

method higher_order_example for x methods meth =
  (cases x, meth, meth)

lemma
  assumes A: "x = Some a"
  shows "the x = a"
  by (higher_order_example x \<open>simp add: A\<close>)

subsection \<open>Recursion\<close>

method recursion_example for x :: bool =
  (print_term x,
     match (x) in "A \<and> B" for A B \<Rightarrow>
    \<open>print_term A,
     print_term B,
     recursion_example A,
     recursion_example B | -\<close>)

lemma "P"
  apply (recursion_example "(A \<and> D) \<and> (B \<and> C)")
  oops

subsection \<open>Solves combinator\<close>

lemma "A \<Longrightarrow> B \<Longrightarrow> A \<and> B"
  apply (solves \<open>rule conjI\<close>)?  \<comment> \<open>Doesn't solve the goal!\<close>
  apply (solves \<open>rule conjI, assumption, assumption\<close>)
  done

subsection \<open>Demo\<close>

named_theorems intros and elims and subst

method prop_solver declares intros elims subst =
  (assumption |
    rule intros | erule elims |
    subst subst | subst (asm) subst |
    (erule notE; solves prop_solver))+

lemmas [intros] =
  conjI
  impI
  disjCI
  iffI
  notI
lemmas [elims] =
  impCE
  conjE
  disjE

lemma "((A \<or> B) \<and> (A \<longrightarrow> C) \<and> (B \<longrightarrow> C)) \<longrightarrow> C"
  apply prop_solver
  done

method guess_all =
  (match premises in U[thin]:"\<forall>x. P (x :: 'a)" for P \<Rightarrow>
    \<open>match premises in "?H (y :: 'a)" for y \<Rightarrow>
       \<open>rule allE[where P = P and x = y, OF U]\<close>
   | match conclusion in "?H (y :: 'a)" for y \<Rightarrow>
       \<open>rule allE[where P = P and x = y, OF U]\<close>\<close>)

lemma "(\<forall>x. P x \<longrightarrow> Q x) \<Longrightarrow> P y \<Longrightarrow> Q y"
  apply guess_all
  apply prop_solver
  done

lemma "(\<forall>x. P x \<longrightarrow> Q x) \<Longrightarrow> P z \<Longrightarrow> P y \<Longrightarrow> Q y"
  apply (solves \<open>guess_all, prop_solver\<close>)  \<comment> \<open>Try it without solve\<close>
  done

method guess_ex =
  (match conclusion in
    "\<exists>x. P (x :: 'a)" for P \<Rightarrow>
      \<open>match premises in "?H (x :: 'a)" for x \<Rightarrow>
              \<open>rule exI[where x=x]\<close>\<close>)

lemma "P x \<Longrightarrow> \<exists>x. P x"
  apply guess_ex
  apply prop_solver
  done

method fol_solver =
  ((guess_ex | guess_all | prop_solver); solves fol_solver)

declare
  allI [intros]
  exE [elims]
  ex_simps [subst]
  all_simps [subst]

lemma "(\<forall>x. P x) \<and> (\<forall>x. Q x) \<Longrightarrow> (\<forall>x. P x \<and> Q x)"
  and  "\<exists>x. P x \<longrightarrow> (\<forall>x. P x)"
  and "(\<exists>x. \<forall>y. R x y) \<longrightarrow> (\<forall>y. \<exists>x. R x y)"
  by fol_solver+

text \<open>
  Eisbach_Tools provides the catch method, which catches run-time method
  errors. In this example the OF attribute throws an error when it can't
  compose H with A, forcing H to be re-bound to different members of imps
  until it succeeds.
\<close>

lemma
  assumes imps:  "A \<Longrightarrow> B" "A \<Longrightarrow> C" "B \<Longrightarrow> D"
  assumes A: "A"
  shows "B \<and> C"
  apply (rule conjI)
  apply ((match imps in H:"_ \<Longrightarrow> _" \<Rightarrow> \<open>catch \<open>rule H[OF A], print_fact H\<close> \<open>print_fact H, fail\<close>\<close>)+)
  done

text \<open>
  Eisbach_Tools provides the curry and uncurry attributes. This is useful
  when the number of premises of a thm isn't known statically. The pattern
  \<^term>\<open>P \<Longrightarrow> Q\<close> matches P against the major premise of a thm, and Q is the
  rest of the premises with the conclusion. If we first uncurry, then \<^term>\<open>P \<Longrightarrow> Q\<close> will match P with the conjunction of all the premises, and Q with
  the final conclusion of the rule.
\<close>

lemma
  assumes imps: "A \<Longrightarrow> B \<Longrightarrow> C" "D \<Longrightarrow> C" "E \<Longrightarrow> D \<Longrightarrow> A"
  shows "(A \<longrightarrow> B \<longrightarrow> C) \<and> (D \<longrightarrow> C)"
    by (match imps[uncurry] in H[curry]:"_ \<Longrightarrow> C" (cut, multi) \<Rightarrow>
                    \<open>match H in "E \<Longrightarrow> _" \<Rightarrow> fail
                                      \<bar> _ \<Rightarrow> \<open>simp add: H\<close>\<close>)

end


theory Assembly
  imports Machine
begin

subsection \<open>Assembly Programs\<close>

record asm_prog =
  asm_entry :: "addr"
  asm_text  :: "addr \<rightharpoonup> instr"
  asm_data  :: "addr \<rightharpoonup> byte"

context isa
begin

definition asm_text_encoding :: "asm_prog \<Rightarrow> addr \<rightharpoonup> bytes" where
  "asm_text_encoding p a \<equiv> case asm_text p a of Some i \<Rightarrow> isa_encode i | None \<Rightarrow> None"

lemma asm_text_encoding_None: "asm_text p a = None \<longrightarrow> asm_text_encoding p a = None"
  by (simp add: asm_text_encoding_def)

definition asm_is_initial_state :: "asm_prog \<Rightarrow> state \<Rightarrow> bool" where
  "asm_is_initial_state p \<sigma> \<equiv> (state_rip \<sigma> = asm_entry p) \<and> (\<forall> a b. asm_data p a = Some b \<longrightarrow> state_mem \<sigma> a = b)"

definition asm_step :: "asm_prog \<Rightarrow> state \<Rightarrow> state \<Rightarrow> bool" where
  "asm_step p \<sigma>\<^sub>1 \<sigma>\<^sub>2 \<equiv> \<exists> i. Some i = asm_text p (state_rip \<sigma>\<^sub>1) \<and> (i, \<sigma>\<^sub>1, \<sigma>\<^sub>2) \<in> isa_step_instr"

definition asm_semantics :: "asm_prog \<Rightarrow> trace set" ("\<lbrakk> _ \<rbrakk>\<^sub>a") where
 "\<lbrakk> p \<rbrakk>\<^sub>a \<equiv> { \<tau>. asm_is_initial_state p (snth \<tau> 0) \<and> (\<forall> n. asm_step p (snth \<tau> n) (snth \<tau> (n+1))) }"

end

subsection \<open>Properties Of Assembly Programs\<close>

context isa
begin

definition asm_is_encoding_consistent :: "asm_prog \<Rightarrow> bool" where
  "asm_is_encoding_consistent p \<equiv> \<forall> a b\<^sub>1 b\<^sub>2.
    Some b\<^sub>1 = asm_text_encoding p a \<and> Some b\<^sub>2 = asm_text_encoding p (a+1) \<longrightarrow>
    (\<forall> n < length b\<^sub>1 - 1. b\<^sub>1 ! n+1 = b\<^sub>2 ! n)"

definition asm_is_non_overlapping :: "asm_prog \<Rightarrow> bool" where
  "asm_is_non_overlapping p \<equiv> \<forall> a b.
    Some b = asm_text_encoding p a \<longrightarrow>
    (\<forall> n < length b. asm_text_encoding p (a+n) = None)"

definition asm_is_text_and_data_consistent :: "asm_prog \<Rightarrow> bool" where
  "asm_is_text_and_data_consistent p \<equiv> \<forall> a.
    (\<forall> bs. Some bs = asm_text_encoding p a \<longrightarrow> (\<forall> n < length bs. \<forall> b.  Some b  = asm_data          p (a+n) \<longrightarrow> bs!n = b)) \<and>
    (\<forall> b.  Some b  = asm_data          p a \<longrightarrow> (                 \<forall> bs. Some bs = asm_text_encoding p  a    \<longrightarrow> bs!0 = b))"

definition asm_is_non_ambiguous :: "asm_prog \<Rightarrow> bool" where
  "asm_is_non_ambiguous p \<equiv> \<forall> a.
    (\<forall> bs. Some bs = asm_text_encoding p a \<longrightarrow> (\<forall> n < length bs. asm_data p (a+n) = None)) \<and>
    (\<forall> b.  Some b  = asm_data          p a \<longrightarrow> (                 asm_text p  a    = None))"

end

subsubsection \<open>Facts About The Properties\<close>

context isa
begin

lemma asm_non_overlapping_implies_encoding_consistent:
  assumes "asm_is_non_overlapping p"
  shows   "asm_is_encoding_consistent p"
  by (metis asm_is_encoding_consistent_def asm_is_non_overlapping_def assms less_Suc_eq_0_disj less_iff_Suc_add option.distinct(1) zero_less_diff)

lemma asm_non_ambiguous_implies_text_and_data_consistent:
  assumes "asm_is_non_ambiguous p"
  shows   "asm_is_text_and_data_consistent p"
  using asm_is_non_ambiguous_def asm_is_text_and_data_consistent_def asm_text_encoding_None assms by auto

end

end


(* Title:      N-Omega Binary Iterings
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>N-Omega Binary Iterings\<close>

theory N_Omega_Binary_Iterings

imports N_Omega_Algebras Binary_Iterings_Strict

begin

sublocale extended_binary_itering < left_zero_conway_semiring where circ = "(\<lambda>x . x \<star> 1)"
  apply unfold_locales
  using while_left_unfold apply force
  apply (metis mult_1_right while_one_mult_below while_slide)
  by (simp add: while_one_while while_sumstar_2)

class binary_itering_apx = bounded_binary_itering + n_algebra_apx
begin

lemma C_while_import:
  "C (x \<star> z) = C (C x \<star> z)"
proof -
  have 1: "C x * (x \<star> z) \<le> C x \<star> (C x * z)"
    using C_mult_propagate while_simulate by force
  have "C (x \<star> z) = C z \<squnion> C x * (x \<star> z)"
    by (metis inf_sup_distrib1 n_L_T_meet_mult while_left_unfold)
  also have "... \<le> C x \<star> z"
    using 1 by (metis C_decreasing sup_mono while_right_unfold)
  finally have "C (x \<star> z) \<le> C (C x \<star> z)"
    by simp
  thus ?thesis
    by (metis order.antisym inf.boundedI inf.cobounded1 inf.coboundedI2 inf.sup_monoid.add_commute while_absorb_2 while_increasing)
qed

lemma C_while_preserve:
  "C (x \<star> z) = C (x \<star> C z)"
proof -
  have "C x * (x \<star> z) \<le> C x \<star> (C x * z)"
    using C_mult_propagate while_simulate by auto
  also have "... \<le> x \<star> (x * C z)"
    using C_decreasing n_L_T_meet_mult_propagate while_isotone by blast
  finally have 1: "C x * (x \<star> z) \<le> x \<star> (x * C z)"
    .
  have "C (x \<star> z) = C z \<squnion> C x * (x \<star> z)"
    by (metis inf_sup_distrib1 n_L_T_meet_mult while_left_unfold)
  also have "... \<le> x \<star> C z"
    using 1 by (meson order.trans le_supI while_increasing while_right_plus_below)
  finally have "C (x \<star> z) \<le> C (x \<star> C z)"
    by simp
  thus ?thesis
    by (meson order.antisym inf.boundedI inf.cobounded1 inf.coboundedI2 inf.eq_refl while_isotone)
qed

lemma C_while_import_preserve:
  "C (x \<star> z) = C (C x \<star> C z)"
  using C_while_import C_while_preserve by auto

lemma while_L_L:
  "L \<star> L = L"
  by (metis n_L_top_L while_mult_star_exchange while_right_top)

lemma while_L_below_sup:
  "L \<star> x \<le> x \<squnion> L"
  by (metis while_left_unfold sup_right_isotone n_L_below_L)

lemma while_L_split:
  "x \<star> L \<le> (x \<star> y) \<squnion> L"
proof -
  have "x \<star> L \<le> (x \<star> bot) \<squnion> L"
    by (metis sup_commute sup_bot_left mult_1_right n_L_split_L while_right_unfold while_simulate_left_plus while_zero)
  thus ?thesis
    by (metis sup_commute sup_right_isotone order_trans while_right_isotone bot_least)
qed

lemma while_n_while_top_split:
  "x \<star> (n(x \<star> y) * top) \<le> (x \<star> bot) \<squnion> n(x \<star> y) * top"
proof -
  have "x * n(x \<star> y) * top \<le> x * bot \<squnion> n(x * (x \<star> y)) * top"
    by (simp add: n_n_top_split_n_top)
  also have "... \<le> n(x \<star> y) * top \<squnion> x * bot"
    by (metis sup_commute sup_right_isotone mult_left_isotone n_isotone while_left_plus_below)
  finally have "x \<star> (n(x \<star> y) * top) \<le> n(x \<star> y) * top \<squnion> (x \<star> (x * bot))"
    by (metis mult_assoc mult_1_right while_simulate_left mult_left_zero while_left_top)
  also have "... \<le> (x \<star> bot) \<squnion> n(x \<star> y) * top"
    using sup_left_isotone while_right_plus_below by auto
  finally show ?thesis
    .
qed

lemma circ_apx_right_isotone:
  assumes "x \<sqsubseteq> y"
    shows "z \<star> x \<sqsubseteq> z \<star> y"
proof -
  have 1: "x \<le> y \<squnion> L \<and> C y \<le> x \<squnion> n(x) * top"
    using assms apx_def by auto
  hence "z \<star> x \<le> (z \<star> y) \<squnion> (z \<star> L)"
    by (metis while_left_dist_sup while_right_isotone)
  hence 2: "z \<star> x \<le> (z \<star> y) \<squnion> L"
    by (meson le_supI order_lesseq_imp sup.cobounded1 while_L_split)
  have "z \<star> (n(z \<star> x) * top) \<le> (z \<star> bot) \<squnion> n(z \<star> x) * top"
    by (simp add: while_n_while_top_split)
  also have "... \<le> (z \<star> x) \<squnion> n(z \<star> x) * top"
    using sup_left_isotone while_right_isotone by force
  finally have 3: "z \<star> (n(x) * top) \<le> (z \<star> x) \<squnion> n(z \<star> x) * top"
    by (metis mult_left_isotone n_isotone order_trans while_increasing while_right_isotone)
  have "C (z \<star> y) \<le> z \<star> C y"
    by (metis C_while_preserve inf.cobounded2)
  also have "... \<le> (z \<star> x) \<squnion> (z \<star> (n(x) * top))"
    using 1 by (metis while_left_dist_sup while_right_isotone)
  also have "... \<le> (z \<star> x) \<squnion> n(z \<star> x) * top"
    using 3 by simp
  finally show ?thesis
    using 2 apx_def by auto
qed

end

class extended_binary_itering_apx = binary_itering_apx + bounded_extended_binary_itering +
  assumes n_below_while_zero: "n(x) \<le> n(x \<star> bot)"
begin

lemma circ_apx_right_isotone:
  assumes "x \<sqsubseteq> y"
    shows "x \<star> z \<sqsubseteq> y \<star> z"
proof -
  have 1: "x \<le> y \<squnion> L \<and> C y \<le> x \<squnion> n(x) * top"
    using assms apx_def by auto
  hence "x \<star> z \<le> ((y \<star> 1) * L) \<star> (y \<star> z)"
    by (metis while_left_isotone while_sumstar_3)
  also have "... \<le> (y \<star> z) \<squnion> (y \<star> 1) * L"
    by (metis while_productstar sup_right_isotone mult_right_isotone n_L_below_L while_slide)
  also have "... \<le> (y \<star> z) \<squnion> L"
    by (meson order.trans le_supI sup.cobounded1 while_L_split while_one_mult_below)
  finally have 2: "x \<star> z \<le> (y \<star> z) \<squnion> L"
    .
  have "C (y \<star> z) \<le> C y \<star> z"
    by (metis C_while_import inf.sup_right_divisibility)
  also have "... \<le> ((x \<star> 1) * n(x) * top) \<star> (x \<star> z)"
    using 1 by (metis while_left_isotone mult_assoc while_sumstar_3)
  also have "... \<le> (x \<star> z) \<squnion> (x \<star> 1) * n(x) * top"
    by (metis while_productstar sup_left_top sup_right_isotone mult_assoc mult_left_sub_dist_sup_right while_slide)
  also have "... \<le> (x \<star> z) \<squnion> (x \<star> (n(x) * top))"
    using sup_right_isotone while_one_mult_below mult_assoc by auto
  also have "... \<le> (x \<star> z) \<squnion> (x \<star> (n(x \<star> z) * top))"
    by (metis n_below_while_zero bot_least while_right_isotone n_isotone mult_left_isotone sup_right_isotone order_trans)
  also have "... \<le> (x \<star> z) \<squnion> n(x \<star> z) * top"
    by (metis sup_assoc sup_right_isotone while_n_while_top_split sup_bot_right while_left_dist_sup)
  finally show ?thesis
    using 2 apx_def by auto
qed

proposition while_top: "top \<star> x = L \<squnion> top * x" oops
proposition while_one_top: "1 \<star> x = L \<squnion> x" oops
proposition while_unfold_below_1: "x = y * x \<Longrightarrow> x \<le> y \<star> 1" oops

proposition while_square_1: "x \<star> 1 = (x * x) \<star> (x \<squnion> 1)" oops
proposition while_absorb_below_one: "y * x \<le> x \<Longrightarrow> y \<star> x \<le> 1 \<star> x" oops
proposition while_mult_L: "(x * L) \<star> z = z \<squnion> x * L" oops
proposition tarski_top_omega_below_2: "x * L \<le> (x * L) \<star> bot" oops
proposition tarski_top_omega_2: "x * L = (x * L) \<star> bot" oops
proposition while_separate_right_plus: "y * x \<le> x * (x \<star> (1 \<squnion> y)) \<squnion> 1 \<Longrightarrow> y \<star> (x \<star> z) \<le> x \<star> (y \<star> z)" oops
proposition "y \<star> (x \<star> 1) \<le> x \<star> (y \<star> 1) \<Longrightarrow> (x \<squnion> y) \<star> 1 = x \<star> (y \<star> 1)" oops
proposition "y * x \<le> (1 \<squnion> x) * (y \<star> 1) \<Longrightarrow> (x \<squnion> y) \<star> 1 = x \<star> (y \<star> 1)" oops

end

class n_omega_algebra_binary = n_omega_algebra + while +
  assumes while_def: "x \<star> y = n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * y"
begin

lemma while_omega_inf_L_star:
  "x \<star> y = (x\<^sup>\<omega> \<sqinter> L) \<squnion> x\<^sup>\<star> * y"
  by (metis loop_semantics_kappa_mu_nu loop_semantics_kappa_mu_nu_2 while_def)

lemma while_one_mult_while_below_1:
  "(y \<star> 1) * (y \<star> v) \<le> y \<star> v"
proof -
  have "(y \<star> 1) * (y \<star> v) \<le> y \<star> (y \<star> v)"
    by (smt sup_left_isotone mult_assoc mult_right_dist_sup mult_right_isotone n_L_below_L while_def mult_left_one)
  also have "... = n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * y\<^sup>\<star> * v"
    by (simp add: mult_left_dist_sup sup_assoc while_def mult_assoc)
  also have "... = n(y\<^sup>\<omega>) * L \<squnion> (y\<^sup>\<star> * y\<^sup>\<star> * bot \<squnion> y\<^sup>\<star> * n(y\<^sup>\<omega>) * L) \<squnion> y\<^sup>\<star> * y\<^sup>\<star> * v"
    by (metis mult_left_dist_sup star.circ_transitive_equal sup_bot_left mult_assoc)
  also have "... = n(y\<^sup>\<omega>) * L \<squnion> (y\<^sup>\<star> * y\<^sup>\<star> * bot \<squnion> n(y\<^sup>\<star> * y\<^sup>\<omega>) * L) \<squnion> y\<^sup>\<star> * y\<^sup>\<star> * v"
    by (simp add: n_mult_omega_L_star_zero)
  also have "... = n(y\<^sup>\<omega>) * L \<squnion> n(y\<^sup>\<star> * y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * y\<^sup>\<star> * v"
    by (smt (z3) mult_left_dist_sup sup.left_commute sup_bot_left sup_commute)
  finally show ?thesis
    by (simp add: star.circ_transitive_equal star_mult_omega while_def)
qed

lemma star_below_while:
  "x\<^sup>\<star> * y \<le> x \<star> y"
  by (simp add: while_def)

subclass bounded_binary_itering
proof unfold_locales
  fix x y z
  have "z \<squnion> x * ((y * x) \<star> (y * z)) = x * (y * x)\<^sup>\<star> * y * z \<squnion> x * n((y * x)\<^sup>\<omega>) * L \<squnion> z"
    using mult_left_dist_sup sup_commute while_def mult_assoc by auto
  also have "... = x * (y * x)\<^sup>\<star> * y * z \<squnion> n(x * (y * x)\<^sup>\<omega>) * L \<squnion> z"
    by (metis mult_assoc mult_right_isotone bot_least n_mult_omega_L_star_zero sup_relative_same_increasing)
  also have "... = (x * y)\<^sup>\<star> * z \<squnion> n(x * (y * x)\<^sup>\<omega>) * L"
    by (smt sup_assoc sup_commute mult_assoc star.circ_loop_fixpoint star_slide)
  also have "... = (x * y) \<star> z"
    by (simp add: omega_slide sup_monoid.add_commute while_def)
  finally show "(x * y) \<star> z = z \<squnion> x * ((y * x) \<star> (y * z))"
    by simp
next
  fix x y z
  have "(x \<star> y) \<star> (x \<star> z) = n((n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<squnion> (n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * y)\<^sup>\<star> * (x \<star> z)"
    by (simp add: while_def)
  also have "... = n((x\<^sup>\<star> * y)\<^sup>\<omega> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * n(x\<^sup>\<omega>) * L) * L \<squnion> ((x\<^sup>\<star> * y)\<^sup>\<star> \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * n(x\<^sup>\<omega>) * L) * (x \<star> z)"
    using mult_L_sup_omega mult_L_sup_star by force
  also have "... = n((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<squnion> n((x\<^sup>\<star> * y)\<^sup>\<star> * n(x\<^sup>\<omega>) * L) * L \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * (x \<star> z) \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * n(x\<^sup>\<omega>) * L * (x \<star> z)"
    by (simp add: mult_right_dist_sup n_dist_omega_star sup_assoc mult_assoc)
  also have "... = n((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<squnion> n((x\<^sup>\<star> * y)\<^sup>\<star> * n(x\<^sup>\<omega>) * L) * L \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * bot \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * (x \<star> z) \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * n(x\<^sup>\<omega>) * L * (x \<star> z)"
    by (smt sup_assoc sup_bot_left mult_left_dist_sup)
  also have "... = n((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<squnion> ((x\<^sup>\<star> * y)\<^sup>\<star> * n(x\<^sup>\<omega>) * L * (x \<star> z) \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * n(x\<^sup>\<omega>) * L \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * (x \<star> z))"
    by (smt n_n_L_split_n_n_L_L sup_commute sup_assoc)
  also have "... = n((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<squnion> ((x\<^sup>\<star> * y)\<^sup>\<star> * n(x\<^sup>\<omega>) * L \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * (x \<star> z))"
    by (smt mult_L_omega omega_sub_vector le_iff_sup)
  also have "... = n((x\<^sup>\<star> * y)\<^sup>\<omega>) * L \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * (x \<star> z)"
    using mult_left_sub_dist_sup_left sup_absorb2 while_def mult_assoc by auto
  also have "... = (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star> * z \<squnion> (x\<^sup>\<star> * y)\<^sup>\<star> * n(x\<^sup>\<omega>) * L \<squnion> n((x\<^sup>\<star> * y)\<^sup>\<omega>) * L"
    by (simp add: mult_left_dist_sup sup_commute while_def mult_assoc)
  also have "... = (x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<star> * z \<squnion> n((x\<^sup>\<star> * y)\<^sup>\<star> * x\<^sup>\<omega>) * L \<squnion> n((x\<^sup>\<star> * y)\<^sup>\<omega>) * L"
    by (metis sup_bot_right mult_left_dist_sup sup_assoc n_mult_omega_L_star_zero)
  also have "... = (x \<squnion> y) \<star> z"
    using n_dist_omega_star omega_decompose semiring.combine_common_factor star.circ_sup_9 sup_commute while_def by force
  finally show "(x \<squnion> y) \<star> z = (x \<star> y) \<star> (x \<star> z)"
    by simp
next
  fix x y z
  show "x \<star> (y \<squnion> z) = (x \<star> y) \<squnion> (x \<star> z)"
    using semiring.distrib_left sup_assoc sup_commute while_def by force
next
  fix x y z
  show "(x \<star> y) * z \<le> x \<star> (y * z)"
    by (smt sup_left_isotone mult_assoc mult_right_dist_sup mult_right_isotone n_L_below_L while_def)
next
  fix v w x y z
  show "x * z \<le> z * (y \<star> 1) \<squnion> w \<longrightarrow> x \<star> (z * v) \<le> z * (y \<star> v) \<squnion> (x \<star> (w * (y \<star> v)))"
  proof
    assume 1: "x * z \<le> z * (y \<star> 1) \<squnion> w"
    have "z * v \<squnion> x * (z * (y \<star> v) \<squnion> x\<^sup>\<star> * (w * (y \<star> v))) \<le> z * v \<squnion> x * z * (y \<star> v) \<squnion> x\<^sup>\<star> * (w * (y \<star> v))"
      by (metis sup_assoc sup_right_isotone mult_assoc mult_left_dist_sup mult_left_isotone star.left_plus_below_circ)
    also have "... \<le> z * v \<squnion> z * (y \<star> 1) * (y \<star> v) \<squnion> w * (y \<star> v) \<squnion> x\<^sup>\<star> * (w * (y \<star> v))"
      using 1 by (metis sup_assoc sup_left_isotone sup_right_isotone mult_left_isotone mult_right_dist_sup)
    also have "... \<le> z * v \<squnion> z * (y \<star> v) \<squnion> x\<^sup>\<star> * (w * (y \<star> v))"
      by (smt (verit, ccfv_threshold) sup_ge2 le_iff_sup mult_assoc mult_left_dist_sup star.circ_loop_fixpoint while_one_mult_while_below_1 le_supE le_supI)
    also have "... = z * (y \<star> v) \<squnion> x\<^sup>\<star> * (w * (y \<star> v))"
      by (metis le_iff_sup le_supE mult_right_isotone star.circ_loop_fixpoint star_below_while)
    finally have "x\<^sup>\<star> * z * v \<le> z * (y \<star> v) \<squnion> x\<^sup>\<star> * (w * (y \<star> v))"
      using star_left_induct mult_assoc by auto
    thus "x \<star> (z * v) \<le> z * (y \<star> v) \<squnion> (x \<star> (w * (y \<star> v)))"
      by (smt sup_assoc sup_commute sup_right_isotone mult_assoc while_def)
  qed
next
  fix v w x y z
  show "z * x \<le> y * (y \<star> z) \<squnion> w \<longrightarrow> z * (x \<star> v) \<le> y \<star> (z * v \<squnion> w * (x \<star> v))"
  proof
    assume "z * x \<le> y * (y \<star> z) \<squnion> w"
    hence 1: "z * x \<le> y * y\<^sup>\<star> * z \<squnion> (y * n(y\<^sup>\<omega>) * L \<squnion> w)"
      by (simp add: mult_left_dist_sup sup.left_commute sup_commute while_def mult_assoc)
    hence "z * x\<^sup>\<star> \<le> y\<^sup>\<star> * (z \<squnion> (y * n(y\<^sup>\<omega>) * L \<squnion> w) * x\<^sup>\<star>)"
      by (simp add: star_circ_simulate_right_plus)
    also have "... = y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * y * n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
      by (simp add: L_mult_star semiring.distrib_left semiring.distrib_right sup_left_commute sup_monoid.add_commute mult_assoc)
    also have "... = y\<^sup>\<star> * z \<squnion> n(y\<^sup>\<star> * y * y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
      by (metis sup_relative_same_increasing mult_isotone n_mult_omega_L_star_zero star.left_plus_below_circ star.right_plus_circ bot_least)
    also have "... = n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * z \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star>"
      using omega_unfold star_mult_omega sup_commute mult_assoc by force
    finally have "z * x\<^sup>\<star> * v \<le> n(y\<^sup>\<omega>) * L * v \<squnion> y\<^sup>\<star> * z * v \<squnion> y\<^sup>\<star> * w * x\<^sup>\<star> * v"
      by (smt le_iff_sup mult_right_dist_sup)
    also have "... \<le> n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * (z * v \<squnion> w * x\<^sup>\<star> * v)"
      by (metis n_L_below_L mult_assoc mult_right_isotone sup_left_isotone mult_left_dist_sup sup_assoc)
    also have "... \<le> n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * (z * v \<squnion> w * (x \<star> v))"
      using mult_right_isotone semiring.add_left_mono mult_assoc star_below_while by auto
    finally have 2: "z * x\<^sup>\<star> * v \<le> y \<star> (z * v \<squnion> w * (x \<star> v))"
      by (simp add: while_def)
    have 3: "y\<^sup>\<star> * y * y\<^sup>\<star> * bot \<le> y\<^sup>\<star> * w * x\<^sup>\<omega>"
      by (metis sup_commute sup_bot_left mult_assoc mult_left_sub_dist_sup_left star.circ_loop_fixpoint star.circ_transitive_equal)
    have "z * x\<^sup>\<omega> \<le> y * y\<^sup>\<star> * z * x\<^sup>\<omega> \<squnion> (y * n(y\<^sup>\<omega>) * L \<squnion> w) * x\<^sup>\<omega>"
      using 1 by (metis mult_assoc mult_left_isotone mult_right_dist_sup omega_unfold)
    hence "z * x\<^sup>\<omega> \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * y * n(y\<^sup>\<omega>) * L * x\<^sup>\<omega> \<squnion> y\<^sup>\<star> * w * x\<^sup>\<omega>"
      by (smt sup_assoc sup_commute left_plus_omega mult_assoc mult_left_dist_sup mult_right_dist_sup omega_induct star.left_plus_circ)
    also have "... \<le> y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * y * n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * x\<^sup>\<omega>"
      by (metis sup_left_isotone sup_right_isotone mult_assoc mult_right_isotone n_L_below_L)
    also have "... = y\<^sup>\<omega> \<squnion> n(y\<^sup>\<star> * y * y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * w * x\<^sup>\<omega>"
      using 3 by (smt sup_assoc sup_commute sup_relative_same_increasing n_mult_omega_L_star_zero)
    also have "... = y\<^sup>\<omega> \<squnion> y\<^sup>\<star> * w * x\<^sup>\<omega>"
      by (metis mult_assoc omega_unfold star_mult_omega sup_commute le_iff_sup n_L_decreasing)
    finally have "n(z * x\<^sup>\<omega>) * L \<le> n(y\<^sup>\<omega>) * L \<squnion> n(y\<^sup>\<star> * w * x\<^sup>\<omega>) * L"
      by (metis mult_assoc mult_left_isotone mult_right_dist_sup n_dist_omega_star n_isotone)
    also have "... \<le> n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * (w * (n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * bot))"
      by (smt sup_commute sup_right_isotone mult_assoc mult_left_dist_sup n_mult_omega_L_below_zero)
    also have "... \<le> n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * (w * (n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * v))"
      by (metis sup_right_isotone mult_right_isotone bot_least)
    also have "... \<le> n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * (z * v \<squnion> w * (n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star> * v))"
      using mult_left_sub_dist_sup_right sup_right_isotone by auto
    finally have 4: "n(z * x\<^sup>\<omega>) * L \<le> y \<star> (z * v \<squnion> w * (x \<star> v))"
      using while_def by auto
    have "z * (x \<star> v) = z * n(x\<^sup>\<omega>) * L \<squnion> z * x\<^sup>\<star> * v"
      by (simp add: mult_left_dist_sup while_def mult_assoc)
    also have "... = n(z * x\<^sup>\<omega>) * L \<squnion> z * x\<^sup>\<star> * v"
      by (metis sup_commute sup_relative_same_increasing mult_right_isotone n_mult_omega_L_star_zero bot_least)
    finally show "z * (x \<star> v) \<le> y \<star> (z * v \<squnion> w * (x \<star> v))"
      using 2 4 by simp
  qed
qed

lemma while_top:
  "top \<star> x = L \<squnion> top * x"
  by (metis n_top_L star.circ_top star_omega_top while_def)

lemma while_one_top:
  "1 \<star> x = L \<squnion> x"
  by (smt mult_left_one n_top_L omega_one star_one while_def)

lemma while_finite_associative:
  "x\<^sup>\<omega> = bot \<Longrightarrow> (x \<star> y) * z = x \<star> (y * z)"
  by (metis sup_bot_left mult_assoc n_zero_L_zero while_def)

lemma while_while_one:
  "y \<star> (x \<star> 1) = n(y\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * n(x\<^sup>\<omega>) * L \<squnion> y\<^sup>\<star> * x\<^sup>\<star>"
  by (simp add: mult_left_dist_sup sup_assoc while_def mult_assoc)

text \<open>AACP Theorem 8.17\<close>

subclass bounded_extended_binary_itering
proof unfold_locales
  fix w x y z
  have "w * (x \<star> y * z) = n(w * n(x\<^sup>\<omega>) * L) * L \<squnion> w * x\<^sup>\<star> * y * z"
    by (smt sup_assoc sup_commute sup_bot_left mult_assoc mult_left_dist_sup n_n_L_split_n_n_L_L while_def)
  also have "... \<le> n((w * n(x\<^sup>\<omega>) * L)\<^sup>\<omega>) * L \<squnion> w * x\<^sup>\<star> * y * z"
    by (simp add: mult_L_omega)
  also have "... \<le> n((w * (x \<star> y))\<^sup>\<omega>) * L \<squnion> w * x\<^sup>\<star> * y * z"
    by (smt sup_left_isotone sup_ge1 mult_assoc mult_left_isotone mult_right_isotone n_isotone omega_isotone while_def)
  also have "... \<le> n((w * (x \<star> y))\<^sup>\<omega>) * L \<squnion> w * (x \<star> y) * z"
    by (metis star_below_while mult_assoc mult_left_isotone mult_right_isotone sup_right_isotone)
  also have "... \<le> n((w * (x \<star> y))\<^sup>\<omega>) * L \<squnion> (w * (x \<star> y))\<^sup>\<star> * (w * (x \<star> y) * z)"
    using sup.boundedI sup.cobounded1 while_def while_increasing by auto
  finally show "w * (x \<star> y * z) \<le> (w * (x \<star> y)) \<star> (w * (x \<star> y) * z)"
    using while_def by auto
qed

subclass extended_binary_itering_apx
  apply unfold_locales
  by (metis n_below_n_omega n_left_upper_bound n_n_L order_trans while_def)

lemma while_simulate_4_plus:
  assumes "y * x \<le> x * (x \<star> (1 \<squnion> y))"
    shows "y * x * x\<^sup>\<star> \<le> x * (x \<star> (1 \<squnion> y))"
proof -
  have "x * (x \<star> (1 \<squnion> y)) = x * n(x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> * (1 \<squnion> y)"
    by (simp add: mult_left_dist_sup while_def mult_assoc)
  also have "... = n(x * x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> * (1 \<squnion> y)"
    by (smt n_mult_omega_L_star_zero sup_relative_same_increasing sup_commute sup_bot_right mult_left_sub_dist_sup_right)
  finally have 1: "x * (x \<star> (1 \<squnion> y)) = n(x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y"
    using mult_left_dist_sup omega_unfold sup_assoc by force
  hence "x * x\<^sup>\<star> * y * x \<le> x * x\<^sup>\<star> * n(x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> * x\<^sup>\<star> * x \<squnion> x * x\<^sup>\<star> * x * x\<^sup>\<star> * y"
    by (metis assms mult_assoc mult_right_isotone mult_left_dist_sup star_plus)
  also have "... = n(x * x\<^sup>\<star> * x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> * x\<^sup>\<star> * x \<squnion> x * x\<^sup>\<star> * x * x\<^sup>\<star> * y"
    by (smt (z3) sup_commute n_mult_omega_L_star omega_unfold semiring.distrib_left star_plus mult_assoc)
  also have "... = n(x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> * x \<squnion> x * x * x\<^sup>\<star> * y"
    using omega_unfold star.circ_plus_same star.circ_transitive_equal star_mult_omega mult_assoc by auto
  also have "... \<le> n(x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y"
    by (smt sup_assoc sup_ge2 le_iff_sup mult_assoc mult_right_dist_sup star.circ_increasing star.circ_plus_same star.circ_transitive_equal)
  finally have 2: "x * x\<^sup>\<star> * y * x \<le> n(x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y"
    .
  have "(n(x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y) * x \<le> n(x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> * x \<squnion> x * x\<^sup>\<star> * y * x"
    by (metis mult_right_dist_sup n_L_below_L mult_assoc mult_right_isotone sup_left_isotone)
  also have "... \<le> n(x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y * x"
    by (smt sup_commute sup_left_isotone mult_assoc mult_right_isotone star.left_plus_below_circ star_plus)
  also have "... \<le> n(x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y"
    using 2 by simp
  finally show ?thesis
    using 1 assms star_right_induct by force
qed

lemma while_simulate_4_omega:
  assumes "y * x \<le> x * (x \<star> (1 \<squnion> y))"
    shows "y * x\<^sup>\<omega> \<le> x\<^sup>\<omega>"
proof -
  have "x * (x \<star> (1 \<squnion> y)) = x * n(x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> * (1 \<squnion> y)"
    using mult_left_dist_sup while_def mult_assoc by auto
  also have "... = n(x * x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> * (1 \<squnion> y)"
    by (smt (z3) mult_1_right mult_left_sub_dist_sup_left n_mult_omega_L_star sup_commute sup_relative_same_increasing)
  finally have "x * (x \<star> (1 \<squnion> y)) = n(x\<^sup>\<omega>) * L \<squnion> x * x\<^sup>\<star> \<squnion> x * x\<^sup>\<star> * y"
    using mult_left_dist_sup omega_unfold sup_assoc by force
  hence "y * x\<^sup>\<omega> \<le> n(x\<^sup>\<omega>) * L * x\<^sup>\<omega> \<squnion> x * x\<^sup>\<star> * x\<^sup>\<omega> \<squnion> x * x\<^sup>\<star> * y * x\<^sup>\<omega>"
    by (smt assms le_iff_sup mult_assoc mult_right_dist_sup omega_unfold)
  also have "... \<le> x * x\<^sup>\<star> * (y * x\<^sup>\<omega>) \<squnion> x\<^sup>\<omega>"
    by (metis sup_left_isotone mult_L_omega omega_sub_vector mult_assoc omega_unfold star_mult_omega n_L_decreasing le_iff_sup sup_commute)
  finally have "y * x\<^sup>\<omega> \<le> (x * x\<^sup>\<star>)\<^sup>\<omega> \<squnion> (x * x\<^sup>\<star>)\<^sup>\<star> * x\<^sup>\<omega>"
    by (simp add: omega_induct sup_monoid.add_commute)
  thus ?thesis
    by (metis sup_idem left_plus_omega star_mult_omega)
qed

lemma while_square_1:
  "x \<star> 1 = (x * x) \<star> (x \<squnion> 1)"
  by (metis mult_1_right omega_square star_square_2 while_def)

lemma while_absorb_below_one:
  "y * x \<le> x \<Longrightarrow> y \<star> x \<le> 1 \<star> x"
  by (metis star_left_induct_mult sup_mono n_galois n_sub_nL while_def while_one_top)

lemma while_mult_L:
  "(x * L) \<star> z = z \<squnion> x * L"
  by (metis sup_bot_right mult_left_zero while_denest_5 while_one_top while_productstar while_sumstar)

lemma tarski_top_omega_below_2:
  "x * L \<le> (x * L) \<star> bot"
  by (simp add: while_mult_L)

lemma tarski_top_omega_2:
  "x * L = (x * L) \<star> bot"
  by (simp add: while_mult_L)

proposition while_sub_mult_one: "x * (1 \<star> y) \<le> 1 \<star> x" nitpick [expect=genuine,card=3] oops
proposition while_unfold_below: "x = z \<squnion> y * x \<longrightarrow> x \<le> y \<star> z" nitpick [expect=genuine,card=2] oops
proposition while_loop_is_greatest_postfixpoint: "is_greatest_postfixpoint (\<lambda>x . y * x \<squnion> z) (y \<star> z)" nitpick [expect=genuine,card=2] oops
proposition while_loop_is_greatest_fixpoint: "is_greatest_fixpoint (\<lambda>x . y * x \<squnion> z) (y \<star> z)" nitpick [expect=genuine,card=2] oops
proposition while_denest_3: "(x \<star> w) \<star> x\<^sup>\<omega> = (x \<star> w)\<^sup>\<omega>" nitpick [expect=genuine,card=2] oops
proposition while_mult_top: "(x * top) \<star> z = z \<squnion> x * top" nitpick [expect=genuine,card=2] oops
proposition tarski_below_top_omega: "x \<le> (x * L)\<^sup>\<omega>" nitpick [expect=genuine,card=2] oops
proposition tarski_mult_omega_omega: "(x * y\<^sup>\<omega>)\<^sup>\<omega> = x * y\<^sup>\<omega>" nitpick [expect=genuine,card=3] oops
proposition tarski_below_top_omega_2: "x \<le> (x * L) \<star> bot" nitpick [expect=genuine,card=2] oops
proposition "1 = (x * bot) \<star> 1" nitpick [expect=genuine,card=3] oops
proposition tarski: "x = bot \<or> top * x * top = top" nitpick [expect=genuine,card=3] oops
proposition "(x \<squnion> y) \<star> z = ((x \<star> 1) * y) \<star> ((x \<star> 1) * z)" nitpick [expect=genuine,card=2] oops
proposition while_top_2: "top \<star> z = top * z" nitpick [expect=genuine,card=2] oops
proposition while_mult_top_2: "(x * top) \<star> z = z \<squnion> x * top * z" nitpick [expect=genuine,card=2] oops
proposition while_one_mult: "(x \<star> 1) * x = x \<star> x" nitpick [expect=genuine,card=4] oops
proposition "(x \<star> 1) * y = x \<star> y" nitpick [expect=genuine,card=2] oops
proposition while_associative: "(x \<star> y) * z = x \<star> (y * z)" nitpick [expect=genuine,card=2] oops
proposition while_back_loop_is_fixpoint: "is_fixpoint (\<lambda>x . x * y \<squnion> z) (z * (y \<star> 1))" nitpick [expect=genuine,card=4] oops
proposition "1 \<squnion> x * bot = x \<star> 1" nitpick [expect=genuine,card=3] oops
proposition "x = x * (x \<star> 1)" nitpick [expect=genuine,card=3] oops
proposition "x * (x \<star> 1) = x \<star> 1" nitpick [expect=genuine,card=2] oops
proposition "x \<star> 1 = x \<star> (1 \<star> 1)" nitpick [expect=genuine,card=3] oops
proposition "(x \<squnion> y) \<star> 1 = (x \<star> (y \<star> 1)) \<star> 1" nitpick [expect=genuine,card=3] oops
proposition "z \<squnion> y * x = x \<Longrightarrow> y \<star> z \<le> x" nitpick [expect=genuine,card=2] oops
proposition "y * x = x \<Longrightarrow> y \<star> x \<le> x" nitpick [expect=genuine,card=2] oops
proposition "z \<squnion> x * y = x \<Longrightarrow> z * (y \<star> 1) \<le> x" nitpick [expect=genuine,card=3] oops
proposition "x * y = x \<Longrightarrow> x * (y \<star> 1) \<le> x" nitpick [expect=genuine,card=3] oops
proposition "x * z = z * y \<Longrightarrow> x \<star> z \<le> z * (y \<star> 1)" nitpick [expect=genuine,card=2] oops

proposition while_unfold_below_1: "x = y * x \<Longrightarrow> x \<le> y \<star> 1" nitpick [expect=genuine,card=3] oops
proposition "x\<^sup>\<omega> \<le> x\<^sup>\<omega> * x\<^sup>\<omega>" oops
proposition tarski_omega_idempotent: "x\<^sup>\<omega>\<^sup>\<omega> = x\<^sup>\<omega>" oops

end

class n_omega_algebra_binary_strict = n_omega_algebra_binary + circ +
  assumes L_left_zero: "L * x = L"
  assumes circ_def: "x\<^sup>\<circ> = n(x\<^sup>\<omega>) * L \<squnion> x\<^sup>\<star>"
begin

subclass strict_binary_itering
  apply unfold_locales
  apply (metis while_def mult_assoc L_left_zero mult_right_dist_sup)
  by (metis circ_def while_def mult_1_right)

end

end


(* Author: Simon Wimmer *)
section \<open>JSON Parsing\<close>
theory JSON_Parsing
  imports Lexer
begin

definition [consuming]:
  "brace_open \<equiv> lx_ws *-- exactly ''{''"

definition [consuming]:
 "brace_close \<equiv> lx_ws *-- exactly ''}''"

definition [consuming]:
  "bracket_open \<equiv> lx_ws *-- exactly ''[''"

definition [consuming]:
  "bracket_close \<equiv> lx_ws *-- exactly '']''"

definition [consuming]:
  "colon \<equiv> lx_ws *-- exactly '':''"

definition [consuming]:
  "comma \<equiv> lx_ws *-- exactly '',''"

definition json_character :: "(char,char) parser" where [consuming]:
  \<comment>\<open>This is both, too permissive and too strict compared to JSON\<close>
  "json_character \<equiv> do {
    x\<leftarrow>get;
    if x \<notin> set [CHR ''\"'', CHR 0x92, CHR ''\<newline>'']
    then return x
    else err_expecting (shows_string ''JSON string character'') }"

definition [consuming]:
  "json_string = exactly ''\"'' *-- repeat json_character --* exactly ''\"''"
  \<comment>\<open>Less permissive than JSON strings\<close>

definition [consuming]:
  "identifier = exactly ''\"'' *-- repeat1 json_character --* exactly ''\"''"

fun nats_to_nat :: "nat \<Rightarrow> nat list \<Rightarrow> nat" where
  "nats_to_nat x [] = x" |
  "nats_to_nat x (n # ns) = nats_to_nat (10 * x + n) ns"

(* definition [consuming]:
  "lx_rat_fract \<equiv> repeat1 lx_digit'
    with (\<lambda>ns. Fract (int (nats_to_nat 0 ns)) (int (10 ^ length ns)))"

definition lx_rat[consuming]:
  "lx_rat \<equiv> lx_int -- exactly ''.'' *-- lx_rat_fract
    with (\<lambda> (a, b). if a \<ge> 0 then of_int a + b else of_int a - b)" *)

datatype fract = Rat bool int int

definition lx_rat[consuming]:
  "lx_rat \<equiv> lx_int -- exactly ''.'' *-- (repeat1 lx_digit' with int o nats_to_nat 0)
    with (\<lambda> (a, b). if a \<ge> 0 then Rat True a b else Rat False a b)"

definition
  "parse_list a \<equiv> chainL1 (a with (\<lambda>a. [a])) (do {comma; return (@)})"

abbreviation
  "parse_list' a \<equiv> parse_list a \<parallel> lx_ws with (\<lambda>_. [])"

lemma parse_list_cong[fundef_cong]:
  assumes "\<And>l2. ll_fuel l2 \<le> ll_fuel l' \<Longrightarrow> A l2 = A' l2"
  assumes "l=l'"
  shows "parse_list A l = parse_list A' l'"
  unfolding parse_list_def chainL1_def
  apply (intro bind_cong repeat_cong assms order_refl)
  by auto

datatype JSON =
  Object "(string \<times> JSON) list"
| Array "JSON list"
| String string \<comment>\<open>An Isabelle string rather than a JSON string\<close>
| Int int \<comment>\<open>The number type is split into natural Isabelle/HOL types\<close>
| Nat nat
| Rat fract
| Boolean bool \<comment>\<open>True and False are contracted to one constructor\<close>
| Null

definition [consuming]:
  "atom \<equiv> lx_ws *-- (
     json_string       with String
   \<parallel> lx_rat            with JSON.Rat
   \<parallel> lx_nat            with Nat
   \<parallel> lx_int            with JSON.Int
   \<parallel> exactly ''true''  with (\<lambda>_. Boolean True)
   \<parallel> exactly ''false'' with (\<lambda>_. Boolean False)
   \<parallel> exactly ''null''  with (\<lambda>_. Null)
)"

fun json and dict and seq where
  "json ::= atom \<parallel> seq \<parallel> dict" |
  "dict ::=
    brace_open *--
      parse_list' (lx_ws *-- identifier -- colon *-- json)
    --* brace_close with Object" |
  "seq  ::=
    bracket_open *--
      parse_list' json
    --* bracket_close with Array"

paragraph \<open>Test Cases\<close>

definition test where "test \<equiv> STR
''
{
 \"a\": [\"b\", {\"a\":\"a\",\"b\":[\"b\" ,\"d\"]}] ,

 \"c\" : \"c\",

 \"ab\" : 1,
 \"abcd1\" : -11,

 \"abc\" : 11.1,
\"_abc-\" : true,
\"ab_c\" : false,
\"a-bc\":null
}''
"

value [code]
  "parse_all lx_ws json test"

definition test2 where "test2 \<equiv>
 STR ''{
    \"info\": \"Derived from the Uppaal benchmarks found at https://www.it.uu.se/research/group/darts/uppaal/benchmarks/\",
    \"automata\": [
        {
            \"name\": \"ST2\",
            \"initial\": 9,
            \"nodes\": [
                {
                    \"id\": 14,
                    \"name\": \"y_idle\",
                    \"x\": 458.2894592285156,
                    \"y\": 442.4790954589844,
                    \"invariant\": \"\"
                }
            ],
            \"edges\": [
                {
                    \"source\": 9,
                    \"target\": 12,
                    \"guard\": \"\",
                    \"label\": \"tt1?\",
                    \"update\": \"y2 := 0, x2 := 0\"
                }
            ]
        }
    ],
    \"clocks\": \"x0, x1, y1, z1, x2, y2, z2\",
    \"vars\": \"id[-1:2]\",
    \"formula\": \"E<> ((ST1.z_sync || ST1.z_async)  && (ST2.z_sync || ST2.z_async)  )\"
}''"

value [code] "parse_all lx_ws json test2"

end


theory DeadCodeRemoval2
imports Substitution Terms ImageP
begin

definition reach_graph :: "heap \<Rightarrow> var \<Rightarrow> var \<Rightarrow> bool"
  where
  "reach_graph \<Gamma> v\<^sub>1 v\<^sub>2 = (case map_of \<Gamma> v\<^sub>1 of Some e \<Rightarrow> v\<^sub>2 \<in> fv e | None \<Rightarrow> False)"

lemma reach_graph_eqvt[eqvt]: "\<pi> \<bullet> reach_graph \<Gamma>  v\<^sub>1 v\<^sub>2 = reach_graph (\<pi> \<bullet> \<Gamma>) (\<pi> \<bullet> v\<^sub>1)  (\<pi> \<bullet> v\<^sub>2)"
  unfolding reach_graph_def by perm_simp rule

definition reachable :: "heap \<Rightarrow> exp \<Rightarrow> var set"
  where
  "reachable \<Gamma> e = (reach_graph \<Gamma>)\<^sup>*\<^sup>* ``` fv e" (* ImageP would be nicer *)

lemma reachable_eqvt[eqvt]: "\<pi> \<bullet> reachable \<Gamma> e = reachable (\<pi> \<bullet> \<Gamma>) (\<pi> \<bullet> e)"
  unfolding reachable_def ImageP_def by perm_simp rule

definition restrict_reachable :: "heap \<Rightarrow> exp \<Rightarrow> heap"
  where
  "restrict_reachable \<Gamma> e = restrictA (reachable \<Gamma> e) (clearjunk \<Gamma>)"

lemma domA_restrict_reachable[simp]: "domA (restrict_reachable \<Gamma> e) = domA \<Gamma> \<inter> reachable \<Gamma> e"
  unfolding restrict_reachable_def by simp

lemma restrict_reachable_eqvt[eqvt]: "\<pi> \<bullet> restrict_reachable \<Gamma> e = restrict_reachable (\<pi> \<bullet> \<Gamma>) (\<pi> \<bullet> e)"
  unfolding restrict_reachable_def by perm_simp rule

lemma restrict_reachable_eqvt2: "eqvt restrict_reachable"
  unfolding eqvt_def by (rule, perm_simp, rule)

lemma supp_restrictA: "supp (restrictA s \<Gamma>) \<subseteq> supp \<Gamma>"
  by (induction \<Gamma>) (auto simp add: supp_Cons supp_Pair)

lemma supp_delete: "supp (delete x \<Gamma>) \<subseteq> supp \<Gamma>"
  by (induction \<Gamma>) (auto simp add: supp_Cons supp_Pair)

lemma supp_clearjunkA: "supp (clearjunk \<Gamma>) \<subseteq> supp \<Gamma>"
  by (induction \<Gamma> rule: clearjunk.induct) (auto simp add: supp_Cons supp_Pair dest: set_mp[OF supp_delete])

lemma supp_restrict_reachable_subset: "supp (restrict_reachable \<Gamma> e) \<subseteq> supp \<Gamma>"
  unfolding restrict_reachable_def using supp_restrictA supp_clearjunkA by (rule subset_trans)

lemma supp_list_union: "supp l = \<Union>{supp x |x. x \<in> set l}"
  by (induction l) (auto simp add: supp_Nil supp_Cons)
lemma fv_list_union: "fv l = \<Union>{fv x |x. x \<in> set l}"
  by (induction l) auto

lemma set_restrictA: "set (restrictA S \<Gamma>) \<subseteq> set \<Gamma>"
  by (induction \<Gamma>) auto

lemma fv_restrictA:
  assumes "x \<in> fv (restrictA S (clearjunk \<Gamma>))"
  obtains y where "y \<in> S" and "(reach_graph \<Gamma>)\<^sup>=\<^sup>= y x"
proof-
  from assms[unfolded fv_list_union]
  obtain y e where "(y, e) \<in> set (restrictA S (clearjunk \<Gamma>))" and  "x = y \<or> x \<in> fv e" by auto
  show thesis
  proof
    from `(y, e) \<in> set (restrictA S (clearjunk \<Gamma>))`
    have "y \<in> domA (restrictA S (clearjunk \<Gamma>))" by (rule domA_from_set)
    thus "y \<in> S" by simp

    from `(y, e) \<in> set (restrictA S (clearjunk \<Gamma>))`
    have "(y, e) \<in> set (clearjunk \<Gamma>)" using set_restrictA by auto
    hence "map_of (clearjunk \<Gamma>) y = Some e" by (rule map_of_is_SomeI[OF distinct_clearjunk])
    hence "map_of \<Gamma> y = Some e" by (simp add: map_of_clearjunk)
    with `x = y \<or> x \<in> fv e`
    show "(reach_graph \<Gamma>)\<^sup>=\<^sup>= y x"  by (auto simp add:  reach_graph_def)
  qed
qed

lemma fv_e_reachable: "fv e \<subseteq> reachable \<Gamma> e"
  unfolding restrict_reachable_def reachable_def by auto

lemma fv_heap_reachable:  "fv (restrict_reachable \<Gamma> e) \<subseteq> reachable \<Gamma> e"
proof(intro subsetI)
  fix x :: var
  assume "x \<in> fv (restrict_reachable \<Gamma> e)"
  then obtain y where "y \<in> (reachable \<Gamma> e)" and  "(reach_graph \<Gamma>)\<^sup>=\<^sup>= y x"
  unfolding restrict_reachable_def
    by (rule fv_restrictA)
  hence "x \<in> reachable \<Gamma> e"
    unfolding reachable_def by (auto intro: tranclp_into_rtranclp  rtranclp_into_tranclp1)
  thus "x \<in> reachable \<Gamma> e" unfolding reachable_def by auto
qed

nominal_function
  remove_dead_code :: "exp \<Rightarrow> exp"
where
  "remove_dead_code (Lam [x]. e) = Lam [x]. remove_dead_code e"
| "remove_dead_code (App e x) = App (remove_dead_code e) x"
| "remove_dead_code (Var x) = Var x"
| "remove_dead_code (Terms.Let as e) = SmartLet (restrict_reachable (map_ran (\<lambda> _ e. remove_dead_code e) as) (remove_dead_code e)) (remove_dead_code e)"
| "remove_dead_code (Bool b) = Bool b"
| "remove_dead_code (scrut ? e1 : e2) = (remove_dead_code scrut ? remove_dead_code e1 : remove_dead_code e2)"
proof-
case goal1 thus ?case
  unfolding remove_dead_code_graph_aux_def eqvt_def
  apply rule
  apply perm_simp
  apply rule
  done
next
case goal3 thus ?case
  by (metis Terms.Let_def exp_assn.exhaust(1) heapToAssn_asToHeap)
next
case (goal4 x e x' e')
  from goal4(5)
  show ?case
  proof (rule eqvt_lam_case)
    fix \<pi> :: perm
    assume "supp \<pi> \<sharp>* Lam [x]. e"
    hence *: "supp \<pi> \<sharp>* Lam [x]. remove_dead_code_sumC e"
      by (auto simp add:  fresh_star_def fresh_eqvt_at[OF goal4(1)] exp_assn.fsupp)

    have "Lam [(\<pi> \<bullet> x)]. remove_dead_code_sumC (\<pi> \<bullet> e) =  \<pi> \<bullet> Lam [x]. remove_dead_code_sumC e"
        by (simp add: pemute_minus_self eqvt_at_apply'[OF goal4(1)])
    also have "\<dots> = Lam [x]. remove_dead_code_sumC e" by (rule perm_supp_eq[OF *])
    finally show  "Lam [(\<pi> \<bullet> x)]. remove_dead_code_sumC (\<pi> \<bullet> e) = Lam [x]. remove_dead_code_sumC e".
  qed
next
case (goal19 as body as' body')
  from goal19(13)
  show ?case
  proof (rule eqvt_let_case)
    fix \<pi> :: perm

    from goal19(2) have eqvt_at1: "eqvt_at remove_dead_code_sumC body" by auto
    from goal19(1)
    have eqvt_at2: "eqvt_at (map_ran (\<lambda>_. remove_dead_code_sumC)) as" by (induction as) (fastforce simp add: eqvt_at_def)+

    assume assm: "supp \<pi> \<sharp>* Terms.Let as body"

    let ?as' = "restrict_reachable (map_ran (\<lambda>_. remove_dead_code_sumC) as) (remove_dead_code_sumC body)"
    let ?body' = "remove_dead_code_sumC body"
    let ?rable = "reachable (map_ran (\<lambda>_. remove_dead_code_sumC) as) (remove_dead_code_sumC body)"

    have "supp (SmartLet ?as' ?body') \<subseteq> supp as \<union> supp body"
      by (auto 4 4 simp add: exp_assn.supp SmartLet_supp
          dest!: set_mp[OF supp_eqvt_at[OF eqvt_at1 finite_supp]]
                 set_mp[OF supp_eqvt_at[OF eqvt_at2 finite_supp]]
                 set_mp[OF supp_restrict_reachable_subset]
                 )
    moreover
    have "fv ?as' \<subseteq> reachable (map_ran (\<lambda>_. remove_dead_code_sumC) as) ?body'"
      by (rule fv_heap_reachable)
    moreover
    have "fv ?body' \<subseteq> reachable (map_ran (\<lambda>_. remove_dead_code_sumC) as) ?body'"
      by (rule fv_e_reachable)
    ultimately
    have supp_subset: "supp (SmartLet ?as' ?body') \<subseteq> supp (Terms.Let as body)"
      by (auto simp add: Let_supp SmartLet_supp fv_def)
    with assm
    have *: "supp \<pi> \<sharp>* SmartLet ?as' ?body'"  by (auto simp add: fresh_star_def fresh_def)

    have "SmartLet (restrict_reachable (map_ran (\<lambda>_. remove_dead_code_sumC) (\<pi> \<bullet> as))  (remove_dead_code_sumC (\<pi> \<bullet> body))) (remove_dead_code_sumC (\<pi> \<bullet> body)) =
      \<pi> \<bullet> SmartLet ?as' ?body'"
      unfolding  SmartLet_eqvt restrict_reachable_eqvt eqvt_at_apply'[OF eqvt_at1] subst eqvt_at_apply'[OF eqvt_at2] ..
    also have "\<dots> = SmartLet ?as' ?body'" by (rule perm_supp_eq[OF *])
    finally show "SmartLet (restrict_reachable (map_ran (\<lambda>_. remove_dead_code_sumC) (\<pi> \<bullet> as)) (remove_dead_code_sumC (\<pi> \<bullet> body))) (remove_dead_code_sumC (\<pi> \<bullet> body)) =
         (SmartLet ?as' ?body')".
  qed
qed auto
nominal_termination (eqvt) by lexicographic_order

lemma subst_restrictA[simp]:
  "(restrictA S \<Gamma>)[y::h=x] = restrictA S (\<Gamma>[y::h=x])"
  by (induction \<Gamma>) auto

lemma subst_clearjunk[simp]:
  "(clearjunk \<Gamma>)[y::h=x] = clearjunk (\<Gamma>[y::h=x])"
  by (induction \<Gamma> rule:clearjunk.induct) auto

lemma restrictA_cong: "S1 \<inter> domA \<Gamma> = S2 \<inter> domA \<Gamma> \<Longrightarrow> restrictA S1 \<Gamma> = restrictA S2 \<Gamma>"
  by(induction \<Gamma>) auto

lemma rtranclp_image_cong:
 assumes "\<And>x y . R1 x y \<Longrightarrow> x \<in> S"
 assumes "\<And>x y . y \<in> S \<Longrightarrow>  R1 x y \<longleftrightarrow> R2 x y"
 assumes  "S1 \<inter> S = S2 \<inter> S"
 shows  "R1\<^sup>*\<^sup>* ``` S1 \<inter> S = R2\<^sup>*\<^sup>* ``` S2 \<inter> S"
 apply (intro equalityI subsetI)
 apply (elim IntE ImagePE)
 defer
 apply (elim IntE ImagePE)
 defer
 proof-
  fix x y
  assume  "R1\<^sup>*\<^sup>* y x" and  "y \<in> S1" and "x \<in> S"
  hence "R2\<^sup>*\<^sup>* y x"
  apply (induction  rule: rtranclp.induct)
  using assms(1,2) by auto
  moreover
  from `R1\<^sup>*\<^sup>* y x` `x \<in> S` assms(1) have "y \<in> S" by (induction rule: converse_rtranclp_induct) auto
  with `y : S1` have "y \<in> S2" using assms(3) by auto
  with `R2\<^sup>*\<^sup>* y x` `x \<in> S`
  show "x \<in> R2\<^sup>*\<^sup>* ``` S2 \<inter> S" by auto
 next
  fix x y
  assume  "R2\<^sup>*\<^sup>* y x" and  "y \<in> S2" and "x \<in> S"
  hence "R1\<^sup>*\<^sup>* y x"
    apply (induction  rule: rtranclp.induct)
    using assms(1) assms(2)[symmetric] by auto
  moreover
  from `R2\<^sup>*\<^sup>* y x` `x \<in> S` assms(1) assms(2) have "y \<in> S" by (induction rule: converse_rtranclp_induct) auto
  with `y : S2` have "y \<in> S1" using assms(3) by auto
  with `R1\<^sup>*\<^sup>* y x` `x \<in> S`
  show "x \<in> R1\<^sup>*\<^sup>* ``` S1 \<inter> S" by auto
qed

context
  fixes \<Gamma> :: heap and  x y :: var
  assumes fresh: "atom ` domA \<Gamma> \<sharp>* y" "atom ` domA \<Gamma> \<sharp>* x"
begin

lemma subst_map_of[simp]: "map_of \<Gamma>[y::h=x] v = map_option (\<lambda> e. e[y::=x]) (map_of \<Gamma> v)"
  by (induction \<Gamma>) auto

lemma subst_reach_graph[simp]: "y' \<in> domA \<Gamma> \<Longrightarrow>  reach_graph (\<Gamma>[y::h=x]) x' y' =reach_graph \<Gamma> x' (y'[y::v=y])"
  unfolding reach_graph_def using fresh
  by (auto 4 4 intro!: option.case_cong del: iffI simp add: fresh_star_at_base fv_subst_eq)

lemma reachable_eq[simp]:
  "reachable \<Gamma> e \<inter> domA \<Gamma> = reachable \<Gamma>[y::h=x] e[y::=x] \<inter> domA \<Gamma>"
  unfolding reachable_def
  apply (rule rtranclp_image_cong)
  apply (metis reach_graph_def map_add_domA(2) map_of.simps(1) merge_None merge_conv option.case_eq_if)
  apply simp
  using fresh apply (auto simp add: fv_subst_eq fresh_star_at_base)
  done

lemma subst_restrict_reachable[simp]:
  shows "(restrict_reachable \<Gamma> e)[y::h=x] = restrict_reachable (\<Gamma>[y::h=x]) (e[y::=x])"
  unfolding restrict_reachable_def
  apply (simp cong: restrictA_cong)
  apply (subst subst_clearjunk) (* huh? why not simp *)
  apply (rule restrictA_cong)
  apply simp
  done
end

lemma subst_remove_dead_code: "(remove_dead_code e)[y::=x] = remove_dead_code (e [y::=x])"
  and "(map_ran (\<lambda> _ e. remove_dead_code e) \<Gamma>)[y::h=x] = map_ran (\<lambda> _ e. remove_dead_code e) (\<Gamma>[y::h=x])"
proof (nominal_induct e and \<Gamma>  avoiding: y x rule:exp_heap_strong_induct)
case (Let \<Gamma> e y x)
  thus ?case
  by (auto simp add: fresh_star_at_base fv_subst_eq fresh_star_Pair pure_fresh simp del: Let_eq_iff)
qed auto

end