(*  Author:     Tobias Nipkow, 2002  *)

header "Arrow's Theorem for Utility Functions"

theory Arrow_Utility imports Complex_Main
begin

text{* This theory formalizes the first proof due to
Geanakoplos~\cite{Geanakoplos05}.  In contrast to the standard model
of preferences as linear orders, we model preferences as \emph{utility
functions} mapping each alternative to a real number. The type of
alternatives and voters is assumed to be finite. *}

typedecl alt
typedecl indi

axiomatization where
  alt3: "\<exists>a b c::alt. distinct[a,b,c]" and
  finite_alt: "finite(UNIV:: alt set)" and

  finite_indi: "finite(UNIV:: indi set)"

lemma third_alt: "a \<noteq> b \<Longrightarrow> \<exists>c::alt. distinct[a,b,c]"
using alt3 by simp metis

lemma alt2: "\<exists>b::alt. b \<noteq> a"
using alt3 by simp metis

type_synonym pref = "alt \<Rightarrow> real"
type_synonym prof = "indi \<Rightarrow> pref"

definition
 top :: "pref \<Rightarrow> alt \<Rightarrow> bool" (infixr "<\<cdot>" 60) where
"p <\<cdot> b  \<equiv>  \<forall>a. a \<noteq> b \<longrightarrow> p a < p b"

definition
 bot :: "alt \<Rightarrow> pref \<Rightarrow> bool" (infixr "\<cdot><" 60) where
"b \<cdot>< p  \<equiv>  \<forall>a. a \<noteq> b \<longrightarrow> p b < p a"

definition
 extreme :: "pref \<Rightarrow> alt \<Rightarrow> bool" where
"extreme p b  \<equiv>  b \<cdot>< p \<or> p <\<cdot> b"

abbreviation
"Extreme P b == \<forall>i. extreme (P i) b"

lemma less_if_bot[simp]: "\<lbrakk> b \<cdot>< p; x \<noteq> b \<rbrakk> \<Longrightarrow> p b < p x"
by(simp add:bot_def)

lemma [simp]: "\<lbrakk> p <\<cdot> b; x \<noteq> b \<rbrakk> \<Longrightarrow> p x < p b"
by(simp add:top_def)

lemma [simp]: assumes top: "p <\<cdot> b" shows "\<not> p b < p c"
proof (cases)
  assume "b = c" thus ?thesis by simp
next
  assume "b \<noteq> c"
  with top have "p c < p b" by (simp add:eq_sym_conv)
  thus ?thesis by simp
qed

lemma not_less_if_bot[simp]:
  assumes bot: "b \<cdot>< p" shows "\<not> p c < p b"
proof (cases)
  assume "b = c" thus ?thesis by simp
next
  assume "b \<noteq> c"
  with bot have "p b < p c" by (simp add:eq_sym_conv)
  thus ?thesis by simp
qed

lemma top_impl_not_bot[simp]: "p <\<cdot> b \<Longrightarrow> \<not> b \<cdot>< p"
by(unfold bot_def, simp add:alt2)

lemma [simp]: "extreme p b \<Longrightarrow> (\<not> p <\<cdot> b) = (b \<cdot>< p)"
apply(unfold extreme_def)
apply(fastforce dest:top_impl_not_bot)
done

lemma [simp]: "extreme p b \<Longrightarrow> (\<not> b \<cdot>< p) = (p <\<cdot> b)"
apply(unfold extreme_def)
apply(fastforce dest:top_impl_not_bot)
done

text{* Auxiliary construction to hide details of preference model. *}

definition
 mktop :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"mktop p b \<equiv> p(b := Max(range p) + 1)"

definition
 mkbot :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"mkbot p b \<equiv> p(b := Min(range p) - 1)"

definition
 between :: "pref \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> pref" where
"between p a b c \<equiv> p(b := (p a + p c)/2)"

text{*To make things simpler:*}
declare between_def[simp]

lemma [simp]: "a \<noteq> b \<Longrightarrow> mktop p b a = p a"
by(simp add:mktop_def)

lemma [simp]: "a \<noteq> b \<Longrightarrow> mkbot p b a = p a"
by(simp add:mkbot_def)

lemma [simp]: "a \<noteq> b \<Longrightarrow> p a < mktop p b b"
by(simp add:mktop_def finite_alt)

lemma [simp]: "a \<noteq> b \<Longrightarrow> mkbot p b b < p a"
by(simp add:mkbot_def finite_alt)

lemma [simp]: "mktop p b <\<cdot> b"
by(simp add:mktop_def top_def finite_alt)

lemma [simp]: "\<not> b \<cdot>< mktop p b"
by(simp add:mktop_def bot_def alt2 finite_alt)

lemma [simp]: "a \<noteq> b \<Longrightarrow> \<not> P p a < mkbot (P p) b b"
proof (simp add:mkbot_def finite_alt)
  have "\<not> P p a + 1 < P p a" by simp
  thus "EX x. \<not> P p a + 1 < P p x" ..
qed

text{* The proof starts here. *}

locale arrow =
fixes F :: "prof \<Rightarrow> pref"
assumes unanimity: "(\<And>i. P i a < P i b) \<Longrightarrow> F P a < F P b"
and IIA:
"(\<And>i. (P i a < P i b) = (P' i a < P' i b)) \<Longrightarrow>
 (F P a < F P b) = (F P' a < F P' b)"
begin

lemmas IIA' = IIA[THEN iffD1]

definition
 dictates :: "indi \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> bool" ("_ dictates _ < _") where
"(i dictates a < b)  \<equiv>  \<forall>P. P i a < P i b \<longrightarrow> F P a < F P b"
definition
 dictates2 :: "indi \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> bool" ("_ dictates _,_") where
"(i dictates a,b)  \<equiv>  (i dictates a < b) \<and> (i dictates b < a)"
definition
 dictatesx:: "indi \<Rightarrow> alt \<Rightarrow> bool" ("_ dictates'_except _") where
"(i dictates_except c)  \<equiv>  \<forall>a b. c \<notin> {a,b} \<longrightarrow> (i dictates a<b)"
definition
 dictator :: "indi \<Rightarrow> bool" where
"dictator i  \<equiv>  \<forall>a b. (i dictates a<b)"

definition
 pivotal :: "indi \<Rightarrow> alt \<Rightarrow> bool" where
"pivotal i b \<equiv>
 \<exists>P. Extreme P b  \<and>  b \<cdot>< P i  \<and>  b \<cdot>< F P  \<and>
     F (P(i := mktop (P i) b)) <\<cdot> b"

lemma all_top[simp]: "\<forall>i. P i <\<cdot> b \<Longrightarrow> F P <\<cdot> b"
by (unfold top_def) (simp add: unanimity)

lemma not_extreme:
  assumes nex: "\<not> extreme p b"
  shows "\<exists>a c. distinct[a,b,c] \<and> \<not> p a < p b \<and> \<not> p b < p c"
proof -
  obtain a c where abc: "a \<noteq> b \<and> \<not> p a < p b" "b \<noteq> c \<and> \<not> p b < p c"
    using nex by (unfold extreme_def top_def bot_def) fastforce
  show ?thesis
  proof (cases "a = c")
    assume "a \<noteq> c" thus ?thesis using abc by simp blast
  next
    assume ac: "a = c"
    obtain d where d: "distinct[a,b,d]" using abc third_alt by blast
    show ?thesis
    proof (cases "p b < p d")
      case False thus ?thesis using abc d by blast
    next
      case True
      hence db: "\<not> p d < p b" by arith
      from d have "distinct[d,b,c]" by(simp add:ac eq_sym_conv)
      thus ?thesis using abc db by blast
    qed
  qed
qed

lemma extremal:
  assumes extremes: "Extreme P b" shows "extreme (F P) b"
proof (rule ccontr)
  assume nec: "\<not> extreme (F P) b"
  hence "\<exists>a c. distinct[a,b,c] \<and> \<not> F P a < F P b \<and> \<not> F P b < F P c"
    by(rule not_extreme)
  then obtain a c where d: "distinct[a,b,c]" and
    ab: "\<not> F P a < F P b" and bc: "\<not> F P b < F P c" by blast
  let ?P = "\<lambda>i. if P i <\<cdot> b then between (P i) a c b
                else (P i)(c := P i a + 1)"
  have "\<not> F ?P a < F ?P b"
    using extremes d by(simp add:IIA[of _ _ _ P] ab)
  moreover have "\<not> F ?P b < F ?P c"
    using extremes d by(simp add:IIA[of _ _ _ P] bc eq_sym_conv)
  moreover have "F ?P a < F ?P c" by(rule unanimity)(insert d, simp)
  ultimately show False by arith
qed

lemma pivotal_ind: assumes fin: "finite D"
  shows "\<And>P. \<lbrakk> D = {i. b \<cdot>< P i}; Extreme P b; b \<cdot>< F P \<rbrakk>
  \<Longrightarrow> \<exists>i. pivotal i b" (is "\<And>P. ?D D P \<Longrightarrow> ?E P \<Longrightarrow> ?B P \<Longrightarrow> _")
using fin
proof (induct)
  case (empty P)
  from empty(1,2) have "\<forall>i. P i <\<cdot> b" by simp
  hence "F P <\<cdot> b" by simp
  hence False using empty by(blast dest:top_impl_not_bot)
  thus ?case ..
next
  fix D i P
  assume IH: "\<And>P. ?D D P \<Longrightarrow> ?E P \<Longrightarrow> ?B P \<Longrightarrow> \<exists>i. pivotal i b"
    and "?E P" and "?B P" and insert: "insert i D = {i. b \<cdot>< P i}" and "i \<notin> D"
  from insert have "b \<cdot>< P i" by blast
  let ?P = "P(i := mktop (P i) b)"
  show "\<exists>i. pivotal i b"
  proof (cases "F ?P <\<cdot> b")
    case True
    have "pivotal i b"
    proof -
      from `?E P` `?B P` `b \<cdot>< P i` True
      show ?thesis by(unfold pivotal_def, blast)
    qed
    thus ?thesis ..
  next
    case False
    have "D = {i. b \<cdot>< ?P i}"
      by (rule set_eqI) (simp add:`i \<notin> D`, insert insert, blast)
    moreover have "Extreme ?P b"
      using `?E P` by (simp add:extreme_def)
    moreover have "b \<cdot>< F ?P"
      using extremal[OF `Extreme ?P b`] False by(simp del:fun_upd_apply)
    ultimately show ?thesis by(rule IH)
  qed
qed

lemma pivotal_exists: "\<exists>i. pivotal i b"
proof -
  let ?P = "(\<lambda>_ a. if a=b then 0 else 1)::prof"
  have "Extreme ?P b" by(simp add:extreme_def bot_def)
  moreover have "b \<cdot>< F ?P"
    by(simp add:bot_def unanimity del: less_if_bot not_less_if_bot)
  ultimately show "\<exists>i. pivotal i b"
    by (rule pivotal_ind[OF finite_subset[OF subset_UNIV finite_indi] refl])
qed

lemma pivotal_xdictates: assumes pivo: "pivotal i b"
  shows "i dictates_except b"
