theory int_mul_assoc
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Sign = Pos | Neg

datatype Nat = Zero | Succ "Nat"

datatype Z = P "Nat" | N "Nat"

fun toInteger :: "Sign => Nat => Z" where
"toInteger (Pos) y = P y"
| "toInteger (Neg) (Zero) = P Zero"
| "toInteger (Neg) (Succ m) = N m"

fun sign2 :: "Z => Sign" where
"sign2 (P y) = Pos"
| "sign2 (N z) = Neg"

fun plus :: "Nat => Nat => Nat" where
"plus (Zero) y = y"
| "plus (Succ n) y = Succ (plus n y)"

fun opposite :: "Sign => Sign" where
"opposite (Pos) = Neg"
| "opposite (Neg) = Pos"

fun timesSign :: "Sign => Sign => Sign" where
"timesSign (Pos) y = y"
| "timesSign (Neg) y = opposite y"

fun mult :: "Nat => Nat => Nat" where
"mult (Zero) y = Zero"
| "mult (Succ n) y = plus y (mult n y)"

fun absVal :: "Z => Nat" where
"absVal (P n) = n"
| "absVal (N m) = Succ m"

fun times :: "Z => Z => Z" where
"times x y =
   toInteger
     (timesSign (sign2 x) (sign2 y)) (mult (absVal x) (absVal y))"

(*hipster toInteger
          sign2
          plus
          opposite
          timesSign
          mult
          absVal
          times *)

theorem x0 :
  "!! (x :: Z) (y :: Z) (z :: Z) .
     (times x (times y z)) = (times (times x y) z)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Ex004
imports Main
begin

lemma  "(A \<longrightarrow> (B \<and> C)) \<longrightarrow> (A \<longrightarrow> B)"
proof -
{
  assume "A \<longrightarrow> (B \<and> C)"
  {
    assume "A"
    with \<open>A \<longrightarrow> (B \<and> C)\<close> have "B \<and> C" by (rule impE)
    hence B by (rule conjE)
  }
  hence "A \<longrightarrow> B" by (rule impI)
}
thus ?thesis by (rule impI)
qed


theory Contexts
imports "../Nominal"
begin

text {*

  We show here that the Plotkin-style of defining
  beta-reduction (based on congruence rules) is
  equivalent to the Felleisen-Hieb-style representation
  (based on contexts).

  The interesting point in this theory is that contexts
  do not contain any binders. On the other hand the operation
  of filling a term into a context produces an alpha-equivalent
  term.

*}

atom_decl name

text {*
  Lambda-Terms - the Lam-term constructor binds a name
*}

nominal_datatype lam =
    Var "name"
  | App "lam" "lam"
  | Lam "\<guillemotleft>name\<guillemotright>lam" ("Lam [_]._" [100,100] 100)

text {*
  Contexts - the lambda case in contexts does not bind
  a name, even if we introduce the notation [_]._ for CLam.
*}

nominal_datatype ctx =
    Hole ("\<box>" 1000)
  | CAppL "ctx" "lam"
  | CAppR "lam" "ctx"
  | CLam "name" "ctx"  ("CLam [_]._" [100,100] 100)

text {* Capture-Avoiding Substitution *}

nominal_primrec
  subst :: "lam \<Rightarrow> name \<Rightarrow> lam \<Rightarrow> lam"  ("_[_::=_]" [100,100,100] 100)
where
  "(Var x)[y::=s] = (if x=y then s else (Var x))"
| "(App t\<^sub>1 t\<^sub>2)[y::=s] = App (t\<^sub>1[y::=s]) (t\<^sub>2[y::=s])"
| "x\<sharp>(y,s) \<Longrightarrow> (Lam [x].t)[y::=s] = Lam [x].(t[y::=s])"
apply(finite_guess)+
apply(rule TrueI)+
apply(simp add: abs_fresh)
apply(fresh_guess)+
done

text {*
  Filling is the operation that fills a term into a hole.
  This operation is possibly capturing.
*}

nominal_primrec
  filling :: "ctx \<Rightarrow> lam \<Rightarrow> lam" ("_\<lbrakk>_\<rbrakk>" [100,100] 100)
where
  "\<box>\<lbrakk>t\<rbrakk> = t"
| "(CAppL E t')\<lbrakk>t\<rbrakk> = App (E\<lbrakk>t\<rbrakk>) t'"
| "(CAppR t' E)\<lbrakk>t\<rbrakk> = App t' (E\<lbrakk>t\<rbrakk>)"
| "(CLam [x].E)\<lbrakk>t\<rbrakk> = Lam [x].(E\<lbrakk>t\<rbrakk>)"
by (rule TrueI)+

text {*
  While contexts themselves are not alpha-equivalence classes, the
  filling operation produces an alpha-equivalent lambda-term.
*}

lemma alpha_test:
  shows "x\<noteq>y \<Longrightarrow> (CLam [x].\<box>) \<noteq> (CLam [y].\<box>)"
  and   "(CLam [x].\<box>)\<lbrakk>Var x\<rbrakk> = (CLam [y].\<box>)\<lbrakk>Var y\<rbrakk>"
by (auto simp add: alpha ctx.inject lam.inject calc_atm fresh_atm)

text {* The composition of two contexts. *}

nominal_primrec
 ctx_compose :: "ctx \<Rightarrow> ctx \<Rightarrow> ctx" ("_ \<circ> _" [100,100] 100)
where
  "\<box> \<circ> E' = E'"
| "(CAppL E t') \<circ> E' = CAppL (E \<circ> E') t'"
| "(CAppR t' E) \<circ> E' = CAppR t' (E \<circ> E')"
| "(CLam [x].E) \<circ> E' = CLam [x].(E \<circ> E')"
by (rule TrueI)+

lemma ctx_compose:
  shows "(E1 \<circ> E2)\<lbrakk>t\<rbrakk> = E1\<lbrakk>E2\<lbrakk>t\<rbrakk>\<rbrakk>"
by (induct E1 rule: ctx.induct) (auto)

text {* Beta-reduction via contexts in the Felleisen-Hieb style. *}

inductive
  ctx_red :: "lam\<Rightarrow>lam\<Rightarrow>bool" ("_ \<longrightarrow>x _" [80,80] 80)
where
  xbeta[intro]: "E\<lbrakk>App (Lam [x].t) t'\<rbrakk> \<longrightarrow>x E\<lbrakk>t[x::=t']\<rbrakk>"

text {* Beta-reduction via congruence rules in the Plotkin style. *}

inductive
  cong_red :: "lam\<Rightarrow>lam\<Rightarrow>bool" ("_ \<longrightarrow>o _" [80,80] 80)
where
  obeta[intro]: "App (Lam [x].t) t' \<longrightarrow>o t[x::=t']"
| oapp1[intro]: "t \<longrightarrow>o t' \<Longrightarrow> App t t2 \<longrightarrow>o App t' t2"
| oapp2[intro]: "t \<longrightarrow>o t' \<Longrightarrow> App t2 t \<longrightarrow>o App t2 t'"
| olam[intro]:  "t \<longrightarrow>o t' \<Longrightarrow> Lam [x].t \<longrightarrow>o Lam [x].t'"

text {* The proof that shows both relations are equal. *}

lemma cong_red_in_ctx:
  assumes a: "t \<longrightarrow>o t'"
  shows "E\<lbrakk>t\<rbrakk> \<longrightarrow>o E\<lbrakk>t'\<rbrakk>"
using a
by (induct E rule: ctx.induct) (auto)

lemma ctx_red_in_ctx:
  assumes a: "t \<longrightarrow>x t'"
  shows "E\<lbrakk>t\<rbrakk> \<longrightarrow>x E\<lbrakk>t'\<rbrakk>"
using a
by (induct) (auto simp add: ctx_compose[symmetric])

theorem ctx_red_implies_cong_red:
  assumes a: "t \<longrightarrow>x t'"
  shows "t \<longrightarrow>o t'"
using a by (induct) (auto intro: cong_red_in_ctx)

theorem cong_red_implies_ctx_red:
  assumes a: "t \<longrightarrow>o t'"
  shows "t \<longrightarrow>x t'"
using a
proof (induct)
  case (obeta x t' t)
  have "\<box>\<lbrakk>App (Lam [x].t) t'\<rbrakk> \<longrightarrow>x \<box>\<lbrakk>t[x::=t']\<rbrakk>" by (rule xbeta)
  then show  "App (Lam [x].t) t' \<longrightarrow>x t[x::=t']" by simp
qed (metis ctx_red_in_ctx filling.simps)+ (* found by SledgeHammer *)

lemma ctx_existence:
  assumes a: "t \<longrightarrow>o t'"
  shows "\<exists>C s s'. t = C\<lbrakk>s\<rbrakk> \<and> t' = C\<lbrakk>s'\<rbrakk> \<and> s \<longrightarrow>o s'"
using a
by (induct) (metis cong_red.intros filling.simps)+

end


(* Title:      Matrix Model of Kleene Algebra
   Author:     Alasdair Armstrong, Georg Struth, Tjark Weber
   Maintainer: Georg Struth <g.struth at sheffield.ac.uk>
               Tjark Weber <tjark.weber at it.uu.se>
*)

section \<open>Matrices\<close>

theory Matrix
imports "HOL-Word.Word" Dioid
begin

text \<open>In this section we formalise a perhaps more natural version of
matrices of fixed dimension ($m \times n$-matrices). It is well known
that such matrices over a Kleene algebra form a Kleene
algebra~\cite{conway71regular}.\<close>

subsection \<open>Type Definition\<close>

typedef (overloaded) 'a atMost = "{..<LENGTH('a::len)}"
by auto

declare Rep_atMost_inject [simp]

lemma UNIV_atMost:
  "(UNIV::'a atMost set) = Abs_atMost ` {..<LENGTH('a::len)}"
 apply auto
 apply (rule Abs_atMost_induct)
 apply auto
done

lemma finite_UNIV_atMost [simp]: "finite (UNIV::('a::len) atMost set)"
  by (simp add: UNIV_atMost)

