theory Functors
  imports Main Categories

begin

section \<open>Functor\<close>

locale functorCat =
A: category domain codomain composition nonex +
B: category domain' codomain' composition' nonex'
for
  domain :: "'a \<Rightarrow> 'a" ("dom _") and
  codomain :: "'a \<Rightarrow> 'a" ("cod _") and
  composition :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<cdot>" 110) and
  nonex :: "'a" ("*") and
  domain' ("dom2 _") and
  codomain' ("cod2 _")  and
  composition' (infix "\<cdot>2" 110) and
  nonex' :: "'b" ("*2") +
fixes
  F :: "'a \<Rightarrow> 'b"
assumes
  exists: "(E x) \<longrightarrow> E(F x)" and
  nexists:"(\<not>(E x)) \<longrightarrow> (\<not>(E(F x)))" and
  pres1: "(F (dom x)) \<cong> dom2 (F x)" and
  pres2: "(F (cod x)) \<cong> cod2 (F x)" and
  pres3: "(F (x\<cdot>y)) \<^bold>\<ge> (F x)\<cdot>2(F y)"

begin
  lemma True
    nitpick [satisfy, user_axioms, format= 2, expect=genuine, card 'a = 2-10] oops

lemma Pres3Equiv:
  shows "E(x\<cdot>y) \<longrightarrow> (F (x\<cdot>y)) \<simeq> (F x)\<cdot>2(F y)"
  using exists pres3 by auto

lemma reflects_morp:
  shows "(E(F x)) \<longrightarrow> (E x)"
  using nexists by blast

lemma pres_identity:
  assumes "1\<^sub>x"
  shows "B.Id (F x)"
  by (metis A.Id_def B.Id_def assms nexists pres1)

lemma iso_pres:
  assumes "A.Iso x"
  shows "B.Iso (F x)"
  by (smt A.Id_def A.S3 A.S4 A.S5 A.category_axioms B.Iso_def assms category.Iso_def category.S2 exists pres3 pres_identity)

lemma linv_pres:
  assumes "A.leftinv x"
  shows "B.leftinv (F x)"
  by (metis A.leftinv_def B.leftinv_def assms exists pres3 pres_identity)

lemma rinv_pres:
  assumes "A.rightinv x"
  shows "B.rightinv (F x)"
  by (metis A.rightinv_def B.rightinv_def assms exists pres3 pres_identity)

end

section \<open>Composition functor\<close>

lemma comp_functor:
  assumes "functorCat domain codomain composition nonex domain' codomain' composition' nonex' F" and
          "functorCat domain' codomain' composition' nonex' domain'' codomain'' composition'' nonex'' G"
  shows "functorCat domain codomain composition nonex domain'' codomain'' composition'' nonex'' (G o F)"
  by (smt assms(1) assms(2) comp_apply functorCat.axioms(1) functorCat.axioms(2) functorCat.axioms(3) functorCat.intro functorCat.pres3 functorCat_axioms_def)

locale comp_functor =
F: functorCat domain codomain composition nonex domain' codomain' composition' nonex' F +
G: functorCat domain' codomain' composition' nonex' domain'' codomain'' composition'' nonex'' G
for
  domain :: "'a \<Rightarrow> 'a" ("dom _") and
  codomain :: "'a \<Rightarrow> 'a" ("cod _") and
  composition :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<cdot>" 110) and
  nonex :: "'a" ("*") and
  domain' :: "'b \<Rightarrow> 'b" ("dom2 _") and
  codomain' :: "'b \<Rightarrow> 'b" ("cod2 _") and
  composition' :: "'b \<Rightarrow> 'b \<Rightarrow> 'b" (infix "\<cdot>2" 110) and
  nonex' :: "'b" ("*2") and
  domain'' :: "'c \<Rightarrow> 'c" ("dom3 _") and
  codomain'' :: "'c \<Rightarrow> 'c" ("cod3 _") and
  composition'' :: "'c \<Rightarrow> 'c \<Rightarrow> 'c" (infix "\<cdot>3" 110) and
  nonex'' :: "'c" ("*3") and
  F :: "'a \<Rightarrow> 'b" and
  G :: "'b \<Rightarrow> 'c"
begin
    abbreviation map
      where "map \<equiv> G o F"
end

sublocale comp_functor \<subseteq> functorCat domain codomain composition nonex domain'' codomain'' composition'' nonex'' map
  using F.functorCat_axioms G.functorCat_axioms comp_functor by fastforce

section \<open>Endofunctor\<close>

locale endofunctor =
functorCat domain codomain composition nonex domain codomain composition nonex F
for
  domain :: "'a \<Rightarrow> 'a" ("dom _") and
  codomain :: "'a \<Rightarrow> 'a" ("cod _") and
  composition :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<cdot>" 110) and
  nonex :: "'a" ("*") and
  F ::"'a \<Rightarrow> 'a"

section \<open>Faithful functor\<close>

locale faithfulfunctor =
A: category domain codomain composition nonex +
B: category domain' codomain' composition' nonex' +
functorCat domain codomain composition nonex domain' codomain' composition' nonex' F
for
  domain :: "'a \<Rightarrow> 'a" ("dom _") and
  codomain :: "'a \<Rightarrow> 'a" ("cod _") and
  composition :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infix "\<cdot>" 110) and
  nonex :: "'a" ("*") and
  domain' :: "'b \<Rightarrow> 'b" ("dom2 _") and
  codomain' :: "'b \<Rightarrow> 'b" ("cod2 _") and
  composition' :: "'b \<Rightarrow> 'b \<Rightarrow> 'b" (infix "\<cdot>2" 110) and
  nonex' :: "'b" ("*2") and
  F :: "'a \<Rightarrow> 'b" +
assumes
  faith:"((A.par x y) \<and> (F x \<simeq> F y)) \<longrightarrow> (x \<simeq> y)"