proof -
  have "\<And>a c. \<lbrakk> a \<noteq> b; b \<noteq> c \<rbrakk> \<Longrightarrow> i dictates a < c"
  proof (unfold dictates_def, intro allI impI)
    fix a c and P::prof
    assume abc: "a \<noteq> b" "b \<noteq> c" and
           ac: "P i a < P i c"
    show "F P a < F P c"
    proof -
      obtain P1 P2 where
        "Extreme P1 b" and "b \<cdot>< F P1" and "b \<cdot>< P1 i" and "F P2 <\<cdot> b" and
        [simp]: "P2 = P1(i := mktop (P1 i) b)"
        using pivo by (unfold pivotal_def) fast
      let ?P = "\<lambda>j. if j=i then between (P j) a b c
                    else if P1 j <\<cdot> b then mktop (P j) b else mkbot (P j) b"
      have eq: "(F P a < F P c) = (F ?P a < F ?P c)"
        using abc by - (rule IIA, auto)
      have "F ?P a < F ?P b"
      proof (rule IIA')
        fix j show "(P2 j a < P2 j b) = (?P j a < ?P j b)"
          using `Extreme P1 b` by(simp add: ac)
      next
        show "F P2 a < F P2 b"
          using `F P2 <\<cdot> b` abc by(simp add: eq_sym_conv)
      qed
      also have "\<dots> < F ?P c"
      proof (rule IIA')
        fix j show "(P1 j b < P1 j c) = (?P j b < ?P j c)"
          using `Extreme P1 b` `b \<cdot>< P1 i` by(simp add: ac)
      next
        show "F P1 b < F P1 c"
          using `b \<cdot>< F P1` abc by(simp add: eq_sym_conv)
      qed
      finally show ?thesis by(simp add:eq)
    qed
  qed
  thus ?thesis  by(unfold dictatesx_def) fast
qed

lemma pivotal_is_dictator:
  assumes pivo: "pivotal i b" and ab: "a \<noteq> b" and d: "j dictates a,b"
  shows "i = j"
proof (rule ccontr)
  assume pd: "i \<noteq> j"
  obtain P1 P2 where "Extreme P1 b" and "b \<cdot>< F P1" and "F P2 <\<cdot> b" and
    P2: "P2 = P1(i := mktop (P1 i) b)"
    using pivo by (unfold pivotal_def) fast
  have "~(P1 j a < P1 j b)" (is "~ ?ab")
  proof
    assume "?ab"
    hence "F P1 a < F P1 b" using d by(simp add: dictates_def dictates2_def)
    with `b \<cdot>< F P1` show False by simp
  qed
  hence "P1 j b < P1 j a" using `Extreme P1 b`[THEN spec, of j] ab
    unfolding extreme_def top_def bot_def by metis
  hence "P2 j b < P2 j a" using pd by (simp add:P2)
  hence "F P2 b < F P2 a" using d by(simp add: dictates_def dictates2_def)
  with `F P2 <\<cdot> b` show False by simp
qed

theorem dictator: "\<exists>i. dictator i"
proof-
  from pivotal_exists[of b] obtain i where pivo: "pivotal i b" ..
  { fix a assume neq: "a \<noteq> b" have "i dictates a,b"
    proof -
      obtain c where dist: "distinct[a,b,c]"
        using neq third_alt by blast
      obtain j where "pivotal j c" using pivotal_exists by fast
      hence "j dictates_except c" by(rule pivotal_xdictates)
      hence b: "j dictates a,b"
        using dist by(simp add:dictatesx_def dictates2_def eq_sym_conv)
      with pivo neq have "i = j" by(rule pivotal_is_dictator)
      thus ?thesis using b by simp
    qed
  }
  with pivotal_xdictates[OF pivo] have "dictator i"
    by(simp add: dictates_def dictatesx_def dictates2_def dictator_def)
      (metis less_le)
  thus ?thesis ..
qed

end

end


theory sort_NStoogeSort2Permutes
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

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

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

datatype Nat = Z | S "Nat"

fun twoThirds :: "Nat => Nat" where
"twoThirds (Z) = Z"
| "twoThirds (S (Z)) = S Z"
| "twoThirds (S (S (Z))) = S Z"
| "twoThirds (S (S (S n))) = S (S (twoThirds n))"

fun third :: "Nat => Nat" where
"third (Z) = Z"
| "third (S (Z)) = Z"
| "third (S (S (Z))) = Z"
| "third (S (S (S n))) = S (third n)"

fun take :: "Nat => 'a list => 'a list" where
"take (Z) y = Nil2"
| "take (S z) (Nil2) = Nil2"
| "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"

fun sort2 :: "int => int => int list" where
"sort2 x y =
   (if x <= y then Cons2 x (Cons2 y (Nil2)) else
      Cons2 y (Cons2 x (Nil2)))"

fun length :: "'t list => Nat" where
"length (Nil2) = Z"
| "length (Cons2 y xs) = S (length xs)"

fun drop :: "Nat => 'a list => 'a list" where
"drop (Z) y = y"
| "drop (S z) (Nil2) = Nil2"
| "drop (S z) (Cons2 x2 x3) = drop z x3"

fun splitAt :: "Nat => 'a list =>
              (('a list), ('a list)) Pair2" where
"splitAt x y = Pair (take x y) (drop x y)"

fun count :: "int => int list => Nat" where
"count x (Nil2) = Z"
| "count x (Cons2 z xs) =
     (if x = z then S (count x xs) else count x xs)"

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

function nstooge2sort2 :: "int list => int list"
         and nstoogesort2 :: "int list => int list"
         and nstooge2sort1 :: "int list => int list" where
"nstooge2sort2 x =
   case splitAt (twoThirds (length x)) x of
     | Pair ys zs =>
         case splitAt (twoThirds (length x)) x of
           | Pair xs zs2 => append (nstoogesort2 ys) zs2
         end
   end"
| "nstoogesort2 (Nil2) = Nil2"
| "nstoogesort2 (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "nstoogesort2 (Cons2 y (Cons2 y2 (Nil2))) = sort2 y y2"
| "nstoogesort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4))) =
     nstooge2sort2
       (nstooge2sort1 (nstooge2sort2 (Cons2 y (Cons2 y2 (Cons2 x3 x4)))))"
| "nstooge2sort1 x =
     case splitAt (third (length x)) x of
       | Pair ys zs =>
           case splitAt (third (length x)) x of
             | Pair xs zs2 => append ys (nstoogesort2 zs2)
           end
     end"
by pat_completeness auto

(*hipster twoThirds
          third
          take
          sort2
          length
          drop
          splitAt
          count
          append
          nstooge2sort2
          nstoogesort2
          nstooge2sort1 *)

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

end


theory ex2_09 imports Main begin

fun itadd :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"itadd 0 n = n" |
"itadd (Suc m) n = itadd m (Suc n)"

(** see section 2.2.2 **)
fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add 0 n = n" |
"add (Suc m) n = Suc (add m n)"

lemma add_r[simp]: "add m (Suc n) = Suc (add m n)"
apply(induction m)
apply auto
done

theorem "itadd m n = add m n"
apply(induction m arbitrary: n)
apply auto
done

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_58
imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

fun zip :: "'a list => 'b list => (('a, 'b) pair) list" where
"zip (nil2) y = nil2"
| "zip (cons2 z x2) (nil2) = nil2"
| "zip (cons2 z x2) (cons2 x3 x4) = cons2 (pair2 z x3) (zip x2 x4)"

fun drop :: "Nat => 'a list => 'a list" where
"drop (Z) y = y"
| "drop (S z) (nil2) = nil2"
| "drop (S z) (cons2 x2 x3) = drop z x3"

theorem property0 :
  "((drop n (zip xs ys)) = (zip (drop n xs) (drop n ys)))"
  oops

end


(*  Title:       Latin Squares
    Author:      Alexander Bentkamp <bentkamp at gmail.com>, 2015
    Maintainer:  Alexander Bentkamp <bentkamp at gmail.com>
*)

theory Latin_Square
imports Marriage.Marriage
begin

text \<open>
  This theory is about Latin Squares. A Latin Square is a $n \times n$ table filled with
  integers from 1 to n where each number appears exactly once in each row and each column.

  As described in "Das Buch der Beweise" a nice way to describe these squares by a $3 \times n$ matrix.
  Each column of this matrix contains the index of the row r, the index of the column c and the
  number in the cell (r,c). This $3 \times n$ matrix is called orthogonal array ("Zeilenmatrix").

  I thought about different ways to formalize this orthogonal array, and came up with this:
  As the order of the columns in the array does not matter at all and no column can be a
  duplicate of another column, the orthogonal array is in fact a set of 3-tuples. Another
  advantage of formalizing it as a set is that it can easily model partially filled squares.
  For these 3-tuples I decided against 3-lists and against $nat \times nat \times nat$
  (which is really $(nat \times nat) \times nat$) in favor of
  a function from a type with three elements to nat.

  Additionally I use the numbers $0$ to $n-1$ instead of $1$ to $n$ for indexing the rows and columns as
  well as for filling the cells.
\<close>

datatype latin_type = Row | Col | Num

text\<open>latin\_type is of sort enum, needed for "value" command\<close>
instantiation latin_type :: enum
begin
  definition "enum_latin_type == [Row, Col, Num]"
  definition "enum_all_latin_type (P:: latin_type \<Rightarrow> bool) = (P Row \<and> P Col \<and> P Num)"
  definition "enum_ex_latin_type (P:: latin_type \<Rightarrow> bool) = (\<exists>x. P x)"

instance
  apply standard
     apply (auto simp add: enum_latin_type_def enum_all_latin_type_def enum_ex_latin_type_def)
   apply (case_tac x,auto)
by (metis latin_type.exhaust)

end

text\<open>Given a latin\_type t, you might want to reference the other two.
   These are "next t" and "next (next t)":\<close>
definition [simp]:"next t \<equiv> (case t of Row \<Rightarrow> Col | Col \<Rightarrow> Num | Num \<Rightarrow> Row)"

lemma all_types_next_eqiv:"(\<forall>t. P (next t)) \<longleftrightarrow> (\<forall>t. P t)"
  apply (rule iffI)
   using next_def latin_type.case latin_type.exhaust apply metis
  apply metis
done

text \<open>We call a column of the orthogonal array a latin\_entry:\<close>
type_synonym latin_entry = "latin_type \<Rightarrow> nat"

text \<open>This function removes one element of the 3-tupel and returns the other two as a pair:\<close>
definition without :: "latin_type \<Rightarrow> latin_entry \<Rightarrow> nat \<times> nat" where
[simp]:"without t \<equiv> \<lambda>e. (e (next t), e (next (next t)))"

value "without Row (\<lambda>t. case t of Row \<Rightarrow> 0 | Col \<Rightarrow> 1 | Num \<Rightarrow> 2)" \<comment> \<open>returns (1,2)\<close>

abbreviation "row_col \<equiv> without Num" text \<open>returns row and column of a latin\_entry as a pair.\<close>
abbreviation "col_num \<equiv> without Row" text \<open>returns column and number of a latin\_entry as a pair.\<close>
abbreviation "num_row \<equiv> without Col" text \<open>returns number and row of a latin\_entry as a pair.\<close>

text\<open>A partial latin square is a square that contains each number at most once in each row and each
   column, but not all cells have to be filled. Equivalently we can say that any two rows of the
   orthogonal array contain each pair of two numbers at most once. This can be expressed using the
   inj\_on predicate:\<close>
definition partial_latin_square :: "latin_entry set \<Rightarrow> nat \<Rightarrow> bool" where
"partial_latin_square s n \<equiv>
  (\<forall>t. inj_on (without t) s) \<and> \<comment> \<open>numbers are unique in each column (t=Row), numbers are unique in each row (t=Col), rows-column combinations are specified unambiguously (t=Num)\<close>
  (\<forall>e\<in>s. \<forall>t. e t < n) \<comment> \<open>all numbers, column indices and row indices are <n\<close>"

value "partial_latin_square {
  (\<lambda>t. case t of Row \<Rightarrow> 0 | Col \<Rightarrow> 1 | Num \<Rightarrow> 0),
  (\<lambda>t. case t of Row \<Rightarrow> 1 | Col \<Rightarrow> 0 | Num \<Rightarrow> 1)
} 2" \<comment> \<open>True\<close>

value "partial_latin_square {
  (\<lambda>t. case t of Row \<Rightarrow> 0 | Col \<Rightarrow> 0 | Num \<Rightarrow> 1),
  (\<lambda>t. case t of Row \<Rightarrow> 1 | Col \<Rightarrow> 0 | Num \<Rightarrow> 1)
} 2" \<comment> \<open>False, because 1 appears twice in column 0\<close>

text \<open>Looking at the orthogonal array a latin square is given iff any two rows of the
   orthogonal array contain each pair of two numbers at exactly once:\<close>