text \<open>Our matrix type is similar to \mbox{\<open>'a^'n^'m\<close>} from
{\em HOL/Multivariate\_Analysis/Finite\_Cartesian\_Product.thy}, but
(i)~we explicitly define a type constructor for matrices and square
matrices, and (ii)~in the definition of operations, e.g., matrix
multiplication, we impose weaker sort requirements on the element
type.\<close>

context notes [[typedef_overloaded]]
begin

datatype ('a,'m,'n) matrix = Matrix "'m atMost \<Rightarrow> 'n atMost \<Rightarrow> 'a"

datatype ('a,'m) sqmatrix = SqMatrix "'m atMost \<Rightarrow> 'm atMost \<Rightarrow> 'a"

end

fun sqmatrix_of_matrix where
  "sqmatrix_of_matrix (Matrix A) = SqMatrix A"

fun matrix_of_sqmatrix where
  "matrix_of_sqmatrix (SqMatrix A) = Matrix A"

subsection \<open>0 and 1\<close>

instantiation matrix :: (zero,type,type) zero
begin
  definition zero_matrix_def: "0 \<equiv> Matrix (\<lambda>i j. 0)"
  instance ..
end

instantiation sqmatrix :: (zero,type) zero
begin
  definition zero_sqmatrix_def: "0 \<equiv> SqMatrix (\<lambda>i j. 0)"
  instance ..
end

text \<open>Tricky sort issues: compare @{term one_matrix} with @{term
one_sqmatrix} \dots\<close>

instantiation matrix :: ("{zero,one}",len,len) one
begin
  definition one_matrix_def:
    "1 \<equiv> Matrix (\<lambda>i j. if Rep_atMost i = Rep_atMost j then 1 else 0)"
  instance ..
end

instantiation sqmatrix :: ("{zero,one}",type) one
begin
  definition one_sqmatrix_def:
    "1 \<equiv> SqMatrix (\<lambda>i j. if i = j then 1 else 0)"
  instance ..
end

subsection \<open>Matrix Addition\<close>

fun matrix_plus where
  "matrix_plus (Matrix A) (Matrix B) = Matrix (\<lambda>i j. A i j + B i j)"

instantiation matrix :: (plus,type,type) plus
begin
  definition plus_matrix_def: "A + B \<equiv> matrix_plus A B"
  instance ..
end

lemma plus_matrix_def' [simp]:
  "Matrix A + Matrix B = Matrix (\<lambda>i j. A i j + B i j)"
  by (simp add: plus_matrix_def)

instantiation sqmatrix :: (plus,type) plus
begin
  definition plus_sqmatrix_def:
    "A + B \<equiv> sqmatrix_of_matrix (matrix_of_sqmatrix A + matrix_of_sqmatrix B)"
  instance ..
end

lemma plus_sqmatrix_def' [simp]:
  "SqMatrix A + SqMatrix B = SqMatrix (\<lambda>i j. A i j + B i j)"
  by (simp add: plus_sqmatrix_def)

lemma matrix_add_0_right [simp]:
  "A + 0 = (A::('a::monoid_add,'m,'n) matrix)"
  by (cases A, simp add: zero_matrix_def)

lemma matrix_add_0_left [simp]:
  "0 + A = (A::('a::monoid_add,'m,'n) matrix)"
  by (cases A, simp add: zero_matrix_def)

lemma matrix_add_commute [simp]:
  "(A::('a::ab_semigroup_add,'m,'n) matrix) + B = B + A"
  by (cases A, cases B, simp add: add.commute)

lemma matrix_add_assoc:
  "(A::('a::semigroup_add,'m,'n) matrix) + B + C = A + (B + C)"
  by (cases A, cases B, cases C, simp add: add.assoc)

lemma matrix_add_left_commute [simp]:
  "(A::('a::ab_semigroup_add,'m,'n) matrix) + (B + C) = B + (A + C)"
  by (metis matrix_add_assoc matrix_add_commute)

lemma sqmatrix_add_0_right [simp]:
  "A + 0 = (A::('a::monoid_add,'m) sqmatrix)"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_add_0_left [simp]:
  "0 + A = (A::('a::monoid_add,'m) sqmatrix)"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_add_commute [simp]:
  "(A::('a::ab_semigroup_add,'m) sqmatrix) + B = B + A"
  by (cases A, cases B, simp add: add.commute)

lemma sqmatrix_add_assoc:
  "(A::('a::semigroup_add,'m) sqmatrix) + B + C = A + (B + C)"
  by (cases A, cases B, cases C, simp add: add.assoc)

lemma sqmatrix_add_left_commute [simp]:
  "(A::('a::ab_semigroup_add,'m) sqmatrix) + (B + C) = B + (A + C)"
  by (metis sqmatrix_add_commute sqmatrix_add_assoc)

subsection \<open>Order (via Addition)\<close>

instantiation matrix :: (plus,type,type) plus_ord
begin
  definition less_eq_matrix_def:
    "(A::('a, 'b, 'c) matrix) \<le> B \<equiv> A + B = B"
  definition less_matrix_def:
    "(A::('a, 'b, 'c) matrix) < B \<equiv> A \<le> B \<and> A \<noteq> B"

  instance
  proof
    fix A B :: "('a, 'b, 'c) matrix"
    show "A \<le> B \<longleftrightarrow> A + B = B"
      by (metis less_eq_matrix_def)
    show "A < B \<longleftrightarrow> A \<le> B \<and> A \<noteq> B"
      by (metis less_matrix_def)
  qed
end

instantiation sqmatrix :: (plus,type) plus_ord
begin
  definition less_eq_sqmatrix_def:
    "(A::('a, 'b) sqmatrix) \<le> B \<equiv> A + B = B"
  definition less_sqmatrix_def:
    "(A::('a, 'b) sqmatrix) < B \<equiv> A \<le> B \<and> A \<noteq> B"

  instance
  proof
    fix A B :: "('a, 'b) sqmatrix"
    show "A \<le> B \<longleftrightarrow> A + B = B"
      by (metis less_eq_sqmatrix_def)
    show "A < B \<longleftrightarrow> A \<le> B \<and> A \<noteq> B"
      by (metis less_sqmatrix_def)
  qed
end

subsection \<open>Matrix Multiplication\<close>

fun matrix_times :: "('a::{comm_monoid_add,times},'m,'k) matrix \<Rightarrow> ('a,'k,'n) matrix \<Rightarrow> ('a,'m,'n) matrix" where
  "matrix_times (Matrix A) (Matrix B) = Matrix (\<lambda>i j. sum (\<lambda>k. A i k * B k j) (UNIV::'k atMost set))"

notation matrix_times (infixl "*\<^sub>M" 70)

instantiation sqmatrix :: ("{comm_monoid_add,times}",type) times
begin
  definition times_sqmatrix_def:
    "A * B = sqmatrix_of_matrix (matrix_of_sqmatrix A *\<^sub>M matrix_of_sqmatrix B)"
  instance ..
end

lemma times_sqmatrix_def' [simp]:
  "SqMatrix A * SqMatrix B = SqMatrix (\<lambda>i j. sum (\<lambda>k. A i k * B k j) (UNIV::'k atMost set))"
  by (simp add: times_sqmatrix_def)

lemma matrix_mult_0_right [simp]:
  "(A::('a::{comm_monoid_add,mult_zero},'m,'n) matrix) *\<^sub>M 0 = 0"
  by (cases A, simp add: zero_matrix_def)

lemma matrix_mult_0_left [simp]:
  "0 *\<^sub>M (A::('a::{comm_monoid_add,mult_zero},'m,'n) matrix) = 0"
  by (cases A, simp add: zero_matrix_def)

lemma sum_delta_r_0 [simp]:
  "\<lbrakk> finite S; j \<notin> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. f k * (if k = j then 1 else (0::'b::{semiring_0,monoid_mult}))) = 0"
  by (induct S rule: finite_induct, auto)

lemma sum_delta_r_1 [simp]:
  "\<lbrakk> finite S; j \<in> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. f k * (if k = j then 1 else (0::'b::{semiring_0,monoid_mult}))) = f j"
  by (induct S rule: finite_induct, auto)

lemma matrix_mult_1_right [simp]:
  "(A::('a::{semiring_0,monoid_mult},'m::len,'n::len) matrix) *\<^sub>M 1 = A"
  by (cases A, simp add: one_matrix_def)

lemma sum_delta_l_0 [simp]:
  "\<lbrakk> finite S; i \<notin> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. (if i = k then 1 else (0::'b::{semiring_0,monoid_mult})) * f k j) = 0"
  by (induct S rule: finite_induct, auto)

lemma sum_delta_l_1 [simp]:
  "\<lbrakk> finite S; i \<in> S \<rbrakk> \<Longrightarrow> (\<Sum>k\<in>S. (if i = k then 1 else (0::'b::{semiring_0,monoid_mult})) * f k j) = f i j"
  by (induct S rule: finite_induct, auto)

lemma matrix_mult_1_left [simp]:
  "1 *\<^sub>M (A::('a::{semiring_0,monoid_mult},'m::len,'n::len) matrix) = A"
  by (cases A, simp add: one_matrix_def)

lemma matrix_mult_assoc:
  "(A::('a::semiring_0,'m,'n) matrix) *\<^sub>M B *\<^sub>M C = A *\<^sub>M (B *\<^sub>M C)"
 apply (cases A)
 apply (cases B)
 apply (cases C)
 apply (simp add: sum_distrib_right sum_distrib_left mult.assoc)
 apply (subst sum.swap)
 apply (rule refl)
done

lemma matrix_mult_distrib_left:
  "(A::('a::{comm_monoid_add,semiring},'m,'n::len) matrix) *\<^sub>M (B + C) = A *\<^sub>M B + A *\<^sub>M C"
  by (cases A, cases B, cases C, simp add: distrib_left sum.distrib)

lemma matrix_mult_distrib_right:
  "((A::('a::{comm_monoid_add,semiring},'m,'n::len) matrix) + B) *\<^sub>M C = A *\<^sub>M C + B *\<^sub>M C"
  by (cases A, cases B, cases C, simp add: distrib_right sum.distrib)

lemma sqmatrix_mult_0_right [simp]:
  "(A::('a::{comm_monoid_add,mult_zero},'m) sqmatrix) * 0 = 0"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_mult_0_left [simp]:
  "0 * (A::('a::{comm_monoid_add,mult_zero},'m) sqmatrix) = 0"
  by (cases A, simp add: zero_sqmatrix_def)

lemma sqmatrix_mult_1_right [simp]:
  "(A::('a::{semiring_0,monoid_mult},'m::len) sqmatrix) * 1 = A"
  by (cases A, simp add: one_sqmatrix_def)

lemma sqmatrix_mult_1_left [simp]:
  "1 * (A::('a::{semiring_0,monoid_mult},'m::len) sqmatrix) = A"
  by (cases A, simp add: one_sqmatrix_def)

lemma sqmatrix_mult_assoc:
  "(A::('a::{semiring_0,monoid_mult},'m) sqmatrix) * B * C = A * (B * C)"
 apply (cases A)
 apply (cases B)
 apply (cases C)
 apply (simp add: sum_distrib_right sum_distrib_left mult.assoc)
 apply (subst sum.swap)
 apply (rule refl)
done

lemma sqmatrix_mult_distrib_left:
  "(A::('a::{comm_monoid_add,semiring},'m::len) sqmatrix) * (B + C) = A * B + A * C"
  by (cases A, cases B, cases C, simp add: distrib_left sum.distrib)

lemma sqmatrix_mult_distrib_right:
  "((A::('a::{comm_monoid_add,semiring},'m::len) sqmatrix) + B) * C = A * C + B * C"
  by (cases A, cases B, cases C, simp add: distrib_right sum.distrib)

subsection \<open>Square-Matrix Model of Dioids\<close>

text \<open>The following subclass proofs are necessary to connect parts
of our algebraic hierarchy to the hierarchy found in the Isabelle/HOL
library.\<close>

subclass (in ab_near_semiring_one_zerol) comm_monoid_add
proof
  fix a :: 'a
  show "0 + a = a"
    by (fact add_zerol)
qed

subclass (in semiring_one_zero) semiring_0
proof
  fix a :: 'a
  show "0 * a = 0"
    by (fact annil)
  show "a * 0 = 0"
    by (fact annir)
qed

subclass (in ab_near_semiring_one) monoid_mult ..

instantiation sqmatrix :: (dioid_one_zero,len) dioid_one_zero
begin
  instance
  proof
    fix A B C :: "('a, 'b) sqmatrix"
    show "A + B + C = A + (B + C)"
      by (fact sqmatrix_add_assoc)
    show "A + B = B + A"
      by (fact sqmatrix_add_commute)
    show "A * B * C = A * (B * C)"
      by (fact sqmatrix_mult_assoc)
    show "(A + B) * C = A * C + B * C"
      by (fact sqmatrix_mult_distrib_right)
    show "1 * A = A"
      by (fact sqmatrix_mult_1_left)
    show "A * 1 = A"
      by (fact sqmatrix_mult_1_right)
    show "0 + A = A"
      by (fact sqmatrix_add_0_left)
    show "0 * A = 0"
      by (fact sqmatrix_mult_0_left)
    show "A * 0 = 0"
      by (fact sqmatrix_mult_0_right)
    show "A + A = A"
      by (cases A, simp)
    show "A * (B + C) = A * B + A * C"
      by (fact sqmatrix_mult_distrib_left)
  qed
end

subsection \<open>Kleene Star for Matrices\<close>

text \<open>We currently do not implement the Kleene star of matrices,
since this is complicated.\<close>

end


theory BinomialRec
  imports Main
begin

fun binomial :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"binomial _ 0 = 1" |
"binomial 0 _ = 0" |
"binomial (Suc n) (Suc k) = (if k \<ge> n then 1 else (binomial n (Suc k)) + (binomial n k))"

lemma binomial_n_n: "binomial n n = 1"
  by (induction n) auto

lemma "k \<le> n \<Longrightarrow> binomial n k = binomial n (n-k)"
proof (induction n k rule: binomial.induct)
  case (1 n)
  then show ?case
    by (simp add: binomial_n_n)
next
  case (2 k)
  then show ?case
    by simp
next
  case (3 n k)
  then show ?case
  proof (cases "k \<ge> n")
    case True
    then show ?thesis
      by simp
  next
    case False
    then have "k < n"
      by simp
    then have "binomial (Suc n) (Suc k) = binomial n (Suc k) + binomial n k"
      by simp
    also have "\<dots> = binomial n (n - Suc k) + binomial n k"
      using "3.IH" \<open>k < n\<close> by auto
    also have "\<dots> = binomial n (n - k) + binomial n (n - Suc k)"
      using "3.IH" \<open>k < n\<close> by auto
    also have "\<dots> = binomial (Suc n) (Suc n - Suc k)"
      using \<open>k < n\<close> less_iff_Suc_add by auto
    finally show ?thesis
      by simp
  qed
qed

end


theory MinimalHEAP1
imports Map List
begin

(*********************************************************************)
section {* Basic Types *}

type_synonym Loc = nat

definition
  nat1 :: "nat \<Rightarrow> bool"
where
  [iff]: "nat1 n \<equiv> n > 0"

(*********************************************************************)
section {* Things about sets *}

definition
  disjoint :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool"
where
 "disjoint A B \<equiv> A \<inter> B = {}"

(*********************************************************************)
section {* Things about about VDM maps *}

definition
  dom_restr :: "'a set \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)" (infixr "\<triangleleft>" 110)
where
  [intro!]: "s \<triangleleft> m \<equiv> m |` s"

definition
  dom_antirestr :: "'a set \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)" (infixr "-\<triangleleft>" 110)
where
  "s -\<triangleleft> m \<equiv> (\<lambda>x. if x : s then None else m x)"

definition
  munion :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<rightharpoonup> 'b)" (infixl "\<union>m" 90)
where
  [intro!]: "f \<union>m g \<equiv> (if dom f \<inter> dom g = {} then f ++ g else undefined)"

find_theorems "sorted_list_of_set _"
(*
fun
  map_list :: "('a \<rightharpoonup> 'b) \<Rightarrow> ('a \<times> 'b) list"
where
  "map_list empty = []"
| "map_list f = [(x, (the(f x)) | x \<leftarrow> sorted_list_of_set (dom f), true]"*)

definition
  nat1_map :: "(Loc \<rightharpoonup> nat) \<Rightarrow> bool"
where
  "nat1_map f \<equiv> (\<forall> x. x \<in> dom f \<longrightarrow> nat1 (the (f x)))"

(*
lemma dom_code [code]:
  "x \<in> dom f \<longleftrightarrow> x mem  \<noteq> None"
sorry
*)

(*********************************************************************)
section {* Things about heap type representation *}

definition
  locs_of :: "Loc \<Rightarrow> nat \<Rightarrow> (Loc set)"
where
  (* "locs_of l n \<equiv> (if nat1 n then { i. i \<ge> l \<and> i < (l + n) } else undefined)"  *)
  "locs_of l n \<equiv> (if nat1 n then {l..<l+n} else undefined)"

definition
  locs :: "(Loc \<rightharpoonup> nat) \<Rightarrow> Loc set "
where
  "locs sm \<equiv> (if nat1_map sm then
                \<Union> s \<in> dom sm. locs_of s (the (sm s))
               else
                 undefined)" (* TODO: or {}?*)

(*********************************************************************)
section {* Things about heap auxiliary functions (DISPOSE-only) *}

definition
   min_loc :: "(Loc \<rightharpoonup> nat) \<Rightarrow> nat"
where
   "min_loc sm = (if sm \<noteq> empty then
                      Min (dom sm)
                  else
                      undefined)"

definition
  sum_size :: "(Loc \<rightharpoonup> nat) \<Rightarrow> nat"
where
  "sum_size sm = (if sm \<noteq> empty then
                      (\<Sum> x\<in>(dom sm) . the (sm x))
                  else
                      undefined)" (*TODO: or 0? *)

(*********************************************************************)
section {* Things about heap L1 invariant *}

type_synonym F1 = "Loc \<rightharpoonup> nat"

definition
  Disjoint :: "F1 \<Rightarrow> bool"
where
 "Disjoint f \<equiv>
      (\<forall> a \<in> dom f. \<forall> b \<in> dom f . a \<noteq> b \<longrightarrow> disjoint (locs_of a (the(f a))) (locs_of b (the(f b))))"

definition
  sep :: "F1 \<Rightarrow> bool"
where
  "sep f \<equiv> (\<forall> l \<in> dom f . l + the(f l) \<notin> dom f)"

definition
  F1_inv :: "F1 \<Rightarrow> bool"
where
  [intro!]:  "F1_inv f \<equiv> Disjoint f \<and> sep f \<and> nat1_map f \<and> finite(dom f)"

(*********************************************************************)
section {* Things about heap L1 operations *}

definition
  new1_pre :: "F1 \<Rightarrow> nat \<Rightarrow> bool"
where
  "new1_pre f s \<equiv> (\<exists> l \<in> dom f . the(f l) \<ge> s)"

definition
   new1_post_eq :: "F1 \<Rightarrow> nat \<Rightarrow> F1 \<Rightarrow> Loc \<Rightarrow> bool"
where
   "new1_post_eq f s f' r \<equiv> r \<in> dom f \<and> the(f r) = s \<and> f' = {r} -\<triangleleft> f"

definition
   new1_post_gr :: "F1 \<Rightarrow> nat \<Rightarrow> F1 \<Rightarrow> Loc \<Rightarrow> bool"
where
   "new1_post_gr f s f' r \<equiv> r \<in> dom f \<and> the(f r) > s \<and>
                            f' = ({r} -\<triangleleft> f) \<union>m [r + s \<mapsto> the(f r) - s]"

definition
   new1_post :: "F1 \<Rightarrow> nat \<Rightarrow> F1 \<Rightarrow> Loc \<Rightarrow> bool"
where
   "new1_post f s f' r \<equiv> new1_post_eq f s f' r \<or> new1_post_gr f s f' r"

definition
   dispose1_pre :: "F1 \<Rightarrow> Loc \<Rightarrow> nat \<Rightarrow> bool"
where
  "dispose1_pre f d s \<equiv> disjoint (locs_of d s) (locs f)"

definition
   dispose1_post :: "F1 \<Rightarrow> Loc \<Rightarrow> nat \<Rightarrow> F1 \<Rightarrow> bool"