begin
  lemma True
    nitpick [satisfy, user_axioms, format= 2, expect=genuine, card 'a = 4 -10] oops

lemma refl_ide:
  assumes "A.from_hom_set x a a" and "B.Id (F x)"
  shows "A.Id x"
  using assms faith
proof -
  have 1: "A.from_hom_set x a a"
    using assms(1) by blast
  have 2: "A.from_hom_set a a a"
    using "1" A.Id_from_hom_set A.Id_hom A.from_hom_set_def by blast
  have 3: "B.Id (F x)"
    by (simp add: assms(2))
  have 4: "B.Id (F a)"
    using "2" A.Id_def A.from_hom_set_def pres_identity by blast
  have 5: "A.par x a"
    using "1" "2" A.from_hom_set_def by auto
  have 6: "(F x) \<simeq> (F a)"
    by (metis "3" "4" "5" B.Id_def exists pres1)
  have 7: "((A.par x a) \<and> (F x \<simeq> F a))"
    using "5" "6" by blast
  have 8: "(x \<simeq> a)" using faith[where x = \<open>x\<close> and y = \<open>a\<close>]
    using "5" "6" by blast
  show ?thesis
    using "2" "8" A.Id_from_hom_set by blast
qed

lemma comp_help: "((A.par (x::'a) (y::'a)) \<and> (F x \<simeq> F y)) \<Longrightarrow> (x \<simeq> y)"
   using faith by blast

lemma comp_faith_func:
  assumes "faithfulfunctor domain codomain composition nonex domain' codomain' composition' nonex' F" and
          "faithfulfunctor domain' codomain' composition' nonex' domain'' codomain'' composition'' nonex'' G"
  shows "comp_functor domain codomain composition nonex domain' codomain' composition' nonex' domain'' codomain'' composition'' nonex'' F G"
  by (meson assms(1) assms(2) comp_functor.intro faithfulfunctor_def)

end

lemma comp_faith:
  assumes "faithfulfunctor domain codomain composition nonex domain' codomain' composition' nonex' F" and
          "faithfulfunctor domain' codomain' composition' nonex' domain'' codomain'' composition'' nonex'' G"
  shows "faithfulfunctor domain codomain composition nonex domain'' codomain'' composition'' nonex'' (G o F)"
proof-
  interpret F: faithfulfunctor domain codomain composition nonex domain' codomain' composition' nonex' F
    by (simp add: assms(1))
  interpret G: faithfulfunctor domain' codomain' composition' nonex' domain'' codomain'' composition'' nonex'' G
    by (simp add: assms(2))
  interpret A: category domain codomain composition nonex
    by (simp add: F.A.category_axioms)
  interpret B: category domain' codomain' composition' nonex'
    by (simp add: F.B.category_axioms)
  interpret C: category domain'' codomain'' composition'' nonex''
    by (simp add: G.B.category_axioms)
  have 0: "faithfulfunctor domain codomain composition nonex domain' codomain' composition' nonex' F" and
"faithfulfunctor domain' codomain' composition' nonex' domain'' codomain'' composition'' nonex'' G"
    using F.faithfulfunctor_axioms apply simp
    using G.faithfulfunctor_axioms by blast
  from 0 have 1: "comp_functor domain codomain composition nonex domain' codomain' composition' nonex' domain'' codomain'' composition'' nonex'' F G"
    by (simp add: assms(2) faithfulfunctor.comp_faith_func)
  from 1 have 2: "functorCat domain codomain composition nonex domain'' codomain'' composition'' nonex'' (G o F)"
    by (meson comp_functor comp_functor_def)
  have 3: "(F.A.par x y) \<^bold>\<and> ((G o F) x \<simeq> (G o F) y) \<Longrightarrow> (x \<simeq> y)" for x y
  proof -
    assume 0: "(F.A.par x y) \<^bold>\<and> ((G o F) x \<simeq> (G o F) y)"
    from 0 have 1: "(F.A.par x y)" by linarith
    from 1 have 2: "F.B.par (F x) (F y)"  by (metis F.exists F.pres1 F.pres2)
     have 3: "((G o F) x \<simeq> (G o F) y)" using "0" by blast
     from 2 and 3 have 4: "(F.B.par (F x) (F y)) \<^bold>\<and> ((G o F) x \<simeq> (G o F) y)"
       by blast
     from 4 have 5: "(F.B.par ((F x)::'b) ((F y)::'b)) \<^bold>\<and> (G(F x) \<simeq> G(F y))"
       by simp
     thm G.faith
     thm F.faith
     from 5 have 6: "(F x) \<simeq> (F y)" using G.faith[where x = \<open>F x\<close> and y = \<open>F y\<close>]
       by blast
     from 1 and 6 have 7: "(F.A.par x y) \<^bold>\<and> (F x) \<simeq> (F y)" using F.faith
       by blast
     from 7 have 8: "(x \<simeq> y)" using F.comp_help F.faith[where x = \<open>x\<close> and y = \<open>y\<close>]
       by blast
     show ?thesis using 8 by auto
   qed
     have 9:  "((F.A.par x y) \<^bold>\<and> ((G o F) x \<simeq> (G o F) y)) \<^bold>\<rightarrow> (x \<simeq> y)" for x y using 3[where x = \<open>x\<close> and y = \<open>y\<close>]
     by blast
   have "faithfulfunctor domain codomain composition nonex domain'' codomain'' composition'' nonex'' (G \<circ> F)" using 2 9
     by (smt F.A.category_axioms G.B.category_axioms faithfulfunctor.intro faithfulfunctor_axioms.intro)
   thus ?thesis by blast
 qed

section \<open>Identity functor\<close>

locale identityfunc =
A: category
begin

definition map :: "'a \<Rightarrow> 'a"
  where "map x = x"

  lemma isfunctor:
    shows "functorCat domain codomain composition nonex domain codomain composition nonex map"
     by (simp add: A.category_axioms functorCat.intro functorCat_axioms_def local.map_def)
end

sublocale identityfunc \<subseteq> functorCat domain codomain composition nonex domain codomain composition nonex map
  using isfunctor by auto

sublocale category \<subseteq> identityfunc domain codomain composition nonex
  by (simp add: category_axioms identityfunc.intro)

section \<open>Binary functor\<close>

locale biFunctor =
A: category domain codomain composition nonex +
B: category domain' codomain' composition' nonex' +
AxB: productCategory domain codomain composition nonex domain' codomain' composition' nonex' +
C: category domain'' codomain'' composition'' nonex'' +
functorCat AxB.Dom AxB.Cod AxB.Composition AxB.Nonex domain'' codomain'' composition'' nonex'' BF
for
  domain::"'a\<Rightarrow>'a" ("dom _") and
  codomain::"'a\<Rightarrow>'a" ("cod _") and
  composition::"'a\<Rightarrow>'a\<Rightarrow>'a" (infix "\<cdot>" 110) and
  nonex ::"'a" ("*") and
  domain'::"'b\<Rightarrow>'b" ("dom2 _") and
  codomain'::"'b\<Rightarrow>'b" ("cod2 _") and
  composition'::"'b\<Rightarrow>'b\<Rightarrow>'b" (infix "\<cdot>2" 110) and
  nonex' ::"'b" ("2") and
  domain''::"'c\<Rightarrow>'c" ("dom3 _") and
  codomain''::"'c\<Rightarrow>'c" ("cod3 _") and
  composition''::"'c\<Rightarrow>'c\<Rightarrow>'c" (infix "\<cdot>3" 110) and
  nonex'' ::"'c" ("*3") and
  BF :: "'a * 'b \<Rightarrow> 'c"

begin

 lemma True
   nitpick [satisfy, user_axioms, expect=genuine, card 'a=2,card 'b=4,card 'c=8] oops

lemma fix_arg1:
  assumes "A.Id a \<^bold>\<and> E a "
  shows "functorCat domain' codomain' composition' nonex' domain'' codomain'' composition'' nonex'' (\<lambda>x2. BF (a, x2))"
  using assms
  apply unfold_locales
  using AxB.Ex exists apply blast
  using AxB.Ex nexists apply blast
  apply (metis A.Id_def fst_conv pres1 snd_conv)
  apply (metis A.Id3 fst_conv pres2 snd_conv)
  by (smt A.Id3 A.category_axioms category.S6 fst_conv pres3 snd_conv)

lemma fix_arg2:
  assumes "B.Id a \<^bold>\<and> E a"
  shows "functorCat domain codomain composition nonex domain'' codomain'' composition'' nonex'' (\<lambda>x1. BF (x1, a))"
  using assms
  apply unfold_locales
  using AxB.Ex exists apply blast
  using AxB.Ex nexists apply blast
  apply (metis B.Id_def fst_conv pres1 snd_conv)
  apply (metis B.Id3 fst_conv pres2 snd_conv)
  by (metis B.Id3 B.category_axioms category.S6 fst_conv pres3 snd_conv)

subsection \<open>Exchange binary functor\<close>

abbreviation Exch
  where "Exch \<equiv> (\<lambda>x. BF(snd x, fst x))"

lemma Exch_is_binary:
  shows "biFunctor domain' codomain' composition' nonex' domain codomain composition nonex domain'' codomain'' composition'' nonex'' Exch"
  apply unfold_locales
  using AxB.Ex2 apply blast
  using AxB.Ex apply blast
  apply (metis A.S1 AxB.Ex2 B.S1 prod.exhaust_sel)
  apply (metis A.S2 AxB.Ex2 B.S2 prod.exhaust_sel)
  apply (metis A.S3 AxB.Ex2 B.S3 old.prod.inject)
  apply (metis A.S4 AxB.Ex2 B.S4 fst_conv snd_conv)
  apply (metis A.S5 AxB.Ex2 B.S5 eq_fst_iff sndI)
  apply (metis A.S6 AxB.Ex2 B.S6 eq_fst_iff eq_snd_iff)
  using A.SN AxB.Ex2 apply blast
  using AxB.Ex AxB.Ex2 apply auto[1]
  using AxB.Ex AxB.Ex2 apply auto[1]
  using pres1 apply auto[1]
  using pres2 apply auto[1]
  using pres3  AxB.SN  exists apply blast
  using AxB.Ex AxB.Ex2 apply auto[1]
  using AxB.Ex AxB.Ex2 apply auto[1]
  using pres1 apply auto[1]
  using pres2 apply auto[1]
  using pres3  nexists apply blast
  using pres1 apply auto[1]
  using pres2 apply auto[1]
  using pres3 by auto[1]

lemma Exch_simp[simp]:
  shows "Exch (x,y) \<cong> BF (y,x)"
  by simp

end

section \<open>Product functor\<close>

locale prodFunctor =
A: category domain codomain composition nonex +
B: category domain' codomain' composition' nonex' +
C: category domain'' codomain'' composition'' nonex'' +
D: category domain''' codomain''' composition''' nonex''' +
F: functorCat domain codomain composition nonex domain'' codomain'' composition'' nonex'' F +
G: functorCat domain' codomain' composition' nonex' domain''' codomain''' composition''' nonex''' G +
AB: productCategory domain codomain composition nonex domain' codomain' composition' nonex' +
CD: productCategory domain'' codomain'' composition'' nonex'' domain''' codomain''' composition''' nonex'''
for
  domain::"'a\<Rightarrow>'a" ("dom _") and
  codomain::"'a\<Rightarrow>'a" ("cod _") and
  composition::"'a\<Rightarrow>'a\<Rightarrow>'a" (infix "\<cdot>" 110) and
  nonex ::"'a" ("*") and
  domain'::"'b\<Rightarrow>'b" ("dom2 _") and
  codomain'::"'b\<Rightarrow>'b" ("cod2 _") and
  composition'::"'b\<Rightarrow>'b\<Rightarrow>'b" (infix "\<cdot>2" 110) and
  nonex' ::"'b" ("*2") and
  domain''::"'c\<Rightarrow>'c" ("dom3 _") and
  codomain''::"'c\<Rightarrow>'c" ("cod3 _") and
  composition''::"'c\<Rightarrow>'c\<Rightarrow>'c" (infix "\<cdot>3" 110) and
  nonex'' ::"'c" ("*3") and
  domain'''::"'d\<Rightarrow>'d" ("dom4 _") and
  codomain'''::"'d\<Rightarrow>'d" ("cod4 _") and
  composition'''::"'d\<Rightarrow>'d\<Rightarrow>'d" (infix "\<cdot>4" 110) and
  nonex''' ::"'d" ("*4") and
  F::"'a\<Rightarrow>'c" and
  G::"'b\<Rightarrow>'d"
begin

definition map::"'a*'b \<Rightarrow> 'c*'d"
  where "map f = (F (fst f), G (snd f))"

lemma is_functor:
  shows "functorCat AB.Dom AB.Cod AB.Composition AB.Nonex CD.Dom CD.Cod CD.Composition CD.Nonex map"
  apply (unfold_locales)
  using AB.Ex CD.Ex G.exists local.map_def
  apply auto[1]
  using F.exists
  apply blast
  apply (metis AB.Ex CD.Ex F.reflects_morp G.reflects_morp local.map_def prod.exhaust_sel)
  using CD.Ex F.pres1 G.pres1 local.map_def
  apply auto[1]
  using CD.Ex F.pres2 G.pres2 local.map_def
  apply auto[1]
  using CD.Ex F.pres3 G.pres3 local.map_def
  by fastforce

end

sublocale prodFunctor \<subseteq> functorCat AB.Dom AB.Cod AB.Composition AB.Nonex CD.Dom CD.Cod CD.Composition CD.Nonex map
  using is_functor by auto

end


theory list_append_inj_2
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

(*hipster append *)

theorem x0 :
  "!! (xs :: 'a list) (ys :: 'a list) (zs :: 'a list) .
     ((append xs ys) = (append xs zs)) ==> (ys = zs)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


header{* Predicates and relations *}

theory Relations
imports Var
begin
default_sort type

text {* Unifying Theories of Programming (UTP) is a semantic framework based on
an alphabetized relational calculus. An alphabetized predicate is a pair (alphabet, predicate)
where the free variables appearing in the predicate are all in the alphabet. *}

text {* An alphabetized relation is an alphabetized predicate where the alphabet is
composed of input (undecorated) and output (dashed) variables. In this case the
predicate describes a relation between input and output variables. *}

subsection{* Definitions *}

text {* In this section, the definitions of predicates, relations and
standard operators are given.*}

type_synonym '\<alpha> "alphabet"  = "'\<alpha>"
type_synonym '\<alpha> predicate = "'\<alpha> alphabet \<Rightarrow> bool"

definition  true::"'\<alpha> predicate"
where "true \<equiv> \<lambda>A. True"

definition  false::"'\<alpha> predicate"
where "false \<equiv> \<lambda>A. False"

definition  not::"'\<alpha> predicate \<Rightarrow> '\<alpha> predicate" ("\<not> _" [40] 40)
where "\<not> P  \<equiv> \<lambda>A. \<not> (P A)"

definition  conj::"'\<alpha> predicate \<Rightarrow> '\<alpha> predicate \<Rightarrow> '\<alpha> predicate" (infixr "\<and>" 35)
where "P \<and> Q \<equiv> \<lambda>A. P A \<and> Q A"

definition disj::"'\<alpha> predicate \<Rightarrow> '\<alpha> predicate \<Rightarrow> '\<alpha> predicate" (infixr "\<or>" 30)
where "P \<or> Q \<equiv> \<lambda>A. P A \<or> Q A"

definition impl::"'\<alpha> predicate \<Rightarrow> '\<alpha> predicate \<Rightarrow> '\<alpha> predicate" (infixr "\<longrightarrow>" 25)
where "P \<longrightarrow> Q \<equiv> \<lambda>A. P A \<longrightarrow> Q A"

definition iff::"'\<alpha> predicate \<Rightarrow> '\<alpha> predicate \<Rightarrow> '\<alpha> predicate" (infixr "\<longleftrightarrow>" 25)
where "P \<longleftrightarrow> Q \<equiv> \<lambda>A. P A \<longleftrightarrow> Q A"

definition ex::"['\<beta> \<Rightarrow>'\<alpha> predicate] \<Rightarrow> '\<alpha> predicate" (binder "\<^bold>\<exists>" 10)
where "\<^bold>\<exists>x. P x \<equiv> \<lambda>A. \<exists> x. (P x) A"

definition all::"['\<beta> \<Rightarrow>'\<alpha> predicate] \<Rightarrow> '\<alpha> predicate" (binder "\<^bold>\<forall>" 10)
where "\<^bold>\<forall>x. P x \<equiv> \<lambda> A. \<forall>x. (P x) A"

type_synonym '\<alpha> condition = "('\<alpha> \<times> '\<alpha>) \<Rightarrow> bool"
type_synonym '\<alpha> relation  = "('\<alpha> \<times> '\<alpha>) \<Rightarrow> bool"

definition cond::"'\<alpha> relation \<Rightarrow> '\<alpha> condition \<Rightarrow> '\<alpha> relation \<Rightarrow> '\<alpha> relation"
                                                          ("(3_ \<triangleleft> _ \<triangleright> / _)" [14,0,15] 14)
where " (P \<triangleleft> b \<triangleright> Q) \<equiv> (b \<and> P) \<or> ((\<not> b) \<and> Q)"

definition comp::"(('\<alpha> \<times> '\<beta>) \<Rightarrow> bool) \<Rightarrow> (('\<beta> \<times> '\<gamma>) \<Rightarrow> bool) \<Rightarrow> ('\<alpha> \<times> '\<gamma>) \<Rightarrow> bool"
                                                                          (infixr ";;" 25)
where "P ;; Q \<equiv> \<lambda>r. r : ({p. P p} O {q. Q q})"

definition Assign::"('a, 'b) var \<Rightarrow> 'a \<Rightarrow> 'b relation"
  where "Assign x a \<equiv> \<lambda>(A, A'). A' = (assign x a) A"

syntax
  "_assignment" :: "id \<Rightarrow> 'a \<Rightarrow> 'b relation"  ("_ :== _")
translations
  "y :== vv"   => "CONST Assign (VAR y) vv"

abbreviation (input) closure::"'\<alpha> predicate \<Rightarrow> bool" ("[_]")
where "[ P ] \<equiv> \<forall> A. P A"

abbreviation (input) ndet::"'\<alpha> relation \<Rightarrow> '\<alpha> relation \<Rightarrow> '\<alpha> relation" ("(_ \<sqinter> _)")
where "P \<sqinter> Q \<equiv> P \<or> Q"

abbreviation (input) join::"'\<alpha> relation \<Rightarrow> '\<alpha> relation \<Rightarrow> '\<alpha> relation" ("(_ \<squnion> _)")
where "P \<squnion> Q \<equiv> P \<and> Q"

abbreviation (input) ndetS::"'\<alpha> relation set \<Rightarrow> '\<alpha> relation" ("(\<Sqinter> _)")
where "\<Sqinter> S \<equiv> \<lambda>A. A \<in> \<Union>{{p. P p} | P. P \<in> S}"

abbreviation (input) conjS::"'\<alpha> relation set \<Rightarrow> '\<alpha> relation" ("(\<Squnion> _)")
where "\<Squnion> S \<equiv> \<lambda>A. A \<in> \<Inter>{{p. P p} | P. P \<in> S}"

abbreviation (input) skip_r::"'\<alpha> relation" ("\<Pi>r")
where "\<Pi>r \<equiv> \<lambda> (A, A') . A = A'"

abbreviation (input) Bot::"'\<alpha> relation"
where "Bot \<equiv> true"

abbreviation (input) Top::"'\<alpha> relation"
where "Top \<equiv> false"

lemmas utp_defs = true_def false_def conj_def disj_def not_def impl_def iff_def
                  ex_def all_def cond_def comp_def Assign_def

subsection {* Proofs *}

text {* All useful proved lemmas over predicates and relations are presented here.
First, we introduce the most important lemmas that will be used by automatic tools to simplify
proofs. In the second part, other lemmas are proved using these basic ones.*}

subsubsection {* Setup of automated tools *}

lemma true_intro: "true x" by (simp add: utp_defs)
lemma false_elim: "false x \<Longrightarrow> C" by (simp add: utp_defs)

lemma not_intro: "(P x \<Longrightarrow> false x) \<Longrightarrow> (\<not> P) x" by (auto simp add: utp_defs)
lemma not_elim: "(\<not> P) x \<Longrightarrow> P x \<Longrightarrow> C" by (auto simp add: utp_defs)
lemma not_dest: "(\<not> P) x \<Longrightarrow> \<not> P x" by (auto simp add: utp_defs)

lemma conj_intro: "P x \<Longrightarrow> Q x \<Longrightarrow> (P \<and> Q) x" by (auto simp add: utp_defs)
lemma conj_elim: "(P \<and> Q) x \<Longrightarrow> (P x \<Longrightarrow> Q x \<Longrightarrow> C) \<Longrightarrow> C" by (auto simp add: utp_defs)

lemma disj_introC: "(\<not> Q x \<Longrightarrow> P x) \<Longrightarrow> (P \<or> Q) x" by (auto simp add: utp_defs)
lemma disj_elim: "(P \<or> Q) x \<Longrightarrow> (P x \<Longrightarrow> C) \<Longrightarrow> (Q x \<Longrightarrow> C) \<Longrightarrow> C" by (auto simp add: utp_defs)

lemma impl_intro: "(P x \<Longrightarrow> Q x) \<Longrightarrow> (P \<longrightarrow> Q) x" by (auto simp add: utp_defs)
lemma impl_elimC: "(P \<longrightarrow> Q) x \<Longrightarrow> (\<not> P x \<Longrightarrow> R) \<Longrightarrow> (Q x \<Longrightarrow> R) \<Longrightarrow> R " by (auto simp add: utp_defs)

lemma iff_intro: "(P x \<Longrightarrow> Q x) \<Longrightarrow> (Q x \<Longrightarrow> P x) \<Longrightarrow> (P \<longleftrightarrow> Q) x" by (auto simp add: utp_defs)
lemma iff_elimC:
"(P \<longleftrightarrow> Q) x \<Longrightarrow> (P x \<Longrightarrow> Q x \<Longrightarrow> R) \<Longrightarrow> (\<not> P x \<Longrightarrow> \<not> Q x \<Longrightarrow> R) \<Longrightarrow> R" by (auto simp add: utp_defs)

lemma all_intro: "(\<And>a. P a x) \<Longrightarrow> (\<^bold>\<forall>a. P a) x" by (auto simp add: utp_defs)
lemma all_elim: "(\<^bold>\<forall>a. P a) x \<Longrightarrow> (P a x \<Longrightarrow> R) \<Longrightarrow> R" by (auto simp add: utp_defs)

lemma ex_intro: "P a x \<Longrightarrow> (\<^bold>\<exists>a. P a) x" by (auto simp add: utp_defs)
lemma ex_elim: "(\<^bold>\<exists>a. P a) x \<Longrightarrow> (\<And>a. P a x \<Longrightarrow> Q) \<Longrightarrow> Q" by (auto simp add: utp_defs)

lemma comp_intro: "P (a, b) \<Longrightarrow> Q (b, c) \<Longrightarrow> (P ;; Q) (a, c)"
  by (auto simp add: comp_def)

lemma comp_elim:
"(P ;; Q) ac \<Longrightarrow> (\<And>a b c. ac = (a, c) \<Longrightarrow> P (a, b) \<Longrightarrow> Q (b, c) \<Longrightarrow> C) \<Longrightarrow> C"
  by (auto simp add: comp_def)

declare not_def [simp]

declare iff_intro [intro!]
  and not_intro [intro!]
  and impl_intro [intro!]
  and disj_introC [intro!]
  and conj_intro [intro!]
  and true_intro [intro!]
  and comp_intro [intro]

declare not_dest [dest!]
  and iff_elimC [elim!]
  and false_elim [elim!]
  and impl_elimC [elim!]
  and disj_elim [elim!]
  and conj_elim [elim!]
  and comp_elim [elim!]
  and true_elim [elim!]

declare all_intro [intro!] and ex_intro [intro]
declare ex_elim [elim!] and all_elim [elim]

lemmas relation_rules = iff_intro not_intro impl_intro disj_introC conj_intro true_intro
                        comp_intro not_dest iff_elimC false_elim impl_elimC all_elim
                        disj_elim conj_elim comp_elim all_intro ex_intro ex_elim

lemma split_cond:
"A ((P \<triangleleft> b \<triangleright> Q) x) = ((b x \<longrightarrow> A (P x)) \<and> (\<not> b x \<longrightarrow> A (Q x)))"
  by (cases "b x") (auto simp add: utp_defs)

lemma split_cond_asm:
"A ((P \<triangleleft> b \<triangleright> Q) x) = (\<not> ((b x \<and> \<not> A (P x)) \<or> (\<not> b x \<and> \<not> A (Q x))))"
  by (cases "b x") (auto simp add: utp_defs)

lemmas cond_splits = split_cond split_cond_asm

subsubsection {* Misc lemmas *}

lemma cond_idem:"(P \<triangleleft> b \<triangleright> P) = P"
  by (rule ext) (auto split: cond_splits)

lemma cond_symm:"(P \<triangleleft> b \<triangleright> Q) = (Q \<triangleleft> \<not> b \<triangleright> P)"
  by (rule ext) (auto split: cond_splits)

lemma cond_assoc: "((P \<triangleleft> b \<triangleright> Q) \<triangleleft> c \<triangleright> R) = (P \<triangleleft> b \<and> c \<triangleright> (Q \<triangleleft> c \<triangleright> R))"
  by (rule ext) (auto split: cond_splits)

lemma cond_unit_T:"(P \<triangleleft> true \<triangleright> Q) = P"
  by (rule ext) (auto split: cond_splits)

lemma cond_unit_F:"(P \<triangleleft> false \<triangleright> Q) = Q"
  by (rule ext) (auto split: cond_splits)

lemma cond_L6: "(P \<triangleleft> b \<triangleright> (Q \<triangleleft> b \<triangleright> R)) = (P \<triangleleft> b \<triangleright> R)"
  by (rule ext) (auto split: cond_splits)

lemma cond_L7: "(P \<triangleleft> b \<triangleright> (P \<triangleleft> c \<triangleright> Q)) = (P \<triangleleft> b \<or> c \<triangleright> Q)"
  by (rule ext) (auto split: cond_splits)

lemma cond_and_distr: "((P \<and> Q) \<triangleleft> b \<triangleright> (R \<and> S)) = ((P \<triangleleft> b \<triangleright> R) \<and> (Q \<triangleleft> b \<triangleright> S))"
  by (rule ext) (auto split: cond_splits)

lemma cond_imp_distr:
"((P \<longrightarrow> Q) \<triangleleft> b \<triangleright> (R \<longrightarrow> S)) = ((P \<triangleleft> b \<triangleright> R) \<longrightarrow> (Q \<triangleleft> b \<triangleright> S))"
  by (rule ext) (auto split: cond_splits)

lemma cond_eq_distr:
"((P \<longleftrightarrow> Q) \<triangleleft> b \<triangleright> (R \<longleftrightarrow> S)) = ((P \<triangleleft> b \<triangleright> R) \<longleftrightarrow> (Q \<triangleleft> b \<triangleright> S))"
  by (rule ext) (auto split: cond_splits)

lemma comp_assoc: "(P ;; (Q ;; R)) = ((P ;; Q) ;; R)"
  by (rule ext) blast

lemma conj_comp:
"(\<And> a b c. P (a, b) = P (a, c)) \<Longrightarrow> (P \<and> (Q ;; R)) = ((P \<and> Q) ;; R)"
  by (rule ext) blast

lemma comp_cond_left_distr:
  assumes "\<And>x y z. b (x, y) = b (x, z)"
  shows "((P \<triangleleft> b \<triangleright> Q) ;; R) = ((P ;; R) \<triangleleft> b \<triangleright> (Q ;; R))"
  using assms by (auto simp: fun_eq_iff utp_defs)

lemma ndet_symm: "(P::'a relation) \<sqinter> Q = Q \<sqinter> P"
  by (rule ext) blast

lemma ndet_idemp: "P \<sqinter> P = P"
  by (rule ext) blast

lemma ndet_distr: "P \<sqinter> (Q \<sqinter> R) = (P \<sqinter> Q) \<sqinter> (P \<sqinter> R)"
  by (rule ext) blast

lemma cond_ndet_distr: "(P \<triangleleft> b \<triangleright> (Q \<sqinter> R)) = ((P \<triangleleft> b \<triangleright> Q) \<sqinter> (P \<triangleleft> b \<triangleright> R))"
  by (rule ext) (auto split: cond_splits)

lemma ndet_cond_distr: "(P \<sqinter> (Q \<triangleleft> b \<triangleright> R)) = ((P \<sqinter> Q) \<triangleleft> b \<triangleright> (P \<sqinter> R))"
  by (rule ext) (auto split: cond_splits)

lemma comp_ndet_l_distr: "((P \<sqinter> Q) ;; R) = ((P ;; R) \<sqinter> (Q ;; R))"
  by (auto simp: fun_eq_iff utp_defs)

lemma comp_ndet_r_distr: "(P ;; (Q \<sqinter> R)) = ((P ;; Q) \<sqinter> (P ;; R))"
  by (auto simp: fun_eq_iff utp_defs)

lemma l2_5_1_A: "\<forall>X \<in> S. [X \<longrightarrow> (\<Sqinter> S)]"
  by blast

lemma l2_5_1_B: "(\<forall> X \<in> S. [X \<longrightarrow> P]) \<longrightarrow> [(\<Sqinter> S) \<longrightarrow> P]"
  by blast

lemma l2_5_1: "[(\<Sqinter> S) \<longrightarrow> P] \<longleftrightarrow> (\<forall> X \<in> S. [X \<longrightarrow> P])"
  by blast

lemma empty_disj: "\<Sqinter> {} = Top"
  by (rule ext) blast

lemma l2_5_1_2: "[P \<longrightarrow> (\<Squnion> S)] \<longleftrightarrow> (\<forall> X \<in> S. [P \<longrightarrow> X])"
  by blast

lemma empty_conj: "\<Squnion> {} = Bot"
  by (rule ext) blast

lemma l2_5_2: "((\<Squnion> S) \<sqinter> Q) = (\<Squnion>{P \<sqinter> Q | P. P\<in>S})"
  by (rule ext) blast

lemma l2_5_3: "((\<Sqinter> S) \<squnion> Q) = (\<Sqinter>{P \<squnion> Q | P. P \<in> S})"
  by (rule ext) blast

lemma l2_5_4: "((\<Sqinter> S) ;; Q) = (\<Sqinter>{P ;; Q | P. P \<in> S})"
  by (rule ext) blast

lemma l2_5_5: "(Q ;; (\<Sqinter> S)) = (\<Sqinter>{Q ;; P | P. P \<in> S})"
  by (rule ext) blast

lemma all_idem :"(\<^bold>\<forall>b. \<^bold>\<forall>a. P a) = (\<^bold>\<forall>a. P a)"
  by (simp add: all_def)

lemma comp_unit_R [simp]: "(P ;; \<Pi>r) = P"
  by (auto simp: fun_eq_iff utp_defs)

lemma comp_unit_L [simp]: "(\<Pi>r ;; P) = P"
  by (auto simp: fun_eq_iff utp_defs)

lemmas comp_unit_simps = comp_unit_R comp_unit_L

lemma not_cond: "(\<not>(P \<triangleleft> b \<triangleright> Q)) = ((\<not> P) \<triangleleft> b \<triangleright> (\<not> Q))"
  by (rule ext) (auto split: cond_splits)

lemma cond_conj_not_distr:
"((P \<triangleleft> b \<triangleright> Q) \<and> \<not>(R \<triangleleft> b \<triangleright> S)) = ((P \<and> \<not>R) \<triangleleft> b \<triangleright> (Q \<and> \<not>S))"
  by (rule ext) (auto split: cond_splits)

lemma imp_cond_distr: "(R \<longrightarrow> (P \<triangleleft> b \<triangleright> Q)) = ((R \<longrightarrow> P) \<triangleleft> b \<triangleright> (R \<longrightarrow> Q))"
  by (rule ext) (auto split: cond_splits)

lemma cond_imp_dist: "((P \<triangleleft> b \<triangleright> Q) \<longrightarrow> R) = ((P \<longrightarrow> R) \<triangleleft> b \<triangleright> (Q \<longrightarrow> R))"
  by (rule ext) (auto split: cond_splits)

lemma cond_conj_distr: "((P \<triangleleft> b \<triangleright> Q) \<and> R) = ((P \<and> R) \<triangleleft> b \<triangleright> (Q \<and> R))"
  by (rule ext) (auto split: cond_splits)

lemma cond_disj_distr: "((P \<triangleleft> b \<triangleright> Q) \<or> R) = ((P \<or> R) \<triangleleft> b \<triangleright> (Q \<or> R))"
  by (rule ext) (auto split: cond_splits)

lemma cond_know_b: "(b \<and> (P \<triangleleft> b \<triangleright> Q)) = (b \<and> P)"
  by (rule ext) (auto split: cond_splits)

lemma cond_know_nb: "((\<not> (b)) \<and> (P \<triangleleft> b \<triangleright> Q)) = ((\<not> (b)) \<and> Q)"
  by (rule ext) (auto split: cond_splits)

lemma cond_ass_if: "(P \<triangleleft> b \<triangleright> Q) = (((b) \<and> P \<triangleleft> b \<triangleright> Q))"
  by (rule ext) (auto split: cond_splits)

lemma cond_ass_else: "(P \<triangleleft> b \<triangleright> Q) = (P \<triangleleft> b \<triangleright> ((\<not>b) \<and> Q))"
  by (rule ext) (auto split: cond_splits)

lemma not_true_eq_false: "(\<not> true) = false"
  by (rule ext) blast

lemma not_false_eq_true: "(\<not> false) = true"
  by (rule ext) blast

lemma conj_idem: "((P::'\<alpha> predicate) \<and> P) = P"
  by (rule ext) blast

lemma disj_idem: "((P::'\<alpha> predicate) \<or> P) = P"
  by (rule ext) blast

lemma conj_comm: "((P::'\<alpha> predicate) \<and> Q) = (Q \<and> P)"
  by (rule ext) blast

lemma disj_comm: "((P::'\<alpha> predicate) \<or> Q) = (Q \<or> P)"
  by (rule ext) blast

lemma conj_subst: "P = R \<Longrightarrow> ((P::'\<alpha> predicate) \<and> Q) = (R \<and> Q)"
  by (rule ext) blast

lemma conj_assoc:"(((P::'\<alpha> predicate) \<and> Q) \<and> S) = (P \<and> (Q \<and> S))"
  by (rule ext) blast

lemma disj_assoc:"(((P::'\<alpha> predicate) \<or> Q) \<or> S) = (P \<or> (Q \<or> S))"
  by (rule ext) blast

lemma conj_disj_abs:"((P::'\<alpha> predicate) \<and> (P \<or> Q)) = P"
  by (rule ext) blast

lemma disj_conj_abs:"((P::'\<alpha> predicate) \<or> (P \<and> Q)) = P"
  by (rule ext) blast

lemma conj_disj_distr:"((P::'\<alpha> predicate) \<and> (Q \<or> R)) = ((P \<and> Q) \<or> (P \<and> R))"
  by (rule ext) blast

lemma disj_conj_dsitr:"((P::'\<alpha> predicate) \<or> (Q \<and> R)) = ((P \<or> Q) \<and> (P \<or> R))"
  by (rule ext) blast

lemma true_conj_id:"(P \<and> true) = P"
  by (rule ext) blast

lemma true_dsij_zero:"(P \<or> true) = true"
  by (rule ext) blast

lemma true_conj_zero:"(P \<and> false) = false"
  by (rule ext) blast

lemma true_dsij_id:"(P \<or> false) = P"
  by (rule ext) blast

lemma imp_vacuous: "(false \<longrightarrow> u) = true"
  by (rule ext) blast

lemma p_and_not_p: "(P \<and> \<not> P) = false"
  by (rule ext) blast

lemma conj_disj_not_abs: "((P::'\<alpha> predicate) \<and> ((\<not>P) \<or> Q)) = (P \<and> Q)"
  by (rule ext) blast

lemma p_or_not_p: "(P \<or> \<not> P) = true"
  by (rule ext) blast

lemma double_negation: "(\<not> \<not> (P::'\<alpha> predicate)) = P"
  by (rule ext) blast

lemma not_conj_deMorgans: "(\<not> ((P::'\<alpha> predicate) \<and> Q)) = ((\<not> P) \<or> (\<not> Q))"
  by (rule ext) blast

lemma not_disj_deMorgans: "(\<not> ((P::'\<alpha> predicate) \<or> Q)) = ((\<not> P) \<and> (\<not> Q))"
  by (rule ext) blast

lemma p_imp_p: "(P \<longrightarrow> P) = true"
  by (rule ext) blast

lemma imp_imp: "((P::'\<alpha> predicate) \<longrightarrow> (Q \<longrightarrow> R)) = ((P \<and> Q) \<longrightarrow> R)"
  by (rule ext) blast

lemma imp_trans: "((P \<longrightarrow> Q) \<and> (Q \<longrightarrow> R) \<longrightarrow> P \<longrightarrow> R) = true"
  by (rule ext) blast

lemma p_equiv_p: "(P \<longleftrightarrow> P) = true"
  by (rule ext) blast

lemma equiv_eq: "((((P::'\<alpha> predicate) \<and> Q) \<or> (\<not>P \<and> \<not>Q)) = true) \<longleftrightarrow> (P = Q)"
  by (auto simp add: fun_eq_iff utp_defs)

lemma equiv_eq1: "(((P::'\<alpha> predicate) \<longleftrightarrow> Q) = true) \<longleftrightarrow> (P = Q)"
  by (auto simp add: fun_eq_iff utp_defs)

lemma cond_subst: "b = c \<Longrightarrow> (P \<triangleleft> b \<triangleright> Q) = (P \<triangleleft> c \<triangleright> Q)"
  by simp

lemma ex_disj_distr: "((\<^bold>\<exists>x. P x) \<or> (\<^bold>\<exists>x. Q x)) = (\<^bold>\<exists>x. (P x \<or> Q x))"
  by (rule ext) blast

lemma all_disj_distr: "((\<^bold>\<forall>x. P x) \<or> (\<^bold>\<forall>x. Q)) = (\<^bold>\<forall>x. (P x \<or> Q))"
  by (rule ext) blast

lemma all_conj_distr: "((\<^bold>\<forall>x. P x) \<and> (\<^bold>\<forall>x. Q x)) = (\<^bold>\<forall>x. (P x \<and> Q x))"
  by (rule ext) blast

lemma all_triv: "(\<^bold>\<forall>x. P) = P"
  by (rule ext) blast

lemma closure_true: "[true]"
  by blast

lemma closure_p_eq_true: "[P] \<longleftrightarrow> (P = true)"
  by (simp add: fun_eq_iff utp_defs)

lemma closure_equiv_eq: "[P \<longleftrightarrow> Q] \<longleftrightarrow> (P = Q)"
  by (simp add: fun_eq_iff utp_defs)

lemma closure_conj_distr: "([P] \<and> [Q]) = [P \<and> Q]"
  by blast

lemma closure_imp_distr: "[P \<longrightarrow> Q] \<longrightarrow> [P] \<longrightarrow> [Q]"
  by blast

lemma true_iff[simp]: "(P \<longleftrightarrow> true) = P"
  by blast

lemma true_imp[simp]: "(true \<longrightarrow> P) = P"
  by blast

end


theory "Nominal-HOLCF"
imports
  "Nominal-Utils" "HOLCF-Utils"
begin

subsubsection \<open>Type class of continuous permutations and variations thereof\<close>

class cont_pt =
  cpo +
  pt +
  assumes perm_cont: "\<And>p. cont ((permute p) :: 'a::{cpo,pt} \<Rightarrow> 'a)"

class discr_pt =
  discrete_cpo +
  pt

class pcpo_pt =
  cont_pt +
  pcpo

instance pcpo_pt \<subseteq> cont_pt
 by standard (auto intro: perm_cont)

instance discr_pt \<subseteq> cont_pt
 by standard auto

lemma (in cont_pt) perm_cont_simp[simp]: "\<pi> \<bullet> x \<sqsubseteq> \<pi> \<bullet> y \<longleftrightarrow> x \<sqsubseteq> y"
  apply rule
  apply (drule cont2monofunE[OF perm_cont, of _ _ "-\<pi>"], simp)[1]
  apply (erule cont2monofunE[OF perm_cont, of _ _ "\<pi>"])
  done

lemma (in cont_pt) perm_below_to_right: "\<pi> \<bullet> x \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> - \<pi> \<bullet>  y"
  by (metis perm_cont_simp pt_class.permute_minus_cancel(2))

lemma perm_is_ub_simp[simp]: "\<pi> \<bullet> S <| \<pi> \<bullet> (x::'a::cont_pt) \<longleftrightarrow> S <| x"
  by (auto simp add: is_ub_def permute_set_def)

lemma perm_is_ub_eqvt[simp,eqvt]: "S <| (x::'a::cont_pt) \<Longrightarrow> \<pi> \<bullet> S <| \<pi> \<bullet> x"
  by simp

lemma perm_is_lub_simp[simp]: "\<pi> \<bullet> S <<| \<pi> \<bullet> (x::'a::cont_pt) \<longleftrightarrow> S <<| x"
  apply (rule perm_rel_lemma)
  by (metis is_lubI is_lubD1 is_lubD2 perm_cont_simp perm_is_ub_simp)

lemma perm_is_lub_eqvt[simp,eqvt]: "S <<| (x::'a::cont_pt) ==> \<pi> \<bullet> S <<| \<pi> \<bullet> x"
  by simp

lemmas perm_cont2cont[simp,cont2cont] = cont_compose[OF perm_cont]

lemma perm_still_cont: "cont (\<pi> \<bullet> f) = cont (f :: ('a :: cont_pt) \<Rightarrow> ('b :: cont_pt))"
proof
  have imp:"\<And> (f :: 'a \<Rightarrow> 'b) \<pi>. cont f \<Longrightarrow> cont (\<pi> \<bullet> f)"
    unfolding permute_fun_def
    by (metis cont_compose perm_cont)
  show "cont f \<Longrightarrow> cont (\<pi> \<bullet> f)" using imp[of "f" "\<pi>"].
  show "cont (\<pi> \<bullet> f) \<Longrightarrow> cont (f)" using imp[of "\<pi> \<bullet> f" "-\<pi>"] by simp
qed

lemma perm_bottom[simp,eqvt]: "\<pi> \<bullet> \<bottom> = (\<bottom>::'a::{cont_pt,pcpo})"
  proof-
  have "\<bottom> \<sqsubseteq> -\<pi> \<bullet> (\<bottom>::'a::{cont_pt,pcpo})" by simp
  hence "\<pi> \<bullet> \<bottom> \<sqsubseteq> \<pi> \<bullet> (-\<pi> \<bullet> (\<bottom>::'a::{cont_pt,pcpo}))" by(rule cont2monofunE[OF perm_cont])
  hence "\<pi> \<bullet> \<bottom> \<sqsubseteq> (\<bottom>::'a::{cont_pt,pcpo})" by simp
  thus "\<pi> \<bullet> \<bottom> = (\<bottom>::'a::{cont_pt,pcpo})" by simp
qed

lemma bot_supp[simp]: "supp (\<bottom> :: 'a :: pcpo_pt) = {}"
  by (rule supp_fun_eqvt) (simp add: eqvt_def)

lemma bot_fresh[simp]: "a \<sharp> (\<bottom> :: 'a :: pcpo_pt)"
  by (simp add: fresh_def)

lemma bot_fresh_star[simp]: "a \<sharp>* (\<bottom> :: 'a :: pcpo_pt)"
  by (simp add: fresh_star_def)

lemma below_eqvt [eqvt]:
    "\<pi> \<bullet> (x \<sqsubseteq> y) = (\<pi> \<bullet> x \<sqsubseteq> \<pi> \<bullet> (y::'a::cont_pt))" by (auto simp add: permute_pure)

lemma lub_eqvt[simp]:
  "(\<exists> z. S <<| (z::'a::{cont_pt})) \<Longrightarrow> \<pi> \<bullet> lub S = lub (\<pi> \<bullet> S)"
  by (metis lub_eqI perm_is_lub_simp)

lemma chain_eqvt[eqvt]:
  fixes F :: "nat \<Rightarrow> 'a::cont_pt"
  shows "chain F \<Longrightarrow> chain (\<pi> \<bullet> F)"
  apply (rule chainI)
  apply (drule_tac i = i in chainE)
  apply (subst (asm) perm_cont_simp[symmetric, where \<pi> = \<pi>])
  by (metis permute_fun_app_eq permute_pure)

subsubsection \<open>Instance for @{type cfun}\<close>

instantiation "cfun" :: (cont_pt, cont_pt) pt
begin
  definition "p \<bullet> (f :: 'a  \<rightarrow> 'b) = (\<Lambda> x. p \<bullet> (f \<cdot> (- p \<bullet> x)))"

  instance
  apply standard
  apply (simp add: permute_cfun_def eta_cfun)
  apply (simp add: permute_cfun_def cfun_eqI minus_add)
  done
end

lemma permute_cfun_eq: "permute p = (\<lambda> f. (Abs_cfun (permute p)) oo f oo (Abs_cfun (permute (-p))))"
  by (rule, rule cfun_eqI, auto simp add: permute_cfun_def)

lemma Cfun_app_eqvt[eqvt]:
  "\<pi> \<bullet> (f \<cdot> x) = (\<pi> \<bullet> f) \<cdot> (\<pi> \<bullet> x)"
  unfolding permute_cfun_def
  by auto

lemma permute_Lam: "cont f \<Longrightarrow> p \<bullet> (\<Lambda> x. f x) = (\<Lambda> x. (p \<bullet> f) x)"
  apply (rule cfun_eqI)
  unfolding permute_cfun_def
  by (metis Abs_cfun_inverse2 eqvt_lambda unpermute_def )

lemma Abs_cfun_eqvt: "cont f \<Longrightarrow> (p \<bullet> Abs_cfun) f = Abs_cfun f"
  apply (subst permute_fun_def)
  by (metis permute_Lam perm_still_cont permute_minus_cancel(1))

lemma cfun_eqvtI: "(\<And>x. p \<bullet> (f \<cdot> x) = f' \<cdot> (p \<bullet> x)) \<Longrightarrow> p \<bullet> f = f'"
  by (metis Cfun_app_eqvt cfun_eqI permute_minus_cancel(1))

lemma ID_eqvt[eqvt]: "\<pi> \<bullet> ID = ID"
  unfolding ID_def
  apply perm_simp
  apply (simp add: Abs_cfun_eqvt)
  done

instance "cfun" :: (cont_pt, cont_pt) cont_pt
  by standard (subst permute_cfun_eq, auto)

instance "cfun" :: ("{pure,cont_pt}", "{pure,cont_pt}") pure
  by standard (auto  simp add: permute_cfun_def permute_pure Cfun.cfun.Rep_cfun_inverse)

instance "cfun" :: (cont_pt, pcpo_pt) pcpo_pt
  by standard

subsubsection \<open>Instance for @{type fun}\<close>

lemma permute_fun_eq: "permute p = (\<lambda> f. (permute p) \<circ> f \<circ> (permute (-p)))"
  by (rule, rule, metis comp_apply eqvt_lambda unpermute_def)

instance "fun" :: (pt, cont_pt) cont_pt
  apply standard
  apply (rule cont2cont_lambda)
  apply (subst permute_fun_def)
  apply (rule perm_cont2cont)
  apply (rule cont_fun)
  done

lemma fix_eqvt[eqvt]:
  "\<pi> \<bullet> fix = (fix :: ('a \<rightarrow> 'a) \<rightarrow> 'a::{cont_pt,pcpo})"
apply (rule cfun_eqI)
apply (subst permute_cfun_def)
apply simp
apply (rule parallel_fix_ind[OF adm_subst2])
apply (auto simp add: permute_self)
done

subsubsection \<open>Instance for @{type u}\<close>

(* Everything very pure. Does this work?
instantiation u :: (cpo) pt
begin
  definition "p \<bullet> (x :: 'a u) = x"
  instance by standard (auto simp add: permute_u_def)
end
instance u :: (cpo) pure by standard (simp add: permute_u_def)
instance u :: (cpo) cont_pt by standard (simp add: pure_permute_id)
instance u :: (cpo) pcpo_pt ..
*)

instantiation u :: (cont_pt) pt
begin
  definition "p \<bullet> (x :: 'a u) = fup\<cdot>(\<Lambda> x. up\<cdot>(p \<bullet> x))\<cdot>x"
  instance
  apply standard
  apply (case_tac x) apply (auto simp add: permute_u_def)
  apply (case_tac x) apply (auto simp add: permute_u_def)
  done
end

instance u :: (cont_pt) cont_pt
proof
  fix p
  (* Fighting eta contraction... *)
  have "permute p = (\<lambda> x. fup\<cdot>(\<Lambda> x. up\<cdot>(p \<bullet> x))\<cdot>(x:: 'a u))"
    by (rule ext, rule permute_u_def)
  moreover have "cont (\<lambda> x. fup\<cdot>(\<Lambda> x. up\<cdot>(p \<bullet> x))\<cdot>(x:: 'a u))" by simp
  ultimately show "cont (permute p :: 'a u \<Rightarrow> 'a u)" by simp
qed

instance u :: (cont_pt) pcpo_pt ..

class pure_cont_pt = pure + cont_pt

instance u :: (pure_cont_pt) pure
  apply standard
  apply (case_tac x)
  apply (auto simp add: permute_u_def permute_pure)
  done

lemma up_eqvt[eqvt]: "\<pi> \<bullet> up = up"
  apply (rule cfun_eqI)
  apply (subst permute_cfun_def, simp)
  apply (simp add: permute_u_def)
  done

lemma fup_eqvt[eqvt]: "\<pi> \<bullet> fup = fup"
  apply (rule cfun_eqI)
  apply (rule cfun_eqI)
  apply (subst permute_cfun_def, simp)
  apply (subst permute_cfun_def, simp)
  apply (case_tac xa)
  apply simp
  apply (simp add: permute_self)
  done

subsubsection \<open>Instance for @{type lift}\<close>

instantiation lift :: (pt) pt
begin
  definition "p \<bullet> (x :: 'a lift) = case_lift \<bottom> (\<lambda> x. Def (p \<bullet> x)) x"
  instance
  apply standard
  apply (case_tac x) apply (auto simp add: permute_lift_def)
  apply (case_tac x) apply (auto simp add: permute_lift_def)
  done
end

instance lift :: (pt) cont_pt
proof
  fix p
  (* Fighting eta contraction... *)
  have "permute p = (\<lambda> x. case_lift \<bottom> (\<lambda> x. Def (p \<bullet> x)) (x::'a lift))"
    by (rule ext, rule permute_lift_def)
  moreover have "cont (\<lambda> x. case_lift \<bottom> (\<lambda> x. Def (p \<bullet> x)) (x::'a lift))" by simp
  ultimately show "cont (permute p :: 'a lift \<Rightarrow> 'a lift)" by simp
qed

instance lift :: (pt) pcpo_pt ..

instance lift :: (pure) pure
  apply standard
  apply (case_tac x)
  apply (auto simp add: permute_lift_def permute_pure)
  done

lemma Def_eqvt[eqvt]: "\<pi> \<bullet> (Def x) = Def (\<pi> \<bullet> x)"
  by (simp add: permute_lift_def)

lemma case_lift_eqvt[eqvt]: "\<pi> \<bullet> case_lift d f x = case_lift (\<pi> \<bullet> d) (\<pi> \<bullet> f) (\<pi> \<bullet> x)"
  by (cases x) (auto simp add: permute_self)

subsubsection \<open>Instance for @{type prod}\<close>

instance prod :: (cont_pt, cont_pt) cont_pt
proof
  fix p
  (* Fighting eta contraction... *)
  have "permute p = (\<lambda> (x :: ('a, 'b) prod). (p \<bullet> fst x, p \<bullet> snd x))"  by auto
  moreover have "cont ..." by (intro cont2cont)
  ultimately show "cont (permute p :: ('a,'b) prod  \<Rightarrow> ('a,'b) prod)" by simp
qed

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section "Word Alignment"

theory Aligned
  imports
    "HOL-Library.Word"
    More_Word
    Word_EqI
    Typedef_Morphisms
begin

lift_definition is_aligned :: \<open>'a::len word \<Rightarrow> nat \<Rightarrow> bool\<close>
  is \<open>\<lambda>k n. 2 ^ n dvd take_bit LENGTH('a) k\<close>
  by simp

lemma is_aligned_iff_udvd:
  \<open>is_aligned w n \<longleftrightarrow> 2 ^ n udvd w\<close>
  by transfer (simp flip: take_bit_eq_0_iff add: min_def)

lemma is_aligned_iff_take_bit_eq_0:
  \<open>is_aligned w n \<longleftrightarrow> take_bit n w = 0\<close>
  by (simp add: is_aligned_iff_udvd take_bit_eq_0_iff exp_dvd_iff_exp_udvd)

lemma is_aligned_iff_dvd_int:
  \<open>is_aligned ptr n \<longleftrightarrow> 2 ^ n dvd uint ptr\<close>
  by transfer simp

lemma is_aligned_iff_dvd_nat:
  \<open>is_aligned ptr n \<longleftrightarrow> 2 ^ n dvd unat ptr\<close>
proof -
  have \<open>unat ptr = nat \<bar>uint ptr\<bar>\<close>
    by transfer simp
  then have \<open>2 ^ n dvd unat ptr \<longleftrightarrow> 2 ^ n dvd uint ptr\<close>
    by (simp only: dvd_nat_abs_iff) simp
  then show ?thesis
    by (simp add: is_aligned_iff_dvd_int)
qed

lemma is_aligned_0 [simp]:
  \<open>is_aligned 0 n\<close>
  by transfer simp

lemma is_aligned_at_0 [simp]:
  \<open>is_aligned w 0\<close>
  by transfer simp

lemma is_aligned_beyond_length:
  \<open>is_aligned w n \<longleftrightarrow> w = 0\<close> if \<open>LENGTH('a) \<le> n\<close> for w :: \<open>'a::len word\<close>
  using that
  apply (simp add: is_aligned_iff_udvd)
  apply transfer
  apply auto
  done

lemma is_alignedI [intro?]:
  \<open>is_aligned x n\<close> if \<open>x = 2 ^ n * k\<close> for x :: \<open>'a::len word\<close>
proof (unfold is_aligned_iff_udvd)
  from that show \<open>2 ^ n udvd x\<close>
    using dvd_triv_left exp_dvd_iff_exp_udvd by blast
qed

lemma is_alignedE:
  fixes w :: \<open>'a::len word\<close>
  assumes \<open>is_aligned w n\<close>
  obtains q where \<open>w = 2 ^ n * word_of_nat q\<close> \<open>q < 2 ^ (LENGTH('a) - n)\<close>
proof (cases \<open>n < LENGTH('a)\<close>)
  case False
  with assms have \<open>w = 0\<close>
    by (simp add: is_aligned_beyond_length)
  with that [of 0] show thesis
    by simp
next
  case True
  moreover define m where \<open>m = LENGTH('a) - n\<close>
  ultimately have l: \<open>LENGTH('a) = n + m\<close> and \<open>m \<noteq> 0\<close>
    by simp_all
  from \<open>n < LENGTH('a)\<close> have *: \<open>unat (2 ^ n :: 'a word) = 2 ^ n\<close>
    by transfer simp
  from assms have \<open>2 ^ n udvd w\<close>
    by (simp add: is_aligned_iff_udvd)
  then obtain v :: \<open>'a word\<close>
    where \<open>unat w = unat (2 ^ n :: 'a word) * unat v\<close> ..
  moreover define q where \<open>q = unat v\<close>
  ultimately have unat_w: \<open>unat w = 2 ^ n * q\<close>
    by (simp add: *)
  then have \<open>word_of_nat (unat w) = (word_of_nat (2 ^ n * q) :: 'a word)\<close>
    by simp
  then have w: \<open>w = 2 ^ n * word_of_nat q\<close>
    by simp
  moreover have \<open>q < 2 ^ (LENGTH('a) - n)\<close>
  proof (rule ccontr)
    assume \<open>\<not> q < 2 ^ (LENGTH('a) - n)\<close>
    then have \<open>2 ^ (LENGTH('a) - n) \<le> q\<close>
      by simp
    then have \<open>2 ^ LENGTH('a) \<le> 2 ^ n * q\<close>
      by (simp add: l power_add)
    with unat_w [symmetric] show False
      by (metis le_antisym nat_less_le unsigned_less)
  qed
  ultimately show thesis
    using that by blast
qed

lemma is_alignedE' [elim?]:
  fixes w :: \<open>'a::len word\<close>
  assumes \<open>is_aligned w n\<close>
  obtains q where \<open>w = push_bit n (word_of_nat q)\<close> \<open>q < 2 ^ (LENGTH('a) - n)\<close>
proof -
  from assms
  obtain q where \<open>w = 2 ^ n * word_of_nat q\<close> \<open>q < 2 ^ (LENGTH('a) - n)\<close>
    by (rule is_alignedE)
  then have \<open>w = push_bit n (word_of_nat q)\<close>
    by (simp add: push_bit_eq_mult)
  with that show thesis
    using \<open>q < 2 ^ (LENGTH('a) - n)\<close> .
qed

lemma is_aligned_mask:
  \<open>is_aligned w n \<longleftrightarrow> w AND mask n = 0\<close>
  by (simp add: is_aligned_iff_take_bit_eq_0 take_bit_eq_mask)

lemma is_aligned_imp_not_bit:
  \<open>\<not> bit w m\<close> if \<open>is_aligned w n\<close> and \<open>m < n\<close>
  for w :: \<open>'a::len word\<close>
proof -
  from \<open>is_aligned w n\<close>
  obtain q where \<open>w = push_bit n (word_of_nat q)\<close> \<open>q < 2 ^ (LENGTH('a) - n)\<close> ..
  moreover have \<open>\<not> bit (push_bit n (word_of_nat q :: 'a word)) m\<close>
    using \<open>m < n\<close> by (simp add: bit_simps)
  ultimately show ?thesis
    by simp
qed

lemma is_aligned_weaken:
  "\<lbrakk> is_aligned w x; x \<ge> y \<rbrakk> \<Longrightarrow> is_aligned w y"
  unfolding is_aligned_iff_dvd_nat
  by (erule dvd_trans [rotated]) (simp add: le_imp_power_dvd)

lemma is_alignedE_pre:
  fixes w::"'a::len word"
  assumes aligned: "is_aligned w n"
  shows        rl: "\<exists>q. w = 2 ^ n * (of_nat q) \<and> q < 2 ^ (LENGTH('a) - n)"
  using aligned is_alignedE by blast

lemma aligned_add_aligned:
  fixes x::"'a::len word"
  assumes aligned1: "is_aligned x n"
  and     aligned2: "is_aligned y m"
  and           lt: "m \<le> n"
  shows   "is_aligned (x + y) m"
proof cases
  assume nlt: "n < LENGTH('a)"
  show ?thesis
    unfolding is_aligned_iff_dvd_nat dvd_def
  proof -
    from aligned2 obtain q2 where yv: "y = 2 ^ m * of_nat q2"
      and q2v: "q2 < 2 ^ (LENGTH('a) - m)"
      by (auto elim: is_alignedE)

    from lt obtain k where kv: "m + k = n" by (auto simp: le_iff_add)
    with aligned1 obtain q1 where xv: "x = 2 ^ (m + k) * of_nat q1"
      and q1v: "q1 < 2 ^ (LENGTH('a) - (m + k))"
      by (auto elim: is_alignedE)

    have l1: "2 ^ (m + k) * q1 < 2 ^ LENGTH('a)"
      by (rule nat_less_power_trans [OF q1v])
         (subst kv, rule order_less_imp_le [OF nlt])

    have l2: "2 ^ m * q2 < 2 ^ LENGTH('a)"
      by (rule nat_less_power_trans [OF q2v],
          rule order_less_imp_le [OF order_le_less_trans])
         fact+

    have "x = of_nat (2 ^ (m + k) *  q1)" using xv
      by simp

    moreover have "y = of_nat (2 ^ m * q2)" using yv
      by simp

    ultimately have upls: "unat x + unat y = 2 ^ m * (2 ^ k * q1 + q2)"
    proof -
      have f1: "unat x = 2 ^ (m + k) * q1"
        by (metis (no_types) \<open>x = of_nat (2 ^ (m + k) * q1)\<close> l1 nat_mod_lem word_unat.inverse_norm
                             zero_less_numeral zero_less_power)
      have "unat y = 2 ^ m * q2"
        by (metis (no_types) \<open>y = of_nat (2 ^ m * q2)\<close> l2 nat_mod_lem word_unat.inverse_norm
                             zero_less_numeral zero_less_power)
      then show ?thesis
        using f1 by (simp add: power_add semiring_normalization_rules(34))
    qed

    (* (2 ^ k * q1 + q2) *)
    show "\<exists>d. unat (x + y) = 2 ^ m * d"
    proof (cases "unat x + unat y < 2 ^ LENGTH('a)")
      case True

      have "unat (x + y) = unat x + unat y"
        by (subst unat_plus_if', rule if_P) fact

      also have "\<dots> = 2 ^ m * (2 ^ k * q1 + q2)" by (rule upls)
      finally show ?thesis ..
    next
      case False
      then have "unat (x + y) = (unat x + unat y) mod 2 ^ LENGTH('a)"
        by (subst unat_word_ariths(1)) simp

      also have "\<dots> = (2 ^ m * (2 ^ k * q1 + q2)) mod 2 ^ LENGTH('a)"
        by (subst upls, rule refl)

      also
      have "\<dots> = 2 ^ m * ((2 ^ k * q1 +  q2) mod 2 ^ (LENGTH('a) - m))"
      proof -
        have "m \<le> len_of (TYPE('a))"
          by (meson le_trans less_imp_le_nat lt nlt)
        then show ?thesis
          by (metis mult_mod_right ordered_cancel_comm_monoid_diff_class.add_diff_inverse power_add)
      qed

      finally show ?thesis ..
    qed
  qed
next
  assume "\<not> n < LENGTH('a)"
  with assms
  show ?thesis
    by (simp add: is_aligned_mask not_less take_bit_eq_mod power_overflow word_arith_nat_defs(7) flip: take_bit_eq_mask)
qed

corollary aligned_sub_aligned:
  "\<lbrakk>is_aligned (x::'a::len word) n; is_aligned y m; m \<le> n\<rbrakk>
   \<Longrightarrow> is_aligned (x - y) m"
  apply (simp del: add_uminus_conv_diff add:diff_conv_add_uminus)
  apply (erule aligned_add_aligned, simp_all)
  apply (erule is_alignedE)
  apply (rule_tac k="- of_nat q" in is_alignedI)
  apply simp
  done

lemma is_aligned_shift:
  fixes k::"'a::len word"
  shows "is_aligned (k << m) m"
proof cases
  assume mv: "m < LENGTH('a)"
  from mv obtain q where mq: "m + q = LENGTH('a)" and "0 < q"
    by (auto dest: less_imp_add_positive)

  have "(2::nat) ^ m dvd unat (k << m)"
  proof
    have kv: "(unat k div 2 ^ q) * 2 ^ q + unat k mod 2 ^ q = unat k"
      by (rule div_mult_mod_eq)

    have "unat (k << m) = unat (2 ^ m * k)" by (simp add: shiftl_t2n)
    also have "\<dots> = (2 ^ m * unat k) mod (2 ^ LENGTH('a))" using mv
      by (simp add: unat_word_ariths(2))
    also have "\<dots> = 2 ^ m * (unat k mod 2 ^ q)"
      by (subst mq [symmetric], subst power_add, subst mod_mult2_eq) simp
    finally show "unat (k << m) = 2 ^ m * (unat k mod 2 ^ q)" .
  qed

  then show ?thesis by (unfold is_aligned_iff_dvd_nat)
next
  assume "\<not> m < LENGTH('a)"
  then show ?thesis
    by (simp add: not_less power_overflow is_aligned_mask shiftl_zero_size word_size)
qed

lemma aligned_mod_eq_0:
  fixes p::"'a::len word"
  assumes al: "is_aligned p sz"
  shows   "p mod 2 ^ sz = 0"
proof cases
  assume szv: "sz < LENGTH('a)"
  with al
  show ?thesis
    unfolding is_aligned_iff_dvd_nat
    by (simp add: and_mask_dvd_nat p2_gt_0 word_mod_2p_is_mask)
next
  assume "\<not> sz < LENGTH('a)"
  with al show ?thesis
    by (simp add: is_aligned_mask flip: take_bit_eq_mask take_bit_eq_mod)
qed

lemma is_aligned_triv: "is_aligned (2 ^ n ::'a::len word) n"
  by (rule is_alignedI [where k = 1], simp)

lemma is_aligned_mult_triv1: "is_aligned (2 ^ n * x  ::'a::len word) n"
  by (rule is_alignedI [OF refl])

lemma is_aligned_mult_triv2: "is_aligned (x * 2 ^ n ::'a::len word) n"
  by (subst mult.commute, simp add: is_aligned_mult_triv1)

lemma word_power_less_0_is_0:
  fixes x :: "'a::len word"
  shows "x < a ^ 0 \<Longrightarrow> x = 0" by simp

lemma is_aligned_no_wrap:
  fixes off :: "'a::len word"
  fixes ptr :: "'a::len word"
  assumes al: "is_aligned ptr sz"
  and    off: "off < 2 ^ sz"
  shows  "unat ptr + unat off < 2 ^ LENGTH('a)"
proof -
  have szv: "sz < LENGTH('a)"
  using off p2_gt_0 word_neq_0_conv by fastforce

  from al obtain q where ptrq: "ptr = 2 ^ sz * of_nat q" and
    qv: "q < 2 ^ (LENGTH('a) - sz)" by (auto elim: is_alignedE)

  show ?thesis
  proof (cases "sz = 0")
    case True
    then show ?thesis using off ptrq qv
      by simp
  next
    case False
    then have sne: "0 < sz" ..

    show ?thesis
    proof -
      have uq: "unat (of_nat q ::'a::len word) = q"
        apply (subst unat_of_nat)
        apply (rule mod_less)
        apply (rule order_less_trans [OF qv])
        apply (rule power_strict_increasing [OF diff_less [OF sne]])
         apply (simp_all)
        done

      have uptr: "unat ptr = 2 ^ sz * q"
        apply (subst ptrq)
        apply (subst iffD1 [OF unat_mult_lem])
         apply (subst unat_power_lower [OF szv])
         apply (subst uq)
         apply (rule nat_less_power_trans [OF qv order_less_imp_le [OF szv]])
        apply (subst uq)
        apply (subst unat_power_lower [OF szv])
        apply simp
        done

      show "unat ptr + unat off < 2 ^ LENGTH('a)" using szv
        apply (subst uptr)
        apply (subst mult.commute, rule nat_add_offset_less [OF _ qv])
        apply (rule order_less_le_trans [OF unat_mono [OF off] order_eq_refl])
         apply simp_all
        done
    qed
  qed
qed

lemma is_aligned_no_wrap':
  fixes ptr :: "'a::len word"
  assumes al: "is_aligned ptr sz"
  and    off: "off < 2 ^ sz"
  shows  "ptr \<le> ptr + off"
  by (subst no_plus_overflow_unat_size, subst word_size, rule is_aligned_no_wrap) fact+

lemma is_aligned_no_overflow':
  fixes p :: "'a::len word"
  assumes al: "is_aligned p n"
  shows "p \<le> p + (2 ^ n - 1)"
proof cases
  assume "n<LENGTH('a)"
  with al
  have "2^n - (1::'a::len word) < 2^n"
    by (simp add: word_less_nat_alt unat_sub_if_size)
  with al
  show ?thesis by (rule is_aligned_no_wrap')
next
  assume "\<not> n<LENGTH('a)"
  with al
  show ?thesis
  by (simp add: not_less power_overflow is_aligned_mask mask_2pm1)
qed

lemma replicate_not_True:
  "\<And>n. xs = replicate n False \<Longrightarrow> True \<notin> set xs"
  by (induct xs) auto

lemma map_zip_replicate_False_xor:
  "n = length xs \<Longrightarrow> map (\<lambda>(x, y). x = (\<not> y)) (zip xs (replicate n False)) = xs"
  by (induct xs arbitrary: n, auto)

lemma drop_minus_lem:
  "\<lbrakk> n \<le> length xs; 0 < n; n' = length xs \<rbrakk> \<Longrightarrow> drop (n' - n) xs = rev xs ! (n - 1)  # drop (Suc (n' - n)) xs"
proof (induct xs arbitrary: n n')
  case Nil then show ?case by simp
next
  case (Cons y ys)
  from Cons.prems
  show ?case
    apply simp
    apply (cases "n = Suc (length ys)")
     apply (simp add: nth_append)
    apply (simp add: Suc_diff_le Cons.hyps nth_append)
    apply clarsimp
    apply arith
    done
qed

lemma drop_minus:
  "\<lbrakk> n < length xs; n' = length xs \<rbrakk> \<Longrightarrow> drop (n' - Suc n) xs = rev xs ! n  # drop (n' - n) xs"
  apply (subst drop_minus_lem)
     apply simp
    apply simp
   apply simp
  apply simp
  apply (cases "length xs", simp)
  apply (simp add: Suc_diff_le)
  done

lemma aligned_add_xor:
  \<open>(x + 2 ^ n) XOR 2 ^ n = x\<close>
  if al: \<open>is_aligned (x::'a::len word) n'\<close> and le: \<open>n < n'\<close>
proof -
  have \<open>\<not> bit x n\<close>
    using that by (rule is_aligned_imp_not_bit)
  then have \<open>x + 2 ^ n = x OR 2 ^ n\<close>
    by (subst disjunctive_add) (auto simp add: bit_simps disjunctive_add)
  moreover have \<open>(x OR 2 ^ n) XOR 2 ^ n = x\<close>
    by (rule bit_word_eqI) (auto simp add: bit_simps \<open>\<not> bit x n\<close>)
  ultimately show ?thesis
    by simp
qed

lemma is_aligned_add_multI:
  fixes p :: "'a::len word"
  shows "\<lbrakk>is_aligned p m; n \<le> m; n' = n\<rbrakk> \<Longrightarrow> is_aligned (p + x * 2 ^ n) n'"
  apply (erule aligned_add_aligned)
  apply (auto intro: is_alignedI [where k="x"])
  done

lemma is_aligned_no_wrap''':
  fixes ptr :: "'a::len word"
  shows"\<lbrakk> is_aligned ptr sz; sz < LENGTH('a); off < 2 ^ sz \<rbrakk>
         \<Longrightarrow> unat ptr + off < 2 ^ LENGTH('a)"
  apply (drule is_aligned_no_wrap[where off="of_nat off"])
   apply (simp add: word_less_nat_alt)
   apply (erule order_le_less_trans[rotated])
  apply (simp add: take_bit_eq_mod)
  apply (subst(asm) unat_of_nat_len)
   apply (erule order_less_trans)
   apply (erule power_strict_increasing)
   apply simp
  apply assumption
  done

lemma aligned_small_is_0:
  "\<lbrakk> is_aligned x n; x < 2 ^ n \<rbrakk> \<Longrightarrow> x = 0"
  by (simp add: is_aligned_mask less_mask_eq)

corollary is_aligned_less_sz:
  "\<lbrakk>is_aligned a sz; a \<noteq> 0\<rbrakk> \<Longrightarrow> \<not> a < 2 ^ sz"
  by (rule notI, drule(1) aligned_small_is_0, erule(1) notE)

lemma aligned_at_least_t2n_diff:
  "\<lbrakk>is_aligned x n; is_aligned y n; x < y\<rbrakk> \<Longrightarrow> x \<le> y - 2 ^ n"
  apply (erule is_aligned_get_word_bits[where p=y])
   apply (rule ccontr)
   apply (clarsimp simp: linorder_not_le)
   apply (subgoal_tac "y - x = 0")
    apply clarsimp
   apply (rule aligned_small_is_0)
    apply (erule(1) aligned_sub_aligned)
    apply simp
   apply unat_arith
  apply simp
  done

lemma is_aligned_no_overflow'':
  "\<lbrakk>is_aligned x n; x + 2 ^ n \<noteq> 0\<rbrakk> \<Longrightarrow> x \<le> x + 2 ^ n"
  apply (frule is_aligned_no_overflow')
  apply (erule order_trans)
  apply (simp add: field_simps)
  apply (erule word_sub_1_le)
  done

lemma is_aligned_nth [word_eqI_simps]:
  "is_aligned p m = (\<forall>n < m. \<not>p !! n)"
  apply (clarsimp simp: is_aligned_mask bang_eq word_size)
  apply (rule iffI)
   apply clarsimp
   apply (case_tac "n < size p")
    apply (simp add: word_size)
   apply (drule test_bit_size)
   apply simp
  apply clarsimp
  done

lemma range_inter:
  "({a..b} \<inter> {c..d} = {}) = (\<forall>x. \<not>(a \<le> x \<and> x \<le> b \<and> c \<le> x \<and> x \<le> d))"
  by auto

lemma aligned_inter_non_empty:
  "\<lbrakk> {p..p + (2 ^ n - 1)} \<inter> {p..p + 2 ^ m - 1} = {};
     is_aligned p n; is_aligned p m\<rbrakk> \<Longrightarrow> False"
  apply (clarsimp simp only: range_inter)
  apply (erule_tac x=p in allE)
  apply simp
  apply (erule impE)
   apply (erule is_aligned_no_overflow')
  apply (erule notE)
  apply (erule is_aligned_no_overflow)
  done

lemma not_aligned_mod_nz:
  assumes al: "\<not> is_aligned a n"
  shows "a mod 2 ^ n \<noteq> 0"
  apply (rule ccontr)
  using al apply (rule notE)
  apply simp
  apply (rule is_alignedI [of _ _ \<open>a div 2 ^ n\<close>])
  apply (metis add.right_neutral mult.commute word_mod_div_equality)
  done

lemma nat_add_offset_le:
  fixes x :: nat
  assumes yv: "y \<le> 2 ^ n"
  and     xv: "x < 2 ^ m"
  and     mn: "sz = m + n"
  shows   "x * 2 ^ n + y \<le> 2 ^ sz"
proof (subst mn)
  from yv obtain qy where "y + qy = 2 ^ n"
    by (auto simp: le_iff_add)

  have "x * 2 ^ n + y \<le> x * 2 ^ n + 2 ^ n"
    using yv xv by simp
  also have "\<dots> = (x + 1) * 2 ^ n" by simp
  also have "\<dots> \<le> 2 ^ (m + n)" using xv
    by (subst power_add) (rule mult_le_mono1, simp)
  finally show "x * 2 ^ n + y \<le> 2 ^ (m + n)" .
qed

lemma is_aligned_no_wrap_le:
  fixes ptr::"'a::len word"
  assumes al: "is_aligned ptr sz"
  and    szv: "sz < LENGTH('a)"
  and    off: "off \<le> 2 ^ sz"
  shows  "unat ptr + off \<le> 2 ^ LENGTH('a)"
proof -
  from al obtain q where ptrq: "ptr = 2 ^ sz * of_nat q" and
    qv: "q < 2 ^ (LENGTH('a) - sz)" by (auto elim: is_alignedE)

  show ?thesis
  proof (cases "sz = 0")
    case True
    then show ?thesis using off ptrq qv
      by (auto simp add: le_Suc_eq Suc_le_eq) (simp add: le_less)
  next
    case False
    then have sne: "0 < sz" ..

    show ?thesis
    proof -
      have uq: "unat (of_nat q :: 'a word) = q"
        apply (subst unat_of_nat)
        apply (rule mod_less)
        apply (rule order_less_trans [OF qv])
        apply (rule power_strict_increasing [OF diff_less [OF sne]])
        apply simp_all
        done

      have uptr: "unat ptr = 2 ^ sz * q"
        apply (subst ptrq)
        apply (subst iffD1 [OF unat_mult_lem])
        apply (subst unat_power_lower [OF szv])
        apply (subst uq)
        apply (rule nat_less_power_trans [OF qv order_less_imp_le [OF szv]])
        apply (subst uq)
        apply (subst unat_power_lower [OF szv])
        apply simp
        done

      show "unat ptr + off \<le> 2 ^ LENGTH('a)" using szv
        apply (subst uptr)
        apply (subst mult.commute, rule nat_add_offset_le [OF off qv])
        apply simp
        done
    qed
  qed
qed

lemma is_aligned_neg_mask:
  "m \<le> n \<Longrightarrow> is_aligned (x AND NOT (mask n)) m"
  by (metis and_not_mask is_aligned_shift is_aligned_weaken)

lemma unat_minus:
  "unat (- (x :: 'a :: len word)) = (if x = 0 then 0 else 2 ^ size x - unat x)"
  using unat_sub_if_size[where x="2 ^ size x" and y=x]
  by (simp add: unat_eq_0 word_size)

lemma is_aligned_minus:
  \<open>is_aligned (- p) n\<close> if \<open>is_aligned p n\<close> for p :: \<open>'a::len word\<close>
  using that
  apply (cases \<open>n < LENGTH('a)\<close>)
  apply (simp_all add: not_less is_aligned_beyond_length)
  apply transfer
  apply (simp flip: take_bit_eq_0_iff)
  apply (subst take_bit_minus [symmetric])
  apply simp
  done

lemma add_mask_lower_bits:
  "\<lbrakk>is_aligned (x :: 'a :: len word) n;
    \<forall>n' \<ge> n. n' < LENGTH('a) \<longrightarrow> \<not> p !! n'\<rbrakk> \<Longrightarrow> x + p AND NOT (mask n) = x"
  apply (subst word_plus_and_or_coroll)
   apply (rule word_eqI)
   apply (clarsimp simp: word_size is_aligned_nth)
   apply (erule_tac x=na in allE)+
   apply simp
  apply (rule bit_word_eqI)
  apply (auto simp add: bit_simps not_less test_bit_eq_bit)
  apply (metis is_aligned_nth not_le test_bit_eq_bit)
  done

lemma is_aligned_andI1:
  "is_aligned x n \<Longrightarrow> is_aligned (x AND y) n"
  by (simp add: is_aligned_nth)

lemma is_aligned_andI2:
  "is_aligned y n \<Longrightarrow> is_aligned (x AND y) n"
  by (simp add: is_aligned_nth)

lemma is_aligned_shiftl:
  "is_aligned w (n - m) \<Longrightarrow> is_aligned (w << m) n"
  by (simp add: is_aligned_nth nth_shiftl)

lemma is_aligned_shiftr:
  "is_aligned w (n + m) \<Longrightarrow> is_aligned (w >> m) n"
  by (simp add: is_aligned_nth nth_shiftr)

lemma is_aligned_shiftl_self:
  "is_aligned (p << n) n"
  by (rule is_aligned_shift)

lemma is_aligned_neg_mask_eq:
  "is_aligned p n \<Longrightarrow> p AND NOT (mask n) = p"
  by (metis add.left_neutral is_aligned_mask word_plus_and_or_coroll2)

lemma is_aligned_shiftr_shiftl:
  "is_aligned w n \<Longrightarrow> w >> n << n = w"
  by (metis and_not_mask is_aligned_neg_mask_eq)

lemma aligned_shiftr_mask_shiftl:
  "is_aligned x n \<Longrightarrow> ((x >> n) AND mask v) << n = x AND mask (v + n)"
  apply (rule word_eqI)
  apply (simp add: word_size nth_shiftl nth_shiftr)
  apply (subgoal_tac "\<forall>m. x !! m \<longrightarrow> m \<ge> n")
   apply auto[1]
  apply (clarsimp simp: is_aligned_mask)
  apply (drule_tac x=m in word_eqD)
  apply (frule test_bit_size)
  apply (simp add: word_size)
  done

lemma mask_zero:
  "is_aligned x a \<Longrightarrow> x AND mask a = 0"
  by (metis is_aligned_mask)

lemma is_aligned_neg_mask_eq_concrete:
  "\<lbrakk> is_aligned p n; msk AND NOT (mask n) = NOT (mask n) \<rbrakk>
   \<Longrightarrow> p AND msk = p"
  by (metis word_bw_assocs(1) word_bw_comms(1) is_aligned_neg_mask_eq)

lemma is_aligned_and_not_zero:
  "\<lbrakk> is_aligned n k; n \<noteq> 0 \<rbrakk> \<Longrightarrow> 2 ^ k \<le> n"
  using is_aligned_less_sz leI by blast

lemma is_aligned_and_2_to_k:
  "(n AND 2 ^ k - 1) = 0 \<Longrightarrow> is_aligned (n :: 'a :: len word) k"
  by (simp add: is_aligned_mask mask_eq_decr_exp)

lemma is_aligned_power2:
  "b \<le> a \<Longrightarrow> is_aligned (2 ^ a) b"
  by (metis is_aligned_triv is_aligned_weaken)

lemma aligned_sub_aligned':
  "\<lbrakk> is_aligned (a :: 'a :: len word) n; is_aligned b n; n < LENGTH('a) \<rbrakk>
   \<Longrightarrow> is_aligned (a - b) n"
  by (simp add: aligned_sub_aligned)

lemma is_aligned_neg_mask_weaken:
  "\<lbrakk> is_aligned p n; m \<le> n \<rbrakk> \<Longrightarrow> p AND NOT (mask m) = p"
   using is_aligned_neg_mask_eq is_aligned_weaken by blast

lemma is_aligned_neg_mask2 [simp]:
  "is_aligned (a AND NOT (mask n)) n"
  by (simp add: and_not_mask is_aligned_shift)

lemma is_aligned_0':
  "is_aligned 0 n"
  by (fact is_aligned_0)

lemma aligned_add_offset_no_wrap:
  fixes off :: "('a::len) word"
  and     x :: "'a word"
  assumes al: "is_aligned x sz"
  and   offv: "off < 2 ^ sz"
  shows  "unat x + unat off < 2 ^ LENGTH('a)"
proof cases
  assume szv: "sz < LENGTH('a)"
  from al obtain k where xv: "x = 2 ^ sz * (of_nat k)"
    and kl: "k < 2 ^ (LENGTH('a) - sz)"
    by (auto elim: is_alignedE)

  show ?thesis using szv
    apply (subst xv)
    apply (subst unat_mult_power_lem[OF kl])
    apply (subst mult.commute, rule nat_add_offset_less)
      apply (rule less_le_trans[OF unat_mono[OF offv, simplified]])
      apply (erule eq_imp_le[OF unat_power_lower])
     apply (rule kl)
    apply simp
   done
next
  assume "\<not> sz < LENGTH('a)"
  with offv show ?thesis by (simp add: not_less power_overflow )
qed

lemma aligned_add_offset_mod:
  fixes x :: "('a::len) word"
  assumes al: "is_aligned x sz"
  and     kv: "k < 2 ^ sz"
  shows   "(x + k) mod 2 ^ sz = k"
proof cases
  assume szv: "sz < LENGTH('a)"

  have ux: "unat x + unat k < 2 ^ LENGTH('a)"
    by (rule aligned_add_offset_no_wrap) fact+

  show ?thesis using al szv
    apply -
    apply (erule is_alignedE)
    apply (subst word_unat.Rep_inject [symmetric])
    apply (subst unat_mod)
    apply (subst iffD1 [OF unat_add_lem], rule ux)
    apply simp
    apply (subst unat_mult_power_lem, assumption+)
    apply (simp)
    apply (rule mod_less[OF less_le_trans[OF unat_mono], OF kv])
    apply (erule eq_imp_le[OF unat_power_lower])
    done
next
  assume "\<not> sz < LENGTH('a)"
  with al show ?thesis
    by (simp add: not_less power_overflow is_aligned_mask mask_eq_decr_exp
                  word_mod_by_0)
qed

    have rl: "\<And>(p::'a word) k w. \<lbrakk>uint p + uint k < 2 ^ LENGTH('a); w = p + k; w \<le> p + (2 ^ sz - 1) \<rbrakk>
      \<Longrightarrow> k < 2 ^ sz"
      apply -
      apply simp
      apply (subst (asm) add.commute, subst (asm) add.commute, drule word_plus_mcs_4)
       apply (subst add.commute, subst no_plus_overflow_uint_size)
       apply transfer
      apply simp
      apply (auto simp add: le_less power_2_ge_iff szv)
      apply (metis le_less_trans mask_eq_decr_exp mask_lt_2pn order_less_imp_le szv)
      done

    from xb obtain kx where
      kx: "z = x + kx" and
      kxl: "uint x + uint kx < 2 ^ LENGTH('a)"
      by (clarsimp dest!: word_le_exists')

    from yb obtain ky where
      ky: "z = y + ky" and
      kyl: "uint y + uint ky < 2 ^ LENGTH('a)"
      by (clarsimp dest!: word_le_exists')

    have "x = y"
    proof -
      have "kx = z mod 2 ^ sz"
      proof (subst kx, rule sym, rule aligned_add_offset_mod)
        show "kx < 2 ^ sz" by (rule rl) fact+
      qed fact+

      also have "\<dots> = ky"
      proof (subst ky, rule aligned_add_offset_mod)
        show "ky < 2 ^ sz"
          using kyl ky yt by (rule rl)
      qed fact+

      finally have kxky: "kx = ky" .
      moreover have "x + kx = y + ky" by (simp add: kx [symmetric] ky [symmetric])
      ultimately show ?thesis by simp
    qed
    then show False using neq by simp
  qed
next
  assume "\<not> sz < LENGTH('a)"
  with neq alx aly
  have False by (simp add: is_aligned_mask mask_eq_decr_exp power_overflow)
  then show ?thesis ..
qed

lemma is_aligned_add_helper:
  "\<lbrakk> is_aligned p n; d < 2 ^ n \<rbrakk>
     \<Longrightarrow> (p + d AND mask n = d) \<and> (p + d AND (NOT (mask n)) = p)"
  apply (subst (asm) is_aligned_mask)
  apply (drule less_mask_eq)
  apply (rule context_conjI)
   apply (subst word_plus_and_or_coroll)
    apply (simp_all flip: take_bit_eq_mask)
   apply (metis take_bit_eq_mask word_bw_lcs(1) word_log_esimps(1))
  apply (metis add.commute add_left_imp_eq take_bit_eq_mask word_plus_and_or_coroll2)
  done

lemmas mask_inner_mask = mask_eqs(1)

lemma mask_add_aligned:
  "is_aligned p n \<Longrightarrow> (p + q) AND mask n = q AND mask n"
  apply (simp add: is_aligned_mask)
  apply (subst mask_inner_mask [symmetric])
  apply simp
  done

lemma mask_out_add_aligned:
  assumes al: "is_aligned p n"
  shows "p + (q AND NOT (mask n)) = (p + q) AND NOT (mask n)"
  using mask_add_aligned [OF al]
  by (simp add: mask_out_sub_mask)

lemma is_aligned_add_or:
  "\<lbrakk>is_aligned p n; d < 2 ^ n\<rbrakk> \<Longrightarrow> p + d = p OR d"
  apply (subst disjunctive_add)
   apply (simp_all add: is_aligned_iff_take_bit_eq_0)
  apply (simp add: bit_eq_iff)
  apply (auto simp add: bit_simps)
  subgoal for m
    apply (cases \<open>m < n\<close>)
     apply (auto simp add: not_less)
    apply (metis bit_take_bit_iff less_mask_eq take_bit_eq_mask)
    done
  done

lemma not_greatest_aligned:
  "\<lbrakk> x < y; is_aligned x n; is_aligned y n \<rbrakk> \<Longrightarrow> x + 2 ^ n \<noteq> 0"
  by (metis NOT_mask add_diff_cancel_right' diff_0 is_aligned_neg_mask_eq not_le word_and_le1)

lemma neg_mask_mono_le:
  "x \<le> y \<Longrightarrow> x AND NOT(mask n) \<le> y AND NOT(mask n)" for x :: "'a :: len word"
proof (rule ccontr, simp add: linorder_not_le, cases "n < LENGTH('a)")
  case False
  then show "y AND NOT(mask n) < x AND NOT(mask n) \<Longrightarrow> False"
    by (simp add: mask_eq_decr_exp linorder_not_less power_overflow)
next
  case True
  assume a: "x \<le> y" and b: "y AND NOT(mask n) < x AND NOT(mask n)"
  have word_bits: "n < LENGTH('a)" by fact
  have "y \<le> (y AND NOT(mask n)) + (y AND mask n)"
    by (simp add: word_plus_and_or_coroll2 add.commute)
  also have "\<dots> \<le> (y AND NOT(mask n)) + 2 ^ n"
    apply (rule word_plus_mono_right)
     apply (rule order_less_imp_le, rule and_mask_less_size)
     apply (simp add: word_size word_bits)
    apply (rule is_aligned_no_overflow'', simp add: is_aligned_neg_mask word_bits)
    apply (rule not_greatest_aligned, rule b; simp add: is_aligned_neg_mask)
    done
  also have "\<dots> \<le> x AND NOT(mask n)"
    using b
    apply (subst add.commute)
    apply (rule le_plus)
     apply (rule aligned_at_least_t2n_diff; simp add: is_aligned_neg_mask)
    apply (rule ccontr, simp add: linorder_not_le)
    apply (drule aligned_small_is_0[rotated]; simp add: is_aligned_neg_mask)
    done
  also have "\<dots> \<le> x" by (rule word_and_le2)
  also have "x \<le> y" by fact
  finally
  show "False" using b by simp
qed

lemma and_neg_mask_eq_iff_not_mask_le:
  "w AND NOT(mask n) = NOT(mask n) \<longleftrightarrow> NOT(mask n) \<le> w"
  for w :: \<open>'a::len word\<close>
  by (metis eq_iff neg_mask_mono_le word_and_le1 word_and_le2 word_bw_same(1))

lemma neg_mask_le_high_bits [word_eqI_simps]:
  "NOT(mask n) \<le> w \<longleftrightarrow> (\<forall>i \<in> {n ..< size w}. w !! i)"
  for w :: \<open>'a::len word\<close>
  by (auto simp: word_size and_neg_mask_eq_iff_not_mask_le[symmetric] word_eq_iff neg_mask_test_bit)

lemma is_aligned_add_less_t2n:
  "\<lbrakk>is_aligned (p::'a::len word) n; d < 2^n; n \<le> m; p < 2^m\<rbrakk> \<Longrightarrow> p + d < 2^m"
  apply (case_tac "m < LENGTH('a)")
   apply (subst mask_eq_iff_w2p[symmetric])
    apply (simp add: word_size)
   apply (simp add: is_aligned_add_or word_ao_dist less_mask_eq)
   apply (subst less_mask_eq)
    apply (erule order_less_le_trans)
    apply (erule(1) two_power_increasing)
   apply simp
  apply (simp add: power_overflow)
  done

lemma aligned_offset_non_zero:
  "\<lbrakk> is_aligned x n; y < 2 ^ n; x \<noteq> 0 \<rbrakk> \<Longrightarrow> x + y \<noteq> 0"
  apply (cases "y = 0")
   apply simp
  apply (subst word_neq_0_conv)
  apply (subst gt0_iff_gem1)
  apply (erule is_aligned_get_word_bits)
   apply (subst field_simps[symmetric], subst plus_le_left_cancel_nowrap)
     apply (rule is_aligned_no_wrap')
      apply simp
     apply (rule word_leq_le_minus_one)
      apply simp
     apply assumption
    apply (erule (1) is_aligned_no_wrap')
   apply (simp add: gt0_iff_gem1 [symmetric] word_neq_0_conv)
  apply simp
  done

lemma is_aligned_over_length:
  "\<lbrakk> is_aligned p n; LENGTH('a) \<le> n \<rbrakk> \<Longrightarrow> (p::'a::len word) = 0"
  by (simp add: is_aligned_mask mask_over_length)

lemma is_aligned_no_overflow_mask:
  "is_aligned x n \<Longrightarrow> x \<le> x + mask n"
  by (simp add: mask_eq_decr_exp) (erule is_aligned_no_overflow')

lemma aligned_mask_step:
  "\<lbrakk> n' \<le> n; p' \<le> p + mask n; is_aligned p n; is_aligned p' n' \<rbrakk> \<Longrightarrow>
   (p'::'a::len word) + mask n' \<le> p + mask n"
  apply (cases "LENGTH('a) \<le> n")
   apply (frule (1) is_aligned_over_length)
   apply (drule mask_over_length)
   apply clarsimp
  apply (simp add: not_le)
  apply (simp add: word_le_nat_alt unat_plus_simple)
  apply (subst unat_plus_simple[THEN iffD1], erule is_aligned_no_overflow_mask)+
  apply (subst (asm) unat_plus_simple[THEN iffD1], erule is_aligned_no_overflow_mask)
  apply (clarsimp simp: dvd_def is_aligned_iff_dvd_nat)
  apply (rename_tac k k')
  apply (thin_tac "unat p = x" for p x)+
  apply (subst Suc_le_mono[symmetric])
  apply (simp only: Suc_2p_unat_mask)
  apply (drule le_imp_less_Suc, subst (asm) Suc_2p_unat_mask, assumption)
  apply (erule (1) power_2_mult_step_le)
  done

lemma is_aligned_mask_offset_unat:
  fixes off :: "('a::len) word"
  and     x :: "'a word"
  assumes al: "is_aligned x sz"
  and   offv: "off \<le> mask sz"
  shows  "unat x + unat off < 2 ^ LENGTH('a)"
proof cases
  assume szv: "sz < LENGTH('a)"
  from al obtain k where xv: "x = 2 ^ sz * (of_nat k)"
    and kl: "k < 2 ^ (LENGTH('a) - sz)"
    by (auto elim: is_alignedE)

  from offv szv have offv': "unat off < 2 ^ sz"
    by (simp add: mask_2pm1 unat_less_power)

  show ?thesis using szv
    using al is_aligned_no_wrap''' offv' by blast
next
  assume "\<not> sz < LENGTH('a)"
  with al have "x = 0"
    by (meson is_aligned_get_word_bits)
  thus ?thesis by simp
qed

lemma aligned_less_plus_1:
  "\<lbrakk> is_aligned x n; n > 0 \<rbrakk> \<Longrightarrow> x < x + 1"
  apply (rule plus_one_helper2)
   apply (rule order_refl)
  apply (clarsimp simp: field_simps)
  apply (drule arg_cong[where f="\<lambda>x. x - 1"])
  apply (clarsimp simp: is_aligned_mask)
  apply (drule word_eqD[where x=0])
  apply simp
  done

lemma aligned_add_offset_less:
  "\<lbrakk>is_aligned x n; is_aligned y n; x < y; z < 2 ^ n\<rbrakk> \<Longrightarrow> x + z < y"
  apply (cases "y = 0")
   apply simp
  apply (erule is_aligned_get_word_bits[where p=y], simp_all)
  apply (cases "z = 0", simp_all)
  apply (drule(2) aligned_at_least_t2n_diff[rotated -1])
  apply (drule plus_one_helper2)
   apply (rule less_is_non_zero_p1)
   apply (rule aligned_less_plus_1)
    apply (erule aligned_sub_aligned[OF _ _ order_refl],
           simp_all add: is_aligned_triv)[1]
   apply (cases n, simp_all)[1]
  apply (simp only: trans[OF diff_add_eq diff_diff_eq2[symmetric]])
  apply (drule word_less_add_right)
   apply (rule ccontr, simp add: linorder_not_le)
   apply (drule aligned_small_is_0, erule order_less_trans)
    apply (clarsimp simp: power_overflow)
   apply simp
  apply (erule order_le_less_trans[rotated],
         rule word_plus_mono_right)
   apply (erule word_le_minus_one_leq)
  apply (simp add: is_aligned_no_wrap' is_aligned_no_overflow field_simps)
  done

lemma gap_between_aligned:
  "\<lbrakk>a < (b :: 'a ::len word); is_aligned a n; is_aligned b n; n < LENGTH('a) \<rbrakk>
  \<Longrightarrow> a + (2^n - 1) < b"
  by (simp add: aligned_add_offset_less)

lemma is_aligned_add_step_le:
  "\<lbrakk> is_aligned (a::'a::len word) n; is_aligned b n; a < b; b \<le> a + mask n \<rbrakk> \<Longrightarrow> False"
  apply (simp flip: not_le)
  apply (erule notE)
  apply (cases "LENGTH('a) \<le> n")
   apply (drule (1) is_aligned_over_length)+
   apply (drule mask_over_length)
   apply clarsimp
  apply (clarsimp simp: word_le_nat_alt not_less not_le)
  apply (subst (asm) unat_plus_simple[THEN iffD1], erule is_aligned_no_overflow_mask)
  apply (subst (asm) unat_add_lem' [symmetric])
   apply (simp add: is_aligned_mask_offset_unat)
  apply (metis gap_between_aligned linorder_not_less mask_eq_decr_exp unat_arith_simps(2))
  done

lemma aligned_add_mask_lessD:
  "\<lbrakk> x + mask n < y; is_aligned x n \<rbrakk> \<Longrightarrow> x < y" for y::"'a::len word"
  by (metis is_aligned_no_overflow' mask_2pm1 order_le_less_trans)

lemma aligned_add_mask_less_eq:
  "\<lbrakk> is_aligned x n; is_aligned y n;  n < LENGTH('a) \<rbrakk> \<Longrightarrow> (x + mask n < y) = (x < y)"
  for y::"'a::len word"
  using aligned_add_mask_lessD is_aligned_add_step_le word_le_not_less by blast

lemma is_aligned_diff:
  fixes m :: "'a::len word"
  assumes alm: "is_aligned m s1"
  and     aln: "is_aligned n s2"
  and    s2wb: "s2 < LENGTH('a)"
  and      nm: "m \<in> {n .. n + (2 ^ s2 - 1)}"
  and    s1s2: "s1 \<le> s2"
  and     s10: "0 < s1" (* Probably can be folded into the proof \<dots> *)
shows  "\<exists>q. m - n = of_nat q * 2 ^ s1 \<and> q < 2 ^ (s2 - s1)"
proof -
  have rl: "\<And>m s. \<lbrakk> m < 2 ^ (LENGTH('a) - s); s < LENGTH('a) \<rbrakk> \<Longrightarrow> unat ((2::'a word) ^ s * of_nat m) = 2 ^ s * m"
  proof -
    fix m :: nat and  s
    assume m: "m < 2 ^ (LENGTH('a) - s)" and s: "s < LENGTH('a)"
    then have "unat ((of_nat m) :: 'a word) = m"
      apply (subst unat_of_nat)
      apply (subst mod_less)
       apply (erule order_less_le_trans)
       apply (rule power_increasing)
        apply simp_all
      done

    then show "?thesis m s" using s m
      apply (subst iffD1 [OF unat_mult_lem])
      apply (simp add: nat_less_power_trans)+
      done
  qed
  have s1wb: "s1 < LENGTH('a)" using s2wb s1s2 by simp
  from alm obtain mq where mmq: "m = 2 ^ s1 * of_nat mq" and mq: "mq < 2 ^ (LENGTH('a) - s1)"
    by (auto elim: is_alignedE simp: field_simps)
  from aln obtain nq where nnq: "n = 2 ^ s2 * of_nat nq" and nq: "nq < 2 ^ (LENGTH('a) - s2)"
    by (auto elim: is_alignedE simp: field_simps)
  from s1s2 obtain sq where sq: "s2 = s1 + sq" by (auto simp: le_iff_add)

  note us1 = rl [OF mq s1wb]
  note us2 = rl [OF nq s2wb]

  from nm have "n \<le> m" by clarsimp
  then have "(2::'a word) ^ s2 * of_nat nq \<le> 2 ^ s1 * of_nat mq" using nnq mmq by simp
  then have "2 ^ s2 * nq \<le> 2 ^ s1 * mq" using s1wb s2wb
    by (simp add: word_le_nat_alt us1 us2)
  then have nqmq: "2 ^ sq * nq \<le> mq" using sq by (simp add: power_add)

  have "m - n = 2 ^ s1 * of_nat mq - 2 ^ s2 * of_nat nq" using mmq nnq by simp
  also have "\<dots> = 2 ^ s1 * of_nat mq - 2 ^ s1 * 2 ^ sq * of_nat nq" using sq by (simp add: power_add)
  also have "\<dots> = 2 ^ s1 * (of_nat mq - 2 ^ sq * of_nat nq)" by (simp add: field_simps)
  also have "\<dots> = 2 ^ s1 * of_nat (mq - 2 ^ sq * nq)" using s1wb s2wb us1 us2 nqmq
    by (simp add: of_nat_diff)
  finally have mn: "m - n = of_nat (mq - 2 ^ sq * nq) * 2 ^ s1" by simp
  moreover
  from nm have "m - n \<le> 2 ^ s2 - 1"
    by - (rule word_diff_ls', (simp add: field_simps)+)
  then have "(2::'a word) ^ s1 * of_nat (mq - 2 ^ sq * nq) < 2 ^ s2" using mn s2wb by (simp add: field_simps)
  then have "of_nat (mq - 2 ^ sq * nq) < (2::'a word) ^ (s2 - s1)"
  proof (rule word_power_less_diff)
    have mm: "mq - 2 ^ sq * nq < 2 ^ (LENGTH('a) - s1)" using mq by simp
    moreover from s10 have "LENGTH('a) - s1 < LENGTH('a)"
      by (rule diff_less, simp)
    ultimately show "of_nat (mq - 2 ^ sq * nq) < (2::'a word) ^ (LENGTH('a) - s1)"
      using take_bit_nat_less_self_iff [of \<open>LENGTH('a)\<close> \<open>mq - 2 ^ sq * nq\<close>]
      apply (auto simp add: word_less_nat_alt not_le not_less)
      apply (metis take_bit_nat_eq_self_iff)
      done
  qed
  then have "mq - 2 ^ sq * nq < 2 ^ (s2 - s1)" using mq s2wb
    apply (simp add: word_less_nat_alt take_bit_eq_mod)
    apply (subst (asm) mod_less)
    apply auto
     apply (rule order_le_less_trans)
      apply (rule diff_le_self)
     apply (erule order_less_le_trans)
    apply simp
    done
  ultimately show ?thesis
    by auto
qed

lemma is_aligned_addD1:
  assumes al1: "is_aligned (x + y) n"
  and     al2: "is_aligned (x::'a::len word) n"
  shows "is_aligned y n"
  using al2
proof (rule is_aligned_get_word_bits)
  assume "x = 0" then show ?thesis using al1 by simp
next
  assume nv: "n < LENGTH('a)"
  from al1 obtain q1
    where xy: "x + y = 2 ^ n * of_nat q1" and "q1 < 2 ^ (LENGTH('a) - n)"
    by (rule is_alignedE)
  moreover from al2 obtain q2
    where x: "x = 2 ^ n * of_nat q2" and "q2 < 2 ^ (LENGTH('a) - n)"
    by (rule is_alignedE)
  ultimately have "y = 2 ^ n * (of_nat q1 - of_nat q2)"
    by (simp add: field_simps)
  then show ?thesis using nv by (simp add: is_aligned_mult_triv1)
qed

lemmas is_aligned_addD2 =
       is_aligned_addD1[OF subst[OF add.commute,
                                 of "%x. is_aligned x n" for n]]

lemma is_aligned_add:
  "\<lbrakk>is_aligned p n; is_aligned q n\<rbrakk> \<Longrightarrow> is_aligned (p + q) n"
  by (simp add: is_aligned_mask mask_add_aligned)

lemma aligned_shift:
  "\<lbrakk>x < 2 ^ n; is_aligned (y :: 'a :: len word) n;n \<le> LENGTH('a)\<rbrakk>
   \<Longrightarrow> x + y >> n = y >> n"
  apply (subst word_plus_and_or_coroll; rule bit_word_eqI)
   apply (auto simp add: bit_simps is_aligned_nth test_bit_eq_bit)
   apply (metis less_2p_is_upper_bits_unset not_le test_bit_word_eq)
  apply (metis le_add1 less_2p_is_upper_bits_unset test_bit_bin test_bit_word_eq)
  done

lemma aligned_shift':
  "\<lbrakk>x < 2 ^ n; is_aligned (y :: 'a :: len word) n;n \<le> LENGTH('a)\<rbrakk>
   \<Longrightarrow> y + x >> n = y >> n"
  apply (subst word_plus_and_or_coroll; rule bit_word_eqI)
   apply (auto simp add: bit_simps is_aligned_nth test_bit_eq_bit)
   apply (metis less_2p_is_upper_bits_unset not_le test_bit_eq_bit)
  apply (metis bit_imp_le_length le_add1 less_2p_is_upper_bits_unset test_bit_eq_bit)
  done

lemma and_neg_mask_plus_mask_mono: "(p AND NOT (mask n)) + mask n \<ge> p"
  for p :: \<open>'a::len word\<close>
  apply (rule word_le_minus_cancel[where x = "p AND NOT (mask n)"])
   apply (clarsimp simp: subtract_mask)
   using word_and_le1[where a = "mask n" and y = p]
    apply (clarsimp simp: mask_eq_decr_exp word_le_less_eq)
  apply (rule is_aligned_no_overflow'[folded mask_2pm1])
  apply (clarsimp simp: is_aligned_neg_mask)
  done

lemma word_neg_and_le:
  "ptr \<le> (ptr AND NOT (mask n)) + (2 ^ n - 1)"
  for ptr :: \<open>'a::len word\<close>
  by (simp add: and_neg_mask_plus_mask_mono mask_2pm1[symmetric])

lemma is_aligned_sub_helper:
  "\<lbrakk> is_aligned (p - d) n; d < 2 ^ n \<rbrakk>
     \<Longrightarrow> (p AND mask n = d) \<and> (p AND (NOT (mask n)) = p - d)"
  by (drule(1) is_aligned_add_helper, simp)

lemma is_aligned_after_mask:
  "\<lbrakk>is_aligned k m;m\<le> n\<rbrakk> \<Longrightarrow> is_aligned (k AND mask n) m"
  by (rule is_aligned_andI1)

lemma and_mask_plus:
  "\<lbrakk>is_aligned ptr m; m \<le> n; a < 2 ^ m\<rbrakk>
   \<Longrightarrow> ptr + a AND mask n = (ptr AND mask n) + a"
  apply (rule mask_eqI[where n = m])
   apply (simp add:mask_twice min_def)
    apply (simp add:is_aligned_add_helper)
    apply (subst is_aligned_add_helper[THEN conjunct1])
      apply (erule is_aligned_after_mask)
     apply simp
    apply simp
   apply simp
  apply (subgoal_tac "(ptr + a AND mask n) AND NOT (mask m)
     = (ptr + a AND NOT (mask m) ) AND mask n")
   apply (simp add:is_aligned_add_helper)
   apply (subst is_aligned_add_helper[THEN conjunct2])
     apply (simp add:is_aligned_after_mask)
    apply simp
   apply simp
  apply (simp add:word_bw_comms word_bw_lcs)
  done

end


theory DDFS
  imports Main
begin

text \<open>Theory about digraphs\<close>

definition "dVs dG \<equiv> \<Union> {{v1,v2} | v1 v2. (v1, v2) \<in> dG}"

inductive dpath where
  dpath0: "dpath dG []" |
  dpath1: "v \<in> dVs dG \<Longrightarrow> dpath dG [v]" |
  dpath2: "(v,v') \<in> dG \<Longrightarrow> dpath dG (v'#vs) \<Longrightarrow> dpath dG (v#v'#vs)"

declare dpath0[simp]

inductive_simps dpath_1[simp]: "dpath E [v]"

inductive_simps dpath_2[simp]: "dpath E (v # v' # vs)"

abbreviation "dpath_bet dG p \<equiv> \<lambda>v v'. dpath dG p \<and> p \<noteq> [] \<and> hd p = v \<and> last p = v'"

lemma path_then_edge: "dpath_bet dG p v v' \<Longrightarrow> p \<noteq> [] \<Longrightarrow> v \<noteq> v' \<Longrightarrow> (\<exists>v''. (v, v'') \<in> dG)"
  by(cases p; auto split: if_splits simp: neq_Nil_conv)

lemma path_then_in_Vs: "dpath dG p \<Longrightarrow> v \<in> set p \<Longrightarrow> v \<in> dVs dG"
  by(induction rule: dpath.induct) (auto simp: dVs_def)

lemma dpath_cons: "dpath dG (v1#v2#p) \<Longrightarrow> (v1,v2) \<in> dG"
  by simp

lemma hd_of_dpath_bet:
  "dpath_bet dG p v v' \<Longrightarrow> p \<noteq> [] \<Longrightarrow> \<exists>p'. p = v # p'"
  by(auto simp: neq_Nil_conv)

lemma hd_of_dpath_bet':
  "dpath_bet dG p v v' \<Longrightarrow> p \<noteq> [] \<Longrightarrow> v = hd p"
  by(auto simp: neq_Nil_conv)

lemma last_of_dpath_bet:
  "dpath_bet dG p v v' \<Longrightarrow> p \<noteq> [] \<Longrightarrow> v' = last p"
  by(auto simp: neq_Nil_conv)

lemma induct_pcpl:
  "\<lbrakk>P []; \<And>x. P [x]; \<And>x y zs. P zs \<Longrightarrow> P (x # y # zs)\<rbrakk> \<Longrightarrow> P xs"
  by induction_schema (pat_completeness, lexicographic_order)

lemma induct_pcpl_2:
  "\<lbrakk>P []; \<And>x. P [x]; \<And>x y. P [x,y]; \<And>x y z. P [x,y,z]; \<And>w x y z zs. P zs \<Longrightarrow> P (w # x # y # z # zs)\<rbrakk> \<Longrightarrow> P xs"
  by induction_schema (pat_completeness, lexicographic_order)

lemma dVsI1:
assumes "(a, v) \<in> dG" shows "a \<in> dVs dG"
using assms unfolding dVs_def by auto

lemma append_dpath_1: "dpath dG (p1 @ p2) \<Longrightarrow> dpath dG p1"
  by (induction p1) (fastforce intro: dpath.intros elim: dpath.cases simp: dVsI1)+

lemma append_dpath_pref: "dpath dG (p1 @ p2) \<Longrightarrow> dpath dG p1"
  by (induction p1) (fastforce intro: dpath.intros elim: dpath.cases simp: dVsI1)+

lemma append_dpath_suff: "dpath dG (p1 @ p2) \<Longrightarrow> dpath dG p2"
  by (induction p1) (fastforce intro: dpath.intros elim: dpath.cases simp:)+

lemma append_dpath: "dpath dG p1 \<Longrightarrow> dpath dG p2 \<Longrightarrow> (last p1, hd p2) \<in> dG \<Longrightarrow> dpath dG (p1 @ p2)"
  by (induction p1) (fastforce intro: dpath.intros elim: dpath.cases simp: dVsI1)+

lemma split_dpath:
  "dpath_bet dG (p1 @ v2 # p2) v1 v3 \<Longrightarrow> dpath_bet dG (v2 # p2) v2 v3"
proof (induction p1)
  case (Cons v p1)
  then show ?case
    by (auto intro: append_dpath_suff[where ?p1.0 = "v1 # p1"] simp add: path_then_in_Vs)
qed auto

lemma dpath_bet_cons:
  "dpath_bet dG (v # p) v u \<Longrightarrow> p \<noteq> [] \<Longrightarrow> dpath_bet dG p (hd p) u"
  by(auto simp: neq_Nil_conv)

lemma dpath_bet_cons_2:
  "dpath_bet dG p v v' \<Longrightarrow> p \<noteq> [] \<Longrightarrow> dpath_bet dG (v # tl p) v v'"
  by(auto simp: neq_Nil_conv)

lemma dpath_bet_snoc:
  "dpath_bet dG (p @ [v]) v' v'' \<Longrightarrow> v = v''"
  by(auto simp: neq_Nil_conv)

lemma dpath_bet_dpath:
  "p \<noteq> [] \<Longrightarrow> dpath_bet dG p (hd p) (last p) \<longleftrightarrow> dpath dG p"
  by(auto simp: neq_Nil_conv)

lemma dpath_snoc_edge': "dpath dG (p @ [v]) \<Longrightarrow> (v, v') \<in> dG \<Longrightarrow> dpath dG ((p @ [v]) @ [v'])"
  apply (rule append_dpath)
  by (auto simp add: dVs_def)

lemma dpath_snoc_edge: "dpath dG (p @ [v]) \<Longrightarrow> (v, v') \<in> dG \<Longrightarrow> dpath dG (p @ [v, v'])"
  using dpath_snoc_edge'
  by simp

lemma dpath_snoc_edge_2: "dpath dG (p @ [v, v']) \<Longrightarrow> (v, v') \<in> dG"
  using append_dpath_suff[where ?p2.0 = "[v, v']"]
  by auto

lemma dpath_append_edge: "dpath dG (p1 @ p2) \<Longrightarrow> p1 \<noteq> [] \<Longrightarrow> p2 \<noteq> [] \<Longrightarrow> (last p1, hd p2) \<in> dG"
  by (induction p1) (auto simp: path_then_in_Vs neq_Nil_conv)

lemma dpath_transitive_rel:
  assumes "(\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z)" "(\<And>v1 v2. (v1, v2) \<in> dG \<Longrightarrow> R v1 v2)"
  shows "dpath dG (v#vs) \<Longrightarrow> v' \<in> set vs \<Longrightarrow> R v v'"
proof(induction vs arbitrary: v v')
  case (Cons v'' vs)
  hence "R v v''"
    using assms(2)
    by simp
  thus ?case
  proof(cases "v' = v''")
    case False
    thus ?thesis
      apply(intro assms(1)[OF \<open>R v v''\<close>] Cons)
      using Cons.prems
      by auto
  qed simp
qed auto

lemma dpath_transitive_rel':
  assumes "(\<And>x y z. R x y \<Longrightarrow> R y z \<Longrightarrow> R x z)" "(\<And>v1 v2. (v1, v2) \<in> dG \<Longrightarrow> R v1 v2)"
  shows "dpath dG (vs @ [v]) \<Longrightarrow> v' \<in> set vs \<Longrightarrow> R v' v"
proof(induction vs arbitrary: v v' rule: rev_induct)
  case (snoc v'' vs)
  hence "R v'' v"
    by(auto intro: assms dpath_snoc_edge_2)
  thus ?case
  proof(cases "v' = v''")
    case True
    then show ?thesis
      by (simp add: \<open>R v'' v\<close>)
  next
    case False
    thus ?thesis
      apply(intro assms(1)[OF _ \<open>R v'' v\<close>] snoc append_dpath_pref[where ?p1.0 = "vs @ [v'']"])
      using snoc(2,3)
      by auto
  qed
qed auto

end


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_28
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun rev :: "'a list => 'a list" where
  "rev (nil2) = nil2"
| "rev (cons2 z xs) = x (rev xs) (cons2 z (nil2))"

fun revflat :: "('a list) list => 'a list" where
  "revflat (nil2) = nil2"
| "revflat (cons2 xs xss) = x (revflat xss) (rev xs)"

fun qrevflat :: "('a list) list => 'a list => 'a list" where
  "qrevflat (nil2) z = z"
| "qrevflat (cons2 xs xss) z = qrevflat xss (x (rev xs) z)"

theorem property0 :
  "((revflat y) = (qrevflat y (nil2)))"
  oops

end