theory CSLsound
imports Main VHelper Lang
begin

text {* This file contains a soundness proof for CSL (with multiple resources)
  as presented by O'Hearn and Brookes including the data-race freedom property
  of CSL.  For simplicity, there is a slight difference regarding variable
  side-conditions: we do not allow resource-owned variables. *}

text {* (Adapted to Isabelle 2016-1 by Qin Yu and James Brotherston) *}

subsection {* Separation logic assertions *}

text {* A deep embedding of separation logic assertions. *}

datatype assn =
    Aemp                                           (*r Empty heap *)
  | Apointsto exp exp    (infixl "\<longmapsto>" 200)        (*r Singleton heap *)
  | Astar assn assn      (infixl "**" 100)         (*r Separating conjunction *)
  | Awand assn assn                                (*r Separating implication *)
  | Apure bexp                                     (*r Pure assertion *)
  | Aconj assn assn                                (*r Conjunction *)
  | Adisj assn assn                                (*r Disjunction *)
  | Aex "(nat \<Rightarrow> assn)"                            (*r Existential quantification *)

text {* Separating conjunction of a finite list of assertions is
  just a derived assertion. *}

primrec
  Aistar :: "assn list \<Rightarrow> assn"
where
  "Aistar [] = Aemp"
| "Aistar (P # Ps) = Astar P (Aistar Ps)"

primrec
  sat :: "state \<Rightarrow> assn \<Rightarrow> bool" (infixl "\<Turnstile>" 60)
where
  "(\<sigma> \<Turnstile> Aemp)      = (snd \<sigma> = empty)"
| "(\<sigma> \<Turnstile> E \<longmapsto> E')  = (dom (snd \<sigma>) = { edenot E (fst \<sigma>) } \<and> (snd \<sigma>) (edenot E (fst \<sigma>)) = Some (edenot E' (fst \<sigma>)))"
| "(\<sigma> \<Turnstile> P ** Q)    = (\<exists>h1 h2. (fst \<sigma>, h1) \<Turnstile> P \<and> (fst \<sigma>, h2) \<Turnstile> Q \<and> snd \<sigma> = (h1 ++ h2) \<and> disjoint (dom h1) (dom h2))"
| "(\<sigma> \<Turnstile> Awand P Q) = (\<forall>h. disjoint (dom (snd \<sigma>)) (dom h) \<and> (fst \<sigma>, h) \<Turnstile> P \<longrightarrow> (fst \<sigma>, snd \<sigma> ++ h) \<Turnstile> Q)"
| "(\<sigma> \<Turnstile> Apure B)   = bdenot B (fst \<sigma>)"
| "(\<sigma> \<Turnstile> Aconj P Q) = (\<sigma> \<Turnstile> P \<and> \<sigma> \<Turnstile> Q)"
| "(\<sigma> \<Turnstile> Adisj P Q) = (\<sigma> \<Turnstile> P \<or> \<sigma> \<Turnstile> Q)"
| "(\<sigma> \<Turnstile> Aex PP)    = (\<exists>v. \<sigma> \<Turnstile> PP v)"

definition
  implies :: "assn \<Rightarrow> assn \<Rightarrow> bool" (infixl "\<sqsubseteq>" 60)
where
  "P \<sqsubseteq> Q \<equiv> (\<forall>\<sigma>. \<sigma> \<Turnstile> P \<longrightarrow> \<sigma> \<Turnstile> Q)"

lemma sat_istar_map_expand:
  "\<lbrakk> r \<in> set l \<rbrakk> \<Longrightarrow>
     \<sigma> \<Turnstile> Aistar (map f l)
     \<longleftrightarrow> (\<exists>h1 h2. (fst \<sigma>, h1) \<Turnstile> f r
              \<and> (fst \<sigma>, h2) \<Turnstile> Aistar (map f (remove1 r l))
              \<and> snd \<sigma> = (h1 ++ h2)
              \<and> disjoint (dom h1) (dom h2))"
apply (case_tac \<sigma>, rename_tac s h, clarify)
apply (induction l arbitrary: \<sigma>, auto)
apply (intro exI conjI, (simp add: hsimps)+)+
done

subsubsection {* Precision *}

text {* We say that an assertion is precise if for any given heap, there is at
most one subheap that satisfies the formula. (The formal definition below says
that if there are two such subheaps, they must be equal.) *}

definition
  precise :: "assn \<Rightarrow> bool"