definition latin_square :: "latin_entry set \<Rightarrow> nat \<Rightarrow> bool" where
"latin_square s n \<equiv>
  (\<forall>t. bij_betw (without t) s ({0..<n}\<times>{0..<n}))" (* numbers exactly once in each column (t=Row), numbers exactly once in each row (t=Col), rows-column combinations are specified exactly once (t=Num) *)

value "latin_square {
  (\<lambda>t. case t of Row \<Rightarrow> 0 | Col \<Rightarrow> 0 | Num \<Rightarrow> 1),  (\<lambda>t. case t of Row \<Rightarrow> 0 | Col \<Rightarrow> 1 | Num \<Rightarrow> 0),
  (\<lambda>t. case t of Row \<Rightarrow> 1 | Col \<Rightarrow> 0 | Num \<Rightarrow> 0),  (\<lambda>t. case t of Row \<Rightarrow> 1 | Col \<Rightarrow> 1 | Num \<Rightarrow> 1)
} 2" \<comment> \<open>True\<close>

value "latin_square {
  (\<lambda>t. case t of Row \<Rightarrow> 0 | Col \<Rightarrow> 0 | Num \<Rightarrow> 1),  (\<lambda>t. case t of Row \<Rightarrow> 0 | Col \<Rightarrow> 1 | Num \<Rightarrow> 0),
  (\<lambda>t. case t of Row \<Rightarrow> 1 | Col \<Rightarrow> 0 | Num \<Rightarrow> 0),  (\<lambda>t. case t of Row \<Rightarrow> 1 | Col \<Rightarrow> 1 | Num \<Rightarrow> 0)
} 2" \<comment> \<open>False, because 0 appears twice in Col 1 and twice in Row 1\<close>

text \<open>A latin rectangle is a partial latin square in which the first m rows are filled and the following
   rows are empty:\<close>
definition latin_rect :: "latin_entry set \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool" where
"latin_rect s m n \<equiv>
  m \<le> n \<and>
  partial_latin_square s n \<and>
  bij_betw row_col s ({0..<m}\<times>{0..<n}) \<and>
  bij_betw num_row s ({0..<n}\<times>{0..<m})"

value "latin_rect {
  (\<lambda>t. case t of Row \<Rightarrow> 0 | Col \<Rightarrow> 0 | Num \<Rightarrow> 1),  (\<lambda>t. case t of Row \<Rightarrow> 0 | Col \<Rightarrow> 1 | Num \<Rightarrow> 0)
} 1 2" \<comment> \<open>True\<close>

value "latin_rect {
  (\<lambda>t. case t of Row \<Rightarrow> 0 | Col \<Rightarrow> 0 | Num \<Rightarrow> 1),  (\<lambda>t. case t of Row \<Rightarrow> 0 | Col \<Rightarrow> 1 | Num \<Rightarrow> 0),
  (\<lambda>t. case t of Row \<Rightarrow> 1 | Col \<Rightarrow> 0 | Num \<Rightarrow> 0),  (\<lambda>t. case t of Row \<Rightarrow> 1 | Col \<Rightarrow> 1 | Num \<Rightarrow> 1)
} 1 2" \<comment> \<open>False\<close>

text \<open>There is another equivalent description of latin rectangles, which is easier to prove:\<close>
lemma latin_rect_iff:
"m\<le>n \<and> partial_latin_square s n \<and> card s = n*m \<and> (\<forall>e\<in>s. e Row < m) \<longleftrightarrow> latin_rect s m n"
proof (rule iffI)
  assume prems:"m\<le>n \<and> partial_latin_square s n \<and> card s = n * m \<and> (\<forall>e\<in>s. e Row < m)"

  have bij1:"bij_betw row_col s ({0..<m}\<times>{0..<n})" using prems
  proof
    have "inj_on row_col s" using prems partial_latin_square_def by blast
    moreover have "{0..<m} \<times> {0..<n} = row_col ` s"
    proof-
      have "row_col ` s \<subseteq> {0..<m} \<times> {0..<n}" using prems partial_latin_square_def by auto
      moreover have "card (row_col ` s) = card ({0..<m} \<times> {0..<n})" using prems card_image[OF \<open>inj_on row_col s\<close>] by auto
      ultimately show "{0..<m} \<times> {0..<n} = row_col ` s" using card_subset_eq[of "{0..<m} \<times> {0..<n}" "row_col ` s"] by auto
    qed
    ultimately show ?thesis unfolding bij_betw_def by auto
  qed

  have bij2:"bij_betw num_row s ({0..<n}\<times>{0..<m})" using prems
  proof
    have "inj_on num_row s" using prems partial_latin_square_def by blast
    moreover have "{0..<n} \<times> {0..<m} = num_row ` s"
    proof-
      have "num_row ` s \<subseteq> {0..<n} \<times> {0..<m}" using prems partial_latin_square_def by auto
      moreover have "card (num_row ` s) = card ({0..<n} \<times> {0..<m})" using prems card_image[OF \<open>inj_on num_row s\<close>] by auto
      ultimately show "{0..<n} \<times> {0..<m} = num_row ` s" using card_subset_eq[of "{0..<n} \<times> {0..<m}" "num_row ` s"] by auto
    qed
    ultimately show ?thesis unfolding bij_betw_def by auto
  qed

  from prems bij1 bij2 show "latin_rect s m n" unfolding latin_rect_def by auto
next
  assume prems:"latin_rect s m n"
  have "m\<le>n" "partial_latin_square s n" using latin_rect_def prems by auto
  moreover have "card s = m * n"
  proof -
    have "bij_betw row_col s ({0..<m} \<times> {0..<n})" using latin_rect_def prems by auto
    then show ?thesis using bij_betw_same_card[of row_col s "{0..<m} \<times> {0..<n}"] by auto
  qed
  moreover have "\<forall>e\<in>s. e Row < m" using latin_rect_def prems using atLeast0LessThan bij_betwE by fastforce
  ultimately show "m\<le>n \<and> partial_latin_square s n \<and> card s = n * m \<and> (\<forall>e\<in>s. e Row < m)" by auto
qed

text \<open>A square is a latin square iff it is a partial latin square with all $n^2$ cells filled:\<close>
lemma partial_latin_square_full:
"partial_latin_square s n \<and> card s = n*n \<longleftrightarrow> latin_square s n"
proof (rule iffI)
  assume prem: "partial_latin_square s n \<and> card s = n * n"
  have "\<forall>t. (without t) ` s \<subseteq> {0..<n} \<times> {0..<n}"
  proof
    fix t show "(without t) ` s \<subseteq> {0..<n} \<times> {0..<n}" using partial_latin_square_def next_def atLeast0LessThan prem by (cases t) auto
  qed
  then show "partial_latin_square s n \<and> card s = n * n \<Longrightarrow> latin_square s n"
    unfolding latin_square_def using partial_latin_square_def
    by (metis bij_betw_def card_atLeastLessThan card_cartesian_product card_image card_subset_eq diff_zero finite_SigmaI finite_atLeastLessThan)
next
  assume prem:"latin_square s n"
  then have "bij_betw row_col s ({0..<n} \<times> {0..<n})" using latin_square_def by blast
  moreover have "partial_latin_square s n"
  proof -
    have "\<forall>t. \<forall>e\<in>s. (without t) e \<in> ({0..<n}\<times>{0..<n})" using prem latin_square_def bij_betwE by metis
    then have 1:"\<forall>e\<in>s.\<forall>t. e t < n" using latin_square_def all_types_next_eqiv[of "\<lambda>t. \<forall>e\<in>s. e t < n"] bij_betwE by auto
    have 2:"(\<forall>t. inj_on (without t) s)" using prem bij_betw_def latin_square_def by auto
    from 1 2 show ?thesis using partial_latin_square_def by auto
  qed
  ultimately show "partial_latin_square s n \<and> card s = n*n" by (auto simp add:  bij_betw_same_card)
qed

text \<open>Now we prove Lemma 1 from chapter 27 in "Das Buch der Beweise". But first some lemmas, that prove
   very intuitive facts:\<close>

lemma bij_restrict:
assumes "bij_betw f A B" "\<forall>a\<in>A. P a \<longleftrightarrow> Q (f a)"
shows "bij_betw f {a\<in>A. P a} {b\<in>B. Q b}"
proof -
  have inj: "inj_on f {a\<in>A. P a}" using assms bij_betw_def by (metis (mono_tags, lifting) inj_onD inj_onI mem_Collect_eq)
  have surj1: "f ` {a\<in>A. P a} \<subseteq> {b\<in>B. Q b}" using assms(1) assms(2) bij_betwE by blast
  have surj2: "{b\<in>B. Q b} \<subseteq> f ` {a\<in>A. P a}"
  proof
    fix b
    assume "b \<in> {b \<in> B. Q b}"
    then obtain a where "f a = b" "a\<in>A" using assms(1) bij_betw_inv_into_right bij_betwE bij_betw_inv_into mem_Collect_eq by (metis (no_types, lifting))
    then show "b \<in> f ` {a\<in>A. P a}" using \<open>b \<in> {b \<in> B. Q b}\<close> assms(2) by blast
  qed
  with inj surj1 surj2 show ?thesis using bij_betw_imageI by fastforce
qed

lemma cartesian_product_margin1:
assumes "a\<in>A"
shows "{p\<in>A\<times>B. fst p = a} = {a}\<times>B"
using SigmaI assms by auto

lemma cartesian_product_margin2:
assumes "b\<in>B"
shows "{p\<in>A\<times>B. snd p = b} = A\<times>{b}"
using SigmaI assms by auto

text \<open>The union of sets containing at most k elements each cannot contain more elements than
   the number of sets times k:\<close>
lemma limited_family_union: "finite B \<Longrightarrow> \<forall>P\<in>B. card P \<le> k \<Longrightarrow> card (\<Union>B) \<le> card B * k"
proof (induction B rule:finite_induct)
  case empty
  then show ?case by auto
next
  case (insert P B)
  have "card (\<Union>(insert P B)) \<le> card P + card (\<Union>B)" by (simp add: card_Un_le)
  then have "card (\<Union>(insert P B)) \<le> card P + card B * k" using insert by auto
  then show ?case using insert by simp
qed

text \<open>If f hits each element at most k times, the domain of f can only be k times bigger than the
   image of f:\<close>
lemma limited_preimages:
assumes "\<forall>x \<in> f ` D. card ((f -` {x})\<inter>D) \<le> k" "finite D"
shows "card D \<le> card (f ` D) * k "
proof -
  let ?preimages = "(\<lambda>x. (f -` {x})\<inter>D) ` (f ` D)"
  have "D = \<Union>?preimages" by auto
  have "card (\<Union>?preimages) \<le> card ?preimages * k" using limited_family_union[of "?preimages" k] assms by auto
  moreover have "card (?preimages) * k \<le> card (f ` D) * k" using card_image_le[of "f ` D" "\<lambda>x. (f -` {x})\<inter>D"] assms by auto
  ultimately have "card (\<Union>?preimages) \<le> card (f ` D) * k" using le_trans by blast
  then show ?thesis using \<open>D = \<Union>?preimages\<close> by metis
qed

text \<open>Let $A_1, \dots, A_n$ be sets with $k>0$ elements each. Any element is only contained in at most $k$ of
   these sets. Then there are more different elements in total than sets $A_i$:\<close>