where
   "dispose1_post f d s f' \<equiv>
      (\<exists> below above ext .
        below = { x \<in> dom f . x + the(f x) = d } \<triangleleft> f \<and>
        above = { x \<in> dom f . x = d + s } \<triangleleft> f \<and>
        ext   = (above \<union>m below) \<union>m [d \<mapsto> s] \<and>
        f' = ((dom below \<union> dom above) -\<triangleleft> f) \<union>m ([min_loc(ext) \<mapsto> sum_size(ext)]))
      "

definition
  dispose1_below :: "F1 \<Rightarrow> Loc \<Rightarrow> F1"
where
  "dispose1_below f d \<equiv>  { x \<in> dom f . x + the(f x) = d } \<triangleleft> f"

definition
  dispose1_above :: "F1 \<Rightarrow> Loc \<Rightarrow> nat \<Rightarrow> F1"
where
  "dispose1_above f d s \<equiv>  { x \<in> dom f . x = d + s } \<triangleleft> f"

definition
  dispose1_ext :: "F1 \<Rightarrow> Loc \<Rightarrow> nat \<Rightarrow> F1"
where
  "dispose1_ext f d s \<equiv>  (dispose1_above f d s  \<union>m dispose1_below f d) \<union>m [d \<mapsto> s] "

definition
   dispose1_post2 :: "F1 \<Rightarrow> Loc \<Rightarrow> nat \<Rightarrow> F1 \<Rightarrow> bool"
where
   "dispose1_post2 f d s f' \<equiv>
        (f' = ((dom (dispose1_below f d) \<union> dom (dispose1_above f d s)) -\<triangleleft> f)
        \<union>m ([min_loc(dispose1_ext f d s) \<mapsto> sum_size(dispose1_ext f d s)]))"

(*********************************************************************)
section {* Things about heap L1 definition-sets to be expanded *}

lemmas F1_inv_defs = F1_inv_def Disjoint_def nat1_def
                     sep_def nat1_map_def
                        disjoint_def locs_of_def

lemmas new1_pre_defs      = new1_pre_def
lemmas new1_post_defs     = new1_post_def new1_post_eq_def new1_post_gr_def
lemmas dispose1_pre_defs  = dispose1_pre_def disjoint_def nat1_def
                            locs_def nat1_map_def locs_of_def
lemmas dispose1_post_defs = dispose1_post_def

lemmas dispose1_post2_defs = dispose1_post2_def dispose1_below_def
							 dispose1_above_def dispose1_ext_def

lemma dispose1_equiv:
	"dispose1_post f d s f' = dispose1_post2 f d s f'"
unfolding dispose1_post_defs dispose1_post2_defs
by auto

(*********************************************************************)
section {* Things about heap L1 proof satisfiability obligations *}

definition
  PO_new1_fsb :: "bool"
where
  "PO_new1_fsb \<equiv> (\<forall> f s . F1_inv f \<and> nat1 s \<and> new1_pre f s \<longrightarrow>
                        (\<exists> f' r' . new1_post f s f' r' \<and> F1_inv f'))"

definition
  PO_dispose1_fsb :: "bool"
where
  "PO_dispose1_fsb \<equiv> (\<forall> f d s . F1_inv f \<and> nat1 s \<and> dispose1_pre f d s \<longrightarrow>
                        (\<exists> f' . dispose1_post f d s f' \<and> F1_inv f'))"

(*********************************************************************)
section {* Voila! Translate to Haskell please! *}

export_code locs_of nat1  in Haskell module_name VDMMaps file "haskell/"

end


theory Simp_Demo
imports Complex_Main
begin

section{* How to simplify *}

text{* No assumption: *}
lemma "ys @ [] = []"
apply(simp)
oops (* abandon proof *)

text{* Simplification in assumption: *}
lemma "\<lbrakk> xs @ zs = ys @ xs; [] @ xs = [] @ [] \<rbrakk> \<Longrightarrow> ys = zs"
apply(simp)
done

text{* Using additional rules: *}
lemma "(a+b)*(a-b) = a*a - b*(b::int)"
apply(simp add: algebra_simps)
done

text{* Giving a lemma the simp-attribute: *}
declare sorted_Cons [simp]

subsection{* Rewriting with definitions *}

definition sq :: "nat \<Rightarrow> nat" where
"sq n = n*n"

lemma "sq(n*n) = sq(n)*sq(n)"
apply(simp add: sq_def) --"Definition of function is implicitly called f_def"
done

subsection{* Case distinctions *}

text{* Automatic: *}
lemma "(A & B) = (if A then B else False)"
apply(simp)
done

lemma "if A then B else C"
apply(auto)
oops

text{* By hand (for case): *}
lemma "1 \<le> (case ns of [] \<Rightarrow> 1 | n#_ \<Rightarrow> Suc n)"
apply(simp split: list.split)
done

text \<open>By hand: if in assumptions\<close>
lemma "\<lbrakk> if b then x>(0::nat) else x>2 \<rbrakk> \<Longrightarrow> x*x > 0"
  apply (simp split: if_split_asm)
  done

text \<open>By hand: case in assumptions\<close>
lemma "\<lbrakk> case xs of [] \<Rightarrow> ys\<noteq>[] | _ \<Rightarrow> length xs < length ys \<rbrakk> \<Longrightarrow> length xs < length ys"
  apply (simp split: list.split_asm)
  done

(* XXX.splits = XXX.split XXX.split_asm. If no further control of splitting required, use XXX.splits. *)

lemma "\<lbrakk> case xs of [] \<Rightarrow> ys\<noteq>[] | _ \<Rightarrow> length xs < length ys \<rbrakk> \<Longrightarrow> length xs < length ys"
  apply (simp split: list.splits)
  done

subsection {* Arithmetic *}

text{* A bit of linear arithmetic (no multiplication) is automatic: *}
lemma "\<lbrakk> (x::nat) \<le> y+z;  z+x < y \<rbrakk> \<Longrightarrow> x < y"
apply(simp)
done

lemma "(a+b)*(a-b) = a*a - b*(b::int)"
apply(simp add: algebra_simps) (* More arithmetic rules *)
done

lemma "(a/b::real) ^ 5 = (a^5)/(b^5)"
  by (simp add: field_simps) (* Even more rules, in particular about / on fields (eg real)*)

subsection{* Tracing: *}

lemma "rev[x] = []"
supply [[simp_trace]] apply(simp)
oops

text{* Method ``auto'' can be modified almost like ``simp'': instead of
``add'' use ``simp add'': *}

end


(*
  Title:    Libraries.thy
  Author:   Manuel Eberl, TU München

  Definition of lotteries on a set. (Essentially just restricting PMFs to a carrier set)
*)

section \<open>Auxiliary facts about PMFs\<close>

theory Lotteries
  imports Complex_Main "HOL-Probability.Probability"
begin

text \<open>The type of lotteries (a probability mass function)\<close>
type_synonym 'alt lottery = "'alt pmf"

definition lotteries_on :: "'a set \<Rightarrow> 'a lottery set" where
  "lotteries_on A = {p. set_pmf p \<subseteq> A}"

lemma pmf_of_set_lottery:
  "A \<noteq> {} \<Longrightarrow> finite A \<Longrightarrow> A \<subseteq> B \<Longrightarrow> pmf_of_set A \<in> lotteries_on B"
  unfolding lotteries_on_def by auto

lemma pmf_of_list_lottery:
  "pmf_of_list_wf xs \<Longrightarrow> set (map fst xs) \<subseteq> A \<Longrightarrow> pmf_of_list xs \<in> lotteries_on A"
  using set_pmf_of_list[of xs] by (auto simp: lotteries_on_def)

lemma return_pmf_in_lotteries_on [simp,intro]:
  "x \<in> A \<Longrightarrow> return_pmf x \<in> lotteries_on A"
  by (simp add: lotteries_on_def)

end


theory Sort_Descending
imports Main
begin

section\<open>sorting descending\<close>
  context linorder
  begin
  fun sorted_descending :: "'a list \<Rightarrow> bool" where
    "sorted_descending [] \<longleftrightarrow> True" |
    "sorted_descending (a#as) \<longleftrightarrow> (\<forall>x \<in> set as. a \<ge> x) \<and> sorted_descending as"

  definition sort_descending_key :: "('b \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'b list" where
    "sort_descending_key f xs \<equiv> rev (sort_key f xs)"
  end
  lemma sorted_descending_Cons: "sorted_descending (x#xs) \<longleftrightarrow> sorted_descending xs \<and> (\<forall>y\<in>set xs. y \<le> x)"
  by(induction xs) auto

  lemma sorted_descending_tail: "sorted_descending (xs@[x]) \<longleftrightarrow> sorted_descending xs \<and> (\<forall>y\<in>set xs. x \<le> y)"
  by(induction xs) auto

  lemma sorted_descending_append: "sorted_descending (xs @ ys) =
    (sorted_descending xs \<and> sorted_descending ys \<and> (\<forall>x\<in>set xs. \<forall>y\<in>set ys. x \<ge> y))"
  by(induction xs) auto

  lemma sorted_descending: "sorted_descending (rev xs) \<longleftrightarrow> sorted xs"
  apply(induction xs)
   apply(simp)
  apply(auto simp add: sorted_descending_tail)
  done
  lemma sorted_descending_alt: "sorted_descending xs \<longleftrightarrow> sorted (rev xs)"
    using sorted_descending[of "rev xs"] unfolding rev_rev_ident .

  lemma sort_descending: "sorted_descending (sort_descending_key (\<lambda>x. x) xs)"
    by(simp add: sort_descending_key_def sorted_descending)

  lemma sort_descending_key_distinct: "distinct xs \<Longrightarrow> distinct (sort_descending_key f xs)"
    by(simp add: sort_descending_key_def)

  lemma sorted_descending_sort_descending_key: "sorted_descending (map f (sort_descending_key f xs))"
    apply(simp add: sort_descending_key_def)
    using sorted_descending by (metis rev_map sorted_sort_key)

  lemma sorted_descending_split: "sorted_descending (map f l) \<Longrightarrow>
  	\<exists>m n. l = m @ n \<and> (\<forall>e \<in> set m. f (hd l) = f e) \<and> (\<forall>e \<in> set n. f e < f (hd l))"
  proof(induction l)
  	case Nil thus ?case by simp
  next
  	case (Cons a as)
  	from Cons(2) have IHm: "sorted_descending (map f as)" by simp
  	note mIH = Cons(1)[OF this]
  	thus ?case (is ?kees)
  	proof(cases as)
  		case Nil
  		show ?kees unfolding Nil by force
  	next
  		case (Cons aa ass)
  		show ?kees
  		proof(cases "f a = f aa")
  			case True
  			from mIH obtain m n where mn: "as = m @ n" "(\<forall>e\<in>set m. f a = f e)" "(\<forall>e\<in>set n. f e < f a)"
  				using True local.Cons by auto
  			have "a # as = a # m @ n" using mn(1) by simp
  			moreover have "\<forall>e\<in>set (a # m). f (hd (a # m)) = f e" unfolding list.sel(1) using True mn(2) using Cons by auto
  			ultimately show "\<exists>m n. a # as = m @ n \<and> (\<forall>e\<in>set m. f (hd (a # as)) = f e) \<and>
  				(\<forall>e\<in>set n. f e < f (hd (a # as)))" using mn(3) by (metis append.simps(2) list.sel(1))
  		next
  			case False
  			from Cons.prems have "\<forall>y\<in>set (map f as). y < f a"
  				unfolding list.map(2)
  				unfolding sorted_descending_Cons
  				unfolding set_map
  				unfolding local.Cons
  				using False
  				by auto
  			then have "\<forall>e\<in>set as. f e < f a" by simp
  			moreover have "a # as = [a] @ as \<and> (\<forall>e\<in>set [a]. f (hd [a]) = f e)" by simp
  			ultimately show ?kees by (metis list.sel(1))
  		qed
  	qed
  qed

  lemma sort_descending_set_inv[simp]: "set (sort_descending_key k t) = set t"
  	by (simp add: sort_descending_key_def)

end


(* Author: Tobias Nipkow *)

theory Live_True
imports "~~/src/HOL/Library/While_Combinator" Vars Big_Step
begin

subsection "True Liveness Analysis"

fun L :: "com \<Rightarrow> vname set \<Rightarrow> vname set" where
"L SKIP X = X" |
"L (x ::= a) X = (if x \<in> X then vars a \<union> (X - {x}) else X)" |
"L (c\<^sub>1;; c\<^sub>2) X = L c\<^sub>1 (L c\<^sub>2 X)" |
"L (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X = vars b \<union> L c\<^sub>1 X \<union> L c\<^sub>2 X" |
"L (WHILE b DO c) X = lfp(\<lambda>Y. vars b \<union> X \<union> L c Y)"

lemma L_mono: "mono (L c)"
proof-
  { fix X Y have "X \<subseteq> Y \<Longrightarrow> L c X \<subseteq> L c Y"
    proof(induction c arbitrary: X Y)
      case (While b c)
      show ?case
      proof(simp, rule lfp_mono)
        fix Z show "vars b \<union> X \<union> L c Z \<subseteq> vars b \<union> Y \<union> L c Z"
          using While by auto
      qed
    next
      case If thus ?case by(auto simp: subset_iff)
    qed auto
  } thus ?thesis by(rule monoI)
qed

lemma mono_union_L:
  "mono (\<lambda>Y. X \<union> L c Y)"
by (metis (no_types) L_mono mono_def order_eq_iff set_eq_subset sup_mono)

lemma L_While_unfold:
  "L (WHILE b DO c) X = vars b \<union> X \<union> L c (L (WHILE b DO c) X)"
by(metis lfp_unfold[OF mono_union_L] L.simps(5))

lemma L_While_pfp: "L c (L (WHILE b DO c) X) \<subseteq> L (WHILE b DO c) X"
using L_While_unfold by blast

lemma L_While_vars: "vars b \<subseteq> L (WHILE b DO c) X"
using L_While_unfold by blast

lemma L_While_X: "X \<subseteq> L (WHILE b DO c) X"
using L_While_unfold by blast

text{* Disable @{text "L WHILE"} equation and reason only with @{text "L WHILE"} constraints: *}
declare L.simps(5)[simp del]

subsection "Correctness"

theorem L_correct:
  "(c,s) \<Rightarrow> s'  \<Longrightarrow> s = t on L c X \<Longrightarrow>
  \<exists> t'. (c,t) \<Rightarrow> t' & s' = t' on X"
proof (induction arbitrary: X t rule: big_step_induct)
  case Skip then show ?case by auto
next
  case Assign then show ?case
    by (auto simp: ball_Un)
next
  case (Seq c1 s1 s2 c2 s3 X t1)
  from Seq.IH(1) Seq.prems obtain t2 where
    t12: "(c1, t1) \<Rightarrow> t2" and s2t2: "s2 = t2 on L c2 X"
    by simp blast
  from Seq.IH(2)[OF s2t2] obtain t3 where
    t23: "(c2, t2) \<Rightarrow> t3" and s3t3: "s3 = t3 on X"
    by auto
  show ?case using t12 t23 s3t3 by auto
next
  case (IfTrue b s c1 s' c2)
  hence "s = t on vars b" and "s = t on L c1 X" by auto
  from  bval_eq_if_eq_on_vars[OF this(1)] IfTrue(1) have "bval b t" by simp
  from IfTrue.IH[OF `s = t on L c1 X`] obtain t' where
    "(c1, t) \<Rightarrow> t'" "s' = t' on X" by auto
  thus ?case using `bval b t` by auto
next
  case (IfFalse b s c2 s' c1)
  hence "s = t on vars b" "s = t on L c2 X" by auto
  from  bval_eq_if_eq_on_vars[OF this(1)] IfFalse(1) have "~bval b t" by simp
  from IfFalse.IH[OF `s = t on L c2 X`] obtain t' where
    "(c2, t) \<Rightarrow> t'" "s' = t' on X" by auto
  thus ?case using `~bval b t` by auto
next
  case (WhileFalse b s c)
  hence "~ bval b t"
    by (metis L_While_vars bval_eq_if_eq_on_vars set_mp)
  thus ?case using WhileFalse.prems L_While_X[of X b c] by auto
next
  case (WhileTrue b s1 c s2 s3 X t1)
  let ?w = "WHILE b DO c"
  from `bval b s1` WhileTrue.prems have "bval b t1"
    by (metis L_While_vars bval_eq_if_eq_on_vars set_mp)
  have "s1 = t1 on L c (L ?w X)" using  L_While_pfp WhileTrue.prems
    by (blast)
  from WhileTrue.IH(1)[OF this] obtain t2 where
    "(c, t1) \<Rightarrow> t2" "s2 = t2 on L ?w X" by auto
  from WhileTrue.IH(2)[OF this(2)] obtain t3 where "(?w,t2) \<Rightarrow> t3" "s3 = t3 on X"
    by auto
  with `bval b t1` `(c, t1) \<Rightarrow> t2` show ?case by auto
qed

subsection "Executability"

lemma L_subset_vars: "L c X \<subseteq> rvars c \<union> X"
proof(induction c arbitrary: X)
  case (While b c)
  have "lfp(\<lambda>Y. vars b \<union> X \<union> L c Y) \<subseteq> vars b \<union> rvars c \<union> X"
    using While.IH[of "vars b \<union> rvars c \<union> X"]
    by (auto intro!: lfp_lowerbound)
  thus ?case by (simp add: L.simps(5))
qed auto

text{* Make @{const L} executable by replacing @{const lfp} with the @{const
while} combinator from theory @{theory While_Combinator}. The @{const while}
combinator obeys the recursion equation
@{thm[display] While_Combinator.while_unfold[no_vars]}
and is thus executable. *}

lemma L_While: fixes b c X
assumes "finite X" defines "f == \<lambda>Y. vars b \<union> X \<union> L c Y"
shows "L (WHILE b DO c) X = while (\<lambda>Y. f Y \<noteq> Y) f {}" (is "_ = ?r")
proof -
  let ?V = "vars b \<union> rvars c \<union> X"
  have "lfp f = ?r"
  proof(rule lfp_while[where C = "?V"])
    show "mono f" by(simp add: f_def mono_union_L)
  next
    fix Y show "Y \<subseteq> ?V \<Longrightarrow> f Y \<subseteq> ?V"
      unfolding f_def using L_subset_vars[of c] by blast
  next
    show "finite ?V" using `finite X` by simp
  qed
  thus ?thesis by (simp add: f_def L.simps(5))
qed

lemma L_While_let: "finite X \<Longrightarrow> L (WHILE b DO c) X =
  (let f = (\<lambda>Y. vars b \<union> X \<union> L c Y)
   in while (\<lambda>Y. f Y \<noteq> Y) f {})"
by(simp add: L_While)

lemma L_While_set: "L (WHILE b DO c) (set xs) =
  (let f = (\<lambda>Y. vars b \<union> set xs \<union> L c Y)
   in while (\<lambda>Y. f Y \<noteq> Y) f {})"
by(rule L_While_let, simp)

text{* Replace the equation for @{text "L (WHILE \<dots>)"} by the executable @{thm[source] L_While_set}: *}
lemmas [code] = L.simps(1-4) L_While_set
text{* Sorry, this syntax is odd. *}

text{* A test: *}
lemma "(let b = Less (N 0) (V ''y''); c = ''y'' ::= V ''x'';; ''x'' ::= V ''z''
  in L (WHILE b DO c) {''y''}) = {''x'', ''y'', ''z''}"
by eval

subsection "Limiting the number of iterations"

text{* The final parameter is the default value: *}

fun iter :: "('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
"iter f 0 p d = d" |
"iter f (Suc n) p d = (if f p = p then p else iter f n (f p) d)"

text{* A version of @{const L} with a bounded number of iterations (here: 2)
in the WHILE case: *}

fun Lb :: "com \<Rightarrow> vname set \<Rightarrow> vname set" where
"Lb SKIP X = X" |
"Lb (x ::= a) X = (if x \<in> X then X - {x} \<union> vars a else X)" |
"Lb (c\<^sub>1;; c\<^sub>2) X = (Lb c\<^sub>1 \<circ> Lb c\<^sub>2) X" |
"Lb (IF b THEN c\<^sub>1 ELSE c\<^sub>2) X = vars b \<union> Lb c\<^sub>1 X \<union> Lb c\<^sub>2 X" |
"Lb (WHILE b DO c) X = iter (\<lambda>A. vars b \<union> X \<union> Lb c A) 2 {} (vars b \<union> rvars c \<union> X)"

text{* @{const Lb} (and @{const iter}) is not monotone! *}
lemma "let w = WHILE Bc False DO (''x'' ::= V ''y'';; ''z'' ::= V ''x'')
  in \<not> (Lb w {''z''} \<subseteq> Lb w {''y'',''z''})"
by eval

lemma lfp_subset_iter:
  "\<lbrakk> mono f; !!X. f X \<subseteq> f' X; lfp f \<subseteq> D \<rbrakk> \<Longrightarrow> lfp f \<subseteq> iter f' n A D"
proof(induction n arbitrary: A)
  case 0 thus ?case by simp
next
  case Suc thus ?case by simp (metis lfp_lowerbound)
qed

lemma "L c X \<subseteq> Lb c X"
proof(induction c arbitrary: X)
  case (While b c)
  let ?f  = "\<lambda>A. vars b \<union> X \<union> L  c A"
  let ?fb = "\<lambda>A. vars b \<union> X \<union> Lb c A"
  show ?case
  proof (simp add: L.simps(5), rule lfp_subset_iter[OF mono_union_L])
    show "!!X. ?f X \<subseteq> ?fb X" using While.IH by blast
    show "lfp ?f \<subseteq> vars b \<union> rvars c \<union> X"
      by (metis (full_types) L.simps(5) L_subset_vars rvars.simps(5))
  qed
next
  case Seq thus ?case by simp (metis (full_types) L_mono monoD subset_trans)
qed auto

end


theory HM_Logic_Infinitary
  imports
    Weak_Relations
begin

section \<open>Infinitary Hennessy-Milner Logic\<close>

datatype ('a,'x)HML_formula =
  HML_true
| HML_conj \<open>'x set\<close> \<open>'x \<Rightarrow> ('a,'x)HML_formula\<close>  (\<open>AND _ _\<close>)
| HML_neg \<open>('a,'x)HML_formula\<close>                  (\<open>~_\<close> [20] 60)
| HML_poss \<open>'a\<close> \<open>('a,'x)HML_formula\<close>            (\<open>\<langle>_\<rangle>_\<close> [60] 60)

term \<open>\<langle>\<tau>\<rangle>\<langle>1\<rangle>\<langle>2\<rangle>\<langle>a\<rangle> ((\<lambda> x. \<langle>2\<rangle>x) C)\<close>

subsection \<open>Satisfaction Relation\<close>

context lts_tau
begin

function satisfies :: \<open>'s \<Rightarrow> ('a, 's) HML_formula \<Rightarrow> bool\<close>
  (\<open>_ \<Turnstile> _\<close> [50, 50] 50)
  where
    \<open>(p \<Turnstile> HML_true) = True\<close>
  | \<open>(p \<Turnstile> HML_conj I F) = (\<forall> i \<in> I. p \<Turnstile> (F i))\<close>
  | \<open>(p \<Turnstile> HML_neg \<phi>) = (\<not> p \<Turnstile> \<phi>)\<close>
  | \<open>(p \<Turnstile> HML_poss \<alpha> \<phi>) = (\<exists> p'. ((tau \<alpha> \<and> p \<longmapsto>* tau p') \<or> (\<not> tau \<alpha> \<and> p \<longmapsto>\<alpha> p')) \<and> p' \<Turnstile> \<phi>)\<close>
  using HML_formula.exhaust by (auto, blast)

inductive_set HML_wf_rel :: \<open>('s \<times> ('a, 's) HML_formula) rel\<close>
  where
    \<open>\<phi> = F i \<and> i \<in> I \<Longrightarrow> ((p, \<phi>), (p, HML_conj I F)) \<in> HML_wf_rel\<close>
  | \<open>((p, \<phi>), (p, HML_neg \<phi>)) \<in> HML_wf_rel\<close>
  | \<open>((p, \<phi>), (p', HML_poss \<alpha> \<phi>)) \<in> HML_wf_rel\<close>

lemma HML_wf_rel_is_wf: \<open>wf HML_wf_rel\<close>
  unfolding wf_def
proof (safe)
  fix P::\<open>'s \<times> ('a, 's) HML_formula \<Rightarrow> bool\<close> and t::\<open>'s \<times> ('a, 's) HML_formula\<close>
  obtain p \<phi> where \<open>t = (p, \<phi>)\<close> by force
  assume \<open>\<forall>x. (\<forall>y. (y, x) \<in> HML_wf_rel \<longrightarrow> P y) \<longrightarrow> P x\<close>
  hence \<open>P (p, \<phi>)\<close>
    apply (induct \<phi> arbitrary: p)
    apply (metis HML_formula.ctr_transfer(1) HML_formula.distinct(3) HML_formula.distinct(5) HML_formula.rel_distinct(2) HML_wf_relp.cases HML_wf_relp_HML_wf_rel_eq surj_pair)
    apply (smt (verit) HML_formula.distinct(10) HML_formula.distinct(7) HML_formula.inject(1) HML_wf_rel_def UNIV_I case_prodE' image_eqI HML_wf_rel.cases mem_Collect_eq split_conv)
    apply (smt (verit, ccfv_threshold) HML_formula.distinct(11) HML_formula.distinct(7) HML_formula.inject(2) case_prodI2 case_prod_curry HML_wf_rel.cases HML_wf_rel_def)
    apply (smt (verit, del_insts) HML_formula.distinct(3,5,9,11)  HML_formula.inject(3) HML_wf_rel.cases case_prodD case_prodE' HML_wf_rel_def mem_Collect_eq)
    done
  thus \<open>P t\<close> using \<open>t = (p, \<phi>)\<close> by simp
qed

termination satisfies using HML_wf_rel_is_wf
  by (standard, (simp add: HML_wf_rel.intros)+)

inductive_set HML_direct_subformulas :: \<open>(('a, 's) HML_formula) rel\<close>
  where
    \<open>\<phi> = F i \<and> i \<in> I \<Longrightarrow> (\<phi>, HML_conj I F) \<in> HML_direct_subformulas\<close>
  | \<open>(\<phi>, HML_neg \<phi>) \<in> HML_direct_subformulas\<close>
  | \<open>(\<phi>, HML_poss \<alpha> \<phi>) \<in> HML_direct_subformulas\<close>

lemma HML_direct_subformulas_wf: \<open>wf HML_direct_subformulas\<close>
  unfolding wf_def
proof (safe)
  fix P x
  assume \<open>\<forall>x. (\<forall>y. (y, x) \<in> HML_direct_subformulas \<longrightarrow> P y) \<longrightarrow> P x\<close>
  thus \<open>P x\<close>
    apply (induct, auto)
    using HML_direct_subformulas.simps apply blast
    apply (metis HML_direct_subformulas.cases HML_formula.distinct(7) HML_formula.distinct(9) HML_formula.inject(1) range_eqI)
    apply (metis HML_direct_subformulas.simps HML_formula.distinct(11) HML_formula.distinct(7) HML_formula.inject(2))
    by (metis HML_direct_subformulas.simps HML_formula.distinct(11) HML_formula.distinct(9) HML_formula.inject(3))
qed

definition HML_subformulas where \<open>HML_subformulas \<equiv> (HML_direct_subformulas)\<^sup>+\<close>

lemma HML_subformulas_wf: \<open>wf HML_subformulas\<close>
  using HML_direct_subformulas_wf HML_subformulas_def wf_trancl
  by fastforce

lemma conj_only_depends_on_indexset:
  assumes \<open>\<forall>i\<in>I. f1 i = f2 i\<close>
  shows \<open>(p \<Turnstile> HML_conj I f1) = (p \<Turnstile> HML_conj I f2)\<close>
  using assms by auto

subsection \<open>Distinguishing Formulas\<close>

definition HML_equivalent :: \<open>'s \<Rightarrow> 's \<Rightarrow> bool\<close>
  where \<open>HML_equivalent p q
    \<equiv> (\<forall> \<phi>::('a, 's) HML_formula. (p \<Turnstile> \<phi>) \<longleftrightarrow> (q \<Turnstile> \<phi>))\<close>

fun distinguishes ::  \<open>('a,'s) HML_formula \<Rightarrow> 's \<Rightarrow> 's \<Rightarrow> bool\<close>
  where
   \<open>distinguishes \<phi> p q = (p \<Turnstile> \<phi> \<and> \<not> q \<Turnstile> \<phi>)\<close>

fun distinguishes_from_set ::  \<open>('a,'s) HML_formula \<Rightarrow> 's \<Rightarrow> 's set \<Rightarrow> bool\<close>
  where
   \<open>distinguishes_from_set \<phi> p Q = (p \<Turnstile> \<phi> \<and> (\<forall>q. q \<in> Q \<longrightarrow> \<not> q \<Turnstile> \<phi>))\<close>

lemma distinguishing_formula:
  assumes \<open>\<not> HML_equivalent p q\<close>
  shows \<open>\<exists> \<phi>. p \<Turnstile> \<phi> \<and> \<not> q \<Turnstile> \<phi>\<close>
  using assms  satisfies.simps(3) unfolding HML_equivalent_def
  by blast

lemma HML_equivalent_symm:
  assumes \<open>HML_equivalent p q\<close>
  shows \<open>HML_equivalent q p\<close>
  using HML_equivalent_def assms by presburger

subsection \<open>Weak-NOR Hennessy-Milner Logic\<close>

definition HML_weaknor ::
  \<open>'x set \<Rightarrow> ('x \<Rightarrow> ('a,'x)HML_formula) \<Rightarrow> ('a,'x)HML_formula\<close>
  where \<open>HML_weaknor I F = HML_poss \<tau> (HML_conj I (\<lambda>f. HML_neg (F f)))\<close>

definition HML_weaknot ::
  \<open>('a,'x)HML_formula \<Rightarrow> ('a,'x)HML_formula\<close>
  where \<open>HML_weaknot \<phi> = HML_weaknor {undefined} (\<lambda>i. \<phi>)\<close>

inductive_set HML_weak_formulas :: \<open>('a,'x)HML_formula set\<close> where
  Base: \<open>HML_true \<in> HML_weak_formulas\<close> |
  Obs: \<open>\<phi> \<in> HML_weak_formulas \<Longrightarrow> (\<langle>\<tau>\<rangle>\<langle>a\<rangle>\<phi>) \<in> HML_weak_formulas\<close> |
  Conj: \<open>(\<And>i. i \<in> I \<Longrightarrow> F i \<in> HML_weak_formulas) \<Longrightarrow> HML_weaknor I F \<in> HML_weak_formulas\<close>

lemma weak_backwards_truth:
  assumes
    \<open>\<phi> \<in> HML_weak_formulas\<close>
    \<open>p \<longmapsto>* tau  p'\<close>
    \<open>p' \<Turnstile> \<phi>\<close>
  shows
    \<open>p \<Turnstile> \<phi>\<close>
  using assms
  apply (cases)
  apply force
  using satisfies.simps(4) steps_concat tau_tau apply blast
  by (smt (z3) HML_weaknor_def satisfies.simps(4) steps_concat tau_tau)

lemma tau_a_obs_implies_delay_step:
  assumes \<open>p  \<Turnstile> \<langle>\<tau>\<rangle>\<langle>a\<rangle>\<phi>\<close>
  shows \<open>\<exists>p'. p =\<rhd>a p' \<and> p' \<Turnstile> \<phi>\<close>
proof -
  obtain p'' where \<open>p \<Rightarrow>^\<tau> p'' \<and> p'' \<Turnstile> \<langle>a\<rangle>\<phi>\<close> using assms by auto
  thus ?thesis using satisfies.simps(4) steps_concat tau_tau by blast
qed

lemma delay_step_implies_tau_a_obs:
  assumes
    \<open>p =\<rhd>a p'\<close>
    \<open>p' \<Turnstile> \<phi>\<close>
  shows \<open>p  \<Turnstile> \<langle>\<tau>\<rangle>\<langle>a\<rangle>\<phi>\<close>
proof -
  obtain p'' where \<open>p \<Rightarrow>^\<tau> p''\<close> and \<open>p'' \<Rightarrow>^a p'\<close> using assms steps.refl tau_tau by blast
  thus ?thesis by (metis assms(1,2) lts_tau.satisfies.simps(4) lts_tau.tau_tau)
qed

end \<comment> \<open>of \<open>context lts\<close>\<close>
end \<comment> \<open>of \<open>theory\<close>\<close>


(* 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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_HSort2Sorts
  imports "../../Test_Base"
begin

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

datatype Heap = Node "Heap" "int" "Heap" | Nil

fun ordered :: "int list => bool" where
  "ordered (nil2) = True"
| "ordered (cons2 y (nil2)) = True"
| "ordered (cons2 y (cons2 y2 xs)) =
     ((y <= y2) & (ordered (cons2 y2 xs)))"

fun hmerge :: "Heap => Heap => Heap" where
  "hmerge (Node z x2 x3) (Node x4 x5 x6) =
   (if x2 <= x5 then Node (hmerge x3 (Node x4 x5 x6)) x2 z else
      Node (hmerge (Node z x2 x3) x6) x5 x4)"
| "hmerge (Node z x2 x3) (Nil) = Node z x2 x3"
| "hmerge (Nil) y = y"

(*fun did not finish the proof*)
function toList :: "Heap => int list" where
  "toList (Node p y q) = cons2 y (toList (hmerge p q))"
| "toList (Nil) = nil2"
  by pat_completeness auto

fun hinsert :: "int => Heap => Heap" where
  "hinsert x y = hmerge (Node Nil x Nil) y"

fun toHeap2 :: "int list => Heap" where
  "toHeap2 (nil2) = Nil"
| "toHeap2 (cons2 y xs) = hinsert y (toHeap2 xs)"

fun hsort2 :: "int list => int list" where
  "hsort2 x = toList (toHeap2 x)"

theorem property0 :
  "ordered (hsort2 xs)"
  oops

end


(*  Title:      IPv4Addr.thy
    Authors:    Julius Michaelis, Cornelius Diekmann
*)
theory IPv4Addr
imports Main
  NumberWang
  "~~/src/HOL/Word/Word"
  "~~/src/HOL/Library/Code_Target_Nat" (*!*)
begin

value "(2::nat) < 2^32" (*without Code_Target_Nat, this would be rally slow*)

section {*Modelling IPv4 Adresses*}
  text{*An IPv4 address is basically a 32 bit unsigned integer*}
  type_synonym ipv4addr = "32 word"

  value "42 :: ipv4addr"

  value "(42 :: ipv4addr) \<le> 45"

  text{*Conversion between natural numbers and IPv4 adresses*}
  definition nat_of_ipv4addr :: "ipv4addr \<Rightarrow> nat" where
    "nat_of_ipv4addr a = unat a"
  definition ipv4addr_of_nat :: "nat \<Rightarrow> ipv4addr" where
    "ipv4addr_of_nat n =  of_nat n"

  lemma "((nat_of_ipv4addr (42::ipv4addr))::nat) = 42" by eval
  lemma "((ipv4addr_of_nat (42::nat))::ipv4addr) = 42" by eval

  text{*The maximum IPv4 addres*}
  definition max_ipv4_addr :: "ipv4addr" where
    "max_ipv4_addr \<equiv> ipv4addr_of_nat ((2^32) - 1)"

  lemma max_ipv4_addr_number: "max_ipv4_addr = 4294967295"
    by eval
  lemma "max_ipv4_addr = 0b11111111111111111111111111111111"
    by(fact max_ipv4_addr_number)
  lemma max_ipv4_addr_max_word: "max_ipv4_addr = max_word"
    by(simp add: max_ipv4_addr_number max_word_def)
  lemma max_ipv4_addr_max[simp]: "\<forall>a. a \<le> max_ipv4_addr"
    by(simp add: max_ipv4_addr_max_word)
  lemma range_0_max_UNIV[simp]: "{0 .. max_ipv4_addr} = UNIV"
    by(simp add: max_ipv4_addr_max_word) fastforce

  text{*identity functions*}
  lemma nat_of_ipv4addr_ipv4addr_of_nat: "\<lbrakk> n \<le> nat_of_ipv4addr max_ipv4_addr \<rbrakk> \<Longrightarrow> nat_of_ipv4addr (ipv4addr_of_nat n) = n"
    by (metis ipv4addr_of_nat_def le_unat_uoi nat_of_ipv4addr_def)
  lemma nat_of_ipv4addr_ipv4addr_of_nat_mod: "nat_of_ipv4addr (ipv4addr_of_nat n) = n mod 2^32"
    by(simp add: ipv4addr_of_nat_def nat_of_ipv4addr_def unat_of_nat)
  lemma ipv4addr_of_nat_nat_of_ipv4addr: "ipv4addr_of_nat (nat_of_ipv4addr addr) = addr"
    by(simp add: ipv4addr_of_nat_def nat_of_ipv4addr_def)

  text{*Equality of IPv4 adresses*}
  lemma "\<lbrakk> n \<le> nat_of_ipv4addr max_ipv4_addr \<rbrakk> \<Longrightarrow> nat_of_ipv4addr (ipv4addr_of_nat n) = n"
    apply(simp add: nat_of_ipv4addr_def ipv4addr_of_nat_def)
    apply(induction n)
    apply(simp_all)
    by(unat_arith)

  lemma ipv4addr_of_nat_eq: "x = y \<Longrightarrow> ipv4addr_of_nat x = ipv4addr_of_nat y"
    by(simp add: ipv4addr_of_nat_def)

subsection{*Representing IPv4 Adresses*}
  fun ipv4addr_of_dotteddecimal :: "nat \<times> nat \<times> nat \<times> nat \<Rightarrow> ipv4addr" where
    "ipv4addr_of_dotteddecimal (a,b,c,d) = ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a )"

  fun dotteddecimal_of_ipv4addr :: "ipv4addr \<Rightarrow> nat \<times> nat \<times> nat \<times> nat" where
    "dotteddecimal_of_ipv4addr a = (nat_of_ipv4addr ((a >> 24) AND 0xFF),
                                    nat_of_ipv4addr ((a >> 16) AND 0xFF),
                                    nat_of_ipv4addr ((a >> 8) AND 0xFF),
                                    nat_of_ipv4addr (a AND 0xff))"

  declare ipv4addr_of_dotteddecimal.simps[simp del]
  declare dotteddecimal_of_ipv4addr.simps[simp del]

  lemma "ipv4addr_of_dotteddecimal (192, 168, 0, 1) = 3232235521" by eval
  lemma "dotteddecimal_of_ipv4addr 3232235521 = (192, 168, 0, 1)" by eval

  text{*a different notation for @{term ipv4addr_of_dotteddecimal}*}
  lemma ipv4addr_of_dotteddecimal_bit:
    "ipv4addr_of_dotteddecimal (a,b,c,d) = (ipv4addr_of_nat a << 24) + (ipv4addr_of_nat b << 16) + (ipv4addr_of_nat c << 8) + ipv4addr_of_nat d"
  proof -
    have a: "(ipv4addr_of_nat a) << 24 = ipv4addr_of_nat (a * 16777216)"
      by(simp add: ipv4addr_of_nat_def shiftl_t2n, metis Abs_fnat_hom_mult comm_semiring_1_class.normalizing_semiring_rules(7) of_nat_numeral)
    have b: "(ipv4addr_of_nat b) << 16 = ipv4addr_of_nat (b * 65536)"
      by(simp add: ipv4addr_of_nat_def shiftl_t2n, metis Abs_fnat_hom_mult comm_semiring_1_class.normalizing_semiring_rules(7) of_nat_numeral)
    have c: "(ipv4addr_of_nat c) << 8 = ipv4addr_of_nat (c * 256)"
      by(simp add: ipv4addr_of_nat_def shiftl_t2n, metis Abs_fnat_hom_mult comm_semiring_1_class.normalizing_semiring_rules(7) of_nat_numeral)
    have ipv4addr_of_nat_suc: "\<And>x. ipv4addr_of_nat (Suc x) = word_succ (ipv4addr_of_nat (x))"
      by(simp add: ipv4addr_of_nat_def, metis Abs_fnat_hom_Suc of_nat_Suc)
    { fix x y
    have "ipv4addr_of_nat x + ipv4addr_of_nat y = ipv4addr_of_nat (x+y)"
      apply(induction x arbitrary: y)
      apply(simp add: ipv4addr_of_nat_def)
      apply(simp add: ipv4addr_of_nat_suc)
      by (metis (hide_lams, no_types) comm_semiring_1_class.normalizing_semiring_rules(22) comm_semiring_1_class.normalizing_semiring_rules(24) word_succ_p1)
    } from this a b c
    show ?thesis
    apply(simp add: ipv4addr_of_dotteddecimal.simps)
    apply(thin_tac "?x")+
    apply(rule ipv4addr_of_nat_eq)
    by presburger
  qed

  lemma size_ipv4addr: "size (x::ipv4addr) = 32" by(simp add:word_size)
  lemma ipv4addr_of_nat_shiftr_slice: "ipv4addr_of_nat a >> x = slice x (ipv4addr_of_nat a)"
    by(simp add: ipv4addr_of_nat_def shiftr_slice)
  value "(4294967296::ipv4addr) = 2^32"
  lemma nat_of_ipv4addr_slice_ipv4addr_of_nat:
    "nat_of_ipv4addr (slice x (ipv4addr_of_nat a)) = (nat_of_ipv4addr (ipv4addr_of_nat a)) div 2^x"
    apply(simp add: shiftr_slice[symmetric])
    apply(simp add: ipv4addr_of_nat_def word_of_nat)
    apply(simp add: nat_of_ipv4addr_def unat_def)
    apply(simp add: shiftr_div_2n)
    apply(simp add: uint_word_of_int)
    by (smt Divides.pos_mod_sign zpower_int)
  lemma ipv4addr_and_255: "(x::ipv4addr) AND 255 = x AND mask 8"
    apply(subst pow2_mask[of 8, simplified, symmetric])
    by simp
  lemma ipv4addr_of_nat_AND_mask8: "(ipv4addr_of_nat a) AND mask 8 = (ipv4addr_of_nat (a mod 256))"
    apply(simp add: ipv4addr_of_nat_def and_mask_mod_2p)
    apply(simp add: word_of_nat) (*us this to get rid of of_nat. All thm are with word_of_int*)
    apply(simp add: uint_word_of_int)
    apply(subst mod_mod_cancel)
    apply simp
    apply(simp add: zmod_int)
    done

  lemma dotteddecimal_of_ipv4addr_ipv4addr_of_dotteddecimal:
  "\<lbrakk> a < 256; b < 256; c < 256; d < 256 \<rbrakk> \<Longrightarrow> dotteddecimal_of_ipv4addr (ipv4addr_of_dotteddecimal (a,b,c,d)) = (a,b,c,d)"
    apply(simp add: ipv4addr_of_dotteddecimal.simps dotteddecimal_of_ipv4addr.simps)
    apply(simp add: ipv4addr_and_255)
    apply(safe)
    prefer 4
    apply(simp add: ipv4addr_of_nat_AND_mask8)
    apply(simp add: ipv4addr_of_nat_def word_of_nat)
    apply(simp add: nat_of_ipv4addr_def)
    apply(subgoal_tac "(d + 256 * c + 65536 * b + 16777216 * a) mod 256 = d")
    prefer 2
    apply(simp add: NumberWang.mod256)
    apply(simp)
    apply(simp add: unat_def)
    apply(simp add: uint_word_of_int)
    apply(simp add: mod_pos_pos_trivial)
    (*only the shiftright cases left*)
    apply(simp add: ipv4addr_of_nat_def word_of_nat)
    apply(simp add: nat_of_ipv4addr_def unat_def)
    apply(simp add: and_mask_mod_2p)
    apply(simp add: shiftr_div_2n)
    apply(simp add: uint_word_of_int)
    apply(subst mod_pos_pos_trivial)
    apply simp_all
    apply(subst mod_pos_pos_trivial)
    apply simp_all
    apply(subst mod_pos_pos_trivial)
    apply simp_all

    apply(simp add: ipv4addr_of_nat_def word_of_nat)
    apply(simp add: nat_of_ipv4addr_def unat_def)
    apply(simp add: and_mask_mod_2p)
    apply(simp add: shiftr_div_2n)
    apply(simp add: uint_word_of_int)
    apply(subst mod_pos_pos_trivial)
    apply simp_all
    apply(subst mod_pos_pos_trivial[where b="4294967296"])
    apply simp_all
    apply(simp add: NumberWang.div65536)

    apply(simp add: ipv4addr_of_nat_def word_of_nat)
    apply(simp add: nat_of_ipv4addr_def unat_def)
    apply(simp add: and_mask_mod_2p)
    apply(simp add: shiftr_div_2n)
    apply(simp add: uint_word_of_int)
    apply(subst mod_pos_pos_trivial)
    apply simp_all
    apply(subst mod_pos_pos_trivial[where b="4294967296"])
    apply simp_all
    apply(simp add: NumberWang.div256)
    done

  lemma ipv4addr_of_dotteddecimal_eqE: "\<lbrakk> ipv4addr_of_dotteddecimal (a,b,c,d) = ipv4addr_of_dotteddecimal (e,f,g,h); a < 256; b < 256; c < 256; d < 256; e < 256; f < 256; g < 256; h < 256 \<rbrakk> \<Longrightarrow>
     a = e \<and> b = f \<and> c = g \<and> d = h"
     by (metis Pair_inject dotteddecimal_of_ipv4addr_ipv4addr_of_dotteddecimal)

  text{*previous and next ip adresses, without wrap around*}
    definition ip_next :: "ipv4addr \<Rightarrow> ipv4addr" where
      "ip_next a \<equiv> if a = max_ipv4_addr then max_ipv4_addr else a + 1"
    definition ip_prev :: "ipv4addr \<Rightarrow> ipv4addr" where
      "ip_prev a \<equiv> if a = 0 then 0 else a - 1"

    value "ip_next 2"
    value "ip_prev 2"
    value "ip_prev 0"

subsection{*IP ranges*}
  lemma UNIV_ipv4addrset: "(UNIV \<Colon> ipv4addr set) = {0 .. max_ipv4_addr}"
    by(auto)
  value (code) "(42::ipv4addr) \<in> UNIV"

  (*Warning, not executable!*)
  definition ipv4range_set_from_netmask::"ipv4addr \<Rightarrow> ipv4addr \<Rightarrow> ipv4addr set" where
    "ipv4range_set_from_netmask addr netmask \<equiv> let network_prefix = (addr AND netmask) in {network_prefix .. network_prefix OR (NOT netmask)}"

  lemma "ipv4range_set_from_netmask (ipv4addr_of_dotteddecimal (192,168,0,42)) (ipv4addr_of_dotteddecimal (255,255,0,0)) =
          {ipv4addr_of_dotteddecimal (192,168,0,0) .. ipv4addr_of_dotteddecimal (192,168,255,255)}"
   by(simp add: ipv4range_set_from_netmask_def ipv4addr_of_dotteddecimal.simps ipv4addr_of_nat_def)

  lemma "ipv4range_set_from_netmask (ipv4addr_of_dotteddecimal (192,168,0,42)) (ipv4addr_of_dotteddecimal (0,0,0,0)) = UNIV"
    by(simp add: UNIV_ipv4addrset ipv4addr_of_dotteddecimal.simps ipv4addr_of_nat_def ipv4range_set_from_netmask_def max_ipv4_addr_max_word)

  text{*192.168.0.0/24*}
  definition ipv4range_set_from_bitmask::"ipv4addr \<Rightarrow> nat \<Rightarrow> ipv4addr set" where
    "ipv4range_set_from_bitmask addr bitmask \<equiv> ipv4range_set_from_netmask addr (of_bl ((replicate bitmask True) @ (replicate (32 - bitmask) False)))"

  lemma "(replicate 3 True) = [True, True, True]" by eval
  lemma "of_bl (replicate 3 True) = (7::ipv4addr)" by eval

  (*alternate definition*)
  lemma ipv4range_set_from_bitmask_alt1:
    "ipv4range_set_from_bitmask addr bitmask = ipv4range_set_from_netmask addr ((mask bitmask) << (32 - bitmask))"
    apply(simp add: ipv4range_set_from_bitmask_def mask_bl)
    apply(simp add:  Word.shiftl_of_bl)
    done

  lemma "ipv4range_set_from_bitmask (ipv4addr_of_dotteddecimal (192,168,0,42)) 16 =
          {ipv4addr_of_dotteddecimal (192,168,0,0) .. ipv4addr_of_dotteddecimal (192,168,255,255)}"
   by(simp add: ipv4range_set_from_bitmask_def ipv4range_set_from_netmask_def ipv4addr_of_dotteddecimal.simps ipv4addr_of_nat_def)

  lemma ipv4range_set_from_bitmask_0: "ipv4range_set_from_bitmask foo 0 = UNIV"
    apply(rule)
    apply(simp_all)
    apply(simp add: ipv4range_set_from_bitmask_alt1 ipv4range_set_from_netmask_def Let_def)
    apply(simp add: range_0_max_UNIV[symmetric] del: range_0_max_UNIV)
    apply(simp add: mask_def)
    done

  lemma ipv4addr_or_NOT4294967296: "(foo::ipv4addr) OR -4294967296 = foo"
    proof -
      let ?null="-4294967296::ipv4addr"
      have "?null = 0" by simp
      from this Word.word_bool_alg.disj_zero_right
      show "foo OR ?null = foo" by metis
    qed
  lemma ipv4range_set_from_bitmask_32: "ipv4range_set_from_bitmask foo 32 = {foo}"
    apply(rule)
    apply(simp_all)
    apply(simp_all add: ipv4range_set_from_bitmask_alt1 ipv4range_set_from_netmask_def Let_def)
    apply(simp_all add: mask_def)
    apply(simp_all only: max_ipv4_addr_number[symmetric] max_ipv4_addr_max_word Word.word_and_max)
    apply(simp_all add: ipv4addr_or_NOT4294967296)
    done

  lemma ipv4range_set_from_bitmask_alt: "ipv4range_set_from_bitmask pre len = {(pre AND ((mask len) << (32 - len))) .. pre OR (mask (32 - len))}"
    apply(simp only: ipv4range_set_from_bitmask_alt1 ipv4range_set_from_netmask_def Let_def)
    apply(subst Word.word_oa_dist)
    apply(simp only: word_or_not)
    apply(simp only: Word.word_and_max)
    apply(simp only: NOT_mask_len32)
    done

  (*making element check executable*)
  lemma addr_in_ipv4range_set_from_netmask_code[code_unfold]:
    "addr \<in> (ipv4range_set_from_netmask base netmask) \<longleftrightarrow> (base AND netmask) \<le> addr \<and> addr \<le> (base AND netmask) OR (NOT netmask)"
    by(simp add: ipv4range_set_from_netmask_def Let_def)
  lemma addr_in_ipv4range_set_from_bitmask_code[code_unfold]: "addr \<in> (ipv4range_set_from_bitmask pre len) \<longleftrightarrow>
              (pre AND ((mask len) << (32 - len))) \<le> addr \<and> addr \<le> pre OR (mask (32 - len))"
  unfolding ipv4range_set_from_bitmask_alt by simp

  value "ipv4addr_of_dotteddecimal (192,168,4,8) \<in> (ipv4range_set_from_bitmask (ipv4addr_of_dotteddecimal (192,168,0,42)) 16)"

  datatype ipv4range = IPv4Range
                ipv4addr --"start (inclusive)"
                ipv4addr --"end (inclusive)"
                | IPv4Union ipv4range ipv4range

  fun ipv4range_to_set :: "ipv4range \<Rightarrow> ipv4addr set" where
    "ipv4range_to_set (IPv4Range start end) = {start .. end}" |
    "ipv4range_to_set (IPv4Union r1 r2) = (ipv4range_to_set r1) \<union> (ipv4range_to_set r2)"

  fun ipv4range_element where
    "ipv4range_element el (IPv4Range s e) = (s \<le> el \<and> el \<le> e)" |
    "ipv4range_element el (IPv4Union r1 r2) = (ipv4range_element el r1 \<or> ipv4range_element el r2)"
  lemma ipv4range_element_set_eq[simp]: "ipv4range_element el rg = (el \<in> ipv4range_to_set rg)"
    by(induction rg rule: ipv4range_element.induct) simp_all

  fun ipv4range_union where "ipv4range_union r1 r2 = IPv4Union r1 r2"
  lemma ipv4range_union_set_eq[simp]: "ipv4range_to_set (ipv4range_union r1 r2) = ipv4range_to_set r1 \<union> ipv4range_to_set r2" by simp

  fun ipv4range_empty where
    "ipv4range_empty (IPv4Range s e) = (e < s)" |
    "ipv4range_empty (IPv4Union r1 r2) = (ipv4range_empty r1 \<and> ipv4range_empty r2)"
  lemma ipv4range_empty_set_eq[simp]: "ipv4range_empty r \<longleftrightarrow> ipv4range_to_set r = {}"
    by(induction r) auto

  fun ipv4range_optimize_empty where
    "ipv4range_optimize_empty (IPv4Union r1 r2) = (let r1o = ipv4range_optimize_empty r1 in (let r2o = ipv4range_optimize_empty r2 in (
      if ipv4range_empty r1o then r2o else (if ipv4range_empty r2o then r1o else (IPv4Union r1o r2o)))))" |
    "ipv4range_optimize_empty r = r"
  lemma ipv4range_optimize_empty_set_eq[simp]: "ipv4range_to_set (ipv4range_optimize_empty r) = ipv4range_to_set r"
    by(induction r) (simp_all add: Let_def)
  lemma ipv4range_optimize_empty_double[simp]: "ipv4range_optimize_empty (ipv4range_optimize_empty r) = ipv4range_optimize_empty r"
    apply(induction r)
    by(simp_all add: Let_def)
  fun ipv4range_empty_shallow where
    "ipv4range_empty_shallow (IPv4Range s e) = (e < s)" |
    "ipv4range_empty_shallow (IPv4Union _ _) = False"
  lemma helper_optimize_shallow: "ipv4range_empty (ipv4range_optimize_empty r) = ipv4range_empty_shallow (ipv4range_optimize_empty r)"
    by(induction r) fastforce+
  fun ipv4range_optimize_empty2 where
    "ipv4range_optimize_empty2 (IPv4Union r1 r2) = (let r1o = ipv4range_optimize_empty r1 in (let r2o = ipv4range_optimize_empty r2 in (
      if ipv4range_empty_shallow r1o then r2o else (if ipv4range_empty_shallow r2o then r1o else (IPv4Union r1o r2o)))))" |
    "ipv4range_optimize_empty2 r = r"
  lemma ipv4range_optimize_empty_code[code_unfold]: "ipv4range_optimize_empty = ipv4range_optimize_empty2"
    by (subst fun_eq_iff, clarify, rename_tac r, induct_tac r)
       (unfold ipv4range_optimize_empty.simps ipv4range_optimize_empty2.simps Let_def helper_optimize_shallow[symmetric], simp_all)

  fun ipv4range_to_list where
    "ipv4range_to_list (IPv4Union r1 r2) = ipv4range_to_list r1 @ ipv4range_to_list r2" |
    "ipv4range_to_list r = (if ipv4range_empty r then [] else [r])"

  lemma "fold (\<lambda> r s. s \<union> ipv4range_to_set r) (ipv4range_to_list rs) {} = ipv4range_to_set rs"
    apply(induction rs, simp)
    apply(subst ipv4range_to_list.simps(1))
    apply simp
    thm fold_append_concat_rev
    oops

  lemma ipv4range_to_list_set_eq: "(\<Union>set (map ipv4range_to_set (ipv4range_to_list rs))) = ipv4range_to_set rs"
  (* apply(induction rs)
    apply(simp)
    apply(subst ipv4range_to_list.simps(1))
    apply(subst ipv4range_to_set.simps(2))
    apply(subst map_append, subst set_append)
    apply(subst Union_Un_distrib)
    apply simp done*)
  by(induction rs) simp_all

  fun list_to_ipv4range where
    "list_to_ipv4range [r] = r" |
    "list_to_ipv4range (r#rs) = (IPv4Union r (list_to_ipv4range rs))" |
    "list_to_ipv4range [] = IPv4Range 2 1"

  lemma list_to_ipv4range_set_eq: "(\<Union>set (map ipv4range_to_set rs)) = ipv4range_to_set (list_to_ipv4range rs)"
    by(induction rs rule: list_to_ipv4range.induct) simp_all

  fun ipv4range_linearize where "ipv4range_linearize rs = list_to_ipv4range (ipv4range_to_list rs)"
  lemma "ipv4range_to_set (ipv4range_linearize r) = ipv4range_to_set r"
    by(simp, metis list_to_ipv4range_set_eq ipv4range_to_list_set_eq)

  fun ipv4range_optimize_same where "ipv4range_optimize_same rs = list_to_ipv4range (remdups (ipv4range_to_list rs))"
  lemma ipv4range_optimize_same_set_eq[simp]: "ipv4range_to_set (ipv4range_optimize_same rs) = ipv4range_to_set rs"
   by(simp, subst list_to_ipv4range_set_eq[symmetric]) (metis image_set ipv4range_to_list_set_eq set_remdups)

  fun ipv4range_is_simple where "ipv4range_is_simple (IPv4Range _ _) = True" | "ipv4range_is_simple (IPv4Union _ _) = False"
  fun ipv4rangelist_union_free where
    "ipv4rangelist_union_free (r#rs) = (ipv4range_is_simple r \<and> ipv4rangelist_union_free rs)" |
    "ipv4rangelist_union_free [] = True"
  lemma ipv4rangelist_union_freeX: "ipv4rangelist_union_free (r # rs) \<Longrightarrow> \<exists> s e. r = IPv4Range s e"
    by (induction rs) (cases r, simp, simp)+
  lemma ipv4rangelist_union_free_append: "ipv4rangelist_union_free (a@b) = (ipv4rangelist_union_free a \<and> ipv4rangelist_union_free b)"
    by (induction a) (auto)
  lemma ipv4range_to_list_union_free: "l = ipv4range_to_list r \<Longrightarrow> ipv4rangelist_union_free l"
    by(induction r arbitrary: l) (simp_all add: ipv4rangelist_union_free_append)

  (*
  fun ipv4range_merge_rule where
    "ipv4range_merge_rule (IPv4Range s e) (IPv4Range sm em # rs) = ipv4range_merge_rule (if s > ip_next em \<or> e < ip_prev sm
      then (IPv4Range s e) else (IPv4Range (min sm s) (max em e))) rs" |
    "ipv4range_merge_rule r [] = r" |
    "ipv4range_merge_rule _ _ = undefined"
  lemma ipv4range_merge_rule_set_eq[simp]: "ipv4rangelist_union_free rs \<Longrightarrow>
    ipv4range_to_set (ipv4range_merge_rule (IPv4Range s e) rs) \<union> (\<Union>set (map ipv4range_to_set rs)) = ipv4range_to_set (IPv4Range s e) \<union> (\<Union>set (map ipv4range_to_set rs))"
    apply(induction rs arbitrary: s e) apply(simp)
    apply(case_tac a) prefer 2 apply simp
    apply(rename_tac s e sm em)
    apply(simp only: ipv4range_merge_rule.simps)
    apply(case_tac "s > ip_next em \<or> e < ip_prev sm") apply(simp_all only: if_False if_True) apply(auto)[1]
    apply(case_tac "s \<le> sm", case_tac [!] "e \<ge> em")
    apply(simp, metis (hide_lams, no_types) max.order_iff min_max.inf_absorb2 min_max.sup_commute sup_left_commute)
    proof -
      case goal1
      have "ipv4rangelist_union_free rs" using goal1(2) by simp
      note mIH = goal1(1)[OF this]
      from goal1(4) have "s \<le> ip_next em" "ip_prev sm \<le> e" by auto
      have "ipv4range_to_set (IPv4Range s e) \<union> \<Union>set (map ipv4range_to_set (IPv4Range sm em # rs)) =
        ipv4range_to_set (IPv4Range s e) \<union> ipv4range_to_set (IPv4Range sm em) \<union> \<Union>set (map ipv4range_to_set rs)" by force

      have "ipv4range_to_set (ipv4range_merge_rule (IPv4Range s em) rs) \<union> \<Union>set (map ipv4range_to_set (IPv4Range sm em # rs)) =
        ipv4range_to_set (ipv4range_merge_rule (IPv4Range s em) rs) \<union> ipv4range_to_set (IPv4Range sm em) \<union> \<Union>set (map ipv4range_to_set rs)" by force
      moreover have "\<dots> = ipv4range_to_set (ipv4range_merge_rule (IPv4Range s e) rs) \<union> ipv4range_to_set (IPv4Range sm em) \<union> \<Union>set (map ipv4range_to_set rs)"
        (*using goal1(6) ipv4range_merge_rule_mono1[OF order_less_imp_le[OF linorder_class.not_leE[OF goal1(6)]], of s rs]
        apply(subst set_eq_subset) apply(rule) prefer 2 apply force*)
        sorry
      from mIH[of s e] have "ipv4range_to_set (ipv4range_merge_rule (IPv4Range s em) rs) \<union> \<Union>set (map ipv4range_to_set (IPv4Range sm em # rs)) =
        ipv4range_to_set (IPv4Range s e) \<union> \<Union>set (map ipv4range_to_set (IPv4Range sm em # rs))"  sorry
      with goal1(5) goal1(6) show ?case
        by(metis linear min_max.inf_absorb1 min_max.inf_commute min_max.sup_absorb2 min_max.sup_commute)
    oops*)

  (*fun ipv4range_merge_helper where
    "ipv4range_merge_helper [] m = m" |
    "ipv4range_merge_helper ((IPv4Range s e) # rs) m = ipv4range_merge_helper rs
      (if ipv4range_subset_some (IPv4Range s e) m
        then ipv4range_merge_helper rs m
        else (IPv4Union (ipv4range_merge_rule (IPv4Range s e) rs) m))" |
    "ipv4range_merge_helper _ _ = undefined"
  lemma ipv4range_merge_helper_set_eq[simp]: "ipv4rangelist_union_free r \<Longrightarrow>
    ipv4range_to_set (ipv4range_merge_helper r m) = (\<Union>set (map ipv4range_to_set r)) \<union> ipv4range_to_set m"
    apply(induction r arbitrary: m)
    apply(simp_all)
    apply(case_tac a) prefer 2 apply(simp) apply(rename_tac a r m s e)
    apply(simp only: ipv4range_merge_helper.simps)
    apply(case_tac "ipv4range_subset_some a m") apply(simp)
    apply(metis ipv4range_subset_some_set_eq ipv4range_to_set.simps(1) le_iff_sup sup.coboundedI2 sup_assoc)
    apply(simp only: if_False ipv4range_to_set.simps(2))
    (*using ipv4range_merge_rule_set_eq by fastforce*) oops

  fun ipv4range_merge where
    "ipv4range_merge m = ipv4range_optimize_empty (ipv4range_merge_helper (ipv4range_to_list m) (IPv4Range 2 1))"
  lemma ipv4range_merge_set_eq[simp]: "ipv4range_to_set (ipv4range_merge r) = ipv4range_to_set r"
    (*using ipv4range_to_list_set_eq ipv4range_merge_helper_set_eq ipv4range_to_list_union_free by simp*) oops

  value "ipv4range_merge (IPv4Union (IPv4Range 2 3) (IPv4Range 1 1))"*)
(*
  fun ipv4range_ where
    "ipv4range_ (IPv4Range s e)" |
    "ipv4range_ (IPv4Union r1 r2)"
*)

  fun ipv4range_setminus :: "ipv4range \<Rightarrow> ipv4range \<Rightarrow> ipv4range" where
    "ipv4range_setminus (IPv4Range s e) (IPv4Range ms me) = (
      if s > e \<or> ms > me then IPv4Range s e else
      if me \<ge> e
        then
          IPv4Range (if ms = 0 then 1 else s) (min e (ip_prev ms))
        else if ms \<le> s
        then
          IPv4Range (max s (ip_next me)) (if me = max_ipv4_addr then 0 else e)
        else
          IPv4Union (IPv4Range (if ms = 0 then 1 else s) (ip_prev ms)) (IPv4Range (ip_next me) (if me = max_ipv4_addr then 0 else e))
        )" |
     "ipv4range_setminus (IPv4Union r1 r2) t = IPv4Union (ipv4range_setminus r1 t) (ipv4range_setminus r2 t)"|
     "ipv4range_setminus t (IPv4Union r1 r2) = ipv4range_setminus (ipv4range_setminus t r1) r2"

  lemma ipv4range_setminus_rr_set_eq[simp]: "ipv4range_to_set(ipv4range_setminus (IPv4Range s e) (IPv4Range ms me)) =
    ipv4range_to_set (IPv4Range s e) - ipv4range_to_set (IPv4Range ms me)"
     apply(simp only: ipv4range_setminus.simps)
     apply(case_tac "e < s")
      apply simp
     apply(case_tac "me < ms")
      apply simp
     apply(case_tac [!] "e \<le> me")
      apply(case_tac [!] "ms = 0")
        apply(case_tac [!] "ms \<le> s")
            apply(case_tac [!] "me = max_ipv4_addr")
                    apply(simp_all add: ip_prev_def ip_next_def min_def max_def)
            apply(safe)
                                  apply(auto)
                          apply(uint_arith)
                         apply(uint_arith)
                        apply(uint_arith)
                       apply(uint_arith)
                      apply(uint_arith)
                     apply(uint_arith)
                    apply(uint_arith)
                   apply(uint_arith)
                  apply(uint_arith)
                 apply(uint_arith)
                apply(uint_arith)
               apply(uint_arith)
              apply(uint_arith)
             apply(uint_arith)
            apply(uint_arith)
           apply(uint_arith)
          apply(uint_arith)
         apply(uint_arith)
        apply(uint_arith)
       apply(uint_arith)
      apply(uint_arith)
     apply(uint_arith)
   done

  lemma ipv4range_setminus_set_eq[simp]: "ipv4range_to_set (ipv4range_setminus r1 r2) =
    ipv4range_to_set r1 - ipv4range_to_set r2"
    using ipv4range_setminus_rr_set_eq by (induction rule: ipv4range_setminus.induct) auto
  lemma ipv4range_setminus_empty_struct: "ipv4range_empty r2 \<Longrightarrow> ipv4range_setminus r1 r2 = r1"
    by(induction r1 r2 rule: ipv4range_setminus.induct) auto

  definition "ipv4range_UNIV \<equiv> IPv4Range 0 max_ipv4_addr"
  lemma ipv4range_UNIV_set_eq[simp]: "ipv4range_to_set ipv4range_UNIV = UNIV"
    unfolding ipv4range_UNIV_def by simp

  fun ipv4range_invert where "ipv4range_invert r = ipv4range_setminus ipv4range_UNIV r"
  lemma ipv4range_invert_set_eq[simp]: "ipv4range_to_set (ipv4range_invert r) = UNIV - ipv4range_to_set r" by(auto)

  lemma ipv4range_invert_UNIV_empty: "ipv4range_empty (ipv4range_invert ipv4range_UNIV)" by simp

  fun ipv4range_intersection where "ipv4range_intersection r1 r2 =
    ipv4range_optimize_same (ipv4range_setminus (ipv4range_union r1 r2) (ipv4range_union (ipv4range_invert r1) (ipv4range_invert r2)))"
  lemma ipv4range_intersection_set_eq[simp]: "ipv4range_to_set (ipv4range_intersection r1 r2) = ipv4range_to_set r1 \<inter> ipv4range_to_set r2"
    unfolding ipv4range_intersection.simps ipv4range_optimize_same_set_eq by auto

  lemma ipv4range_setminus_intersection_empty_struct_rr:
    "ipv4range_empty (ipv4range_intersection (IPv4Range r1s r1e) (IPv4Range r2s r2e)) \<Longrightarrow>
    ipv4range_setminus (IPv4Range r1s r1e) (IPv4Range r2s r2e) = (IPv4Range r1s r1e)"
    apply(subst(asm) ipv4range_empty_set_eq)
    apply(subst(asm) ipv4range_intersection_set_eq)
    apply(unfold ipv4range_to_set.simps(1))
    apply(cases "ipv4range_empty (IPv4Range r1s r1e)", case_tac [!] "ipv4range_empty (IPv4Range r2s r2e)")
       apply(unfold ipv4range_empty.simps(1))
       apply(force, force, force)
    apply(cases "r1e < r2s")
     defer
     apply(subgoal_tac "r2e < r1s")
      defer
      apply force
     apply(simp only: ipv4range_setminus.simps)
     apply(case_tac [!] "r1e \<le> r2e", case_tac [!] "r2s \<le> r1s")
           apply(auto)
     apply(metis (hide_lams, no_types) comm_semiring_1_class.normalizing_semiring_rules(24) inc_i ip_prev_def le_minus min.absorb_iff1 word_le_sub1 word_zero_le)
    apply(metis inc_le ip_next_def max.order_iff)
  done

  declare ipv4range_intersection.simps[simp del]
  declare ipv4range_setminus.simps(1)[simp del]

  lemma ipv4range_setminus_intersection_empty_struct:
    "ipv4range_empty (ipv4range_intersection r1 r2) \<Longrightarrow>
    ipv4range_setminus r1 r2 = r1"
    by (induction r1 r2 rule: ipv4range_setminus.induct, auto simp add: ipv4range_setminus_intersection_empty_struct_rr) fastforce

  definition "ipv4range_subset r1 r2 \<equiv> ipv4range_empty (ipv4range_setminus r1 r2)"
  lemma ipv4range_subset_set_eq[simp]: "ipv4range_subset r1 r2 = (ipv4range_to_set r1 \<subseteq> ipv4range_to_set r2)"
    unfolding ipv4range_subset_def by simp

  definition ipv4range_eq where
    "ipv4range_eq r1 r2 = (ipv4range_subset r1 r2 \<and> ipv4range_subset r2 r1)"
  lemma ipv4range_eq_set_eq: "ipv4range_eq r1 r2 \<longleftrightarrow> ipv4range_to_set r1 = ipv4range_to_set r2"
    unfolding ipv4range_eq_def by auto
  thm iffD1[OF ipv4range_eq_set_eq]
  declare iffD1[OF ipv4range_eq_set_eq, simp]
  lemma ipv4range_eq_comm: "ipv4range_eq r1 r2 \<longleftrightarrow> ipv4range_eq r2 r1"
    unfolding ipv4range_eq_def by fast
  lemma ipv4range_to_set_alt: "ipv4range_to_set r = {x. ipv4range_element x r}"
    unfolding ipv4range_element_set_eq by blast

  lemma ipv4range_un_empty: "ipv4range_empty r1 \<Longrightarrow> ipv4range_eq (ipv4range_union r1 r2) r2"
    by(subst ipv4range_eq_set_eq, simp)
  lemma ipv4range_un_emty_b: "ipv4range_empty r2 \<Longrightarrow> ipv4range_eq (ipv4range_union r1 r2) r1"
    by(subst ipv4range_eq_set_eq, simp)

  lemma ipv4range_Diff_triv:
    assumes "ipv4range_empty (ipv4range_intersection a b)" shows "ipv4range_eq (ipv4range_setminus a b) a"
    using ipv4range_setminus_intersection_empty_struct[OF assms] ipv4range_eq_set_eq[of a a] by simp

  fun ipv4range_size where
    "ipv4range_size (IPv4Union a b) = ipv4range_size a + ipv4range_size b" |
    "ipv4range_size (IPv4Range s e) = (if s \<le> e then 1 else 0)"
  lemma "ipv4range_size r = length (ipv4range_to_list r)"
    by(induction r, simp_all)

  quotient_type ipv4rq = ipv4range / ipv4range_eq
    by (unfold equivp_def, simp only: fun_eq_iff, unfold ipv4range_eq_set_eq) auto
  (* lift all the things *)
  lift_definition ipv4rq_union :: "ipv4rq \<Rightarrow> ipv4rq \<Rightarrow> ipv4rq" is IPv4Union unfolding ipv4range_eq_set_eq by simp
  lift_definition ipv4rq_setminus :: "ipv4rq \<Rightarrow> ipv4rq \<Rightarrow> ipv4rq" is ipv4range_setminus unfolding ipv4range_eq_set_eq by simp
  lift_definition ipv4rq_intersection :: "ipv4rq \<Rightarrow> ipv4rq \<Rightarrow> ipv4rq" is ipv4range_intersection unfolding ipv4range_eq_set_eq by simp
  lift_definition ipv4rq_empty :: "ipv4rq \<Rightarrow> bool" is ipv4range_empty unfolding ipv4range_eq_set_eq by simp
  lift_definition ipv4rq_element :: "ipv4addr \<Rightarrow> ipv4rq \<Rightarrow> bool" is ipv4range_element unfolding ipv4range_eq_set_eq by simp
  lift_definition ipv4rq_to_set :: "ipv4rq \<Rightarrow> ipv4addr set" is ipv4range_to_set unfolding ipv4range_eq_set_eq by simp
  lift_definition ipv4rq_UNIV :: ipv4rq is ipv4range_UNIV .
  lift_definition ipv4rq_eq :: "ipv4rq \<Rightarrow> ipv4rq \<Rightarrow> bool" is ipv4range_eq unfolding ipv4range_eq_set_eq by simp
  lemma ipv4rq_union_set_eq: "ipv4rq_to_set (ipv4rq_union r1 r2) = ipv4rq_to_set r1 \<union> ipv4rq_to_set r2" by transfer simp
  lemma ipv4rq_setminus_set_eq: "ipv4rq_to_set (ipv4rq_setminus r1 r2) = ipv4rq_to_set r1 - ipv4rq_to_set r2" by transfer simp
  lemma ipv4rq_intersection_set_eq: "ipv4rq_to_set (ipv4rq_intersection r1 r2) = ipv4rq_to_set r1 \<inter> ipv4rq_to_set r2" by transfer simp
  lemma ipv4rq_empty_set_eq: "ipv4rq_empty r = (ipv4rq_to_set r = {})" by transfer simp
  lemma ipv4rq_element_set_eq: "ipv4rq_element x r = (x \<in> ipv4rq_to_set r)" by transfer simp
  lemma ipv4rq_UNIV_set_eq: "ipv4rq_to_set ipv4rq_UNIV = UNIV" by transfer simp
  lemmas ipv4rq_eqs[simp] = ipv4rq_union_set_eq ipv4rq_intersection_set_eq ipv4rq_setminus_set_eq ipv4rq_empty_set_eq ipv4rq_UNIV_set_eq

  instantiation ipv4rq :: equal
  begin
    definition "equal_ipv4rq r1 r2 = ipv4rq_eq r1 r2"
  instance
    proof
      case goal1 thus ?case unfolding equal_ipv4rq_def by transfer simp
    qed
  end

  abbreviation ipv4rq_abbr :: "ipv4addr \<Rightarrow> ipv4addr \<Rightarrow> ipv4rq" ("[_; _]") where
    "[s;e] \<equiv> abs_ipv4rq (IPv4Range s e)"
  abbreviation ipv4un_abbr :: "ipv4rq \<Rightarrow> ipv4rq \<Rightarrow> ipv4rq" ("_ \<union>\<^sub>r\<^sub>g _") where
    "r1 \<union>\<^sub>r\<^sub>g r2 == ipv4rq_union r1 r2"

  lemma rq_on_set: "ipv4rq_to_set x = ipv4rq_to_set y \<longleftrightarrow> x = y"
    by (metis Quotient_ipv4rq Quotient_rel_rep ipv4range_eq_set_eq ipv4rq_to_set.rep_eq)

  fun ipv4range_intersection2 :: "ipv4range \<Rightarrow> ipv4range \<Rightarrow> ipv4range" where
  "ipv4range_intersection2 (IPv4Union a1 a2) (IPv4Union b1 b2) = IPv4Union
    (IPv4Union (ipv4range_intersection2 a1 b1) (ipv4range_intersection2 a1 b2))
    (IPv4Union (ipv4range_intersection2 a2 b1) (ipv4range_intersection2 a2 b2))" (* equation can be left out *) |
  "ipv4range_intersection2 r (IPv4Union r1 r2) = (IPv4Union (ipv4range_intersection2 r r1) (ipv4range_intersection2 r r2))" |
  "ipv4range_intersection2 (IPv4Union r1 r2) r = (IPv4Union (ipv4range_intersection2 r1 r) (ipv4range_intersection2 r2 r))" |
  "ipv4range_intersection2 (IPv4Range s1 e1) (IPv4Range s2 e2) = IPv4Range (max s1 s2) (min e1 e2)"
  lemma ipv4range_intersection2_set_eq[simp]: "ipv4range_to_set (ipv4range_intersection2 r1 r2) =
    ipv4range_to_set r1 \<inter> ipv4range_to_set r2"
    by (induction rule: ipv4range_intersection2.induct) auto

  lift_definition ipv4rq_intersection2 :: "ipv4rq \<Rightarrow> ipv4rq \<Rightarrow> ipv4rq"
    is ipv4range_intersection2 unfolding ipv4range_eq_set_eq by simp
  lemma ipv4rq_intersection2_set_eq: "ipv4rq_to_set (ipv4rq_intersection2 r1 r2) = ipv4rq_to_set r1 \<inter> ipv4rq_to_set r2"
    by transfer simp

  lift_definition ipv4rq_optimize_empty :: "ipv4rq \<Rightarrow> ipv4rq"
    is ipv4range_optimize_empty unfolding ipv4range_eq_set_eq by simp
  lemma ipv4rq_optimize_empty_type_id: "(ipv4rq_optimize_empty r) = r"
    by(transfer, rename_tac rt, induct_tac rt)
      (unfold ipv4range_eq_set_eq, simp add: Let_def)+

  lemma ipv4rq_int_int2_code[code_unfold]: "ipv4rq_intersection = (\<lambda>x y. ipv4rq_optimize_empty (ipv4rq_intersection2 x y))"
    unfolding fun_eq_iff
    unfolding ipv4rq_optimize_empty_type_id rq_on_set[symmetric]
    unfolding ipv4rq_intersection2_set_eq ipv4rq_intersection_set_eq
    by clarify

  lemma rule_ipv4rq_eq_set: "ipv4rq_to_set x = ipv4rq_to_set y \<Longrightarrow> x = y"
    using ipv4range_eq_set_eq by transfer blast

  definition "is_lowest_element x S = (x \<in> S \<and> (\<forall>y\<in>S. y \<le> x \<longrightarrow> y = x))"
  lemma is_lowest_elment_alt: "(x \<in> S \<and> (\<forall>y\<in>S. x \<le> y)) = is_lowest_element x S"
    unfolding is_lowest_element_def
    oops

  fun ipv4range_lowest_element where
    "ipv4range_lowest_element (IPv4Range s e) = (if s \<le> e then Some s else None)" |
    "ipv4range_lowest_element (IPv4Union A B) = (case (ipv4range_lowest_element A, ipv4range_lowest_element B) of
      (Some a, Some b) \<Rightarrow> Some (if a < b then a else b) |
      (None, Some b) \<Rightarrow> Some b |
      (Some a, None) \<Rightarrow> Some a |
      (None, None) \<Rightarrow> None)
    "
  lemma ipv4range_lowest_none_empty: "ipv4range_lowest_element r = None \<longleftrightarrow> ipv4range_empty r"
    by(induction r, simp_all, fastforce)
  lemma ipv4range_lowest_element_correct_A: "ipv4range_lowest_element r = Some x \<Longrightarrow> ipv4range_element x r \<and> (\<forall>y \<in> ipv4range_to_set r. (y \<le> x \<longrightarrow> y = x))"
    apply(induction r arbitrary: x rule: ipv4range_lowest_element.induct)
     apply(rename_tac rs re x, case_tac "rs \<le> re", auto)[1]
    apply(subst(asm) ipv4range_lowest_element.simps(2))
    apply(rename_tac A B x)
    apply(case_tac     "ipv4range_lowest_element B")
     apply(case_tac[!] "ipv4range_lowest_element A")
       apply(simp_all add: ipv4range_lowest_none_empty)[3]
    apply fastforce
  done

  lemma smallerequalgreater: "((y :: ipv4addr) \<le> s \<longrightarrow> y = s) = (y \<ge> s)" by fastforce
  lemma somecase: "x = Some y \<Longrightarrow> case x of None \<Rightarrow> a | Some z \<Rightarrow> b z = b y" by simp

  lemma ipv4range_lowest_element_set_eq: "
    \<not>ipv4range_empty r \<Longrightarrow>
    (ipv4range_lowest_element r = Some x) = (is_lowest_element x (ipv4range_to_set r))"
    unfolding is_lowest_element_def
    apply(rule iffI)
    using ipv4range_lowest_element_correct_A ipv4range_lowest_none_empty apply simp
    apply(induction r arbitrary: x rule: ipv4range_lowest_element.induct)
    apply simp
    apply(rename_tac A B x)
    apply(case_tac     "ipv4range_lowest_element B")
     apply(case_tac[!] "ipv4range_lowest_element A")
       apply(auto)[3]
    apply(subgoal_tac "\<not> ipv4range_empty A \<and> \<not> ipv4range_empty B")
     prefer 2
     using arg_cong[where f = Not, OF ipv4range_lowest_none_empty] apply(simp, metis)
    apply(clarsimp simp add: ipv4range_lowest_none_empty)
    proof - (* TODO: be rid of *)
      fix A :: ipv4range and B :: ipv4range and xa :: "32 word" and a :: "32 word" and aa :: "32 word"
      assume a1: "\<And>x. x \<in> ipv4range_to_set B \<and> (\<forall>y\<in>ipv4range_to_set B. y \<le> x \<longrightarrow> y = x) \<Longrightarrow> a = x"
      assume a2: "ipv4range_lowest_element B = Some a"
      assume a3: "ipv4range_lowest_element A = Some aa"
      assume a4: "xa \<in> ipv4range_to_set A \<or> xa \<in> ipv4range_to_set B"
      assume a5: "\<forall>y\<in>ipv4range_to_set A \<union> ipv4range_to_set B. y \<le> xa \<longrightarrow> y = xa"
      obtain sk\<^sub>0 :: "32 word \<Rightarrow> 32 word" where f1: "\<forall>x\<^sub>0. x\<^sub>0 \<notin> ipv4range_to_set B \<or> sk\<^sub>0 x\<^sub>0 \<in> ipv4range_to_set B \<and> sk\<^sub>0 x\<^sub>0 \<le> x\<^sub>0 \<and> sk\<^sub>0 x\<^sub>0 \<noteq> x\<^sub>0 \<or> a = x\<^sub>0"
        using a1 by (metis (lifting))
      have "\<forall>x\<^sub>0. x\<^sub>0 \<notin> {uub. uub \<in> ipv4range_to_set A \<or> uub \<in> ipv4range_to_set B} \<or> \<not> x\<^sub>0 \<le> xa \<or> xa = x\<^sub>0"
        using a5 by blast
      hence f2: "\<forall>x\<^sub>0. \<not> (x\<^sub>0 \<in> ipv4range_to_set A \<or> x\<^sub>0 \<in> ipv4range_to_set B) \<or> xa = x\<^sub>0 \<or> \<not> x\<^sub>0 \<le> xa"
        by blast
      hence "xa \<notin> ipv4range_to_set B \<or> a = xa"
        using f1 by (metis (lifting))
      hence "aa = xa \<or> a = xa"
        using f2 a3 a4 by (metis (lifting) ipv4range_element_set_eq ipv4range_lowest_element_correct_A le_less_linear less_asym')
      thus "(aa < a \<longrightarrow> aa = xa) \<and> (\<not> aa < a \<longrightarrow> a = xa)"
        using a2 f2 a3 by (metis (lifting) ipv4range_element_set_eq ipv4range_lowest_element_correct_A le_less_linear less_asym')
    qed

  lift_definition ipv4rq_lowest_element :: "ipv4rq \<Rightarrow> ipv4addr option" is ipv4range_lowest_element unfolding ipv4range_eq_set_eq
  proof -
    fix r1 r2
    assume eq: "ipv4range_to_set r1 = ipv4range_to_set r2"
    show "ipv4range_lowest_element r1 = ipv4range_lowest_element r2"
    proof(cases "ipv4range_empty r1")
      case True
      moreover
      with eq have "ipv4range_empty r2" by simp
      ultimately
      have "ipv4range_lowest_element r1 = None" "ipv4range_lowest_element r2 = None"
        using ipv4range_lowest_none_empty[symmetric] by simp_all
      then show ?thesis ..
    next
      case False
      with eq have False2: "\<not>ipv4range_empty r2" by simp
      note ipv4range_lowest_element_set_eq[OF False] ipv4range_lowest_element_set_eq[OF False2]
      with eq show ?thesis
        by (metis not_Some_eq)
    qed
  qed

  lemma ipv4rq_lowest_element_set_eq:
   "\<not>ipv4rq_empty r \<Longrightarrow>
    (ipv4rq_lowest_element r = Some x) = (is_lowest_element x (ipv4rq_to_set r))"
    by(transfer, simp add: ipv4range_lowest_element_set_eq)

  lemma ipv4rq_lowest_in:
    assumes "\<not>ipv4rq_empty r"
    shows "ipv4rq_element (the (ipv4rq_lowest_element r)) r"
  using assms by(transfer, metis ipv4range_lowest_element_correct_A ipv4range_lowest_none_empty option.exhaust option.sel)

  fun list_to_ipv4rq :: "ipv4rq list \<Rightarrow> ipv4rq" where
    "list_to_ipv4rq [] = ipv4rq_setminus ipv4rq_UNIV ipv4rq_UNIV" |
    "list_to_ipv4rq [x] = x" |
    "list_to_ipv4rq (x#xs) = ipv4rq_union x (list_to_ipv4rq xs)"
  lemma list_to_ipv4rq_set_eq[simp]: "ipv4rq_to_set (list_to_ipv4rq rs) = (\<Union>set (map ipv4rq_to_set rs))"
    by(induction rs rule: list_to_ipv4rq.induct) simp_all

end


theory Chapter12_2
imports "HOL-IMP.Hoare_Examples"
begin

text\<open>
\section*{Chapter 12}

\setcounter{exercise}{1}

\exercise
Define @{text bsubst} and prove the Substitution Lemma:
\<close>

fun bsubst :: "bexp \<Rightarrow> aexp \<Rightarrow> vname \<Rightarrow> bexp" where
(* your definition/proof here *)

lemma bsubstitution: "bval (bsubst b a x) s = bval b (s[a/x])"
(* your definition/proof here *)

text\<open>
This may require a similar definition and proof for @{typ aexp}.
\endexercise

\exercise
Define a command @{text cmax} that stores the maximum of the values of the IMP variables
@{text "x"} and @{text "y"} in the IMP variable @{text "z"} and prove that
@{text cmax} satisfies its specification:
\<close>

abbreviation cmax :: com where
(* your definition/proof here *)

lemma "\<turnstile> {\<lambda>s. True} cmax {\<lambda>s. s ''z'' = max (s ''x'') (s ''y'')}"
(* your definition/proof here *)

text\<open>
Function @{const max} is the predefined maximum function.
Proofs about @{const max} are often automatic when simplifying with @{thm[source] max_def}.
\endexercise

\exercise\label{exe:Hoare:sumeq}
Define an equality operation for arithmetic expressions
\<close>

definition Eq :: "aexp \<Rightarrow> aexp \<Rightarrow> bexp" where
(* your definition/proof here *)

text\<open> such that \<close>

lemma bval_Eq[simp]: "bval (Eq a1 a2) s = (aval a1 s = aval a2 s)"
(* your definition/proof here *)

text\<open> Prove the following variant of the summation command correct: \<close>

lemma
  "\<turnstile> {\<lambda>s. s ''x'' = i \<and> 0 \<le> i}
     ''y'' ::= N 0;;
     WHILE Not(Eq (V ''x'') (N 0))
     DO (''y'' ::= Plus (V ''y'') (V ''x'');;
           ''x'' ::= Plus (V ''x'') (N (-1)))
     {\<lambda>s. s ''y'' = sum i}"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Prove that the following command computes @{prop"y - x"} if @{prop"(0::nat) \<le> x"}:
\<close>

lemma
  "\<turnstile> {\<lambda>s. s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> x}
     WHILE Less (N 0) (V ''x'')
     DO (''x'' ::= Plus (V ''x'') (N (-1));; ''y'' ::= Plus (V ''y'') (N (-1)))
     {\<lambda>t. t ''y'' = y - x}"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise\label{exe:Hoare:mult}
Define and verify a command @{text cmult} that stores the product of
@{text "x"} and @{text "y"} in @{text "z"} assuming @{prop"(0::int)\<le>y"}:
\<close>

abbreviation cmult :: com where
(* your definition/proof here *)

lemma
  "\<turnstile> {\<lambda>s.  s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> y} cmult {\<lambda>t. t ''z'' = x*y}"
(* your definition/proof here *)

text\<open>
You may have to simplify with @{thm[source] algebra_simps} to deal with \<open>\<close>@{text"*"}''.
\endexercise

\exercise\label{exe:Hoare:sqrt}
The following command computes an integer approximation @{text r} of the square root
of @{text "i \<ge> 0"}, i.e.\ @{text"r\<^sup>2 \<le> i < (r+1)\<^sup>2"}. Prove
\<close>

lemma
  "\<turnstile> { \<lambda>s. s ''x'' = i \<and> 0 \<le> i}
     ''r'' ::= N 0;; ''r2'' ::= N 1;;
     WHILE (Not (Less (V ''x'') (V ''r2'')))
     DO (''r'' ::= Plus (V ''r'') (N 1);;
            ''r2'' ::= Plus (V ''r2'') (Plus (Plus (V ''r'') (V ''r'')) (N 1)))
     {\<lambda>s. (s ''r'')^2 \<le> i \<and> i < (s ''r'' + 1)^2}"
(* your definition/proof here *)

text\<open>
Figure out how @{text r2} is related to @{text r} before
formulating the invariant.
The proof may require simplification with @{thm[source] algebra_simps}
and @{thm[source] power2_eq_square}.
\endexercise

\exercise
Prove by induction:
\<close>

lemma "\<turnstile> {P} c {\<lambda>s. True}"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise\label{exe:fwdassign}
Design and prove correct a forward assignment rule of the form
\ \mbox{@{text"\<turnstile> {P} x ::= a {?}"}} \
where @{text"?"} is some suitable postcondition that depends on @{text P},
@{text x} and @{text a}. Hint: @{text"?"} may need @{text"\<exists>"}.
\<close>

lemma "\<turnstile> {P} x ::= a {Questionmark}"
(* your definition/proof here *)
text\<open>
(In case you wonder if your @{text Questionmark} is strong enough: see Exercise~\ref{exe:sp})
\endexercise
\<close>
end