where
  "precise P \<equiv> \<forall>h1 h2 h1' h2' s. disjoint (dom h1) (dom h2) \<and> disjoint (dom h1') (dom h2')
                   \<and> h1 ++ h2 = h1' ++ h2' \<and> (s, h1) \<Turnstile> P \<and> (s, h1') \<Turnstile> P
               \<longrightarrow> h1 = h1'"

text {* A direct consequence of the definition that is more useful in
Isabelle, because unfolding the definition slows down Isabelle's simplifier
dramatically. *}

lemma preciseD:
  "\<lbrakk> precise P; (s, x) \<Turnstile> P; (s, x') \<Turnstile> P; x ++ y = x' ++ y';
     disjoint (dom x) (dom y); disjoint (dom x') (dom y') \<rbrakk> \<Longrightarrow>
    x = x' \<and> y = y'"
unfolding precise_def
by (drule all5_impD, (erule conjI)+, simp_all, rule map_add_cancel)
   (subst (1 2) map_add_comm, auto simp add: disjoint_def)

text {* The separating conjunction of precise assertions is precise: *}

lemma precise_istar:
  "\<forall>x \<in> set l. precise x \<Longrightarrow> precise (Aistar l)"
apply (induct l, simp_all (no_asm) add: precise_def)
apply (clarsimp simp add: map_add_assoc [THEN sym])
apply (drule (3) preciseD, simp_all, clarsimp?)+
done

subsubsection {* Auxiliary definition for resource environments *}

definition
  envs :: "('a \<Rightarrow> assn) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> assn"
where
  "envs \<Gamma> l l' \<equiv> Aistar (map \<Gamma> (list_minus l l'))"

lemma sat_envs_expand:
  "\<lbrakk> r \<in> set l; r \<notin> set l'; distinct l \<rbrakk> \<Longrightarrow>
     \<sigma> \<Turnstile> envs \<Gamma> l l'
     \<longleftrightarrow> (\<exists>h1 h2. (fst \<sigma>, h1) \<Turnstile> \<Gamma> r
              \<and> (fst \<sigma>, h2) \<Turnstile> envs \<Gamma> (removeAll r l) l'
              \<and> snd \<sigma> = h1 ++ h2 \<and> disjoint (dom h1) (dom h2))"
apply (simp add: envs_def distinct_remove1_removeAll [THEN sym] add: list_minus_remove1)
apply (subst sat_istar_map_expand [where f=\<Gamma> and r=r], simp_all)
done

lemma envs_upd:
  "r \<notin> set l \<Longrightarrow> envs (\<Gamma>(r := R)) l l' = envs \<Gamma> l l'"
  "r \<in> set l' \<Longrightarrow> envs (\<Gamma>(r := R)) l l' = envs \<Gamma> l l'"
by (simp_all add: envs_def)

lemma envs_removeAll_irr:
  "r \<notin> set l \<Longrightarrow> envs \<Gamma> l (removeAll r l') = envs \<Gamma> l l'"
by (simp add: envs_def list_minus_removeAll_irr)

lemma envs_removeAll2:
  "r \<in> set l' \<Longrightarrow> envs \<Gamma> (removeAll r l) (removeAll r l') = envs \<Gamma> l l'"
by (simp add: envs_def list_minus_removeAll2)

lemma envs_app:
  "disjoint (set x) (set z) \<Longrightarrow> envs \<Gamma> (x @ z) (y @ z) = envs \<Gamma> x y"
  "disjoint (set z) (set x) \<Longrightarrow> envs \<Gamma> (z @ x) (z @ y) = envs \<Gamma> x y"
by (simp_all add: envs_def list_minus_appl list_minus_appr)

subsubsection {* Free variables, substitutions *}

primrec
  fvA :: "assn \<Rightarrow> var set"
where
  "fvA (Aemp)      = {}"
| "fvA (Apure B)   = fvB B"
| "fvA (e1 \<longmapsto> e2) = (fvE e1 \<union> fvE e2)"
| "fvA (P ** Q)    = (fvA P \<union> fvA Q)"
| "fvA (Awand P Q) = (fvA P \<union> fvA Q)"
| "fvA (Aconj P Q) = (fvA P \<union> fvA Q)"
| "fvA (Adisj P Q) = (fvA P \<union> fvA Q)"
| "fvA (Aex P)     = (\<Union>x. fvA (P x))"

definition
  fvAs :: "('a \<Rightarrow> assn) \<Rightarrow> var set"
where
  "fvAs \<Gamma> = (\<Union>x. fvA (\<Gamma> x))"

primrec
  subA :: "var \<Rightarrow> exp \<Rightarrow> assn \<Rightarrow> assn"
where
  "subA x E (Aemp)      = Aemp"
| "subA x E (Apure B)   = Apure (subB x E B)"
| "subA x E (e1 \<longmapsto> e2) = (subE x E e1 \<longmapsto> subE x E e2)"
| "subA x E (P ** Q)    = (subA x E P ** subA x E Q)"
| "subA x E (Awand P Q) = Awand (subA x E P) (subA x E Q)"
| "subA x E (Aconj P Q) = Aconj (subA x E P) (subA x E Q)"
| "subA x E (Adisj P Q) = Adisj (subA x E P) (subA x E Q)"
| "subA x E (Aex PP)    = Aex (\<lambda>n. subA x E (PP n))"

lemma subA_assign:
 "(s,h) \<Turnstile> subA x E P \<longleftrightarrow> (s(x := edenot E s), h) \<Turnstile> P"
by (induct P arbitrary: h, simp_all add: subE_assign subB_assign fun_upd_def)

lemma fvA_istar[simp]: "fvA (Aistar Ps) = (\<Union>P \<in> set Ps. fvA P)"
by (induct Ps, simp_all)

text {* Proposition 4.2 for assertions *}

lemma assn_agrees: "agrees (fvA P) s s' \<Longrightarrow> (s, h) \<Turnstile> P \<longleftrightarrow> (s', h) \<Turnstile> P"
apply (induct P arbitrary: h, simp_all add: bexp_agrees)
apply (clarsimp, (subst exp_agrees, simp_all)+ )
apply (rule iff_exI, simp add: agrees_def)
done

text {* Corollaries of Proposition 4.2, useful for automation. *}

lemma assns_agrees:
  "agrees (fvAs J) s s' \<Longrightarrow> (s, h) \<Turnstile> envs J l1 l2 \<longleftrightarrow> (s', h) \<Turnstile> envs J l1 l2"
apply (clarsimp simp add: envs_def, subst assn_agrees, simp_all)
apply (erule agrees_search, auto simp add: fvAs_def)
done

corollary assns_agreesE[elim]:
  "\<lbrakk> (s, h) \<Turnstile> envs J l1 l2 ; agrees (fvAs J) s s' \<rbrakk> \<Longrightarrow> (s',h) \<Turnstile> envs J l1 l2"
by (simp add: assns_agrees)

corollary assn_agrees2[simp]:
  "x \<notin> fvA P \<Longrightarrow> (s(x := v), h) \<Turnstile> P \<longleftrightarrow> (s, h) \<Turnstile> P"
by (rule assn_agrees, simp add: agrees_def)

corollary assns_agrees2[simp]:
  "x \<notin> fvAs J \<Longrightarrow> (s(x := v), h) \<Turnstile> envs J l l' \<longleftrightarrow> (s, h) \<Turnstile> envs J l l'"
by (rule assns_agrees, simp add: agrees_def)

subsection {* Meaning of CSL judgments *}

text {* Definition 5.1: Configuration safety. *}

primrec
  safe :: "nat \<Rightarrow> cmd \<Rightarrow> stack \<Rightarrow> heap \<Rightarrow> (rname \<Rightarrow> assn) \<Rightarrow> assn \<Rightarrow> bool"
where
  "safe 0       C s h \<Gamma> Q = True"
| "safe (Suc n) C s h \<Gamma> Q = (
(* Condition (i) *)
            (C = Cskip \<longrightarrow> (s, h) \<Turnstile> Q)
(* Condition (ii) *)
          \<and> (\<forall>hF. disjoint (dom h) (dom hF) \<longrightarrow> \<not> aborts C (s, h ++ hF))
(* Condition (iii) *)
          \<and> accesses C s \<subseteq> dom h
(* Condition (iv) *)
          \<and> (\<forall>hJ hF C' \<sigma>'.
                  red C (s,h ++ hJ ++ hF) C' \<sigma>'
                 \<longrightarrow> (s, hJ) \<Turnstile> envs \<Gamma> (llocked C') (llocked C)
                 \<longrightarrow> (disjoint (dom h) (dom hJ) \<and> disjoint (dom h) (dom hF) \<and> disjoint (dom hJ) (dom hF))
                 \<longrightarrow> (\<exists>h' hJ'.
                         snd \<sigma>' = h' ++ hJ' ++ hF
                       \<and> disjoint (dom h') (dom hJ') \<and> disjoint (dom h') (dom hF) \<and> disjoint (dom hJ') (dom hF)
                       \<and> (fst \<sigma>', hJ') \<Turnstile> envs \<Gamma> (llocked C) (llocked C')
                       \<and> safe n C' (fst \<sigma>') h' \<Gamma> Q)))"

text {* The predicate @{text "safe n C s h \<Gamma> Q"} says that the command @{text C} and the logical state
  @{text "(s, h)"} are safe with respect to the resource environment @{text \<Gamma>} and the
  postcondition @{text Q} for @{text n} execution steps.
  Intuitively, any configuration is safe for zero steps.
  For @{text "n + 1"} steps, it must
  (i) satisfy the postcondition if it is a terminal configuration,
  (ii) not abort,
  (iii) access memory only inside its footprint, and
  (iv) after any step it does, re-establish the resource invariant and be safe for
  another @{text n} steps. *}

text {* Definition 5.2: The meaning of CSL judgements. *}

definition
  CSL :: "(rname \<Rightarrow> assn) \<Rightarrow> assn \<Rightarrow> cmd \<Rightarrow> assn \<Rightarrow> bool"
  ("_ \<turnstile> { _ } _ { _ }")
where
  "\<Gamma> \<turnstile> {P} C {Q} \<equiv> (user_cmd C \<and> (\<forall>n s h. (s, h) \<Turnstile> P \<longrightarrow> safe n C s h \<Gamma> Q))"

subsubsection {* Basic properties of Definition 5.1 *}

text {* Proposition 4.3: Monotonicity with respect to the step number. *}

lemma safe_mon:
  "\<lbrakk> safe n C s h J Q; m \<le> n \<rbrakk> \<Longrightarrow> safe m C s h J Q"
apply (induct m arbitrary: C s n h l, simp)
apply (case_tac n, clarify)
apply (simp only: safe.simps, clarsimp)
apply (drule all5D, drule (2) imp3D, simp, clarsimp)
apply (rule_tac x="h'" in exI, rule_tac x="hJ'" in exI, simp)
done

text {* Proposition 4.4: Safety depends only the free variables
        of @{term "C"}, @{term "Q"}, and @{term "\<Gamma>"}. *}

lemma safe_agrees:
  "\<lbrakk> safe n C s h \<Gamma> Q ;
     agrees (fvC C \<union> fvA Q \<union> fvAs \<Gamma>) s s' \<rbrakk>
   \<Longrightarrow> safe n C s' h \<Gamma> Q"
apply (induct n arbitrary: C s s' h bl, simp, simp only: safe.simps, clarify)
apply (rule conjI, clarsimp, subst assn_agrees, subst agreesC, assumption+)
apply (rule conjI, clarsimp)
 apply (drule_tac aborts_agrees, simp, fast, simp, simp)
apply (rule conjI, subst (asm) accesses_agrees, simp_all)
apply (clarify, drule_tac X="fvC C \<union> fvAs \<Gamma> \<union> fvA Q" in red_agrees,
       simp (no_asm), fast, simp (no_asm), fast, clarify)
apply (drule (1) all5_impD, clarsimp)
apply (drule impD, erule assns_agreesE, simp add: agreesC, clarify)
apply (rule_tac x="h'" and y="hJ'" in ex2I, simp add: hsimps)
apply (rule conjI, erule assns_agreesE, subst agreesC, assumption)
apply (erule (1) mall4_imp2D, simp add: agreesC)
apply (drule red_properties, auto)
done

subsection {* Soundness of the proof rules *}

subsubsection {* Skip *}

lemma safe_skip[intro!]:
  "(s,h) \<Turnstile> Q \<Longrightarrow> safe n Cskip s h J Q"
by (induct n, simp_all)

theorem rule_skip:
  "\<Gamma> \<turnstile> {P} Cskip {P}"
by (auto simp add: CSL_def)

subsubsection {* Parallel composition *}

lemma safe_par:
 "\<lbrakk> safe n C1 s h1 J Q1; safe n C2 s h2 J Q2;
    wf_cmd (Cpar C1 C2);
    disjoint (dom h1) (dom h2);
    disjoint (fvC C1 \<union> fvA Q1 \<union> fvAs J) (wrC C2);
    disjoint (fvC C2 \<union> fvA Q2 \<union> fvAs J) (wrC C1)\<rbrakk>
  \<Longrightarrow> safe n (Cpar C1 C2) s (h1 ++ h2) J (Q1 ** Q2)"
apply (induct n arbitrary: C1 C2 s h1 h2 bl1 bl2, simp, clarsimp)
apply (rule conjI, clarify)
 -- {* no aborts *}
 apply (erule aborts.cases, simp_all add: hsimps)
    apply (clarify, drule_tac a="h2 ++ hF" in all_impD, simp_all add: hsimps)
   apply (clarify, drule_tac allD, drule_tac a="h1 ++ hF" in all_impD, simp_all add: hsimps)
 -- {* no races *}
 apply (clarsimp, erule notE, erule disjoint_search [rotated], erule disjoint_search,
        erule order_trans [OF writes_accesses])+
-- {* accesses *}
apply (rule conjI, erule order_trans, simp)+
-- {* step *}
 apply (clarsimp, erule red_par_cases)
 -- {* C1 does a step *}
  apply (clarify, drule_tac a="hJ" and b="h2 ++ hF" in all2D, drule all3_impD,
         simp_all add: hsimps envs_app locked_eq, clarsimp)
  apply (rule_tac x="h' ++ h2" in exI, rule_tac x="hJ'" in exI, simp add: hsimps)
  apply (frule (1) red_wf_cmd, drule red_properties, clarsimp)
  apply (drule_tac a=C1' and b=C2 in mall2D, simp add: hsimps)
  apply (subst map_add_commute, simp add: hsimps)
  apply (drule mall3_imp2D, erule_tac[3] mimp3D, simp_all add: hsimps)
  apply (rule_tac s="s" in safe_agrees)
  apply (rule_tac n="Suc n" in safe_mon, simp add: hsimps, simp)
  apply (fastforce simp add: agreesC disjoint_commute)
  apply (intro conjI | erule (1) disjoint_search)+
 -- {* C2 does a step *}
  apply (clarify, drule_tac a="hJ" and b="h1 ++ hF" in all2D, drule all3_imp2D,
         simp_all add: hsimps envs_app, clarsimp)
  apply (rule_tac x="h1 ++ h'" in exI, rule_tac x="hJ'" in exI, simp add: hsimps)
  apply (frule (1) red_wf_cmd, drule red_properties, clarsimp)
  apply (drule_tac a=C1 and b=C2' in mall2D, simp add: hsimps)
  apply (drule mall3_imp2D, erule_tac[3] mimp3D, simp_all add: hsimps)
  apply (rule_tac s="s" in safe_agrees)
   apply (rule_tac n="Suc n" in safe_mon, simp add: hsimps, simp)
  apply (subst agreesC, fastforce, fastforce, fastforce)
  -- {* Par skip skip *}
  apply (clarify)
  apply (rule_tac x="h1 ++ h2" in exI, rule_tac x="hJ" in exI, simp add: hsimps)
  apply (rule_tac safe_skip, simp, (rule exI, erule conjI)+, simp)
done

theorem rule_par:
 "\<lbrakk> \<Gamma> \<turnstile> {P1} C1 {Q1} ; \<Gamma> \<turnstile> {P2} C2 {Q2};
    disjoint (fvC C1 \<union> fvA Q1 \<union> fvAs \<Gamma>) (wrC C2);
    disjoint (fvC C2 \<union> fvA Q2 \<union> fvAs \<Gamma>) (wrC C1) \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> {P1 ** P2} (Cpar C1 C2) {Q1 ** Q2}"
by (auto simp add: CSL_def intro!: safe_par)

subsubsection {* Resource declaration *}

lemma safe_resource:
 "\<lbrakk> safe n C s h (\<Gamma>(r := R)) Q; wf_cmd C; disjoint (fvA R) (wrC C) \<rbrakk> \<Longrightarrow>
     (\<forall>hR. r \<notin> locked C \<longrightarrow> disjoint (dom h) (dom hR) \<longrightarrow> (s,hR) \<Turnstile> R \<longrightarrow> safe n (Cresource r C) s (h ++ hR) \<Gamma> (Q ** R))
   \<and> (r \<in> locked C \<longrightarrow> safe n (Cresource r C) s h \<Gamma> (Q ** R))"
apply (induct n arbitrary: C s h, simp, clarsimp)
apply (rule conjI, clarify)
 apply (rule conjI, clarify)
  -- {* no aborts *}
  apply (erule aborts.cases, simp_all, clarsimp)
  apply (drule_tac a="hR ++ hF" in all_impD, simp, simp add: hsimps)
 -- {* accesses *}
 apply (rule conjI, erule order_trans, simp)
 -- {* step *}
 apply (clarify, frule red_properties, clarsimp)
 apply (erule red.cases, simp_all, clarsimp, rename_tac C s C' s' hh)
 -- {* normal step *}
  apply (case_tac "r \<in> set (llocked C')", simp_all add: locked_eq)
   apply (drule_tac a="hJ ++ hR" and b="hF" and c=C' and d=s' and e=hh in all5D, simp add: hsimps)
   apply (drule impD, subst sat_envs_expand [where r=r], simp_all)
     apply (rule wf_cmd_distinct_locked, erule (1) red_wf_cmd)
    apply (intro exI conjI, simp, simp_all add: envs_upd)
   apply (clarsimp simp add: envs_removeAll_irr)
   apply (drule (1) mall3_imp2D, erule (1) red_wf_cmd)
   apply (drule mimpD, fast, clarsimp)
   apply (intro exI conjI, simp+)
  -- {* @{term "r \<notin> locked C'"} *}
  apply (drule_tac a="hJ" and b="hR ++ hF" and c=C' and d=s' and e=hh in all5D, simp add: hsimps)
  apply (clarsimp simp add: envs_upd)
  apply (drule (1) mall3_imp2D, erule (1) red_wf_cmd)
  apply (drule mimpD, fast, clarsimp)
  apply (rule_tac x="h' ++ hR" and y="hJ'" in ex2I, simp add: hsimps)
  apply (drule_tac a=hR in all_imp2D, simp_all add: hsimps)
  apply (subst assn_agrees, simp_all, fastforce)
 -- {* skip *}
 apply (clarsimp simp add: envs_def)
 apply (rule_tac x="h ++ hR" in exI, simp add: hsimps, rule safe_skip, simp, fast)
-- {* not user cmd *}
apply (clarsimp)
apply (rule conjI, clarsimp, erule aborts.cases, simp_all, clarsimp, clarsimp)
apply (frule red_properties, clarsimp)
apply (erule red.cases, simp_all, clarsimp, rename_tac C s C' s' hh)
apply (drule_tac a="hJ" and b="hF" and c=C' and d=s' and e=hh in all5D, simp add: hsimps)
apply (clarsimp simp add: envs_upd envs_removeAll2)
apply (drule (1) mall3_imp2D, erule (1) red_wf_cmd)
apply (drule mimpD, fast, clarsimp)
apply (case_tac "r \<in> set (llocked C')", simp_all add: locked_eq envs_removeAll2 envs_upd)
 apply (intro exI conjI, simp+)
apply (subst (asm) sat_envs_expand [where r=r], simp_all add: wf_cmd_distinct_locked,
       clarsimp, rename_tac hR' hJ')
apply (drule (2) all_imp2D, rule_tac x="h' ++ hR'" and y=hJ' in ex2I, simp add: hsimps envs_upd)
done

theorem rule_resource:
 "\<lbrakk> \<Gamma>(r := R) \<turnstile> {P} C {Q} ; disjoint (fvA R) (wrC C) \<rbrakk> \<Longrightarrow>
    \<Gamma> \<turnstile> {P ** R} (Cresource r C) {Q ** R}"
by (clarsimp simp add: CSL_def, drule (1) all3_impD)
   (auto simp add: locked_eq dest!: safe_resource)

subsubsection {* Frame rule *}

text {* The safety of the frame rule can be seen as a special case of the parallel composition
  rule taking one thread to be the empty command. *}

lemma safe_frame:
 "\<lbrakk> safe n C s h J Q;
    disjoint (dom h) (dom hR);
    disjoint (fvA R) (wrC C);
    (s,hR) \<Turnstile> R\<rbrakk>
  \<Longrightarrow> safe n C s (h ++ hR) J (Q ** R)"
apply (induct n arbitrary: C s h hR, simp, clarsimp)
apply (rule conjI, clarify, fast)
apply (rule conjI, clarify)
 -- {* no aborts *}
 apply (drule_tac a="hR ++ hF" in all_impD, simp, simp add: hsimps)
-- {* accesses *}
apply (rule conjI, erule order_trans, simp)
-- {* step *}
apply (clarify, frule red_properties, clarsimp)
apply (drule_tac a="hJ" and b="hR ++ hF" in all3D, simp add: hsimps, drule (1) all2_impD, clarsimp)
apply (rule_tac y="hJ'" and x="h' ++ hR" in ex2I, clarsimp simp add: hsimps)
apply (subst map_add_commute, simp add: hsimps)
apply (drule mall4D, erule mimp4D, simp_all add: hsimps)
 apply (erule (1) disjoint_search)
apply (subst assn_agrees, simp_all, fastforce)
done

theorem rule_frame:
 "\<lbrakk> \<Gamma> \<turnstile> {P} C {Q} ; disjoint (fvA R) (wrC C) \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> {P ** R} C {Q ** R}"
by (auto simp add: CSL_def intro: safe_frame)

subsubsection {* Conditional critical regions *}

lemma safe_inwith:
  "\<lbrakk>safe n C s h \<Gamma> (Q ** \<Gamma> r); wf_cmd (Cinwith r C) \<rbrakk>
  \<Longrightarrow> safe n (Cinwith r C) s h \<Gamma> Q"
apply (induct n arbitrary: C s h, simp_all, clarify)
apply (rule conjI)
 apply (clarify, erule aborts.cases, simp_all, clarsimp)
apply (clarify, erule_tac red.cases, simp_all, clarify)
 apply (frule (1) red_wf_cmd)
 apply (drule (1) all5_imp2D, simp_all)
 apply (simp add: envs_def list_minus_removeAll [THEN sym] locked_eq)+
 apply fast
apply (clarsimp simp add: envs_def, rename_tac hQ hJ)
apply (rule_tac x="hQ" and y="hJ" in ex2I, simp add: hsimps, fast)
done

theorem rule_with:
  "\<lbrakk> \<Gamma> \<turnstile> {Aconj (P ** \<Gamma> r) (Apure B)} C {Q ** \<Gamma> r} \<rbrakk>
   \<Longrightarrow> \<Gamma> \<turnstile> {P} Cwith r B C {Q}"
apply (clarsimp simp add: CSL_def)
apply (case_tac n, simp, clarsimp)
apply (rule conjI, clarify, erule aborts.cases, simp_all)
apply (clarify, erule red.cases, simp_all, clarsimp)
apply (simp add: envs_def, rule_tac x="h ++ hJ" in exI, simp)
apply (rule safe_inwith, erule all3_impD, auto dest: user_cmdD)
done

subsubsection {* Sequential composition *}

lemma safe_seq:
 "\<lbrakk> safe n C s h J Q; user_cmd C2;
    \<forall>m s' h'. m \<le> n \<and> (s', h') \<Turnstile> Q \<longrightarrow> safe m C2 s' h' J R \<rbrakk>
  \<Longrightarrow> safe n (Cseq C C2) s h J R"
apply (induct n arbitrary: C s h l, simp, clarsimp)
apply (rule conjI, clarsimp)
 apply (erule aborts.cases, simp_all, clarsimp)
apply (clarsimp, erule red.cases, simp_all)
 -- {* Seq1 *}
 apply (clarify, rule_tac x="h" and y="hJ" in ex2I, simp)
-- {* Seq2 *}
apply (clarify, drule (1) all5_impD, clarsimp)
apply (drule (1) mall3_impD, rule_tac x="h'" and y="hJ'" in ex2I, simp)
done

theorem rule_seq:
  "\<lbrakk> \<Gamma> \<turnstile> {P} C1 {Q} ; \<Gamma> \<turnstile> {Q} C2 {R} \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> {P} Cseq C1 C2 {R}"
by (auto simp add: CSL_def intro!: safe_seq)

subsubsection {* Conditionals (if-then-else) *}

theorem rule_if:
  "\<lbrakk> \<Gamma> \<turnstile> {Aconj P (Apure B)} C1 {Q} ;
     \<Gamma> \<turnstile> {Aconj P (Apure (Bnot B))} C2 {Q} \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> {P} Cif B C1 C2 {Q}"
apply (clarsimp simp add: CSL_def)
apply (case_tac n, simp, clarsimp)
apply (intro conjI allI impI notI, erule aborts.cases, simp_all)
apply (elim conjE)
apply (erule red.cases, simp_all)
apply (clarsimp, intro exI, (rule conjI, simp)+, simp)+
done

subsubsection {* While *}

lemma safe_while:
  "\<lbrakk> \<Gamma> \<turnstile> {Aconj P (Apure B)} C {P} ; (s, h) \<Turnstile> P \<rbrakk>
  \<Longrightarrow> safe n (Cwhile B C) s h \<Gamma> (Aconj P (Apure (Bnot B)))"
apply (induct n arbitrary: s h, simp, clarsimp)
apply (intro conjI allI impI notI, erule aborts.cases, simp_all)
apply (elim conjE, erule red.cases, simp_all)
apply (clarsimp, intro exI, (rule conjI, simp)+)
apply (subgoal_tac "\<forall>m s h. m \<le> n \<and> (s, h) \<Turnstile> P \<longrightarrow> safe m (Cwhile B C) s h \<Gamma> (Aconj P (Apure (Bnot B)))")
 apply (case_tac n, simp, clarsimp)
 apply (intro conjI allI impI notI, erule aborts.cases, simp_all)
 apply (elim conjE, erule red.cases, simp_all)
  apply (clarsimp, intro exI, (rule conjI, simp)+)
  apply (clarsimp simp add: CSL_def, rule safe_seq, blast, simp, clarsimp)
 apply (clarsimp, intro exI, (rule conjI, simp)+, rule safe_skip, simp)
apply (clarsimp, drule (1) mall2_impD, erule (1) safe_mon)
done

theorem rule_while:
  "\<Gamma> \<turnstile> {Aconj P (Apure B)} C {P}
  \<Longrightarrow> \<Gamma> \<turnstile> {P} Cwhile B C {Aconj P (Apure (Bnot B))}"
by (auto simp add: CSL_def intro: safe_while)

subsubsection {* Local variable declaration *}

lemma safe_inlocal:
  "\<lbrakk> safe n C (s(x:=v)) h \<Gamma> Q ; x \<notin> fvA Q \<union> fvAs \<Gamma> \<rbrakk>
  \<Longrightarrow> safe n (Cinlocal x v C) s h \<Gamma> Q"
apply (induct n arbitrary: s h v C, simp, clarsimp)
apply (intro conjI allI impI notI, erule aborts.cases, simp_all, clarsimp)
apply (elim conjE, erule red.cases, simp_all)
 apply (clarsimp, drule (1) all5_imp2D, simp)
 apply (clarsimp, intro exI, (rule conjI, simp)+, simp)
apply (fastforce simp add: safe_skip)
done

theorem rule_local:
  "\<lbrakk> \<Gamma> \<turnstile> {Aconj P (Apure (Beq (Evar x) E))} C {Q} ;
     x \<notin> fvA P \<union> fvA Q \<union> fvAs \<Gamma> \<union> fvE E \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> {P} Clocal x E C {Q}"
apply (auto simp add: CSL_def intro: safe_inlocal)
apply (case_tac n, simp_all)
apply (intro conjI allI impI notI, erule aborts.cases, simp_all)
apply (elim conjE, erule red.cases, simp_all, clarsimp)
apply (intro exI conjI, simp_all, rule safe_inlocal, simp_all)
done

subsubsection {* Basic commands (Assign, Read, Write, Alloc, Free) *}

theorem rule_assign:
  "x \<notin> fvAs \<Gamma> \<Longrightarrow> \<Gamma> \<turnstile> {subA x E Q} Cassign x E {Q}"
apply (clarsimp simp add: CSL_def)
apply (case_tac n, simp, clarsimp)
apply (rule conjI, clarsimp, erule aborts.cases, simp_all)
apply (clarsimp, erule red.cases, simp_all)
apply (rule_tac x="h" in exI, rule_tac x="hJ" in exI,
       clarsimp simp add: subA_assign)
done

theorem rule_read:
  "\<lbrakk> x \<notin> fvE E \<union> fvE E' \<union> fvAs \<Gamma> \<rbrakk> \<Longrightarrow>
    \<Gamma> \<turnstile> {E \<longmapsto> E'} Cread x E {Aconj (E \<longmapsto> E') (Apure (Beq (Evar x) E'))}"
apply (clarsimp simp add: CSL_def)
apply (case_tac n, simp, clarsimp)
apply (rule conjI)
 apply (clarsimp, erule aborts.cases, simp_all, clarsimp simp add: dom_def)
apply (clarify, erule red.cases, simp_all, elim exE conjE, hypsubst)
apply (rule_tac x="h" in exI, rule_tac x="hJ" in exI, clarsimp)
apply (simp add: disjoint_def, clarsimp, elim disjE, clarsimp+)
done

theorem rule_write:
  "\<Gamma> \<turnstile> {E \<longmapsto> E0} Cwrite E E' {E \<longmapsto> E'}"
apply (clarsimp simp add: CSL_def)
apply (case_tac n, simp, clarsimp)
apply (rule conjI)
 apply (clarsimp, erule aborts.cases, simp_all, clarsimp simp add: dom_def)
apply (clarify, erule red.cases, simp_all, clarsimp)
apply (rule_tac x="h(edenot E sa \<mapsto> edenot E' sa)" in exI, rule_tac x="hJ" in exI, simp)
apply (rule conjI [rotated], clarsimp)
apply (subst map_add_assoc [THEN sym], subst map_add_commute, simp add: hsimps)
apply (subst map_add_upd [THEN sym], simp add: hsimps del: map_add_upd)
done

theorem rule_alloc:
  "\<lbrakk> x \<notin> fvE E \<union> fvAs \<Gamma> \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> {Aemp} Calloc x E {Evar x \<longmapsto> E}"
apply (clarsimp simp add: CSL_def)
apply (case_tac n, simp, clarsimp)
apply (rule conjI, clarsimp, erule aborts.cases, simp_all)
apply (clarify)
apply (erule red.cases, simp_all)
apply (rule_tac x="Map.empty(v \<mapsto> edenot E s)" in exI, rule_tac x="hJ" in exI, simp)
apply (elim conjE, hypsubst, simp, elim conjE)
apply (clarsimp simp add: map_add_upd_left disjoint_def)
done

theorem rule_free:
  "\<Gamma> \<turnstile> {E \<longmapsto> E0} Cdispose E {Aemp}"
apply (clarsimp simp add: CSL_def)
apply (case_tac n, simp, clarsimp)
apply (rule conjI)
 apply (clarsimp, erule aborts.cases, simp_all, clarsimp simp add: dom_def)
apply (clarify, erule red.cases, simp_all, clarsimp)
apply (rule_tac x="h(edenot E sa := None)" in exI, rule_tac x="hJ" in exI, simp)
apply (clarsimp, rule ext, simp, clarify, erule dom_eqD, simp)
done

subsubsection {* Simple structural rules (Conseq, Disj, Ex) *}

lemma safe_conseq:
 "\<lbrakk> safe n C s h \<Gamma> Q ; Q \<sqsubseteq> Q' \<rbrakk> \<Longrightarrow> safe n C s h \<Gamma> Q'"
apply (induct n arbitrary: C s h, simp, clarsimp simp add: implies_def)
apply (drule (2) all5_imp2D, simp_all, clarsimp)
apply (drule (1) mall3_impD, rule_tac x="h'" and y="hJ'" in ex2I, simp)
done

theorem rule_conseq:
 "\<lbrakk> \<Gamma> \<turnstile> {P} C {Q} ; P' \<sqsubseteq> P ; Q \<sqsubseteq> Q' \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> {P'} C {Q'}"
by (fastforce simp add: CSL_def implies_def elim!: safe_conseq)

theorem rule_disj:
 "\<lbrakk> \<Gamma> \<turnstile> {P1} C {Q1}; \<Gamma> \<turnstile> {P2} C {Q2} \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> {Adisj P1 P2} C {Adisj Q1 Q2}"
by (clarsimp simp add: CSL_def, safe)
   (rule safe_conseq, simp_all add: implies_def, drule (2) all3_impD, force)+

theorem rule_ex:
 "\<lbrakk> \<forall>n. (\<Gamma> \<turnstile> {P n} C {Q n}) \<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> {Aex P} C {Aex Q}"
by (clarsimp simp add: CSL_def, rule_tac Q = "Q v" in safe_conseq,
    auto simp add: implies_def)

subsubsection {* Conjunction rule *}

lemma safe_conj:
  "\<lbrakk> safe n C s h \<Gamma> Q1;
     safe n C s h \<Gamma> Q2;
     \<forall>r. precise (\<Gamma> r) \<rbrakk>
  \<Longrightarrow> safe n C s h \<Gamma> (Aconj Q1 Q2)"
apply (induct n arbitrary: C s h, simp, clarsimp)
apply (drule (1) all5_impD, clarsimp)+
apply (rule_tac x=h' and y=hJ' in ex2I, simp)
apply (erule mall3_imp2D, simp_all, drule map_add_cancel, simp_all)
apply (drule_tac s="a" and y="h'" and y'="h'a" in preciseD [rotated], simp_all add: hsimps)
apply (auto simp add: envs_def precise_istar)
done

theorem rule_conj:
 "\<lbrakk> \<Gamma> \<turnstile> {P1} C {Q1};
    \<Gamma> \<turnstile> {P2} C {Q2};
    \<forall>r. precise (\<Gamma> r) \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> {Aconj P1 P2} C {Aconj Q1 Q2}"
by (auto simp add: CSL_def intro: safe_conj)

subsubsection {* Auxiliary variables *}

lemma safe_aux:
  "\<lbrakk> safe n C s h \<Gamma> Q; disjoint X (fvC (rem_vars X C) \<union> fvA Q \<union> fvAs \<Gamma>) \<rbrakk>
  \<Longrightarrow> safe n (rem_vars X C) s h \<Gamma> Q"
apply (induct n arbitrary: C s h, simp_all)
apply (intro conjI impI allI, clarsimp)
apply (fastforce intro: aborts_remvars)
apply (elim conjE, erule order_trans [OF accesses_remvars])
apply (clarsimp, frule red_properties, drule aux_red, simp_all)
apply (drule_tac a="hJ ++ hF" in allD, simp add: hsimps)
apply (clarsimp, drule (2) all5_imp2D, clarsimp)
apply (intro exI conjI, simp+)
apply (fastforce simp add: disjoint_commute agreesC)
apply (drule (1) mall3_imp2D, fast)
apply (erule safe_agrees, fastforce simp add: disjoint_commute agreesC)
done

text {* The proof rule for eliminating auxiliary variables. Note that a
  set of variables, @{term X}, is auxiliary for a command @{term C}
  iff it disjoint from @{term "fvC (rem_vars X C)"}. *}

theorem rule_aux:
  "\<lbrakk> \<Gamma> \<turnstile> {P} C {Q} ;
     disjoint X (fvA P \<union> fvA Q \<union> fvAs \<Gamma> \<union> fvC (rem_vars X C)) \<rbrakk>
  \<Longrightarrow> \<Gamma> \<turnstile> {P} rem_vars X C {Q}"
by (auto simp add: CSL_def safe_aux disjoint_commute)

subsection {* Alternative definition of configuration safety *}

text {* Here is an alternative definition of safety monotonicity that does not
  quantify over the frame @{term hF}. *}

primrec
  safe_weak :: "nat \<Rightarrow> cmd \<Rightarrow> stack \<Rightarrow> heap \<Rightarrow> (rname \<Rightarrow> assn) \<Rightarrow> assn \<Rightarrow> bool"
where
  "safe_weak 0       C s h \<Gamma> Q = True"
| "safe_weak (Suc n) C s h \<Gamma> Q = (
(* Condition (i) *)
            (C = Cskip \<longrightarrow> (s, h) \<Turnstile> Q)
(* Condition (ii) *)
          \<and> \<not> aborts C (s, h)
(* Condition (iii) *)
          \<and> accesses C s \<subseteq> dom h
(* Condition (iv) *)
          \<and> (\<forall>hJ C' \<sigma>'.
                  red C (s,h ++ hJ) C' \<sigma>'
                 \<longrightarrow> (s, hJ) \<Turnstile> envs \<Gamma> (llocked C') (llocked C)
                 \<longrightarrow> (disjoint (dom h) (dom hJ))
                 \<longrightarrow> (\<exists>h' hJ'.
                         snd \<sigma>' = h' ++ hJ'
                       \<and> disjoint (dom h') (dom hJ')
                       \<and> (fst \<sigma>', hJ') \<Turnstile> envs \<Gamma> (llocked C) (llocked C')
                       \<and> safe_weak n C' (fst \<sigma>') h' \<Gamma> Q)))"

text {* It is easy to show that the alternative definition is weaker
  than the one with the quantification: *}

lemma safe_weakI:
  "safe n C s h \<Gamma> Q \<Longrightarrow> safe_weak n C s h \<Gamma> Q"
apply (induct n arbitrary: C s h, simp, clarsimp)
apply (rule conjI, drule_tac a=empty in allD, simp)
apply (clarify, drule_tac b=empty in all5D, simp, drule (2) imp2D, fast)
done

text {* If, however, the operational semantics satisfies the safety
monotonicity and frame properties (which it does), then the two
definitions are equivalent.  We first prove that the operational
semantics satisfies these two properties, and then using these
properties, we show that the alternative definition of configuration
safety implies the original one. *}

text {* [A] Safety monotonicity: *}

lemma safety_monotonicity_helper[rule_format]:
  "aborts C \<sigma>  \<Longrightarrow> \<forall>s h hF. \<sigma> = (s, h ++ hF) \<longrightarrow> disjoint (dom h) (dom hF) \<longrightarrow> aborts C (s, h)"
by (erule aborts.induct, auto)

lemma safety_monotonicity:
  "\<lbrakk> aborts C (s, h ++ hF); disjoint (dom h) (dom hF) \<rbrakk> \<Longrightarrow> aborts C (s, h)"
by (erule safety_monotonicity_helper, simp_all)

text {* [B] Frame property: *}

lemma frame_property_helper[rule_format]:
  "red C \<sigma>  C' \<sigma>' \<Longrightarrow> \<forall>s h hF s' h''. \<sigma> = (s, h ++ hF) \<longrightarrow> \<sigma>' = (s', h'')
   \<longrightarrow> disjoint (dom h) (dom hF)
   \<longrightarrow> \<not> aborts C (s, h)
   \<longrightarrow> (\<exists>h'. red C (s, h) C' (s', h') \<and> h'' = h' ++ hF \<and> disjoint (dom h') (dom hF))"
apply (erule red.induct, fastforce+)
-- {* Read *}
apply (clarsimp, rename_tac h hF)
apply (case_tac "h (edenot E s)", erule notE, fastforce)
apply (intro exI conjI red_Read, fast+, simp_all)
apply (fastforce simp add: disjoint_def)
-- {* Write *}
apply (clarsimp, rename_tac h hF)
apply (case_tac "h (edenot E s)", erule notE, fastforce)
apply (rule_tac x="h(edenot E s \<mapsto> edenot E' s)" in exI, intro conjI, fast)
 apply (rule map_add_upd_left [THEN sym], fastforce simp add: disjoint_def)
apply (fastforce simp add: disjoint_def)
-- {* Alloc *}
apply (clarsimp, rename_tac h hF)
apply (rule_tac x="h(v \<mapsto> edenot E s)" in exI, intro conjI)
  apply (rule_tac v=v in red_Alloc, fast+)
 apply (rule map_add_upd_left [THEN sym], fastforce simp add: disjoint_def)
apply (fastforce simp add: disjoint_def)
-- {* Dispose *}
apply (clarsimp, rename_tac h hF)
apply (case_tac "h (edenot E s)", erule notE, fastforce)
  apply (rule_tac x="h(edenot E s := None)" in exI, intro conjI, fast)
 apply (subgoal_tac "hF(edenot E s := None) = hF", simp, rule ext, fastforce simp add: disjoint_def)
apply (fastforce simp add: disjoint_def)
done

lemma frame_property:
  "\<lbrakk> red C (s, h ++ hF) C' (s', h''); disjoint (dom h) (dom hF); \<not> aborts C (s, h) \<rbrakk>
  \<Longrightarrow> \<exists>h'. red C (s, h) C' (s', h') \<and> h'' = h' ++ hF \<and> disjoint (dom h') (dom hF)"
by (erule frame_property_helper, simp_all)

text {* Finally, using safety monotonicity and the frame property, we conclude that
  @{term "safe_weak n C s h \<Gamma> Q"} implies @{term "safe n C s h \<Gamma> Q"}. *}

lemma safe_weakE:
  "safe_weak n C s h \<Gamma> Q \<Longrightarrow> safe n C s h \<Gamma> Q"
apply (induct n arbitrary: C s h, simp, clarsimp)
apply (rule conjI, clarify)
 apply (erule notE, erule (1) safety_monotonicity)
apply (clarify, drule frame_property, simp)
 apply (erule contrapos_nn, erule (1) safety_monotonicity, clarify)
apply (drule (2) all4_imp2D, clarsimp, fast)
done

end


theory Stream_applicative
  imports Main "$HIPSTER_HOME/IsaHipster"
    "types/Stream"
    Smap
begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy

(* Lifting *)
primcorec spure :: "'a \<Rightarrow> 'a Stream" where
  "shd (spure x) = x"
| "stl (spure x) = spure x"

(* Sequential application *)
primcorec sapp :: " ('a \<Rightarrow> 'b) Stream \<Rightarrow> 'a Stream \<Rightarrow> 'b Stream" where
  "shd (sapp fs xs) = (shd fs) (shd xs)"
| "stl (sapp fs xs) = sapp (stl fs) (stl xs)"

(*cohipster smap spure sapp*)
(* Discovered in ca 40 seconds *)
lemma lemma_ac [thy_expl]: "sapp (spure z) x2 = smap z x2"
  by (coinduction arbitrary: x2 z rule: Stream.Stream.coinduct_strong)
  auto

lemma lemma_ad [thy_expl]: "smap y (spure z) = spure (y z)"
  by (coinduction arbitrary: y z rule: Stream.Stream.coinduct_strong)
    auto

lemma lemma_ae [thy_expl]: "smap z (SCons y (spure x2)) = SCons (z y) (spure (z x2))"
  by (coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    (simp add: lemma_ad)

lemma lemma_af [thy_expl]: "sapp (SCons y (spure z)) (spure x2) = SCons (y x2) (spure (z x2))"
  by (coinduction arbitrary: x2 y z rule: Stream.Stream.coinduct_strong)
    (simp add: Stream_applicative.lemma_ac lemma_ad)

(*cohipster sapp spure Fun.comp
== Laws ==
  1. shd (spure x) = x
  2. stl (spure y) = spure y
Warning: generated term of untestable type Stream (X1 -> X2)
  3. sapp (spure f) z = sapp (spure f) z
  4. sapp (spure f) (spure y) = spure (f y)
  5. shd (sapp (spure f) y) = f (shd y)
  6. stl (sapp (spure f) x2) = sapp (spure f) (stl x2)
tip-spec: src/QuickSpec/Eval.hs, line 361: Untestable instance spure (X1 . X2) of testable schema spure (X1 . X1)
CallStack (from HasCallStack):
  error, called at src/QuickSpec/Eval.hs:361:12 in quickspec-2-AOUQDFNL2O4D7eGTuZ37W9:QuickSpec.Eval*)
end


theory WellfoundedExtra
  imports Main
begin

lemma wfP_inj_wfP:
  fixes R :: \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close> and f :: \<open>'a \<Rightarrow> 'b\<close>
  assumes \<open>wfP R\<close> \<open>inj_on f { x . \<exists>y. R x y \<or> R y x }\<close>
  shows \<open>wfP (\<lambda>x y. \<exists>x\<^sub>1 y\<^sub>1. R x\<^sub>1 y\<^sub>1 \<and> x = f x\<^sub>1 \<and> y = f y\<^sub>1)\<close>
proof -
  define X where \<open>X \<equiv> { x . \<exists>y. R x y \<or> R y x }\<close>
  define X' where \<open>X' \<equiv> f ` X\<close>
  define P where \<open>P \<equiv> \<lambda>x y. \<exists>x\<^sub>1 y\<^sub>1. R x\<^sub>1 y\<^sub>1 \<and> x = f x\<^sub>1 \<and> y = f y\<^sub>1\<close>
  define g where \<open>g \<equiv> inv_into X f\<close>
  have f_inj: \<open>inj_on f X\<close>
    using assms(2) by (auto simp: X_def)
  then have f1: \<open>x = y\<close> if \<open>x \<in> X\<close> \<open>y \<in> X\<close> \<open>f x = f y\<close>  for x y
    using that inj_onD by metis
  have g_inj: \<open>inj_on g X'\<close>
    apply (auto simp: g_def X'_def)
    using f_inj by (simp add: inj_on_def)
  then have g1: \<open>x = y\<close> if \<open>x \<in> X'\<close> \<open>y \<in> X'\<close> \<open>g x = g y\<close>  for x y
    using that inj_onD by metis
  have gf[simp]: \<open>g (f x) = x\<close> if \<open>x \<in> X\<close> for x
    using that f_inj by (auto simp: g_def)
  have fg[simp]: \<open>f (g x) = x\<close> if \<open>x \<in> X'\<close> for x
    using that f_inj X'_def by (auto simp: g_def)
  have fg_img[simp]: \<open>f ` g ` Y = Y\<close> if \<open>Y \<subseteq> X'\<close> for Y
    using that apply (auto intro!: that simp: image_def)
    subgoal premises P for x
      apply (intro exI[of _ \<open>g x\<close>] conjI bexI[of _ \<open>x\<close>])
      using P fg by auto
    done
  have P1: \<open>P x y \<Longrightarrow> x \<in> X' \<and> y \<in> X'\<close> for x y
    by (auto simp: X_def X'_def P_def)
  have \<open>\<exists>z. z \<in> Q \<and> (\<forall>y. R y z \<longrightarrow> y \<notin> Q)\<close> if as: \<open>Q \<noteq> {}\<close> for Q
  proof -
    have AA: \<open>\<exists>x. x \<in> Q\<close> using as by blast
    note assms(1)[simplified wf_eq_minimal[to_pred],simplified,rule_format,OF AA]
    then show \<open>\<exists>z. z \<in> Q \<and> (\<forall>y. R y z \<longrightarrow> y \<notin> Q)\<close>
      by blast
  qed
  then obtain pick where
        pick: \<open>\<And>Q. Q \<noteq> {} \<Longrightarrow> pick Q \<in> Q\<close>
              \<open>\<And>Q y. \<lbrakk> Q \<noteq> {} ; R y (pick Q) \<rbrakk> \<Longrightarrow> y \<notin> Q\<close>
    by moura
  show \<open>?thesis\<close>
  proof (clarsimp simp add: wf_eq_minimal[to_pred])
    fix Q and x :: \<open>'b\<close>
    assume as: \<open>x \<in> Q\<close>
    define Q' where Q1: \<open>Q' \<equiv> g ` Q\<close>
    define z where \<open>z \<equiv> if Q \<inter> X' \<noteq> {} then f (pick (g ` (Q \<inter> X'))) else x\<close>
    have \<open>Q \<inter> X' \<subseteq> X'\<close> by blast
    then have fgQX'[simp]: \<open>f ` g ` (Q \<inter> X') = Q \<inter> X'\<close> by simp
    show \<open>\<exists>z\<in>Q. \<forall>y. (\<exists>x\<^sub>1 y\<^sub>1. R x\<^sub>1 y\<^sub>1 \<and> y = f x\<^sub>1 \<and> z = f y\<^sub>1) \<longrightarrow> y \<notin> Q\<close>
    proof (intro bexI[of _ \<open>z\<close>] allI impI ; (elim exE conjE)?)
      show \<open>z \<in> Q\<close>
      proof (cases \<open>g ` (Q \<inter> X') = {}\<close>)
        assume as1: \<open>g ` (Q \<inter> X') = {}\<close>
        then have \<open>Q \<inter> X' = {}\<close> by auto
        then have \<open>z = x\<close> by (auto simp: z_def)
        then show \<open>z \<in> Q\<close> using as by simp
      next
        assume as1: \<open>g ` (Q \<inter> X') \<noteq> {}\<close>
        then have \<open>Q \<inter> X' \<noteq> {}\<close> by auto
        then have z: \<open>z = f (pick (g ` (Q \<inter> X')))\<close> by (auto simp: z_def)
        have \<open>pick (g ` (Q \<inter> X')) \<in> g ` (Q \<inter> X')\<close>
          using pick[of \<open>g ` (Q \<inter> X')\<close>] as1 by blast
        then have \<open>f (pick (g ` (Q \<inter> X'))) \<in> Q\<close>
          by (auto simp: z_def)
        then show \<open>z \<in> Q\<close> using z by simp
      qed
      fix y x\<^sub>1 y\<^sub>1
      assume as1: \<open>R x\<^sub>1 y\<^sub>1\<close> \<open>y = f x\<^sub>1\<close> \<open>z = f y\<^sub>1\<close>
      then have x1y1: \<open>x\<^sub>1 \<in> X\<close> \<open>y\<^sub>1 \<in> X\<close> using X_def by auto
      then have yz: \<open>y \<in> X'\<close> \<open>z \<in> X'\<close> using X'_def as1 by auto
      show \<open>y \<notin> Q\<close>
      proof
        assume as2: \<open>y \<in> Q\<close>
        then have QX': \<open>Q \<inter> X' \<noteq> {}\<close> using yz by blast
        then have z: \<open>z = f (pick (g ` (Q \<inter> X')))\<close> using z_def by auto
        have gQX'_ss: \<open>g ` (Q \<inter> X') \<subseteq> X\<close> using X'_def by auto
        have \<open>g ` (Q \<inter> X') \<noteq> {}\<close> using QX' by blast
        then obtain pick1: \<open>pick (g ` (Q \<inter> X')) \<in> g ` (Q \<inter> X')\<close>
            \<open>\<And>y. R y (pick (g ` (Q \<inter> X'))) \<Longrightarrow> y \<notin> g ` (Q \<inter> X')\<close>
          using pick by metis
        then have \<open>pick (g ` (Q \<inter> X')) \<in> X\<close> using gQX'_ss by blast
        then have \<open>y\<^sub>1 = pick (g ` (Q \<inter> X'))\<close>
          using f1  x1y1(2) z as1(3) by metis
        then have pick2: \<open>\<And>y. R y y\<^sub>1 \<Longrightarrow> y \<notin> g ` (Q \<inter> X')\<close>
          using pick1(2) by auto
        then have \<open>x\<^sub>1 \<notin> g ` (Q \<inter> X')\<close> using as1(1) by metis
        then show \<open>False\<close>
          by (metis IntI as1(2) as2 gf imageI x1y1(1) yz(1))
      qed
    qed
  qed
qed

end


section \<open>The Ford-Fulkerson Method\<close>
theory FordFulkerson_Algo
imports
  Flow_Networks.Ford_Fulkerson
  Flow_Networks.Refine_Add_Fofu
begin
text \<open>In this theory, we formalize the abstract Ford-Fulkerson
  method, which is independent of how an augmenting path is chosen\<close>

context Network
begin

subsection \<open>Algorithm\<close>
text \<open>
  We abstractly specify the procedure for finding an augmenting path:
  Assuming a valid flow, the procedure must return an augmenting path
  iff there exists one.
  \<close>
definition "find_augmenting_spec f \<equiv> do {
    assert (NFlow c s t f);
    select p. NPreflow.isAugmentingPath c s t f p
  }"

text \<open>Moreover, we specify augmentation of a flow along a path\<close>
definition (in NFlow) "augment_with_path p \<equiv> augment (augmentingFlow p)"

text \<open>
  We also specify the loop invariant, and annotate it to the loop.
\<close>
abbreviation "fofu_invar \<equiv> \<lambda>(f,brk).
        NFlow c s t f
      \<and> (brk \<longrightarrow> (\<forall>p. \<not>NPreflow.isAugmentingPath c s t f p))
    "

text \<open>Finally, we obtain the Ford-Fulkerson algorithm.
  Note that we annotate some assertions to ease later refinement\<close>
definition "fofu \<equiv> do {
  let f\<^sub>0 = (\<lambda>_. 0);

  (f,_) \<leftarrow> while\<^bsup>fofu_invar\<^esup>
    (\<lambda>(f,brk). \<not>brk)
    (\<lambda>(f,_). do {
      p \<leftarrow> find_augmenting_spec f;
      case p of
        None \<Rightarrow> return (f,True)
      | Some p \<Rightarrow> do {
          assert (p\<noteq>[]);
          assert (NPreflow.isAugmentingPath c s t f p);
          let f = NFlow.augment_with_path c f p;
          assert (NFlow c s t f);
          return (f, False)
        }
    })
    (f\<^sub>0,False);
  assert (NFlow c s t f);
  return f
}"

subsection \<open>Partial Correctness\<close>
text \<open>Correctness of the algorithm is a consequence from the
  Ford-Fulkerson theorem. We need a few straightforward
  auxiliary lemmas, though:
\<close>

text \<open>The zero flow is a valid flow\<close>
lemma zero_flow: "NFlow c s t (\<lambda>_. 0)"
  apply unfold_locales
  by (auto simp: s_node t_node cap_non_negative)

text \<open>Augmentation preserves the flow property\<close>
lemma (in NFlow) augment_pres_nflow:
  assumes AUG: "isAugmentingPath p"
  shows "NFlow c s t (augment (augmentingFlow p))"
proof -
  from augment_flow_presv[OF augFlow_resFlow[OF AUG]]
  interpret f': Flow c s t "augment (augmentingFlow p)" .
  show ?thesis by intro_locales
qed

text \<open>Augmenting paths cannot be empty\<close>
lemma (in NFlow) augmenting_path_not_empty:
  "\<not>isAugmentingPath []"
  unfolding isAugmentingPath_def using s_not_t by auto

text \<open>Finally, we can use the verification condition generator to
  show correctness\<close>

subsection \<open>Algorithm without Assertions\<close>
text \<open>For presentation purposes, we extract a version of the algorithm
  without assertions, and using a bit more concise notation\<close>

context begin

private abbreviation (input) "augment
  \<equiv> NFlow.augment_with_path"
private abbreviation (input) "is_augmenting_path f p
  \<equiv> NPreflow.isAugmentingPath c s t f p"

text \<open> {} \<close>
text_raw \<open>\DefineSnippet{ford_fulkerson_algo}{\<close>
definition "ford_fulkerson_method \<equiv> do {
  let f\<^sub>0 = (\<lambda>(u,v). 0);

  (f,brk) \<leftarrow> while (\<lambda>(f,brk). \<not>brk)
    (\<lambda>(f,brk). do {
      p \<leftarrow> select p. is_augmenting_path f p;
      case p of
        None \<Rightarrow> return (f,True)
      | Some p \<Rightarrow> return (augment c f p, False)
    })
    (f\<^sub>0,False);
  return f
}"
text_raw \<open>}%EndSnippet\<close>

text \<open> {} \<close>

end \<comment> \<open>Anonymous context\<close>
end \<comment> \<open>Network\<close>

text \<open> {} \<close>
text_raw \<open>\DefineSnippet{ford_fulkerson_correct}{\<close>
theorem (in Network) "ford_fulkerson_method \<le> (spec f. isMaxFlow f)"
text_raw \<open>}%EndSnippet\<close>
text \<open> {} \<close>
proof -
  have [simp]: "(\<lambda>(u,v). 0) = (\<lambda>_. 0)" by auto
  have "ford_fulkerson_method \<le> fofu"
    unfolding ford_fulkerson_method_def fofu_def Let_def find_augmenting_spec_def
    apply (rule refine_IdD)
    apply (refine_vcg)
    apply (refine_dref_type)
    apply (vc_solve simp: NFlow.augment_with_path_def solve: exI)
    done
  also note fofu_partial_correct
  finally show ?thesis .
qed

end \<comment> \<open>Theory\<close>


section "Simulation proofs"

theory simulation_proofs
  imports execution_invariants
begin

text "We establish a general rule for doing simulation proofs on the semantics.
The function @{term f} transforms an original trace to the simulation trace.
The predicate @{term P} relates the original trace and state with the simulation trace and state."

lemma trace_simulationProof[consumes 1, case_names initial f_empty_to_empty induct_step[coupling steps1 steps2 step]]:
  assumes steps_tr: "init ~~ tr \<leadsto>* S"
    and P_initial: "P [] [] init init"
    and f_empty_to_empty: "f [] = []"
    and induct_step: "\<And>tr a S1 S2 S1'. \<lbrakk>P tr (f tr) S1 S2; init ~~ tr \<leadsto>* S1; init ~~ f tr \<leadsto>* S2; S1 ~~ a \<leadsto> S1'\<rbrakk>
      \<Longrightarrow> \<exists>S2'. (init ~~ f (tr@[a]) \<leadsto>* S2') \<and> P (tr@[a]) (f (tr@[a])) S1' S2'"
  shows "\<exists>S'. (init ~~ f tr \<leadsto>* S') \<and>  P tr (f tr) S S'"
  using steps_tr proof (induct rule: steps_induct)
  case initial
  show ?case
    using P_initial steps_refl by (auto simp add: f_empty_to_empty  )

next
  case (step S' tr a S'')
  from this
  obtain S1'
    where S1'_step: "init ~~ f tr \<leadsto>* S1'"
      and S1'_P: "P tr (f tr) S' S1'"
    by blast

  from induct_step[OF S1'_P \<open>init ~~ tr \<leadsto>* S'\<close> S1'_step \<open> S' ~~ a \<leadsto> S''\<close>]
  obtain S2'
    where S2'_steps: "init ~~ f (tr @ [a]) \<leadsto>* S2'"
      and S2'_P: "P (tr @ [a]) (f (tr @ [a])) S'' S2'"
    by blast

  then show " \<exists>S'. (init ~~ f (tr @ [a]) \<leadsto>* S') \<and> P (tr @ [a]) (f (tr @ [a])) S'' S'"
    by blast
qed

end


theory ex11
  imports "HOL-Data_Structures.Leftist_Heap"
begin

fun lh_insert::"'a::ord \<Rightarrow> 'a lheap \<Rightarrow> 'a lheap" where
  "lh_insert x Leaf = Node Leaf (x, 1) Leaf"
| "lh_insert x (Node l (y, k) r) = (if x \<ge> y then (node l y (lh_insert x r))
                                    else (node l x (lh_insert y r)))"

lemma set_lh_insert: "set_tree (lh_insert x t) = set_tree t \<union> {x}"
  apply(induction t arbitrary:x)
   apply (auto split: if_splits simp: node_def)
  done

declare[[names_short]]

value "lh_insert 1 \<langle>\<langle>\<rangle>, (0::nat, 1), \<langle>\<rangle>\<rangle>"

find_theorems "\<forall>_\<in>(_\<union>_). _"

lemma "heap (t::nat lheap) \<Longrightarrow> heap (lh_insert x t)"
  apply(induction t arbitrary: x)
   apply (fastforce simp: node_def set_lh_insert ball_Un)+
  done

lemma "ltree t \<Longrightarrow> ltree (lh_insert x t)"
  apply(induction t arbitrary:x)
   apply (auto split: if_splits simp: node_def)
  done

fun t_lh_insert::"'a::ord \<Rightarrow> 'a lheap \<Rightarrow> nat" where
  "t_lh_insert x Leaf = 1"
| "t_lh_insert x (Node l (y, k) r) = 1 + (if x \<ge> y then (t_lh_insert x r)
                                          else (t_lh_insert y r))"

lemma "t_lh_insert x t \<le> rank t + 1"
  apply(induction t arbitrary: x)
   apply auto
  done

find_theorems "(\<in>#)" "(-)::'a multiset \<Rightarrow> 'a multiset \<Rightarrow> 'a multiset"

datatype ('a, 's) bs_pq = Empty | Heap 'a 's

locale Bs_Priority_Queue =
  orig: Priority_Queue where
    empty = orig_empty and
    is_empty = orig_is_empty and
    insert = orig_insert and
    get_min = orig_get_min and
    del_min = orig_del_min and
    invar = orig_invar and
    mset = orig_mset
  for orig_empty orig_is_empty orig_insert orig_get_min orig_del_min orig_invar
  and orig_mset :: "'s \<Rightarrow> 'a::linorder multiset"
begin

definition empty where
  "empty = Empty"

fun is_empty where
  "is_empty Empty = True"
| "is_empty (Heap _ _) = False "

fun insert where
  "insert x Empty = Heap x orig_empty"
| "insert x (Heap m q) = (if x < m then Heap x (orig_insert m q) else Heap m (orig_insert x q))"

fun get_min where
 "get_min (Heap m _) = m"

fun del_min where
 "del_min (Heap m q) = (if orig_is_empty q then Empty
                        else Heap (orig_get_min q) (orig_del_min q))"

fun invar where
  "invar Empty = True"
| "invar (Heap m q) = ((orig_invar q) \<and> (\<forall>x\<in>set_mset (orig_mset q). m \<le> x))"

fun mset where
  "mset Empty = {#}"
| "mset (Heap m q) = add_mset m (orig_mset q)"

lemmas [simp] = orig.mset_empty orig.is_empty orig.mset_insert orig.mset_del_min
                orig.mset_get_min orig.invar_empty orig.invar_insert orig.invar_del_min

sublocale Priority_Queue where
  empty = empty
  and is_empty=is_empty
  and insert=insert
  and get_min=get_min
  and del_min=del_min
  and invar=invar
  and mset=mset
  apply unfold_locales
proof goal_cases
case 1
  then show ?case
    by (auto simp add: empty_def)
next
  case (2 q)
  then show ?case
    by (cases q) auto
next
  case (3 q x)
  then show ?case
    by (cases q) auto
next
  case (4 q)
  then show ?case
    by (cases q) auto
next
  case (5 q)
  then show ?case
    by (cases q) (auto simp: Min_insert2)
next
  case 6
  then show ?case
    by (auto simp: empty_def)
next
  case (7 q x)
  then show ?case
    by (cases q) auto
next
  case (8 q)
  then show ?case
    apply (cases q)
    using in_diffD
    by force+
qed
end

end

end


section \<open>Deciding Regular Expression Equivalence (2)\<close>

theory pEquivalence_Checking
imports Equivalence_Checking Derivatives
begin

text\<open>\noindent Similar to theory @{theory "Regular-Sets.Equivalence_Checking"}, but
with partial derivatives instead of derivatives.\<close>

text\<open>Lifting many notions to sets:\<close>

definition "Lang R == UN r:R. lang r"
definition "Nullable R == EX r:R. nullable r"
definition "Pderiv a R == UN r:R. pderiv a r"
definition "Atoms R == UN r:R. atoms r"

(* FIXME: rename pderiv_set in Derivatives to Pderiv and drop the one above *)

lemma Atoms_pderiv: "Atoms(pderiv a r) \<subseteq> atoms r"
apply (induct r)
apply (auto simp: Atoms_def UN_subset_iff)
apply (fastforce)+
done

lemma Atoms_Pderiv: "Atoms(Pderiv a R) \<subseteq> Atoms R"
using Atoms_pderiv by (fastforce simp: Atoms_def Pderiv_def)

lemma pderiv_no_occurrence:
  "x \<notin> atoms r \<Longrightarrow> pderiv x r = {}"
by (induct r) auto

lemma Pderiv_no_occurrence:
  "x \<notin> Atoms R \<Longrightarrow> Pderiv x R = {}"
by(auto simp:pderiv_no_occurrence Atoms_def Pderiv_def)

lemma Deriv_Lang: "Deriv c (Lang R) = Lang (Pderiv c R)"
by(auto simp: Deriv_pderiv Pderiv_def Lang_def)

lemma Nullable_pderiv[simp]: "Nullable(pderivs w r) = (w : lang r)"
apply(induction w arbitrary: r)
apply (simp add: Nullable_def nullable_iff singleton_iff)
using eqset_imp_iff[OF Deriv_pderiv[where 'a = 'a]]
apply (simp add: Nullable_def Deriv_def)
done

type_synonym 'a Rexp_pair = "'a rexp set * 'a rexp set"
type_synonym 'a Rexp_pairs = "'a Rexp_pair list"

definition is_Bisimulation :: "'a list \<Rightarrow> 'a Rexp_pairs \<Rightarrow> bool"
where
"is_Bisimulation as ps =
  (\<forall>(R,S)\<in> set ps. Atoms R \<union> Atoms S \<subseteq> set as \<and>
    (Nullable R \<longleftrightarrow> Nullable S) \<and>
    (\<forall>a\<in>set as. (Pderiv a R, Pderiv a S) \<in> set ps))"

lemma Bisim_Lang_eq:
assumes Bisim: "is_Bisimulation as ps"
assumes "(R, S) \<in> set ps"
shows "Lang R = Lang S"
proof -
  define ps' where "ps' = ({}, {}) # ps"
  from Bisim have Bisim': "is_Bisimulation as ps'"
    by (fastforce simp: ps'_def is_Bisimulation_def UN_subset_iff Pderiv_def Atoms_def)
  let ?R = "\<lambda>K L. (\<exists>(R,S)\<in>set ps'. K = Lang R \<and> L = Lang S)"
  show ?thesis
  proof (rule language_coinduct[where R="?R"])
    from \<open>(R,S) \<in> set ps\<close>
    have "(R,S) \<in> set ps'" by (auto simp: ps'_def)
    thus "?R (Lang R) (Lang S)" by auto
  next
    fix K L assume "?R K L"
    then obtain R S where rs: "(R, S) \<in> set ps'"
      and KL: "K = Lang R" "L = Lang S" by auto
    with Bisim' have "Nullable R \<longleftrightarrow> Nullable S"
      by (auto simp: is_Bisimulation_def)
    thus "[] \<in> K \<longleftrightarrow> [] \<in> L"
      by (auto simp: nullable_iff KL Nullable_def Lang_def)
    fix a
    show "?R (Deriv a K) (Deriv a L)"
    proof cases
      assume "a \<in> set as"
      with rs Bisim'
      have "(Pderiv a R, Pderiv a S) \<in> set ps'"
        by (auto simp: is_Bisimulation_def)
      thus ?thesis by (fastforce simp: KL Deriv_Lang)
    next
      assume "a \<notin> set as"
      with Bisim' rs
      have "a \<notin> Atoms R \<union> Atoms S"
        by (fastforce simp: is_Bisimulation_def UN_subset_iff)
      then have "Pderiv a R = {}" "Pderiv a S = {}"
        by (metis Pderiv_no_occurrence Un_iff)+
      then have "Deriv a K = Lang {}" "Deriv a L = Lang {}"
        unfolding KL Deriv_Lang by auto
      thus ?thesis by (auto simp: ps'_def)
    qed
  qed
qed

subsection \<open>Closure computation\<close>

fun test :: "'a Rexp_pairs * 'a Rexp_pairs \<Rightarrow> bool" where
"test (ws, ps) = (case ws of [] \<Rightarrow>  False | (R,S)#_ \<Rightarrow> Nullable R = Nullable S)"

fun step :: "'a list \<Rightarrow>
  'a Rexp_pairs * 'a Rexp_pairs \<Rightarrow> 'a Rexp_pairs * 'a Rexp_pairs"
where "step as (ws,ps) =
    (let
      (R,S) = hd ws;
      ps' = (R,S) # ps;
      succs = map (\<lambda>a. (Pderiv a R, Pderiv a S)) as;
      new = filter (\<lambda>p. p \<notin> set ps \<union> set ws) succs
    in (remdups new @ tl ws, ps'))"

definition closure ::
  "'a list \<Rightarrow> 'a Rexp_pairs * 'a Rexp_pairs
   \<Rightarrow> ('a Rexp_pairs * 'a Rexp_pairs) option" where
"closure as = while_option test (step as)"

definition pre_Bisim :: "'a list \<Rightarrow> 'a rexp set \<Rightarrow> 'a rexp set \<Rightarrow>
 'a Rexp_pairs * 'a Rexp_pairs \<Rightarrow> bool"
where
"pre_Bisim as R S = (\<lambda>(ws,ps).
 ((R,S) \<in> set ws \<union> set ps) \<and>
 (\<forall>(R,S)\<in> set ws \<union> set ps. Atoms R \<union> Atoms S \<subseteq> set as) \<and>
 (\<forall>(R,S)\<in> set ps. (Nullable R \<longleftrightarrow> Nullable S) \<and>
   (\<forall>a\<in>set as. (Pderiv a R, Pderiv a S) \<in> set ps \<union> set ws)))"

lemma step_set_eq: "\<lbrakk> test (ws,ps); step as (ws,ps) = (ws',ps') \<rbrakk>
  \<Longrightarrow> set ws' \<union> set ps' =
     set ws \<union> set ps
     \<union> (\<Union>a\<in>set as. {(Pderiv a (fst(hd ws)), Pderiv a (snd(hd ws)))})"
by(auto split: list.splits)

subsection \<open>The overall procedure\<close>

definition check_eqv :: "'a rexp \<Rightarrow> 'a rexp \<Rightarrow> bool"
where
"check_eqv r s =
  (case closure (add_atoms r (add_atoms s [])) ([({r}, {s})], []) of
     Some([],_) \<Rightarrow> True | _ \<Rightarrow> False)"

text\<open>Test:\<close>
lemma "check_eqv
  (Plus One (Times (Atom 0) (Star(Atom 0))))
  (Star(Atom(0::nat)))"
by eval

subsection "Termination and Completeness"

definition PDERIVS :: "'a rexp set => 'a rexp set" where
"PDERIVS R = (UN r:R. pderivs_lang UNIV r)"

lemma PDERIVS_incr[simp]: "R \<subseteq> PDERIVS R"
apply(auto simp add: PDERIVS_def pderivs_lang_def)
by (metis pderivs.simps(1) insertI1)

lemma Pderiv_PDERIVS: assumes "R' \<subseteq> PDERIVS R" shows "Pderiv a R' \<subseteq> PDERIVS R"
proof
  fix r assume "r : Pderiv a R'"
  then obtain r' where "r' : R'" "r : pderiv a r'" by(auto simp: Pderiv_def)
  from \<open>r' : R'\<close> \<open>R' \<subseteq> PDERIVS R\<close> obtain s w where "s : R" "r' : pderivs w s"
    by(auto simp: PDERIVS_def pderivs_lang_def)
  hence "r \<in> pderivs (w @ [a]) s" using \<open>r : pderiv a r'\<close> by(auto simp add:pderivs_snoc)
  thus "r : PDERIVS R" using \<open>s : R\<close> by(auto simp: PDERIVS_def pderivs_lang_def)
qed

lemma finite_PDERIVS: "finite R \<Longrightarrow> finite(PDERIVS R)"
by(simp add: PDERIVS_def finite_pderivs_lang_UNIV)

lemma closure_Some: assumes "finite R0" "finite S0" shows "\<exists>p. closure as ([(R0,S0)],[]) = Some p"
proof(unfold closure_def)
  let ?Inv = "%(ws,bs).  distinct ws \<and> (ALL (R,S) : set ws. R \<subseteq> PDERIVS R0 \<and> S \<subseteq> PDERIVS S0 \<and> (R,S) \<notin> set bs)"
  let ?m1 = "%bs. Pow(PDERIVS R0) \<times> Pow(PDERIVS S0) - set bs"
  let ?m2 = "%(ws,bs). card(?m1 bs)"
  have Inv0: "?Inv ([(R0, S0)], [])" by simp
  { fix s assume "test s" "?Inv s"
    obtain ws bs where [simp]: "s = (ws,bs)" by fastforce
    from \<open>test s\<close> obtain R S ws' where [simp]: "ws = (R,S)#ws'"
      by(auto split: prod.splits list.splits)
    let ?bs' = "(R,S) # bs"
    let ?succs = "map (\<lambda>a. (Pderiv a R, Pderiv a S)) as"
    let ?new = "filter (\<lambda>p. p \<notin> set bs \<union> set ws) ?succs"
    let ?ws' = "remdups ?new @ ws'"
    have *: "?Inv (step as s)"
    proof -
      from \<open>?Inv s\<close> have "distinct ?ws'" by auto
      have "ALL (R,S) : set ?ws'. R \<subseteq> PDERIVS R0 \<and> S \<subseteq> PDERIVS S0 \<and> (R,S) \<notin> set ?bs'" using \<open>?Inv s\<close>
        by(simp add: Ball_def image_iff) (metis Pderiv_PDERIVS)
      with \<open>distinct ?ws'\<close> show ?thesis by(simp)
    qed
    have "?m2(step as s) < ?m2 s"
    proof -
      have "finite(?m1 bs)"
        by(metis assms finite_Diff finite_PDERIVS finite_cartesian_product finite_Pow_iff)
      moreover have "?m2(step as s) < ?m2 s" using \<open>?Inv s\<close>
        by(auto intro: psubset_card_mono[OF \<open>finite(?m1 bs)\<close>])
      then show ?thesis using \<open>?Inv s\<close> by simp
    qed
    note * and this
  } note step = this
  show "\<exists>p. while_option test (step as) ([(R0, S0)], []) = Some p"
    by(rule measure_while_option_Some [where P = ?Inv and f = ?m2, OF _ Inv0])(simp add: step)
qed

theorem closure_Some_Inv: assumes "closure as ([({r},{s})],[]) = Some p"
shows "\<forall>(R,S)\<in>set(fst p). \<exists>w. R = pderivs w r \<and> S = pderivs w s" (is "?Inv p")
proof-
  from assms have 1: "while_option test (step as) ([({r},{s})],[]) = Some p"
    by(simp add: closure_def)
  have Inv0: "?Inv ([({r},{s})],[])" by simp (metis pderivs.simps(1))
  { fix p assume "?Inv p" "test p"
    obtain ws bs where [simp]: "p = (ws,bs)" by fastforce
    from \<open>test p\<close> obtain R S ws' where [simp]: "ws = (R,S)#ws'"
      by(auto split: prod.splits list.splits)
    let ?succs = "map (\<lambda>a. (Pderiv a R, Pderiv a S)) as"
    let ?new = "filter (\<lambda>p. p \<notin> set bs \<union> set ws) ?succs"
    let ?ws' = "remdups ?new @ ws'"
    from \<open>?Inv p\<close> obtain w where [simp]: "R = pderivs w r" "S = pderivs w s"
      by auto
    { fix x assume "x : set as"
      have "EX w. Pderiv x R = pderivs w r \<and> Pderiv x S = pderivs w s"
        by(rule_tac x="w@[x]" in exI)(simp add: pderivs_append Pderiv_def)
    }
    with \<open>?Inv p\<close> have "?Inv (step as p)" by auto
  } note Inv_step = this
  show ?thesis
    apply(rule while_option_rule[OF _ 1])
    apply(erule (1) Inv_step)
    apply(rule Inv0)
    done
qed

lemma closure_complete: assumes "lang r = lang s"
 shows "EX bs. closure as ([({r},{s})],[]) = Some([],bs)" (is ?C)
proof(rule ccontr)
  assume "\<not> ?C"
  then obtain R S ws bs
    where cl: "closure as ([({r},{s})],[]) = Some((R,S)#ws,bs)"
    using closure_Some[of "{r}" "{s}", simplified]
    by (metis (hide_lams, no_types) list.exhaust prod.exhaust)
  from assms closure_Some_Inv[OF this]
    while_option_stop[OF cl[unfolded closure_def]]
  show "False" by auto
qed

corollary completeness: "lang r = lang s \<Longrightarrow> check_eqv r s"
by(auto simp add: check_eqv_def dest!: closure_complete
      split: option.split list.split)

end


           (*-------------------------------------------*
            |        CSP-Prover on Isabelle2004         |
            |               December 2004               |
            |                                           |
            |        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 CPO_pair
imports CPO
begin

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

         1. Pairs of CPO are also CPO.
         2.
         3.
         4.

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

(*  Take care the following rules automatically applied                *)
(*                                                                     *)
(*          split_paired_Ex:  (EX x. P x) = (EX a b. P (a, b))         *)
(*          split_paired_All: (ALL x. P x) = (ALL a b. P (a, b))       *)

(**********************************************************
              def: pair of bot
 **********************************************************)

instantiation prod :: (bot, bot) bot0
begin

definition
  pair_Bot_def : "Bot == (Bot, Bot)"

instance ..

end

(* isabelle 2009-1
defs (overloaded)
  pair_Bot_def : "Bot == (Bot, Bot)"
*)

(************************************************************
                   Pairuct bot ==> bot
 ************************************************************)

(*** pair Bot ***)

lemma pair_Bot:
  "ALL (x::('x::bot * 'y::bot)). Bot <= x"
apply (simp add: order_pair_def)
by (auto simp add: pair_Bot_def bottom_bot)

(*****************************
       Pair bot => bot
 *****************************)

instance prod :: (bot, bot) bot
apply (intro_classes)
by (simp add: pair_Bot)

(*
definition
  pair_Bot_def : "Bot == (Bot, Bot)"

  instance proof
  fix x :: "'a * 'b"
  show "Bot <= x"
   apply (simp add: pair_Bot_def)
   apply (simp add: order_pair_def)
   apply (auto simp add: bottom_bot)
   done
  qed
*)

(************************************************************
                   Pair CPO ==> CPO
 ************************************************************)

(*** pair directed decompo ***)

declare split_paired_Ex  [simp del]
declare split_paired_All [simp del]

lemma pair_directed_decompo_fst:
  "directed (Xc::('x::cpo * 'y::cpo) set) ==> directed (fst ` Xc)"
apply (simp add: directed_def)
apply (intro allI impI)
apply (simp add: in_image_set)
apply (elim conjE exE)
apply (drule_tac x="ya" in spec)
apply (drule_tac x="yb" in spec)
apply (simp)

apply (elim conjE exE)
apply (rule_tac x="fst z" in exI)
by (auto simp add: order_pair_def)

lemma pair_directed_decompo_snd:
  "directed (Xc::('x::cpo * 'y::cpo) set) ==> directed (snd ` Xc)"
apply (simp add: directed_def)
apply (intro allI impI)
apply (simp add: in_image_set)
apply (elim conjE exE)
apply (drule_tac x="ya" in spec)
apply (drule_tac x="yb" in spec)
apply (simp)

apply (elim conjE exE)
apply (rule_tac x="snd z" in exI)
by (auto simp add: order_pair_def)

declare split_paired_Ex  [simp]
declare split_paired_All [simp]

(*** pair cpo lemma ***)

lemma pair_cpo_lm:
  "directed (Xc::('x::cpo * 'y::cpo) set) ==> Xc hasLUB"
apply (simp add: hasLUB_def)
apply (rule_tac x="LUB (fst ` Xc)" in exI)
apply (rule_tac x="LUB (snd ` Xc)" in exI)
apply (simp add: pair_LUB_decompo)

apply (insert pair_directed_decompo_fst[of Xc])
apply (insert pair_directed_decompo_snd[of Xc])
apply (simp)

apply (insert complete_cpo_lm)
apply (drule_tac x="fst ` Xc" in spec)
apply (insert complete_cpo_lm)
apply (drule_tac x="snd ` Xc" in spec)
by (simp add: isLUB_to_LUB)

(*****************************
       Pair CPO => CPO
 *****************************)

instance prod :: (cpo,cpo) cpo
apply (intro_classes)
by (simp add: pair_cpo_lm del: split_paired_Ex)

(************************************************************
                Pairuct CPO_BOT ==> CPO_BOT
 ************************************************************)

instance prod :: (cpo_bot,cpo_bot) cpo_bot
by (intro_classes)

(************************************************************
                     fst continuity
 ************************************************************)

lemma fst_continuous: "continuous fst"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (insert complete_cpo_lm)
apply (drule_tac x="X" in spec)
apply (simp add: hasLUB_def)

apply (elim exE)
apply (rule_tac x="a" in exI)
apply (simp add: pair_LUB_decompo)
apply (rule_tac x="b" in exI)
by (simp)

lemma snd_continuous: "continuous snd"
apply (simp add: continuous_iff)
apply (intro allI impI)
apply (insert complete_cpo_lm)
apply (drule_tac x="X" in spec)
apply (simp add: hasLUB_def)

apply (elim exE)
apply (rule_tac x="a" in exI)
apply (rule_tac x="b" in exI)
by (simp add: pair_LUB_decompo)

(************************************************************
                   Pair continuity
 ************************************************************)

lemma pair_continuous_only_if:
  "continuous h
   ==> (continuous (fst o h) & continuous (snd o h))"
by (simp add: fst_continuous snd_continuous compo_continuous)

lemma pair_continuous_if:
  "[| continuous (fst o h) ; continuous (snd o h) |]
   ==> continuous h"
apply (simp add: continuous_iff)
apply (insert complete_cpo_lm)
apply (intro allI impI)
apply (drule_tac x="X" in spec)
apply (simp)

apply (erule exE)
apply (rule_tac x="x" in exI)
apply (simp)

apply (simp add: pair_LUB_decompo)
apply (erule conjE)
apply (drule_tac x="X" in spec)
apply (drule_tac x="X" in spec)
apply (simp)

apply (elim exE)
(* apply (simp add: image_compose) *)
apply (simp add: image_comp)
apply (subgoal_tac "x = xa", simp)
by (simp add: LUB_unique)

lemma pair_continuous:
  "continuous h = (continuous (fst o h) & continuous (snd o h))"
apply (rule iffI)
apply (simp add: pair_continuous_only_if)
apply (simp add: pair_continuous_if)
done

end


theory Util
  imports Main
begin

lemma prod_split_asmE:
  "\<lbrakk> (a,b) = x; P (fst x) (snd x) \<rbrakk> \<Longrightarrow> P a b"
  by (clarsimp split: prod.split)

lemma prod_eq:
  "\<lbrakk> a = fst x ; b = snd x \<rbrakk> \<Longrightarrow> x = (a,b)"
  by simp

end


header{* Pseudo Waisberg Algebra *}

theory PseudoWaisbergAlgebra
imports Operations
begin

class impl_lr_algebra = one + left_imp + right_imp +
  assumes W1a [simp]: "1 l\<rightarrow> a = a"
  and W1b [simp]: "1 r\<rightarrow> a = a"

  and W2a: "(a l\<rightarrow> b) r\<rightarrow> b = (b l\<rightarrow> a) r\<rightarrow> a"
  and W2b: "(b l\<rightarrow> a) r\<rightarrow> a = (b r\<rightarrow> a) l\<rightarrow> a"
  and W2c: "(b r\<rightarrow> a) l\<rightarrow> a = (a r\<rightarrow> b) l\<rightarrow> b"

  and W3a: "(a l\<rightarrow> b) l\<rightarrow> ((b l\<rightarrow> c) r\<rightarrow> (a l\<rightarrow> c)) = 1"
  and W3b: "(a r\<rightarrow> b) r\<rightarrow> ((b r\<rightarrow> c) l\<rightarrow> (a r\<rightarrow> c)) = 1"

begin

lemma P1_a [simp]: "x l\<rightarrow> x = 1"
  apply (cut_tac a = 1 and b = 1 and c = x in W3b)
  by simp

lemma P1_b [simp]: "x r\<rightarrow> x = 1"
  apply (cut_tac a = 1 and b = 1 and c = x in W3a)
  by simp

lemma P2_b: "x r\<rightarrow> y = 1 \<Longrightarrow> y r\<rightarrow> x = 1 \<Longrightarrow> x = y"
  apply (subgoal_tac "(y r\<rightarrow> x) l\<rightarrow> x = y")
  apply simp
  apply (subgoal_tac "(x r\<rightarrow> y) l\<rightarrow> y = y")
  apply (unfold W2c)
  by simp_all

lemma P2_c: "x l\<rightarrow> y = 1 \<Longrightarrow> y r\<rightarrow> x = 1 \<Longrightarrow> x = y"
  apply (subgoal_tac "(y r\<rightarrow> x) l\<rightarrow> x = y")
  apply simp
  apply (subgoal_tac "(x l\<rightarrow> y) r\<rightarrow> y = y")
  apply (unfold W2b) [1]
  apply (unfold W2c) [1]
  by simp_all

lemma P3_a: "(x l\<rightarrow> 1) r\<rightarrow> 1 = 1"
  apply (unfold W2a)
  by simp

lemma P3_b: "(x r\<rightarrow> 1) l\<rightarrow> 1 = 1"
  apply (unfold W2c)
  by simp

lemma P4_a [simp]: "x l\<rightarrow> 1 = 1"
  apply (subgoal_tac "x l\<rightarrow> ((x l\<rightarrow> 1) r\<rightarrow> 1) = 1")
  apply (simp add: P3_a)
  apply (cut_tac a = 1 and b = x and c = 1 in W3a)
  by simp

lemma P4_b [simp]: "x r\<rightarrow> 1 = 1"
  apply (subgoal_tac "x r\<rightarrow> ((x r\<rightarrow> 1) l\<rightarrow> 1) = 1")
  apply (simp add: P3_b)
  apply (cut_tac a = 1 and b = x and c = 1 in W3b)
  by simp

lemma P5_a: "x l\<rightarrow> y = 1 \<Longrightarrow> y l\<rightarrow> z = 1 \<Longrightarrow> x l\<rightarrow> z = 1"
  apply (cut_tac a = x and b = y and c = z in W3a)
  by simp

lemma P5_b: "x r\<rightarrow> y = 1 \<Longrightarrow> y r\<rightarrow> z = 1 \<Longrightarrow> x r\<rightarrow> z = 1"
  apply (cut_tac a = x and b = y and c = z in W3b)
  by simp

lemma P6_a: "x l\<rightarrow> (y r\<rightarrow> x) = 1"
  apply (cut_tac a = y and b = 1 and c = x in W3b)
  by simp

lemma P6_b: "x r\<rightarrow> (y l\<rightarrow> x) = 1"
  apply (cut_tac a = y and b = 1 and c = x in W3a)
  by simp

lemma P7: "(x l\<rightarrow> (y r\<rightarrow> z) = 1) = (y r\<rightarrow> (x l\<rightarrow> z) = 1)"
  proof
    fix x y z assume A: "x l\<rightarrow> y r\<rightarrow> z = 1" show "y r\<rightarrow> x l\<rightarrow> z = 1"
      apply (rule_tac y = "(z r\<rightarrow> y) l\<rightarrow> y" in P5_b)
      apply (simp add: P6_b)
      apply (unfold W2c)
      apply (subgoal_tac "(x l\<rightarrow> (y r\<rightarrow> z)) l\<rightarrow> (((y r\<rightarrow> z) l\<rightarrow> z) r\<rightarrow> x l\<rightarrow> z) = 1")
      apply (unfold A) [1]
      apply simp
      by (simp add: W3a)
    next
    fix x y z assume A: "y r\<rightarrow> x l\<rightarrow> z = 1" show "x l\<rightarrow> y r\<rightarrow> z = 1"
      apply (rule_tac y = "(z l\<rightarrow> x) r\<rightarrow> x" in P5_a)
      apply (simp add: P6_a)
      apply (unfold W2a)
      apply (subgoal_tac "(y r\<rightarrow> x l\<rightarrow> z) r\<rightarrow> (((x l\<rightarrow> z) r\<rightarrow> z) l\<rightarrow> y r\<rightarrow> z) = 1")
      apply (unfold A) [1]
      apply simp
      by (simp add: W3b)
    qed

lemma P8_a: "(x l\<rightarrow> y) r\<rightarrow> ((z l\<rightarrow> x) l\<rightarrow> (z l\<rightarrow> y)) = 1"
  by (simp add: W3a P7 [THEN sym])

lemma P8_b: "(x r\<rightarrow> y) l\<rightarrow> ((z r\<rightarrow> x) r\<rightarrow> (z r\<rightarrow> y)) = 1"
  by (simp add: W3b P7)

lemma P9: "x l\<rightarrow> (y r\<rightarrow> z) = y r\<rightarrow> (x l\<rightarrow> z)"
  apply (rule P2_c)
  apply (subst P7)
  apply (rule_tac y = "(z r\<rightarrow> y) l\<rightarrow> y" in P5_b)
  apply (simp add: P6_b)
  apply (subst W2c)
  apply (rule P8_a)
  apply (subst P7 [THEN sym])
  apply (rule_tac y = "(z l\<rightarrow> x) r\<rightarrow> x" in P5_a)
  apply (simp add: P6_a)
  apply (subst W2a)
  by (simp add: P8_b)

definition
  "lesseq_a a b = (a l\<rightarrow> b = 1)"

definition
  "less_a a b = (lesseq_a a b \<and> \<not> lesseq_a b a)"

definition
  "lesseq_b a b = (a r\<rightarrow> b = 1)"

definition
  "less_b a b = (lesseq_b a b \<and> \<not> lesseq_b b a)"

definition
  "sup_a a b = (a l\<rightarrow> b) r\<rightarrow> b"

end

sublocale impl_lr_algebra < order_a!:order lesseq_a less_a
  apply unfold_locales
  apply (simp add: less_a_def)
  apply (simp_all add: lesseq_a_def)
  apply (rule P5_a)
  apply simp_all
  apply (rule P2_a)
  by simp_all

sublocale impl_lr_algebra < order_b!:order lesseq_b less_b
  apply unfold_locales
  apply (simp add: less_b_def)
  apply (simp_all add: lesseq_b_def)
  apply (rule P5_b)
  apply simp_all
  apply (rule P2_b)
  by simp_all

sublocale impl_lr_algebra < slattice_a!:semilattice_sup sup_a lesseq_a less_a
  apply unfold_locales
  apply (simp_all add: lesseq_a_def sup_a_def)
  apply (simp add: P9)
  apply (simp add: P9)
  apply (subst W2a)
  apply (subgoal_tac "((z l\<rightarrow> y) r\<rightarrow> y) l\<rightarrow> ((y l\<rightarrow> x) r\<rightarrow> x) = 1")
  apply simp
  apply (subgoal_tac "((z l\<rightarrow> y) r\<rightarrow> y) l\<rightarrow> ((x l\<rightarrow> y) r\<rightarrow> y) = 1")
  apply (simp add: W2a)
  apply (subgoal_tac "((z l\<rightarrow> y) r\<rightarrow> y) l\<rightarrow> (x l\<rightarrow> y) r\<rightarrow> y = ((x l\<rightarrow> y) r\<rightarrow> (z l\<rightarrow> y)) r\<rightarrow> (((z l\<rightarrow> y) r\<rightarrow> y) l\<rightarrow> (x l\<rightarrow> y) r\<rightarrow> y)")
  apply (simp add: W3b)
  apply (subgoal_tac "(x l\<rightarrow> y) r\<rightarrow> z l\<rightarrow> y = 1")
  apply simp
  apply (cut_tac a = z and b = x and c = y in W3a)
  by simp

sublocale impl_lr_algebra < slattice_b!:semilattice_sup sup_a lesseq_b less_b
  apply unfold_locales
  apply (simp_all add: lesseq_b_def sup_a_def)
  apply (simp_all add: W2b)
  apply (simp add: P9 [THEN sym])
  apply (simp add: P9 [THEN sym])
  apply (subst W2c)
  apply (subgoal_tac "((z r\<rightarrow> y) l\<rightarrow> y) r\<rightarrow> ((y r\<rightarrow> x) l\<rightarrow> x) = 1")
  apply simp
  apply (subgoal_tac "((z r\<rightarrow> y) l\<rightarrow> y) r\<rightarrow> ((x r\<rightarrow> y) l\<rightarrow> y) = 1")
  apply (simp add: W2c)
  apply (subgoal_tac "((z r\<rightarrow> y) l\<rightarrow> y) r\<rightarrow> (x r\<rightarrow> y) l\<rightarrow> y = ((x r\<rightarrow> y) l\<rightarrow> (z r\<rightarrow> y)) l\<rightarrow> (((z r\<rightarrow> y) l\<rightarrow> y) r\<rightarrow> (x r\<rightarrow> y) l\<rightarrow> y)")
  apply (simp add: W3a)
  apply (subgoal_tac "(x r\<rightarrow> y) l\<rightarrow> z r\<rightarrow> y = 1")
  apply simp
  apply (cut_tac a = z and b = x and c = y in W3b)
  by simp

context impl_lr_algebra
begin
lemma lesseq_a_b: "lesseq_b = lesseq_a"
  apply (simp add: fun_eq_iff)
  apply clarify
  apply (cut_tac x = x and y = xa in slattice_a.le_iff_sup)
  apply (cut_tac x = x and y = xa in slattice_b.le_iff_sup)
  by simp

lemma P10: "(a l\<rightarrow> b = 1) = (a r\<rightarrow> b = 1)"
  apply (cut_tac lesseq_a_b)
  by (simp add: fun_eq_iff lesseq_a_def lesseq_b_def)
end

class one_ord = one + ord

class impl_lr_ord_algebra = impl_lr_algebra + one_ord +
  assumes
     order: "a \<le> b = (a l\<rightarrow> b = 1)"
  and
     strict: "a < b = (a \<le> b \<and> \<not> b \<le> a)"
begin
lemma order_l: "(a \<le> b) = (a l\<rightarrow> b = 1)"
  by (simp add: order)

lemma order_r: "(a \<le> b) = (a r\<rightarrow> b = 1)"
  by (simp add: order P10)

lemma P11_a: "a \<le> b l\<rightarrow> a"
  by (simp add: order_r P6_b)

lemma P11_b: "a \<le> b r\<rightarrow> a"
  by (simp add: order_l P6_a)

lemma P12: "(a \<le> b l\<rightarrow> c) = (b \<le> a r\<rightarrow> c)"
  apply (subst order_r)
  apply (subst order_l)
  by (simp add: P7)

lemma P13_a: "a \<le> b \<Longrightarrow> b l\<rightarrow> c \<le> a l\<rightarrow> c"
  apply (subst order_r)
  apply (simp add: order_l)
  apply (cut_tac a = a and b = b and c = c in W3a)
  by simp

lemma P13_b: "a \<le> b \<Longrightarrow> b r\<rightarrow> c \<le> a r\<rightarrow> c"
  apply (subst order_l)
  apply (simp add: order_r)
  apply (cut_tac a = a and b = b and c = c in W3b)
  by simp

lemma P14_a: "a \<le> b \<Longrightarrow> c l\<rightarrow> a \<le> c l\<rightarrow> b"
  apply (simp add: order_l)
  apply (cut_tac x = a and y = b and z = c in P8_a)
  by simp

lemma P14_b: "a \<le> b \<Longrightarrow> c r\<rightarrow> a \<le> c r\<rightarrow> b"
  apply (simp add: order_r)
  apply (cut_tac x = a and y = b and z = c in P8_b)
  by simp

subclass order
  apply (subgoal_tac "op \<le> = lesseq_a \<and> op < = less_a")
  apply simp
  apply unfold_locales
  apply safe
  by (simp_all add: fun_eq_iff lesseq_a_def less_a_def order_l strict)

end

class one_zero_uminus = one + zero + left_uminus + right_uminus

class impl_neg_lr_algebra = impl_lr_ord_algebra + one_zero_uminus +
  assumes
      W4: "-l 1 = -r 1"
  and W5a: "(-l a r\<rightarrow> -l b) l\<rightarrow> (b l\<rightarrow> a) = 1"
  and W5b: "(-r a l\<rightarrow> -r b) l\<rightarrow> (b r\<rightarrow> a) = 1"
  and zero_def: "0 = -l 1"
begin

lemma zero_r_def: "0 = -r 1"
  by (simp add: zero_def W4)

lemma C1_a [simp]: "(-l x r\<rightarrow> 0) l\<rightarrow> x = 1"
  apply (unfold zero_def)
  apply (cut_tac a = x and b = 1 in W5a)
  by simp

lemma C1_b [simp]: "(-r x l\<rightarrow> 0) r\<rightarrow> x = 1"
  apply (unfold zero_r_def)
  apply (cut_tac a = x and b = 1 in W5b)
  by (simp add: P10)

lemma C2_b [simp]: "0 r\<rightarrow> x = 1"
  apply (cut_tac x= "-r x l\<rightarrow> 0" and y = x and z = 0 in P8_b)
  by (simp add: P6_b)

lemma C2_a [simp]: "0 l\<rightarrow> x = 1"
  by (simp add: P10)

lemma C3_a: "x l\<rightarrow> 0 = -l x"
  proof -
    have A: "-l x l\<rightarrow> (x l\<rightarrow> 0) = 1"
      apply (cut_tac x = "-l x" and y = "-l (-r 1)" in P6_a)
      apply (cut_tac a = "-r 1" and b = "x" in W5a)
      apply (unfold zero_r_def)
      apply (rule_tac y = " -l (-r (1\<Colon>'a)) r\<rightarrow> -l x" in P5_a)
      by simp_all
    have B: "(x l\<rightarrow> 0) r\<rightarrow> -l x = 1"
      apply (cut_tac a = "-l x r\<rightarrow> 0" and b = x and c = 0 in W3a)
      apply simp
      apply (cut_tac b = "-l x" and a = 0 in W2c)
      by simp
    show "x l\<rightarrow> 0 = -l x"
      apply (rule antisym)
      apply (simp add: order_r B)
      by (simp add: order_l A)
    qed

lemma C3_b: "x r\<rightarrow> 0 = -r x"
  apply (rule antisym)
  apply (simp add: order_l)
  apply (cut_tac x = x in C1_b)
  apply (cut_tac a = "-r x l\<rightarrow> 0" and b = x and c = 0 in W3b)
  apply simp
  apply (cut_tac b = "-r x" and a = 0 in W2a)
  apply simp
  apply (cut_tac x = "-r x" and y = "-r (-l 1)" in P6_b)
  apply (cut_tac a = "-l 1" and b = "x" in W5b)
  apply (unfold zero_def order_r)
  apply (rule_tac y = " -r (-l (1\<Colon>'a)) l\<rightarrow> -r x" in P5_b)
  by (simp_all add: P10)

lemma C4_a [simp]: "-r (-l x) = x"
  apply (unfold C3_b [THEN sym] C3_a [THEN sym])
  apply (subst W2a)
  by simp

lemma C4_b [simp]: "-l (-r x) = x"
  apply (unfold C3_b [THEN sym] C3_a [THEN sym])
  apply (subst W2c)
  by simp

lemma C5_a: "-r x l\<rightarrow> -r y = y r\<rightarrow> x"
  apply (rule antisym)
  apply (simp add: order_l W5b)
  apply (cut_tac a = "-r y" and b = "-r x" in W5a)
  by (simp add: order_l)

lemma C5_b: "-l x r\<rightarrow> -l y = y l\<rightarrow> x"
  apply (rule antisym)
  apply (simp add: order_l W5a)
  apply (cut_tac a = "-l y" and b = "-l x" in W5b)
  by (simp add: order_l)

lemma C6: "-r x l\<rightarrow> y = -l y r\<rightarrow> x"
  apply (cut_tac x = x and y = "-l y" in C5_a)
  by simp

lemma C7_a: "(x \<le> y) = (-l y \<le> -l x)"
  apply (subst order_l)
  apply (subst order_r)
  by (simp add: C5_b)

lemma C7_b: "(x \<le> y) = (-r y \<le> -r x)"
  apply (subst order_r)
  apply (subst order_l)
  by (simp add: C5_a)

end

class pseudo_wajsberg_algebra = impl_neg_lr_algebra +
  assumes
  W6: "-r (a l\<rightarrow> -l b) = -l (b r\<rightarrow> -r a)"
begin
definition
  "mult a b = -r (a l\<rightarrow> -l b)"

definition
  "inf_a a b = -l (a r\<rightarrow> -r (a l\<rightarrow> b))"

definition
  "inf_b a b = -r (b l\<rightarrow> -l (b r\<rightarrow> a))"

end

sublocale pseudo_wajsberg_algebra < slattice_inf_a!:semilattice_inf inf_a "op \<le>" "op <"
  apply unfold_locales
  apply (simp_all add: inf_a_def)
  apply (subst C7_b)
  apply (simp add: order_l P9 C5_a P10 [THEN sym] P6_a)
  apply (subst C7_b)
  apply (simp add: order_l P9 C5_a P10 [THEN sym] P6_a)
  apply (subst W6 [THEN sym])
  apply (subst C7_a)
  apply simp
  proof -
    fix x y z
    assume A: "x \<le> y"
    assume B: "x \<le> z"
    have C: "x l\<rightarrow> y = 1" by (simp add: order_l [THEN sym] A)
    have E: "((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> -l x = ((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((x l\<rightarrow> y) l\<rightarrow> -l x)"
      by (simp add: C)
    have F: "((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((x l\<rightarrow> y) l\<rightarrow> -l x) =  ((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((-l y r\<rightarrow> -l x) l\<rightarrow> -l x)"
      by (simp add: C5_b)
    have G: "((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((-l y r\<rightarrow> -l x) l\<rightarrow> -l x) = ((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((-l x r\<rightarrow> -l y) l\<rightarrow> -l y)"
      by (simp add: W2c)
    have H: "((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((-l x r\<rightarrow> -l y) l\<rightarrow> -l y) = ((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((y l\<rightarrow> x) l\<rightarrow> -l y)"
      by (simp add: C5_b)
    have I: "((y l\<rightarrow> z) l\<rightarrow> -l y) l\<rightarrow> ((y l\<rightarrow> x) l\<rightarrow> -l y) = 1"
      apply (simp add: order_l [THEN sym] P14_a)
      apply (rule P13_a)
      apply (rule P14_a)
      by (simp add: B)
    show "(y l\<rightarrow> z) l\<rightarrow> -l y \<le> -l x"
      by (simp add: order_l E F G H I)
    next
    qed

sublocale pseudo_wajsberg_algebra < slattice_inf_b!:semilattice_inf inf_b "op \<le>" "op <"
  apply unfold_locales
  apply (simp_all add: inf_b_def)
  apply (subst C7_a)
  apply (simp add: order_r P9 [THEN sym] C5_b P10 P6_b)
  apply (subst C7_a)
  apply (simp add: order_r P9 [THEN sym] C5_b P10 P6_b)
  apply (subst W6)
  apply (subst C7_b)
  apply simp
  proof -
    fix x y z
    assume A: "x \<le> y"
    assume B: "x \<le> z"
    have C: "x r\<rightarrow> z = 1" by (simp add: order_r [THEN sym] B)
    have E: "((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> -r x = ((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((x r\<rightarrow> z) r\<rightarrow> -r x)"
      by (simp add: C)
    have F: "((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((x r\<rightarrow> z) r\<rightarrow> -r x) =  ((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((-r z l\<rightarrow> -r x) r\<rightarrow> -r x)"
      by (simp add: C5_a)
    have G: "((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((-r z l\<rightarrow> -r x) r\<rightarrow> -r x) = ((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((-r x l\<rightarrow> -r z) r\<rightarrow> -r z)"
      by (simp add: W2a)
    have H: "((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((-r x l\<rightarrow> -r z) r\<rightarrow> -r z) = ((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((z r\<rightarrow> x) r\<rightarrow> -r z)"
      by (simp add: C5_a)
    have I: "((z r\<rightarrow> y) r\<rightarrow> -r z) r\<rightarrow> ((z r\<rightarrow> x) r\<rightarrow> -r z) = 1"
      apply (simp add: order_r [THEN sym])
      apply (rule P13_b)
      apply (rule P14_b)
      by (simp add: A)
    show "(z r\<rightarrow> y) r\<rightarrow> -r z \<le> -r x"
      by (simp add: order_r E F G H I)
    next
    qed

context pseudo_wajsberg_algebra
begin
lemma inf_a_b: "inf_a = inf_b"
  apply (simp add: fun_eq_iff)
  apply clarify
  apply (rule antisym)
  by simp_all

end
end


section \<open>A simple example demonstrating parallelism for code generated towards Isabelle/ML\<close>

theory Parallel_Example
imports Complex_Main "~~/src/HOL/Library/Parallel" "~~/src/HOL/Library/Debug"
begin

subsection \<open>Compute-intensive examples.\<close>

subsubsection \<open>Fragments of the harmonic series\<close>

definition harmonic :: "nat \<Rightarrow> rat" where
  "harmonic n = sum_list (map (\<lambda>n. 1 / of_nat n) [1..<n])"

subsubsection \<open>The sieve of Erathostenes\<close>

text \<open>
  The attentive reader may relate this ad-hoc implementation to the
  arithmetic notion of prime numbers as a little exercise.
\<close>

primrec mark :: "nat \<Rightarrow> nat \<Rightarrow> bool list \<Rightarrow> bool list" where
  "mark _ _ [] = []"
| "mark m n (p # ps) = (case n of 0 \<Rightarrow> False # mark m m ps
    | Suc n \<Rightarrow> p # mark m n ps)"

lemma length_mark [simp]:
  "length (mark m n ps) = length ps"
  by (induct ps arbitrary: n) (simp_all split: nat.split)

function sieve :: "nat \<Rightarrow> bool list \<Rightarrow> bool list" where
  "sieve m ps = (case dropWhile Not ps
   of [] \<Rightarrow> ps
    | p#ps' \<Rightarrow> let n = m - length ps' in takeWhile Not ps @ p # sieve m (mark n n ps'))"
by pat_completeness auto

termination \<comment> \<open>tuning of this proof is left as an exercise to the reader\<close>
  apply (relation "measure (length \<circ> snd)")
  apply rule
  apply (auto simp add: length_dropWhile_le)
proof -
  fix ps qs q
  assume "dropWhile Not ps = q # qs"
  then have "length (q # qs) = length (dropWhile Not ps)" by simp
  then have "length qs < length (dropWhile Not ps)" by simp
  moreover have "length (dropWhile Not ps) \<le> length ps"
    by (simp add: length_dropWhile_le)
  ultimately show "length qs < length ps" by auto
qed

primrec natify :: "nat \<Rightarrow> bool list \<Rightarrow> nat list" where
  "natify _ [] = []"
| "natify n (p#ps) = (if p then n # natify (Suc n) ps else natify (Suc n) ps)"

primrec list_primes where
  "list_primes (Suc n) = natify 1 (sieve n (False # replicate n True))"

subsubsection \<open>Naive factorisation\<close>

function factorise_from :: "nat \<Rightarrow> nat \<Rightarrow> nat list" where
  "factorise_from k n = (if 1 < k \<and> k \<le> n
    then
      let (q, r) = Divides.divmod_nat n k
      in if r = 0 then k # factorise_from k q
        else factorise_from (Suc k) n
    else [])"
by pat_completeness auto

termination factorise_from \<comment> \<open>tuning of this proof is left as an exercise to the reader\<close>
term measure
apply (relation "measure (\<lambda>(k, n). 2 * n - k)")
apply (auto simp add: prod_eq_iff)
apply (case_tac "k \<le> 2 * q")
apply (rule diff_less_mono)
apply auto
done

definition factorise :: "nat \<Rightarrow> nat list" where
  "factorise n = factorise_from 2 n"

subsection \<open>Concurrent computation via futures\<close>

definition computation_harmonic :: "unit \<Rightarrow> rat" where
  "computation_harmonic _ = Debug.timing (STR ''harmonic example'') harmonic 300"

definition computation_primes :: "unit \<Rightarrow> nat list" where
  "computation_primes _ = Debug.timing (STR ''primes example'') list_primes 4000"

definition computation_future :: "unit \<Rightarrow> nat list \<times> rat" where
  "computation_future = Debug.timing (STR ''overall computation'')
   (\<lambda>() \<Rightarrow> let c = Parallel.fork computation_harmonic
     in (computation_primes (), Parallel.join c))"

value "computation_future ()"

definition computation_factorise :: "nat \<Rightarrow> nat list" where
  "computation_factorise = Debug.timing (STR ''factorise'') factorise"

definition computation_parallel :: "unit \<Rightarrow> nat list list" where
  "computation_parallel _ = Debug.timing (STR ''overall computation'')
     (Parallel.map computation_factorise) [20000..<20100]"

value "computation_parallel ()"

end