lemma union_limited_replicates:
assumes "finite I" "\<forall>i\<in>I. finite (A i)" "k>0" "\<forall>i\<in>I. card (A i) = k" "\<forall>i\<in>I. \<forall>x\<in>(A i). card {i\<in>I. x\<in>A i} \<le> k"
shows "card (\<Union>i\<in>I. (A i)) \<ge> card I" using assms
proof -
  let ?pairs = "{(i,x). i\<in>I \<and> x\<in>A i}"

  have card_pairs: "card ?pairs = card I * k" using assms
  proof (induction I rule:finite_induct)
    case empty
    then show ?case using card_eq_0_iff by auto
  next
    case (insert i0 I)
    have "\<forall>i\<in>I. \<forall>x\<in>(A i). card {i\<in>I. x\<in>A i} \<le> k"
    proof (rule ballI)+
      fix i x assume "i \<in> I" "x\<in>A i"
      then have "card {i \<in> insert i0 I. x \<in> A i} \<le> k" using insert by auto
      moreover have "finite {i \<in> insert i0 I. x \<in> A i}" using insert by auto
      ultimately show "card  {i\<in>I. x\<in>A i} \<le> k" using card_mono[of "{i \<in> insert i0 I. x \<in> A i}" "{i \<in> I. x \<in> A i}"] le_trans by blast
    qed
    then have card_S: "card {(i, x). i \<in> I \<and> x \<in> A i} = card I * k" using insert by auto

    have card_B: "card {(i, x). i=i0 \<and> x\<in>A i0} = k" using insert by auto

    have "{(i, x). i \<in> insert i0 I \<and> x \<in> A i} = {(i, x). i \<in> I \<and> x \<in> A i} \<union> {(i, x). i=i0 \<and> x\<in>A i0}" by auto
    moreover have "{(i, x). i \<in> I \<and> x \<in> A i} \<inter> {(i, x). i=i0 \<and> x\<in>A i0} = {}" using insert by auto
    moreover have "finite {(i, x). i \<in> I \<and> x \<in> A i}" using insert rev_finite_subset[of "I \<times> \<Union>(A ` I)" "{(i, x). i \<in> I \<and> x \<in> A i}"] by auto
    moreover have "finite {(i, x). i=i0 \<and> x\<in>A i0}" using insert card_B card_infinite neq0_conv by blast
    ultimately have "card {(i, x). i \<in> insert i0 I \<and> x \<in> A i} = card {(i, x). i \<in> I \<and> x \<in> A i} + card {(i, x). i=i0 \<and> x\<in>A i0}" by (simp add: card_Un_disjoint)
    with card_S card_B have "card {(i, x). i \<in> insert i0 I \<and> x \<in> A i} = (card I + 1) * k" by auto
    then show ?case using insert by auto
  qed

  define f where "f ix = (case ix of (i,x) \<Rightarrow> x)" for ix :: "'a \<times> 'b"

  have preimages_le_k: "\<forall>x \<in> f ` ?pairs. card ((f -` {x}) \<inter> ?pairs) \<le> k"
  proof
    fix x0 assume x0_def: "x0 \<in> f ` ?pairs"
    have "(f -` {x0}) \<inter> ?pairs = {(i,x). i\<in>I \<and> x\<in>A i \<and> x=x0}" using f_def by auto
    moreover have "card {(i,x). i\<in>I \<and> x\<in>A i \<and> x=x0} = card {i\<in>I. x0\<in>A i}" using \<open>finite I\<close>
    proof -
      have "inj_on (\<lambda>i. (i,x0)) {i\<in>I. x0\<in>A i}" by (meson Pair_inject inj_onI)
      moreover have "(\<lambda>i. (i,x0)) ` {i\<in>I. x0\<in>A i} = {(i,x). i\<in>I \<and> x\<in>A i \<and> x=x0}" by (rule subset_antisym) blast+
      ultimately show ?thesis using card_image by fastforce
    qed
    ultimately have 1:"card ((f -` {x0}) \<inter> ?pairs) = card  {i\<in>I. x0\<in>A i}" by auto

    have"\<exists>i0. x0\<in>A i0 \<and> i0\<in>I" using x0_def f_def by auto
    then have "card {i\<in>I. x0\<in>A i} \<le> k" using assms by auto
    with 1 show "card ((f -` {x0}) \<inter> ?pairs) \<le> k" by auto
  qed

  have "card ?pairs \<le> card (f ` ?pairs) * k"
  proof -
    have "finite {(i, x). i \<in> I \<and> x \<in> A i}" using assms card_pairs not_finite_existsD by fastforce
    then show ?thesis using limited_preimages[of f ?pairs k, OF preimages_le_k] by auto
  qed

  then have "card I  \<le> card (f ` ?pairs) " using card_pairs assms by auto
  moreover have "f ` ?pairs = (\<Union>i\<in>I. (A i))" using f_def [abs_def] by auto
  ultimately show ?thesis using f_def by auto
qed

text \<open>In a $m \times n$ latin rectangle each number appears in m columns:\<close>
lemma latin_rect_card_col:
assumes "latin_rect s m n" "x<n"
shows "card {e Col|e. e\<in>s \<and> e Num = x} = m"
proof -
  have "card {e \<in> s. e Num = x} = m"
  proof -
    have 1:"bij_betw num_row s ({0..<n}\<times>{0..<m})" using assms latin_rect_def by auto
    have 2:"\<forall>e\<in>s. e Num = x \<longleftrightarrow> fst (num_row e) = x" by simp
    have "bij_betw num_row {e\<in>s. e Num = x} ({x}\<times>{0..<m})"
      using bij_restrict[OF 1 2] cartesian_product_margin1[of x "{0..<n}" " {0..<m}"] assms by auto
    then show ?thesis using card_cartesian_product by (simp add: bij_betw_same_card)
  qed
  moreover have "card {e\<in>s. e Num = x} = card {e Col |e. e \<in> s \<and> e Num = x}"
  proof -
    have "inj_on col_num s" using assms latin_rect_def[of s m n] partial_latin_square_def[of s n] by blast
    then have "inj_on col_num {e\<in>s. e Num = x}" by (metis (mono_tags, lifting) inj_onD inj_onI mem_Collect_eq)
    then have "inj_on (\<lambda>e. e Col) {e\<in>s. e Num = x}" unfolding inj_on_def using without_def by auto
    moreover have "(\<lambda>e. e Col) ` {e\<in>s. e Num = x} = {e Col |e. e \<in> s \<and> e Num = x}" by (rule subset_antisym) blast+
    ultimately show ?thesis using card_image by fastforce
  qed
  ultimately show ?thesis by auto
qed

text \<open>In a $m \times n$ latin rectangle each column contains m numbers:\<close>
lemma latin_rect_card_num:
assumes "latin_rect s m n" "x<n"
shows "card {e Num|e. e\<in>s \<and> e Col = x} = m"
proof -
  have "card {e \<in> s. e Col = x} = m"
  proof -
    have 1:"bij_betw row_col s ({0..<m}\<times>{0..<n})" using assms latin_rect_def by auto
    have 2:"\<forall>e\<in>s. e Col = x \<longleftrightarrow> snd (row_col e) = x" by simp
    have "bij_betw row_col {e\<in>s. e Col = x} ({0..<m}\<times>{x})"
      using bij_restrict[OF 1 2] cartesian_product_margin2[of x "{0..<n}" " {0..<m}"] assms by auto
    then show ?thesis using card_cartesian_product by (simp add: bij_betw_same_card)
  qed
  moreover have "card {e\<in>s. e Col = x} = card {e Num |e. e \<in> s \<and> e Col = x}"
  proof -
    have "inj_on col_num s" using assms latin_rect_def[of s m n] partial_latin_square_def[of s n] by blast
    then have "inj_on col_num {e\<in>s. e Col = x}" by (metis (mono_tags, lifting) inj_onD inj_onI mem_Collect_eq)
    then have "inj_on (\<lambda>e. e Num) {e\<in>s. e Col = x}" unfolding inj_on_def using without_def by auto
    moreover have "(\<lambda>e. e Num) ` {e\<in>s. e Col = x} = {e Num |e. e \<in> s \<and> e Col = x}" by (rule subset_antisym) blast+
    ultimately show ?thesis using card_image by fastforce
  qed
  ultimately show ?thesis by auto
qed

text \<open>Finally we prove lemma 1 chapter 27 of "Das Buch der Beweise":\<close>
theorem
  assumes "latin_rect s (n-m) n" "m\<le>n"
  shows "\<exists>s'. s\<subseteq>s' \<and> latin_square s' n"
using assms
proof (induction m arbitrary:s) \<comment> \<open>induction over the number of empty rows\<close>
  case 0
  then have "bij_betw row_col s ({0..<n} \<times> {0..<n})" using latin_rect_def by auto
  then have "card s = n*n" by (simp add:bij_betw_same_card)
  then show ?case using partial_latin_square_full 0 latin_rect_def by auto
next
  case (Suc m)

  \<comment> \<open>We use the Hall theorem on the sets $A_j$ of numbers that do not occur in column $j$:\<close>
  let ?not_in_column = "\<lambda>j. {0..<n} - {e Num |e. e\<in>s \<and> e Col = j}"

  \<comment> \<open>Proof of the hall condition:\<close>
  have "\<forall>J\<subseteq>{0..<n}. card J \<le> card (\<Union>j\<in>J. ?not_in_column j)"
  proof (rule allI; rule impI)
    fix J assume J_def:"J\<subseteq>{0..<n}"
    have "\<forall>j\<in>J. card (?not_in_column j) = Suc m"
    proof
      fix j assume j_def:"j\<in>J"
      have "{e Num |e. e\<in>s \<and> e Col = j} \<subseteq> {0..<n}" using atLeastLessThan_iff Suc latin_rect_def partial_latin_square_def by auto
      moreover then have "finite {e Num |e. e\<in>s \<and> e Col = j}" using finite_subset by auto
      ultimately have "card (?not_in_column j) = card {0..<n} - card {e Num |e. e \<in> s \<and> e Col = j}" using card_Diff_subset[of "{e Num |e. e\<in>s \<and> e Col = j}" "{0..<n}"] by auto
      then show "card(?not_in_column j) = Suc m" using latin_rect_card_num J_def j_def Suc by auto
    qed
    moreover have "\<forall>j0\<in>J. \<forall>x\<in>?not_in_column j0. card {j \<in> J. x \<in> ?not_in_column j} \<le> Suc m"
    proof (rule ballI; rule ballI)
      fix j0 x assume "j0 \<in> J" "x \<in> ?not_in_column j0"
      then have "card ({0..<n} - {e Col|e. e\<in>s \<and> e Num = x}) = Suc m"
      proof -
        have "card {e Col|e. e\<in>s \<and> e Num = x} = n - Suc m" using latin_rect_card_col \<open>x \<in> ?not_in_column j0\<close> Suc by auto
        moreover have "{e Col|e. e\<in>s \<and> e Num = x}\<subseteq>{0..<n}" using Suc latin_rect_def partial_latin_square_def by auto
        moreover then have "finite {e Col|e. e\<in>s \<and> e Num = x}" using finite_subset by auto
        ultimately show ?thesis using card_Diff_subset[of "{e Col|e. e\<in>s \<and> e Num = x}" "{0..<n}"] using Suc.prems by auto
      qed
      moreover have "{j \<in> J. x \<in> ?not_in_column j} \<subseteq> {0..<n} - {e Col|e. e\<in>s \<and> e Num = x}" using Diff_mono J_def using \<open>x \<in> ?not_in_column j0\<close> by blast
      ultimately show "card {j \<in> J. x \<in> ?not_in_column j} \<le> Suc m" by (metis (no_types, lifting) card_mono finite_Diff finite_atLeastLessThan)
    qed
    moreover have "finite J" using J_def finite_subset by auto
    ultimately show "card J \<le> card (\<Union>j\<in>J. ?not_in_column j)" using union_limited_replicates[of J ?not_in_column "Suc m"] by auto
  qed

  \<comment> \<open>The Hall theorem gives us a system of distinct representatives, which we can use to fill the next row:\<close>
  then obtain R where R_def:"\<forall>j\<in>{0..<n}. R j \<in> ?not_in_column j \<and> inj_on R {0..<n}" using marriage_HV[of "{0..<n}" "?not_in_column"] by blast

  define new_row where "new_row = (\<lambda>j. rec_latin_type (n - Suc m) j (R j)) ` {0..<n}"
  define s' where "s' = s \<union> new_row"

  \<comment> \<open>s' is now a latin rect with one more row:\<close>
  have "latin_rect s' (n-m) n"
  proof -
    \<comment> \<open>We prove all four criteria specified in the lemma latinrectiff:\<close>
    have "n-m \<le> n" by auto
    moreover have "partial_latin_square s' n"
    proof -
      have "inj_on (without Col) s'" unfolding inj_on_def
      proof (rule ballI; rule ballI; rule impI)
        fix e1 e2 assume "e1 \<in> s'" "e2 \<in> s'" "num_row e1 = num_row e2"
        then have "e1 Num = e2 Num" "e1 Row = e2 Row" using without_def by auto
        moreover have "e1 Col = e2 Col"
        proof (cases)
          assume "e1 Row = n - Suc m"
          then have "e2 Row = n - Suc m" using without_def \<open>num_row e1 = num_row e2\<close> by auto
          have "\<forall>e\<in>s. e Row < n - Suc m" using Suc latin_rect_iff by blast
          then have "e1 \<in> new_row" "e2 \<in> new_row"  using s'_def \<open>e1 \<in> s'\<close> \<open>e2 \<in> s'\<close> \<open>e1 Row = n - Suc m\<close> \<open>e2 Row = n - Suc m\<close> by auto
          then have "e1 Num = R (e1 Col)" "e2 Num = R (e2 Col)" using new_row_def by auto
          then have "R (e1 Col) = R (e2 Col)" using \<open>e1 Num = e2 Num\<close> by auto
          moreover have "e1 Col < n" "e2 Col < n" using \<open>e1 \<in> new_row\<close> \<open>e2 \<in> new_row\<close> new_row_def by auto
          ultimately show "e1 Col = e2 Col" using R_def inj_on_def by (metis (mono_tags, lifting) atLeast0LessThan lessThan_iff)
        next
          assume "e1 Row \<noteq> n - Suc m"
          then have "e1\<in>s" "e2\<in>s" using new_row_def s'_def \<open>e1\<in>s'\<close> \<open>e2\<in>s'\<close> \<open>e1 Row = e2 Row\<close> by auto
          then show "e1 Col = e2 Col" using Suc latin_rect_def bij_betw_def by (metis \<open>num_row e1 = num_row e2\<close> inj_onD)
        qed
        ultimately show "e1=e2" using latin_type.induct[of "\<lambda>t. e1 t = e2 t"] by auto
      qed
      moreover have "inj_on (without Row) s'" unfolding inj_on_def
      proof (rule ballI; rule ballI; rule impI)
        fix e1 e2 assume "e1 \<in> s'" "e2 \<in> s'" "col_num e1 = col_num e2"
        then have "e1 Col = e2 Col" "e1 Num = e2 Num" using without_def by auto
        moreover have "e1 Row = e2 Row"
        proof (cases)
          assume "e1 Row = n - Suc m"
          have "\<forall>e\<in>s. e Row < n - Suc m" using Suc latin_rect_iff by blast
          then have "e2 Num \<in> ?not_in_column (e2 Col)" using R_def new_row_def \<open>e1 Col = e2 Col\<close> \<open>e1 Num = e2 Num\<close> using s'_def \<open>e1 \<in> s'\<close> \<open>e1 Row = n - Suc m\<close> by auto
          then show "e1 Row = e2 Row" using new_row_def \<open>e1 Row = n - Suc m\<close>  s'_def \<open>e2 \<in> s'\<close> by auto
        next
          assume "e1 Row \<noteq> n - Suc m"
          then have "e1\<in>s" using new_row_def s'_def \<open>e1\<in>s'\<close> by auto
          then have "e2 Num \<notin> ?not_in_column (e2 Col)" using \<open>e1 Col = e2 Col\<close> \<open>e1 Num = e2 Num\<close> by auto
          then have "e2\<in>s" using new_row_def s'_def \<open>e2\<in>s'\<close> R_def by auto
          moreover have "inj_on col_num s" using Suc.prems latin_rect_def[of s "(n - Suc m)" n] partial_latin_square_def[of s n] by blast
          ultimately show "e1 Row = e2 Row" using Suc latin_rect_def by (metis \<open>col_num e1 = col_num e2\<close> \<open>e1 \<in> s\<close> inj_onD)
        qed
        ultimately show "e1=e2" using latin_type.induct[of "\<lambda>t. e1 t = e2 t"] by auto
      qed
      moreover have "inj_on (without Num) s'" unfolding inj_on_def
      proof (rule ballI; rule ballI; rule impI)
        fix e1 e2 assume "e1 \<in> s'" "e2 \<in> s'" "row_col e1 = row_col e2"
        then have "e1 Row = e2 Row" "e1 Col = e2 Col" using without_def by auto
        moreover have "e1 Num = e2 Num"
        proof (cases)
          assume "e1 Row = n - Suc m"
          then have "e2 Row = n - Suc m" using without_def \<open>row_col e1 = row_col e2\<close> by auto
          have "\<forall>e\<in>s. e Row < n - Suc m" using Suc latin_rect_iff by blast
          then show "e1 Num = e2 Num" using \<open>e1 Col = e2 Col\<close> using new_row_def s'_def \<open>e1 \<in> s'\<close> \<open>e2 \<in> s'\<close> \<open>e1 Row = n - Suc m\<close> \<open>e2 Row = n - Suc m\<close> by auto
        next
          assume "e1 Row \<noteq> n - Suc m"
          then have "e1\<in>s" "e2\<in>s" using new_row_def s'_def \<open>e1\<in>s'\<close> \<open>e2\<in>s'\<close> \<open>e1 Row = e2 Row\<close> by auto
          then show "e1 Num = e2 Num" using Suc latin_rect_def bij_betw_def by (metis \<open>row_col e1 = row_col e2\<close> inj_onD)
        qed
        ultimately show "e1=e2" using latin_type.induct[of "\<lambda>t. e1 t = e2 t"] by auto
      qed
      moreover have "\<forall>e\<in>s'. \<forall>t. e t < n"
      proof (rule ballI; rule allI)
        fix e t assume "e\<in>s'"
        then show "e t < n"
        proof (cases)
          assume "e\<in>new_row"
          then show ?thesis using new_row_def R_def by (induction t) auto
        next
          assume "e\<notin>new_row"
          then show ?thesis using s'_def \<open>e\<in>s'\<close> latin_rect_def partial_latin_square_def Suc by auto
        qed
      qed
      ultimately show "partial_latin_square s' n" unfolding partial_latin_square_def using latin_type.induct[of "\<lambda>t. inj_on (without t) s'"] by auto
    qed
    moreover have "card s' = n * (n - m)"
    proof -
      have card_s:"card s = n * (n - Suc m)" using latin_rect_iff Suc by auto
      have card_new_row:"card new_row = n" unfolding new_row_def
      proof -
        have "inj_on (\<lambda>j. rec_latin_type (n - Suc m) j (R j)) {0..<n}" unfolding inj_on_def
        proof (rule ballI; rule ballI; rule impI)
          fix j1 j2 assume "j1 \<in> {0..<n}" "j2 \<in> {0..<n}" "rec_latin_type (n - Suc m) j1 (R j1) = rec_latin_type (n - Suc m) j2 (R j2)"
          then show  "j1 = j2" using latin_type.rec(2)[of "(n - Suc m)" j1 "R j1"] latin_type.rec(2)[of _ j2 _] by auto
        qed
        then show "card ((\<lambda>j. rec_latin_type (n - Suc m) j (R j)) ` {0..<n}) = n" by (simp add: card_image)
      qed
      have "s \<inter> new_row = {}"
      proof -
        have "\<forall>e\<in>s. e Row < n - Suc m" using Suc latin_rect_iff by blast
        then have "\<forall>e \<in> new_row. e \<notin> s" using new_row_def by auto
        then show ?thesis by blast
      qed
      moreover have "finite s" using Suc latin_rect_def by (metis bij_betw_finite finite_SigmaI finite_atLeastLessThan)
      moreover have "finite new_row" using new_row_def by simp
      ultimately have "card s' = card s + card new_row" using s'_def card_Un_disjoint by auto
      with card_s card_new_row show ?thesis using Suc by (metis Suc_diff_Suc Suc_le_lessD add.commute mult_Suc_right)
    qed
    moreover have "\<forall>e\<in>s'. e Row < (n - m)"
    proof (rule ballI; cases)
      fix e
      assume "e\<in>new_row"
      then show "e Row < n - m" using Suc new_row_def R_def by auto
    next
      fix e
      assume "e \<in> s'" "e\<notin>new_row"
      then have "e Row < n - Suc m"  using latin_rect_iff Suc  s'_def \<open>e\<in>s'\<close> by auto
      then show "e Row < n - m" by auto
    qed
    ultimately show ?thesis using latin_rect_iff[of "n-m" n] by auto
  qed

  \<comment> \<open>Finally we use the induction hypothesis:\<close>
  then obtain s'' where "s' \<subseteq> s''" "latin_square s'' n" using Suc by auto
  then have "s \<subseteq> s''" using s'_def by auto
  then show "\<exists>s'. s \<subseteq> s' \<and> latin_square s' n" using \<open>latin_square s'' n\<close> by auto
qed

end


(* 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_bin_nat_times_comm
imports "../../Test_Base"
begin

datatype Bin = One | ZeroAnd "Bin" | OneAnd "Bin"

fun s :: "Bin => Bin" where
"s (One) = ZeroAnd One"
| "s (ZeroAnd xs) = OneAnd xs"
| "s (OneAnd ys) = ZeroAnd (s ys)"

fun plus :: "Bin => Bin => Bin" where
"plus (One) y = s y"
| "plus (ZeroAnd z) (One) = s (ZeroAnd z)"
| "plus (ZeroAnd z) (ZeroAnd ys) = ZeroAnd (plus z ys)"
| "plus (ZeroAnd z) (OneAnd xs) = OneAnd (plus z xs)"
| "plus (OneAnd x2) (One) = s (OneAnd x2)"
| "plus (OneAnd x2) (ZeroAnd zs) = OneAnd (plus x2 zs)"
| "plus (OneAnd x2) (OneAnd ys2) = ZeroAnd (s (plus x2 ys2))"

fun times :: "Bin => Bin => Bin" where
"times (One) y = y"
| "times (ZeroAnd xs1) y = ZeroAnd (times xs1 y)"
| "times (OneAnd xs12) y = plus (ZeroAnd (times xs12 y)) y"

theorem property0 :
  "((times x y) = (times y x))"
  oops

end


theory Kleene_Fixed_Point
  imports Complete_Relations
begin

section \<open>Iterative Fixed Point Theorem\<close>

text \<open>Kleene's fixed-point theorem states that,
for a pointed directed complete partial order $\tp{A,\SLE}$
and a Scott-continuous map $f: A \to A$,
the supremum of $\set{f^n(\bot) \mid n\in\Nat}$ exists in $A$ and is a least
fixed point.
Mashburn \cite{mashburn83} generalized the result so that
$\tp{A,\SLE}$ is a $\omega$-complete partial order
and $f$ is $\omega$-continuous.

In this section we further generalize the result and show that
for $\omega$-complete relation $\tp{A,\SLE}$
and for every bottom element $\bot \in A$,
the set $\set{f^n(\bot) \mid n\in\Nat}$ has suprema (not necessarily unique, of
course) and,
they are quasi-fixed points.
Moreover, if $(\SLE)$ is attractive, then the suprema are precisely the least
quasi-fixed points.\<close>

subsection \<open>Scott Continuity, $\omega$-Completeness, $\omega$-Continuity\<close>

text \<open>In this Section, we formalize $\omega$-completeness, Scott continuity and $\omega$-continuity.
We then prove that a Scott continuous map is $\omega$-continuous and that an $\omega$-continuous
map is ``nearly'' monotone.\<close>

context
  fixes A :: "'a set" and less_eq :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infix "\<sqsubseteq>" 50)
begin

definition "omega_continuous f \<equiv>
  f ` A \<subseteq> A \<and>
  (\<forall>c :: nat \<Rightarrow> 'a. \<forall> b \<in> A.
  range c \<subseteq> A \<longrightarrow>
  monotone (\<le>) (\<sqsubseteq>) c \<longrightarrow>
  extreme_bound A (\<sqsubseteq>) (range c) b \<longrightarrow> extreme_bound A (\<sqsubseteq>) (f ` range c) (f b))"

lemmas omega_continuousI[intro?] =
  omega_continuous_def[unfolded atomize_eq, THEN iffD2, unfolded conj_imp_eq_imp_imp, rule_format]

lemmas omega_continuousDdom =
  omega_continuous_def[unfolded atomize_eq, THEN iffD1, unfolded conj_imp_eq_imp_imp, THEN conjunct1]

lemmas omega_continuousD =
  omega_continuous_def[unfolded atomize_eq, THEN iffD1, unfolded conj_imp_eq_imp_imp, THEN conjunct2, rule_format]

lemmas omega_continuousE[elim] =
  omega_continuous_def[unfolded atomize_eq, THEN iffD1, elim_format, unfolded conj_imp_eq_imp_imp, rule_format]

lemma omega_continuous_imp_mono_refl:
  assumes cont: "omega_continuous f"
    and x: "x \<in> A" and y: "y \<in> A"
    and xy: "x \<sqsubseteq> y" and xx: "x \<sqsubseteq> x" and yy: "y \<sqsubseteq> y"
  shows "f x \<sqsubseteq> f y"
proof-
  define c :: "nat \<Rightarrow> 'a" where "c \<equiv> \<lambda>i. if i = 0 then x else y"
  from x y xx xy yy have c: "range c \<subseteq> A" "monotone (\<le>) (\<sqsubseteq>) c"
    by (auto simp: c_def intro!: monotoneI)
  have "extreme_bound A (\<sqsubseteq>) (range c) y" using xy yy x y by (auto simp: c_def)
  then have fboy: "extreme_bound A (\<sqsubseteq>) (f ` range c) (f y)" using c cont y by auto
  then show "f x \<sqsubseteq> f y" by (auto simp: c_def)
qed

definition "scott_continuous f \<equiv>
  f ` A \<subseteq> A \<and>
  (\<forall>X s. X \<subseteq> A \<longrightarrow> directed X (\<sqsubseteq>) \<longrightarrow> X \<noteq> {} \<longrightarrow> extreme_bound A (\<sqsubseteq>) X s \<longrightarrow> extreme_bound A (\<sqsubseteq>) (f ` X) (f s))"

lemmas scott_continuousI[intro?] =
  scott_continuous_def[unfolded atomize_eq, THEN iffD2, unfolded conj_imp_eq_imp_imp, rule_format]

lemmas scott_continuousE =
  scott_continuous_def[unfolded atomize_eq, THEN iffD1, elim_format, unfolded conj_imp_eq_imp_imp, rule_format]

lemma scott_continuous_imp_mono_refl:
  assumes scott: "scott_continuous f"
    and x: "x \<in> A" and y: "y \<in> A" and xy: "x \<sqsubseteq> y" and yy: "y \<sqsubseteq> y"
  shows "f x \<sqsubseteq> f y"
proof-
  define D where "D \<equiv> {x,y}"
  from x y xy yy have dir_D: "D \<subseteq> A" "directed D (\<sqsubseteq>)" "D \<noteq> {}"
    by (auto simp: D_def intro!: bexI[of _ y] directedI)
  have "extreme_bound A (\<sqsubseteq>) D y" using xy yy x y by (auto simp: D_def)
  then have fboy: "extreme_bound A (\<sqsubseteq>) (f ` D) (f y)" using dir_D scott by (auto elim!: scott_continuousE)
  then show "f x \<sqsubseteq> f y" by (auto simp: D_def)
qed

lemma scott_continuous_imp_omega_continuous:
  assumes scott: "scott_continuous f" shows "omega_continuous f"
proof
  from scott show "f ` A \<subseteq> A" by (auto elim!: scott_continuousE)
  fix c :: "nat \<Rightarrow> 'a"
  assume mono: "monotone (\<le>) (\<sqsubseteq>) c" and c: "range c \<subseteq> A"
  from monotone_directed_image[OF mono[folded monotone_on_UNIV] order.directed] scott c
  show "extreme_bound A (\<sqsubseteq>) (range c) b \<Longrightarrow> extreme_bound A (\<sqsubseteq>) (f ` range c) (f b)" for b
    by (auto elim!: scott_continuousE)
qed

end

subsection \<open>Existence of Iterative Fixed Points\<close>

text \<open>The first part of Kleene's theorem demands to prove that the set
$\set{f^n(\bot) \mid n \in \Nat}$ has a supremum and
that all such are quasi-fixed points. We prove this claim without assuming
anything on the relation $\SLE$ besides $\omega$-completeness and one bottom element.\<close>

(*
no_notation power (infixr "^" 80)
*)
notation compower ("_^_"[1000,1000]1000)

lemma mono_funpow: assumes f: "f ` A \<subseteq> A" and mono: "monotone_on A r r f"
  shows "monotone_on A r r (f^n)"
proof (induct n)
  case 0
  show ?case using monotone_on_id by (auto simp: id_def)
next
  case (Suc n)
  with funpow_dom[OF f] show ?case
    by (auto intro!: monotone_onI monotone_onD[OF mono] elim!:monotone_onE)
qed

no_notation bot ("\<bottom>")

context
  fixes A and less_eq (infix "\<sqsubseteq>" 50) and bot ("\<bottom>") and f
  assumes bot: "\<bottom> \<in> A" "\<forall>q \<in> A. \<bottom> \<sqsubseteq> q"
  assumes cont: "omega_continuous A (\<sqsubseteq>) f"
begin

interpretation less_eq_notations.

private lemma f: "f ` A \<subseteq> A" using cont by auto

private abbreviation(input) "Fn \<equiv> {f^n \<bottom> |. n :: nat}"

private lemma fn_ref: "f^n \<bottom> \<sqsubseteq> f^n \<bottom>" and fnA: "f^n \<bottom> \<in> A"
proof (atomize(full), induct n)
  case 0
  from bot show ?case by simp
next
  case (Suc n)
  then have fn: "f^n \<bottom> \<in> A" and fnfn: "f^n \<bottom> \<sqsubseteq> f^n \<bottom>" by auto
  from f fn omega_continuous_imp_mono_refl[OF cont fn fn fnfn fnfn fnfn]
  show ?case by auto
qed

private lemma FnA: "Fn \<subseteq> A" using fnA by auto

private lemma fn_monotone: "monotone (\<le>) (\<sqsubseteq>) (\<lambda>n. f^n \<bottom>)"
proof
  fix n m :: nat
  assume "n \<le> m"
  from le_Suc_ex[OF this] obtain k where m: "m = n + k" by auto
  from bot fn_ref fnA omega_continuous_imp_mono_refl[OF cont]
  show "f^n \<bottom> \<sqsubseteq> f^m \<bottom>" by (unfold m, induct n, auto)
qed

private lemma Fn: "Fn = range (\<lambda>n. f^n \<bottom>)" by auto

theorem kleene_qfp:
  assumes q: "extreme_bound A (\<sqsubseteq>) Fn q"
  shows "f q \<sim> q"
proof
  have fq: "extreme_bound A (\<sqsubseteq>) (f ` Fn) (f q)"
    apply (unfold Fn)
    apply (rule omega_continuousD[OF cont])
    using FnA fn_monotone q by (unfold Fn, auto)
  with bot have nq: "f^n \<bottom> \<sqsubseteq> f q" for n
    by(induct n, auto simp: extreme_bound_iff)
  then show "q \<sqsubseteq> f q" using f q by blast
  have "f (f^n \<bottom>) \<in> Fn" for n by (auto intro!: exI[of _ "Suc n"])
  then have "f ` Fn \<subseteq> Fn" by auto
  from extreme_bound_mono[OF this fq q]
  show "f q \<sqsubseteq> q".
qed

lemma ex_kleene_qfp:
  assumes comp: "omega_complete A (\<sqsubseteq>)"
  shows "\<exists>p. extreme_bound A (\<sqsubseteq>) Fn p"
  using fn_monotone
  apply (intro comp[unfolded omega_complete_def, THEN completeD, OF FnA])
  by fast

subsection \<open>Iterative Fixed Points are Least.\<close>
text \<open>Kleene's theorem also states that the quasi-fixed point found this way is a least one.
Again, attractivity is needed to prove this statement.\<close>

lemma kleene_qfp_is_least:
  assumes attract: "\<forall>q \<in> A. \<forall>x \<in> A. f q \<sim> q \<longrightarrow> x \<sqsubseteq> f q \<longrightarrow> x \<sqsubseteq> q"
  assumes q: "extreme_bound A (\<sqsubseteq>) Fn q"
  shows "extreme {s \<in> A. f s \<sim> s} (\<sqsupseteq>) q"
proof(safe intro!: extremeI kleene_qfp[OF q])
  from q
  show "q \<in> A" by auto
  fix c assume c: "c \<in> A" and cqfp: "f c \<sim> c"
  {
    fix n::nat
    have "f^n \<bottom> \<sqsubseteq> c"
    proof(induct n)
      case 0
      show ?case using bot c by auto
    next
      case IH: (Suc n)
      have "c \<sqsubseteq> c" using attract cqfp c by auto
      with IH have "f^(Suc n) \<bottom> \<sqsubseteq> f c"
        using omega_continuous_imp_mono_refl[OF cont] fn_ref fnA c by auto
      then show ?case using attract cqfp c fnA by blast
    qed
  }
  then show "q \<sqsubseteq> c" using q c by auto
qed

lemma kleene_qfp_iff_least:
  assumes comp: "omega_complete A (\<sqsubseteq>)"
  assumes attract: "\<forall>q \<in> A. \<forall>x \<in> A. f q \<sim> q \<longrightarrow> x \<sqsubseteq> f q \<longrightarrow> x \<sqsubseteq> q"
  assumes dual_attract: "\<forall>p \<in> A. \<forall>q \<in> A. \<forall>x \<in> A. p \<sim> q \<longrightarrow> q \<sqsubseteq> x \<longrightarrow> p \<sqsubseteq> x"
  shows "extreme_bound A (\<sqsubseteq>) Fn = extreme {s \<in> A. f s \<sim> s} (\<sqsupseteq>)"
proof (intro ext iffI kleene_qfp_is_least[OF attract])
  fix q
  assume q: "extreme {s \<in> A. f s \<sim> s} (\<sqsupseteq>) q"
  from q have qA: "q \<in> A" by auto
  from q have qq: "q \<sqsubseteq> q" by auto
  from q have fqq: "f q \<sim> q" by auto
  from ex_kleene_qfp[OF comp]
  obtain k where k: "extreme_bound A (\<sqsubseteq>) Fn k" by auto
  have qk: "q \<sim> k"
  proof
    from kleene_qfp[OF k] q k
    show "q \<sqsubseteq> k" by auto
    from kleene_qfp_is_least[OF _ k] q attract
    show "k \<sqsubseteq> q" by blast
  qed
  show "extreme_bound A (\<sqsubseteq>) Fn q"
  proof (intro extreme_boundI,safe)
    fix n
    show "f^n \<bottom> \<sqsubseteq> q"
    proof (induct n)
      case 0
      from bot q show ?case by auto
    next
      case S:(Suc n)
      from fnA f have fsnbA: "f (f^n \<bottom>) \<in> A" by auto
      have fnfn: "f^n \<bottom> \<sqsubseteq> f^n \<bottom>" using fn_ref by auto
      have "f (f^n \<bottom>) \<sqsubseteq> f q"
        using omega_continuous_imp_mono_refl[OF cont fnA qA S fnfn qq] by auto
      then show ?case using fsnbA qA attract fqq by auto
    qed
  next
    fix x
    assume "bound Fn (\<sqsubseteq>) x" and x: "x \<in> A"
    with k have kx: "k \<sqsubseteq> x" by auto
    with dual_attract[rule_format, OF _ _ x qk] q k
    show "q \<sqsubseteq> x" by auto
  next
    from q show "q \<in> A" by auto
  qed
qed

end

context attractive begin

interpretation less_eq_notations.

theorem kleene_qfp_is_dual_extreme:
  assumes comp: "omega_complete A (\<sqsubseteq>)"
    and cont: "omega_continuous A (\<sqsubseteq>) f" and bA: "b \<in> A" and bot: "\<forall>x \<in> A. b \<sqsubseteq> x"
  shows "extreme_bound A (\<sqsubseteq>) {f^n b |. n :: nat} = extreme {s \<in> A. f s \<sim> s} (\<sqsupseteq>)"
  apply (rule kleene_qfp_iff_least[OF bA bot cont comp])
  using cont[THEN omega_continuousDdom]
  by (auto dest: sym_order_trans order_sym_trans)

end

corollary(in antisymmetric) kleene_fp:
  assumes cont: "omega_continuous A (\<sqsubseteq>) f"
    and b: "b \<in> A" "\<forall>x \<in> A. b \<sqsubseteq> x"
    and p: "extreme_bound A (\<sqsubseteq>) {f^n b |. n :: nat} p"
  shows "f p = p"
  using kleene_qfp[OF b cont] p cont[THEN omega_continuousDdom]
  by (auto 2 3 intro!:antisym)

no_notation compower ("_^_"[1000,1000]1000)

end


(*  Title:      JinjaThreads/Compiler/ListIndex.thy
    Author:     Tobias Nipkow, Andreas Lochbihler
*)

header {* \isaheader{Indexing variables in variable lists} *}

theory ListIndex imports Main begin

text{* In order to support local variables and arbitrarily nested
blocks, the local variables are arranged as an indexed list. The
outermost local variable (``this'') is the first element in the list,
the most recently created local variable the last element. When
descending into a block structure, a corresponding list @{term Vs} of
variable names is maintained. To find the index of some variable
@{term V}, we have to find the index of the \emph{last} occurrence of
@{term V} in @{term Vs}. This is what @{term index} does: *}

primrec index :: "'a list \<Rightarrow> 'a \<Rightarrow> nat"
where
  "index [] y = 0"
| "index (x#xs) y =
  (if x=y then if x \<in> set xs then index xs y + 1 else 0 else index xs y + 1)"

definition hidden :: "'a list \<Rightarrow> nat \<Rightarrow> bool"
where "hidden xs i  \<equiv>  i < size xs \<and> xs!i \<in> set(drop (i+1) xs)"

subsection {* @{term index} *}

lemma [simp]: "(index (xs @ [x]) y = size xs) = (x = y)"
(*<*)by(induct xs) auto(*>*)

lemma [simp]: "x \<in> set xs \<Longrightarrow> xs ! index xs x = x"
(*<*)by(induct xs) auto(*>*)

lemma [simp]: "x \<notin> set xs \<Longrightarrow> index xs x = size xs"
(*<*)by(induct xs) auto(*>*)

lemma size_index_conv[simp]: "(size xs = index xs x) = (x \<notin> set xs)"
(*<*)by(induct xs) auto(*>*)

lemma "(index xs x < size xs) = (x \<in> set xs)"
(*<*)by(induct xs) auto(*>*)

lemma [simp]: "\<lbrakk> y \<in> set xs; x \<noteq> y \<rbrakk> \<Longrightarrow> index (xs @ [x]) y = index xs y"
(*<*)by(induct xs) auto(*>*)

lemma index_less_size[simp]: "x \<in> set xs \<Longrightarrow> index xs x < size xs"
(*<*)
apply(induct xs)
 apply simp
apply(fastforce)
done
(*>*)

lemma index_less_aux: "\<lbrakk>x \<in> set xs; size xs \<le> n\<rbrakk> \<Longrightarrow> index xs x < n"
(*<*)
apply(subgoal_tac "index xs x < size xs")
apply(simp (no_asm_simp))
apply simp
done
(*>*)

lemma [simp]: "x \<in> set xs \<or> y \<in> set xs \<Longrightarrow> (index xs x = index xs y) = (x = y)"
(*<*)by (induct xs) auto(*>*)

lemma inj_on_index: "inj_on (index xs) (set xs)"
(*<*)by(simp add:inj_on_def)(*>*)

lemma index_drop: "\<And>x i. \<lbrakk> x \<in> set xs; index xs x < i \<rbrakk> \<Longrightarrow> x \<notin> set(drop i xs)"
(*<*)
apply(induct xs)
apply (auto simp:drop_Cons split:split_if_asm nat.splits dest:in_set_dropD)
done
(*>*)

subsection {* @{term hidden} *}

lemma hidden_index: "x \<in> set xs \<Longrightarrow> hidden (xs @ [x]) (index xs x)"
(*<*)
apply(auto simp add:hidden_def index_less_aux nth_append)
 apply(drule index_less_size)
 apply(simp del:index_less_size)
done
(*>*)

lemma hidden_inacc: "hidden xs i \<Longrightarrow> index xs x \<noteq> i"
(*<*)
apply(case_tac "x \<in> set xs")
apply(auto simp add:hidden_def index_less_aux nth_append index_drop)
done
(*>*)

lemma [simp]: "hidden xs i \<Longrightarrow> hidden (xs@[x]) i"
(*<*)by(auto simp add:hidden_def nth_append)(*>*)

lemma fun_upds_apply: "\<And>m ys.
  (m(xs[\<mapsto>]ys)) x =
  (let xs' = take (size ys) xs
   in if x \<in> set xs' then Some(ys ! index xs' x) else m x)"
(*<*)
apply(induct xs)
 apply (simp add:Let_def)
apply(case_tac ys)
 apply (simp add:Let_def)
apply (simp add:Let_def)
done
(*>*)

lemma map_upds_apply_eq_Some:
  "((m(xs[\<mapsto>]ys)) x = Some y) =
  (let xs' = take (size ys) xs
   in if x \<in> set xs' then ys ! index xs' x = y else m x = Some y)"
(*<*)by(simp add:fun_upds_apply Let_def)(*>*)

lemma map_upds_upd_conv_index:
  "\<lbrakk>x \<in> set xs; size xs \<le> size ys \<rbrakk>
  \<Longrightarrow> m(xs[\<mapsto>]ys)(x\<mapsto>y) = m(xs[\<mapsto>]ys[index xs x := y])"
(*<*)
apply(rule ext)
apply(simp add:fun_upds_apply index_less_aux eq_sym_conv Let_def)
done
(*>*)

lemma image_index:
  "A \<subseteq> set(xs@[x]) \<Longrightarrow> index (xs @ [x]) ` A =
  (if x \<in> A then insert (size xs) (index xs ` (A-{x})) else index xs ` A)"
(*<*)
apply(auto simp:image_def)
   apply(rule bexI)
    prefer 2 apply blast
   apply simp
  apply(rule ccontr)
  apply(erule_tac x=xa in ballE)
   prefer 2 apply blast
  apply(fastforce simp add:neq_commute)
 apply(subgoal_tac "x \<noteq> xa")
  prefer 2 apply blast
 apply(fastforce simp add:neq_commute)
apply(subgoal_tac "x \<noteq> xa")
 prefer 2 apply blast
apply(force)
done
(*>*)

lemma index_le_lengthD: "index xs x < length xs \<Longrightarrow> x \<in> set xs"
by(erule contrapos_pp)(simp)

lemma not_hidden_index_nth: "\<lbrakk> i < length Vs; \<not> hidden Vs i \<rbrakk> \<Longrightarrow> index Vs (Vs ! i) = i"
by(induct Vs arbitrary: i)(auto split: split_if_asm nat.split_asm simp add: nth_Cons hidden_def)

lemma hidden_snoc_nth:
  assumes len: "i < length Vs"
  shows "hidden (Vs @ [Vs ! i]) i"
proof(cases "hidden Vs i")
  case True thus ?thesis by simp
next
  case False
  with len have "index Vs (Vs ! i) = i" by(rule not_hidden_index_nth)
  moreover from len have "hidden (Vs @ [Vs ! i]) (index Vs (Vs ! i))"
    by(auto intro: hidden_index)
  ultimately show ?thesis by simp
qed

lemma map_upds_Some_eq_nth_index:
  assumes "[Vs [\<mapsto>] vs] V = Some v" "length Vs \<le> length vs"
  shows "vs ! index Vs V = v"
proof -
  from `[Vs [\<mapsto>] vs] V = Some v` have "V \<in> set Vs"
    by -(rule classical, auto)
  with `[Vs [\<mapsto>] vs] V = Some v` `length Vs \<le> length vs` show ?thesis
  proof(induct Vs arbitrary: vs)
    case Nil thus ?case by simp
  next
    case (Cons x xs ys)
    note IH = `\<And>vs. \<lbrakk> [xs [\<mapsto>] vs] V = Some v; length xs \<le> length vs; V \<in> set xs \<rbrakk> \<Longrightarrow> vs ! index xs V = v`
    from `[x # xs [\<mapsto>] ys] V = Some v` obtain y Ys where "ys = y # Ys" by(cases ys, auto)
    with `length (x # xs) \<le> length ys` have "length xs \<le> length Ys" by simp
    show ?case
    proof(cases "V \<in> set xs")
      case True
      with `[x # xs [\<mapsto>] ys] V = Some v` `length xs \<le> length Ys` `ys = y # Ys`
      have "[xs [\<mapsto>] Ys] V = Some v"
        apply(auto simp add: map_upds_def map_of_eq_None_iff set_zip image_Collect split: split_if_asm)
        apply(clarsimp simp add: in_set_conv_decomp)
        apply(hypsubst_thin)
        apply(erule_tac x="length ys" in allE)
        by(simp)
      with IH[OF this `length xs \<le> length Ys` True] `ys = y # Ys` True
      show ?thesis by(simp)
    next
      case False with `V \<in> set (x # xs)` have "x = V" by auto
      with False `[x # xs [\<mapsto>] ys] V = Some v` `ys = y # Ys` have "y = v"
        by(auto)
      with False `x = V` `ys = y # Ys`
      show ?thesis by(simp)
    qed
  qed
qed

end


(*  Title:      IPv4.thy
    Authors:    Cornelius Diekmann, Julius Michaelis
*)
theory IPv4
imports IP_Address
        NumberWang_IPv4
        (* include "HOL-Library.Code_Target_Nat" if you need to work with actual numbers.*)
begin

section \<open>IPv4 Adresses\<close>
  text\<open>An IPv4 address is basically a 32 bit unsigned integer.\<close>
  type_synonym ipv4addr = "32 word"

  lemma ipv4addr_and_mask_eq_self [simp]:
    \<open>a && 4294967295 = a\<close> for a :: ipv4addr
  proof -
    have \<open>take_bit 32 a = a\<close>
      by (rule take_bit_word_eq_self) simp
    then show ?thesis
      by (simp add: take_bit_eq_mask mask_numeral)
  qed

  text\<open>Conversion between natural numbers and IPv4 adresses\<close>
  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"

  text\<open>The maximum IPv4 addres\<close>
  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"
    unfolding max_ipv4_addr_def ipv4addr_of_nat_def by(simp)
  lemma "max_ipv4_addr = 0b11111111111111111111111111111111"
    by(fact max_ipv4_addr_number)
  lemma max_ipv4_addr_max_word: "max_ipv4_addr = - 1"
    by(simp add: max_ipv4_addr_number)
  lemma max_ipv4_addr_max[simp]: "\<forall>a. a \<le> max_ipv4_addr"
    by(simp add: max_ipv4_addr_max_word)
  lemma UNIV_ipv4addrset: "UNIV = {0 .. max_ipv4_addr}" (*not in the simp set, for a reason*)
    by(simp add: max_ipv4_addr_max_word) fastforce

  text\<open>identity functions\<close>
  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 take_bit_eq_mod)
  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 (simp add: nat_of_ipv4addr_ipv4addr_of_nat_mod max_ipv4_addr_def)
  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)

  subsection\<open>Representing IPv4 Adresses (Syntax)\<close>

  context
    includes bit_operations_syntax
  begin

  fun ipv4addr_of_dotdecimal :: "nat \<times> nat \<times> nat \<times> nat \<Rightarrow> ipv4addr" where
    "ipv4addr_of_dotdecimal (a,b,c,d) = ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a )"

  fun dotdecimal_of_ipv4addr :: "ipv4addr \<Rightarrow> nat \<times> nat \<times> nat \<times> nat" where
    "dotdecimal_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_dotdecimal.simps[simp del]
  declare dotdecimal_of_ipv4addr.simps[simp del]

  text\<open>Examples:\<close>
  lemma "ipv4addr_of_dotdecimal (192, 168, 0, 1) = 3232235521"
    by(simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)
    (*could be solved by eval, but needs "HOL-Library.Code_Target_Nat"*)
  lemma "dotdecimal_of_ipv4addr 3232235521 = (192, 168, 0, 1)"
    by(simp add: dotdecimal_of_ipv4addr.simps nat_of_ipv4addr_def)

  text\<open>a different notation for @{term ipv4addr_of_dotdecimal}\<close>
  lemma ipv4addr_of_dotdecimal_bit:
    "ipv4addr_of_dotdecimal (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)
    have b: "(ipv4addr_of_nat b) << 16 = ipv4addr_of_nat (b * 65536)"
      by(simp add: ipv4addr_of_nat_def shiftl_t2n)
    have c: "(ipv4addr_of_nat c) << 8 = ipv4addr_of_nat (c * 256)"
      by(simp add: ipv4addr_of_nat_def shiftl_t2n)
    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; fail)
        by(simp add: ipv4addr_of_nat_suc word_succ_p1)
    } from this a b c
    show ?thesis
      apply(simp add: ipv4addr_of_dotdecimal.simps)
      apply(rule arg_cong[where f=ipv4addr_of_nat])
      apply(thin_tac _)+
      by presburger
  qed

  lemma size_ipv4addr: "size (x::ipv4addr) = 32" by(simp add:word_size)

  lemma dotdecimal_of_ipv4addr_ipv4addr_of_dotdecimal:
  "\<lbrakk> a < 256; b < 256; c < 256; d < 256 \<rbrakk> \<Longrightarrow>
    dotdecimal_of_ipv4addr (ipv4addr_of_dotdecimal (a,b,c,d)) = (a,b,c,d)"
  proof -
    assume  "a < 256" and "b < 256" and "c < 256" and "d < 256"
    note assms= \<open>a < 256\<close> \<open>b < 256\<close> \<open>c < 256\<close> \<open>d < 256\<close>
    hence a:  "nat_of_ipv4addr ((ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) >> 24) AND mask 8) = a"
      apply (simp only: flip: take_bit_eq_mask)
      apply (simp add: ipv4addr_of_nat_def nat_of_ipv4addr_def)
      apply transfer
      apply (simp add: drop_bit_take_bit nat_take_bit_eq flip: take_bit_eq_mask)
      apply (simp add: drop_bit_eq_div take_bit_eq_mod)
      done
    have ipv4addr_of_nat_AND_mask8: "(ipv4addr_of_nat a) AND mask 8 = (ipv4addr_of_nat (a mod 256))"
      for a
      apply (simp only: flip: take_bit_eq_mask)
      apply (simp add: ipv4addr_of_nat_def)
      apply transfer
      apply (simp flip: take_bit_eq_mask)
      apply (simp add: take_bit_eq_mod of_nat_mod)
      done
    from assms have b:
      "nat_of_ipv4addr ((ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) >> 16) AND mask 8) = b"
      apply (simp only: flip: take_bit_eq_mask)
      apply (simp add: ipv4addr_of_nat_def nat_of_ipv4addr_def)
      apply transfer
      apply (simp add: drop_bit_take_bit flip: take_bit_eq_mask)
      using div65536
      apply (simp add: drop_bit_eq_div take_bit_eq_mod)
      done
    from assms have c:
      "nat_of_ipv4addr ((ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) >> 8) AND mask 8) = c"
      apply (simp only: flip: take_bit_eq_mask)
      apply (simp add: ipv4addr_of_nat_def nat_of_ipv4addr_def)
      apply transfer
      apply (simp add: drop_bit_take_bit flip: take_bit_eq_mask)
      using div256
      apply (simp add: drop_bit_eq_div take_bit_eq_mod)
      done
    from \<open>d < 256\<close> have d: "nat_of_ipv4addr (ipv4addr_of_nat (d + 256 * c + 65536 * b + 16777216 * a) AND mask 8) = d"
      apply (simp only: flip: take_bit_eq_mask)
      apply (simp add: ipv4addr_of_nat_AND_mask8 ipv4addr_of_nat_def nat_of_ipv4addr_def)
      apply transfer
      apply (simp flip: take_bit_eq_mask)
      apply (simp add: take_bit_eq_mod nat_mod_distrib nat_add_distrib nat_mult_distrib mod256)
      done
    from a b c d show ?thesis
      apply (simp add: ipv4addr_of_dotdecimal.simps dotdecimal_of_ipv4addr.simps mask_numeral)
      done
  qed

  lemma ipv4addr_of_dotdecimal_dotdecimal_of_ipv4addr:
    "(ipv4addr_of_dotdecimal (dotdecimal_of_ipv4addr ip)) = ip"
  proof -
    have ip_and_mask8_bl_drop24: "(ip::ipv4addr) AND mask 8 = of_bl (drop 24 (to_bl ip))"
      by(simp add: of_drop_to_bl size_ipv4addr)
    have List_rev_drop_geqn: "length x \<ge> n \<Longrightarrow> (take n (rev x)) = rev (drop (length x - n) x)"
      for x :: "'a list" and n by(simp add: List.rev_drop)
    have and_mask_bl_take: "length x \<ge> n \<Longrightarrow> ((of_bl x) AND mask n) = (of_bl (rev (take n (rev (x)))))"
      for x n by(simp add: List_rev_drop_geqn of_bl_drop)
    have ipv4addr_and_255: "x AND 255 = take_bit 8 x" for x :: ipv4addr
      by (simp add: take_bit_eq_mask mask_numeral)
    have bit_equality:
      "((ip >> 24) AND 0xFF << 24) + ((ip >> 16) AND 0xFF << 16) + ((ip >> 8) AND 0xFF << 8) + (ip AND 0xFF) =
       of_bl (take 8 (to_bl ip) @ take 8 (drop 8 (to_bl ip)) @ take 8 (drop 16 (to_bl ip)) @ drop 24 (to_bl ip))"
      apply (simp add: ipv4addr_and_255 shiftl_def shiftr_def rev_drop rev_take drop_take)
      apply (simp only: of_bl_append mult.commute [of \<open>2 ^ n\<close> for n] flip: push_bit_eq_mult)
      apply (simp add: of_bl_drop_eq_take_bit take_drop of_bl_take_to_bl_eq_drop_bit take_bit_drop_bit take_bit_word_eq_self)
      done
    have blip_split: "\<And> blip. length blip = 32 \<Longrightarrow>
      blip = (take 8 blip) @ (take 8 (drop 8 blip)) @ (take 8 (drop 16 blip)) @ (take 8 (drop 24 blip))"
      by(rename_tac blip,case_tac blip,simp_all)+ (*I'm so sorry for this ...*)
    have "ipv4addr_of_dotdecimal (dotdecimal_of_ipv4addr ip) = of_bl (to_bl ip)"
      apply (subst blip_split)
       apply simp
      apply (simp add: ipv4addr_of_dotdecimal_bit dotdecimal_of_ipv4addr.simps)
      apply (simp add: ipv4addr_of_nat_nat_of_ipv4addr)
      apply (simp flip: bit_equality)
      done
    thus ?thesis using word_bl.Rep_inverse[symmetric] by simp
  qed

  lemma ipv4addr_of_dotdecimal_eqE:
    "\<lbrakk> ipv4addr_of_dotdecimal (a,b,c,d) = ipv4addr_of_dotdecimal (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 dotdecimal_of_ipv4addr_ipv4addr_of_dotdecimal)

subsection\<open>IP Ranges: Examples\<close>
  lemma "(UNIV :: ipv4addr set) = {0 .. max_ipv4_addr}" by(simp add: UNIV_ipv4addrset)
  lemma "(42::ipv4addr) \<in> UNIV" by(simp)

  (*Warning, not executable!*)

  lemma "ipset_from_netmask (ipv4addr_of_dotdecimal (192,168,0,42)) (ipv4addr_of_dotdecimal (255,255,0,0)) =
          {ipv4addr_of_dotdecimal (192,168,0,0) .. ipv4addr_of_dotdecimal (192,168,255,255)}"
   by(simp add: ipset_from_netmask_def ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)

  lemma "ipset_from_netmask (ipv4addr_of_dotdecimal (192,168,0,42)) (ipv4addr_of_dotdecimal (0,0,0,0)) = UNIV"
    by(simp add: UNIV_ipv4addrset ipset_from_netmask_def ipv4addr_of_dotdecimal.simps
                 ipv4addr_of_nat_def max_ipv4_addr_max_word)

  text\<open>192.168.0.0/24\<close>

  lemma fixes addr :: ipv4addr
    shows "ipset_from_cidr addr pflength =
            ipset_from_netmask addr ((mask pflength) << (32 - pflength))"
    by(simp add: ipset_from_cidr_def)

  lemma "ipset_from_cidr (ipv4addr_of_dotdecimal (192,168,0,42)) 16 =
          {ipv4addr_of_dotdecimal (192,168,0,0) .. ipv4addr_of_dotdecimal (192,168,255,255)}"
   by(simp add: ipset_from_cidr_alt mask_eq ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def)

  lemma "ip \<in> (ipset_from_cidr (ipv4addr_of_dotdecimal (0, 0, 0, 0)) 0)"
    by(simp add: ipset_from_cidr_0)

  lemma ipv4set_from_cidr_32: fixes addr :: ipv4addr
    shows "ipset_from_cidr addr 32 = {addr}"
    by (simp add: ipset_from_cidr_alt mask_numeral)

  lemma fixes pre :: ipv4addr
    shows "ipset_from_cidr pre len = {(pre AND ((mask len) << (32 - len))) .. pre OR (mask (32 - len))}"
    by (simp add: ipset_from_cidr_alt ipset_from_cidr_def)

  text\<open>making element check executable\<close>
  lemma addr_in_ipv4set_from_netmask_code[code_unfold]:
    fixes addr :: ipv4addr
    shows "addr \<in> (ipset_from_netmask base netmask) \<longleftrightarrow>
            (base AND netmask) \<le> addr \<and> addr \<le> (base AND netmask) OR (NOT netmask)"
    by (simp add: addr_in_ipset_from_netmask_code)
  lemma addr_in_ipv4set_from_cidr_code[code_unfold]:
    fixes addr :: ipv4addr
    shows "addr \<in> (ipset_from_cidr pre len) \<longleftrightarrow>
              (pre AND ((mask len) << (32 - len))) \<le> addr \<and> addr \<le> pre OR (mask (32 - len))"
    by(simp add: addr_in_ipset_from_cidr_code)

  (*small numbers because we didn't load Code_Target_Nat. Should work by eval*)
  lemma "ipv4addr_of_dotdecimal (192,168,42,8) \<in> (ipset_from_cidr (ipv4addr_of_dotdecimal (192,168,0,0)) 16)"
    by (simp add: ipv4addr_of_nat_def ipset_from_cidr_def ipv4addr_of_dotdecimal.simps
      ipset_from_netmask_def mask_eq_exp_minus_1 word_le_def)

  definition ipv4range_UNIV :: "32 wordinterval" where "ipv4range_UNIV \<equiv> wordinterval_UNIV"

  lemma ipv4range_UNIV_set_eq: "wordinterval_to_set ipv4range_UNIV = UNIV"
    by(simp only: ipv4range_UNIV_def wordinterval_UNIV_set_eq)

  thm iffD1[OF wordinterval_eq_set_eq]
  (*TODO: probably the following is a good idea?*)
  (*
  declare iffD1[OF wordinterval_eq_set_eq, cong]
  *)

  text\<open>This \<open>LENGTH('a)\<close> is 32 for IPv4 addresses.\<close>
  lemma ipv4cidr_to_interval_simps[code_unfold]: "ipcidr_to_interval ((pre::ipv4addr), len) = (
      let netmask = (mask len) << (32 - len);
          network_prefix = (pre AND netmask)
      in (network_prefix, network_prefix OR (NOT netmask)))"
  by(simp add: ipcidr_to_interval_def Let_def ipcidr_to_interval_start.simps ipcidr_to_interval_end.simps)

  end

end