(*  Title:      HOL/Num.thy
    Author:     Florian Haftmann
    Author:     Brian Huffman
*)

section {* Binary Numerals *}

theory Num
imports BNF_Least_Fixpoint
begin

subsection {* The @{text num} type *}

datatype num = One | Bit0 num | Bit1 num

text {* Increment function for type @{typ num} *}

primrec inc :: "num \<Rightarrow> num" where
  "inc One = Bit0 One" |
  "inc (Bit0 x) = Bit1 x" |
  "inc (Bit1 x) = Bit0 (inc x)"

text {* Converting between type @{typ num} and type @{typ nat} *}

primrec nat_of_num :: "num \<Rightarrow> nat" where
  "nat_of_num One = Suc 0" |
  "nat_of_num (Bit0 x) = nat_of_num x + nat_of_num x" |
  "nat_of_num (Bit1 x) = Suc (nat_of_num x + nat_of_num x)"

primrec num_of_nat :: "nat \<Rightarrow> num" where
  "num_of_nat 0 = One" |
  "num_of_nat (Suc n) = (if 0 < n then inc (num_of_nat n) else One)"

lemma nat_of_num_pos: "0 < nat_of_num x"
  by (induct x) simp_all

lemma nat_of_num_neq_0: " nat_of_num x \<noteq> 0"
  by (induct x) simp_all

lemma nat_of_num_inc: "nat_of_num (inc x) = Suc (nat_of_num x)"
  by (induct x) simp_all

lemma num_of_nat_double:
  "0 < n \<Longrightarrow> num_of_nat (n + n) = Bit0 (num_of_nat n)"
  by (induct n) simp_all

text {*
  Type @{typ num} is isomorphic to the strictly positive
  natural numbers.
*}

lemma nat_of_num_inverse: "num_of_nat (nat_of_num x) = x"
  by (induct x) (simp_all add: num_of_nat_double nat_of_num_pos)

lemma num_of_nat_inverse: "0 < n \<Longrightarrow> nat_of_num (num_of_nat n) = n"
  by (induct n) (simp_all add: nat_of_num_inc)

lemma num_eq_iff: "x = y \<longleftrightarrow> nat_of_num x = nat_of_num y"
  apply safe
  apply (drule arg_cong [where f=num_of_nat])
  apply (simp add: nat_of_num_inverse)
  done

lemma num_induct [case_names One inc]:
  fixes P :: "num \<Rightarrow> bool"
  assumes One: "P One"
    and inc: "\<And>x. P x \<Longrightarrow> P (inc x)"
  shows "P x"
proof -
  obtain n where n: "Suc n = nat_of_num x"
    by (cases "nat_of_num x", simp_all add: nat_of_num_neq_0)
  have "P (num_of_nat (Suc n))"
  proof (induct n)
    case 0 show ?case using One by simp
  next
    case (Suc n)
    then have "P (inc (num_of_nat (Suc n)))" by (rule inc)
    then show "P (num_of_nat (Suc (Suc n)))" by simp
  qed
  with n show "P x"
    by (simp add: nat_of_num_inverse)
qed

text {*
  From now on, there are two possible models for @{typ num}:
  as positive naturals (rule @{text "num_induct"})
  and as digit representation (rules @{text "num.induct"}, @{text "num.cases"}).
*}

subsection {* Numeral operations *}

instantiation num :: "{plus,times,linorder}"
begin

definition [code del]:
  "m + n = num_of_nat (nat_of_num m + nat_of_num n)"

definition [code del]:
  "m * n = num_of_nat (nat_of_num m * nat_of_num n)"

definition [code del]:
  "m \<le> n \<longleftrightarrow> nat_of_num m \<le> nat_of_num n"

definition [code del]:
  "m < n \<longleftrightarrow> nat_of_num m < nat_of_num n"

instance
  by (default, auto simp add: less_num_def less_eq_num_def num_eq_iff)

end

lemma nat_of_num_add: "nat_of_num (x + y) = nat_of_num x + nat_of_num y"
  unfolding plus_num_def
  by (intro num_of_nat_inverse add_pos_pos nat_of_num_pos)

lemma nat_of_num_mult: "nat_of_num (x * y) = nat_of_num x * nat_of_num y"
  unfolding times_num_def
  by (intro num_of_nat_inverse mult_pos_pos nat_of_num_pos)

lemma add_num_simps [simp, code]:
  "One + One = Bit0 One"
  "One + Bit0 n = Bit1 n"
  "One + Bit1 n = Bit0 (n + One)"
  "Bit0 m + One = Bit1 m"
  "Bit0 m + Bit0 n = Bit0 (m + n)"
  "Bit0 m + Bit1 n = Bit1 (m + n)"
  "Bit1 m + One = Bit0 (m + One)"
  "Bit1 m + Bit0 n = Bit1 (m + n)"
  "Bit1 m + Bit1 n = Bit0 (m + n + One)"
  by (simp_all add: num_eq_iff nat_of_num_add)

lemma mult_num_simps [simp, code]:
  "m * One = m"
  "One * n = n"
  "Bit0 m * Bit0 n = Bit0 (Bit0 (m * n))"
  "Bit0 m * Bit1 n = Bit0 (m * Bit1 n)"
  "Bit1 m * Bit0 n = Bit0 (Bit1 m * n)"
  "Bit1 m * Bit1 n = Bit1 (m + n + Bit0 (m * n))"
  by (simp_all add: num_eq_iff nat_of_num_add
    nat_of_num_mult distrib_right distrib_left)

lemma eq_num_simps:
  "One = One \<longleftrightarrow> True"
  "One = Bit0 n \<longleftrightarrow> False"
  "One = Bit1 n \<longleftrightarrow> False"
  "Bit0 m = One \<longleftrightarrow> False"
  "Bit1 m = One \<longleftrightarrow> False"
  "Bit0 m = Bit0 n \<longleftrightarrow> m = n"
  "Bit0 m = Bit1 n \<longleftrightarrow> False"
  "Bit1 m = Bit0 n \<longleftrightarrow> False"
  "Bit1 m = Bit1 n \<longleftrightarrow> m = n"
  by simp_all

lemma le_num_simps [simp, code]:
  "One \<le> n \<longleftrightarrow> True"
  "Bit0 m \<le> One \<longleftrightarrow> False"
  "Bit1 m \<le> One \<longleftrightarrow> False"
  "Bit0 m \<le> Bit0 n \<longleftrightarrow> m \<le> n"
  "Bit0 m \<le> Bit1 n \<longleftrightarrow> m \<le> n"
  "Bit1 m \<le> Bit1 n \<longleftrightarrow> m \<le> n"
  "Bit1 m \<le> Bit0 n \<longleftrightarrow> m < n"
  using nat_of_num_pos [of n] nat_of_num_pos [of m]
  by (auto simp add: less_eq_num_def less_num_def)

lemma less_num_simps [simp, code]:
  "m < One \<longleftrightarrow> False"
  "One < Bit0 n \<longleftrightarrow> True"
  "One < Bit1 n \<longleftrightarrow> True"
  "Bit0 m < Bit0 n \<longleftrightarrow> m < n"
  "Bit0 m < Bit1 n \<longleftrightarrow> m \<le> n"
  "Bit1 m < Bit1 n \<longleftrightarrow> m < n"
  "Bit1 m < Bit0 n \<longleftrightarrow> m < n"
  using nat_of_num_pos [of n] nat_of_num_pos [of m]
  by (auto simp add: less_eq_num_def less_num_def)

text {* Rules using @{text One} and @{text inc} as constructors *}

lemma add_One: "x + One = inc x"
  by (simp add: num_eq_iff nat_of_num_add nat_of_num_inc)

lemma add_One_commute: "One + n = n + One"
  by (induct n) simp_all

lemma add_inc: "x + inc y = inc (x + y)"
  by (simp add: num_eq_iff nat_of_num_add nat_of_num_inc)

lemma mult_inc: "x * inc y = x * y + x"
  by (simp add: num_eq_iff nat_of_num_mult nat_of_num_add nat_of_num_inc)

text {* The @{const num_of_nat} conversion *}

lemma num_of_nat_One:
  "n \<le> 1 \<Longrightarrow> num_of_nat n = One"
  by (cases n) simp_all

lemma num_of_nat_plus_distrib:
  "0 < m \<Longrightarrow> 0 < n \<Longrightarrow> num_of_nat (m + n) = num_of_nat m + num_of_nat n"
  by (induct n) (auto simp add: add_One add_One_commute add_inc)

text {* A double-and-decrement function *}

primrec BitM :: "num \<Rightarrow> num" where
  "BitM One = One" |
  "BitM (Bit0 n) = Bit1 (BitM n)" |
  "BitM (Bit1 n) = Bit1 (Bit0 n)"

lemma BitM_plus_one: "BitM n + One = Bit0 n"
  by (induct n) simp_all

lemma one_plus_BitM: "One + BitM n = Bit0 n"
  unfolding add_One_commute BitM_plus_one ..

text {* Squaring and exponentiation *}

primrec sqr :: "num \<Rightarrow> num" where
  "sqr One = One" |
  "sqr (Bit0 n) = Bit0 (Bit0 (sqr n))" |
  "sqr (Bit1 n) = Bit1 (Bit0 (sqr n + n))"

primrec pow :: "num \<Rightarrow> num \<Rightarrow> num" where
  "pow x One = x" |
  "pow x (Bit0 y) = sqr (pow x y)" |
  "pow x (Bit1 y) = sqr (pow x y) * x"

lemma nat_of_num_sqr: "nat_of_num (sqr x) = nat_of_num x * nat_of_num x"
  by (induct x, simp_all add: algebra_simps nat_of_num_add)

lemma sqr_conv_mult: "sqr x = x * x"
  by (simp add: num_eq_iff nat_of_num_sqr nat_of_num_mult)

subsection {* Binary numerals *}

text {*
  We embed binary representations into a generic algebraic
  structure using @{text numeral}.
*}

class numeral = one + semigroup_add
begin

primrec numeral :: "num \<Rightarrow> 'a" where
  numeral_One: "numeral One = 1" |
  numeral_Bit0: "numeral (Bit0 n) = numeral n + numeral n" |
  numeral_Bit1: "numeral (Bit1 n) = numeral n + numeral n + 1"

lemma numeral_code [code]:
  "numeral One = 1"
  "numeral (Bit0 n) = (let m = numeral n in m + m)"
  "numeral (Bit1 n) = (let m = numeral n in m + m + 1)"
  by (simp_all add: Let_def)

lemma one_plus_numeral_commute: "1 + numeral x = numeral x + 1"
  apply (induct x)
  apply simp
  apply (simp add: add.assoc [symmetric], simp add: add.assoc)
  apply (simp add: add.assoc [symmetric], simp add: add.assoc)
  done

lemma numeral_inc: "numeral (inc x) = numeral x + 1"
proof (induct x)
  case (Bit1 x)
  have "numeral x + (1 + numeral x) + 1 = numeral x + (numeral x + 1) + 1"
    by (simp only: one_plus_numeral_commute)
  with Bit1 show ?case
    by (simp add: add.assoc)
qed simp_all

declare numeral.simps [simp del]

abbreviation "Numeral1 \<equiv> numeral One"

declare numeral_One [code_post]

end

text {* Numeral syntax. *}

syntax
  "_Numeral" :: "num_const \<Rightarrow> 'a"    ("_")

ML_file "Tools/numeral.ML"

parse_translation {*
  let
    fun numeral_tr [(c as Const (@{syntax_const "_constrain"}, _)) $ t $ u] =
          c $ numeral_tr [t] $ u
      | numeral_tr [Const (num, _)] =
          (Numeral.mk_number_syntax o #value o Lexicon.read_num) num
      | numeral_tr ts = raise TERM ("numeral_tr", ts);
  in [(@{syntax_const "_Numeral"}, K numeral_tr)] end
*}

typed_print_translation {*
  let
    fun dest_num (Const (@{const_syntax Bit0}, _) $ n) = 2 * dest_num n
      | dest_num (Const (@{const_syntax Bit1}, _) $ n) = 2 * dest_num n + 1
      | dest_num (Const (@{const_syntax One}, _)) = 1;
    fun num_tr' ctxt T [n] =
      let
        val k = dest_num n;
        val t' =
          Syntax.const @{syntax_const "_Numeral"} $
            Syntax.free (string_of_int k);
      in
        (case T of
          Type (@{type_name fun}, [_, T']) =>
            if Printer.type_emphasis ctxt T' then
              Syntax.const @{syntax_const "_constrain"} $ t' $
                Syntax_Phases.term_of_typ ctxt T'
            else t'
        | _ => if T = dummyT then t' else raise Match)
      end;
  in
   [(@{const_syntax numeral}, num_tr')]
  end
*}

subsection {* Class-specific numeral rules *}

text {*
  @{const numeral} is a morphism.
*}

subsubsection {* Structures with addition: class @{text numeral} *}

context numeral
begin

lemma numeral_add: "numeral (m + n) = numeral m + numeral n"
  by (induct n rule: num_induct)
     (simp_all only: numeral_One add_One add_inc numeral_inc add.assoc)

lemma numeral_plus_numeral: "numeral m + numeral n = numeral (m + n)"
  by (rule numeral_add [symmetric])

lemma numeral_plus_one: "numeral n + 1 = numeral (n + One)"
  using numeral_add [of n One] by (simp add: numeral_One)

lemma one_plus_numeral: "1 + numeral n = numeral (One + n)"
  using numeral_add [of One n] by (simp add: numeral_One)

lemma one_add_one: "1 + 1 = 2"
  using numeral_add [of One One] by (simp add: numeral_One)

lemmas add_numeral_special =
  numeral_plus_one one_plus_numeral one_add_one

end

subsubsection {*
  Structures with negation: class @{text neg_numeral}
*}

class neg_numeral = numeral + group_add
begin

lemma uminus_numeral_One:
  "- Numeral1 = - 1"
  by (simp add: numeral_One)

text {* Numerals form an abelian subgroup. *}

inductive is_num :: "'a \<Rightarrow> bool" where
  "is_num 1" |
  "is_num x \<Longrightarrow> is_num (- x)" |
  "\<lbrakk>is_num x; is_num y\<rbrakk> \<Longrightarrow> is_num (x + y)"

lemma is_num_numeral: "is_num (numeral k)"
  by (induct k, simp_all add: numeral.simps is_num.intros)

lemma is_num_add_commute:
  "\<lbrakk>is_num x; is_num y\<rbrakk> \<Longrightarrow> x + y = y + x"
  apply (induct x rule: is_num.induct)
  apply (induct y rule: is_num.induct)
  apply simp
  apply (rule_tac a=x in add_left_imp_eq)
  apply (rule_tac a=x in add_right_imp_eq)
  apply (simp add: add.assoc)
  apply (simp add: add.assoc [symmetric], simp add: add.assoc)
  apply (rule_tac a=x in add_left_imp_eq)
  apply (rule_tac a=x in add_right_imp_eq)
  apply (simp add: add.assoc)
  apply (simp add: add.assoc, simp add: add.assoc [symmetric])
  done

lemma is_num_add_left_commute:
  "\<lbrakk>is_num x; is_num y\<rbrakk> \<Longrightarrow> x + (y + z) = y + (x + z)"
  by (simp only: add.assoc [symmetric] is_num_add_commute)

lemmas is_num_normalize =
  add.assoc is_num_add_commute is_num_add_left_commute
  is_num.intros is_num_numeral
  minus_add

definition dbl :: "'a \<Rightarrow> 'a" where "dbl x = x + x"
definition dbl_inc :: "'a \<Rightarrow> 'a" where "dbl_inc x = x + x + 1"
definition dbl_dec :: "'a \<Rightarrow> 'a" where "dbl_dec x = x + x - 1"

definition sub :: "num \<Rightarrow> num \<Rightarrow> 'a" where
  "sub k l = numeral k - numeral l"

lemma numeral_BitM: "numeral (BitM n) = numeral (Bit0 n) - 1"
  by (simp only: BitM_plus_one [symmetric] numeral_add numeral_One eq_diff_eq)

lemma dbl_simps [simp]:
  "dbl (- numeral k) = - dbl (numeral k)"
  "dbl 0 = 0"
  "dbl 1 = 2"
  "dbl (- 1) = - 2"
  "dbl (numeral k) = numeral (Bit0 k)"
  by (simp_all add: dbl_def numeral.simps minus_add)

lemma dbl_inc_simps [simp]:
  "dbl_inc (- numeral k) = - dbl_dec (numeral k)"
  "dbl_inc 0 = 1"
  "dbl_inc 1 = 3"
  "dbl_inc (- 1) = - 1"
  "dbl_inc (numeral k) = numeral (Bit1 k)"
  by (simp_all add: dbl_inc_def dbl_dec_def numeral.simps numeral_BitM is_num_normalize algebra_simps del: add_uminus_conv_diff)

lemma dbl_dec_simps [simp]:
  "dbl_dec (- numeral k) = - dbl_inc (numeral k)"
  "dbl_dec 0 = - 1"
  "dbl_dec 1 = 1"
  "dbl_dec (- 1) = - 3"
  "dbl_dec (numeral k) = numeral (BitM k)"
  by (simp_all add: dbl_dec_def dbl_inc_def numeral.simps numeral_BitM is_num_normalize)

lemma sub_num_simps [simp]:
  "sub One One = 0"
  "sub One (Bit0 l) = - numeral (BitM l)"
  "sub One (Bit1 l) = - numeral (Bit0 l)"
  "sub (Bit0 k) One = numeral (BitM k)"
  "sub (Bit1 k) One = numeral (Bit0 k)"
  "sub (Bit0 k) (Bit0 l) = dbl (sub k l)"
  "sub (Bit0 k) (Bit1 l) = dbl_dec (sub k l)"
  "sub (Bit1 k) (Bit0 l) = dbl_inc (sub k l)"
  "sub (Bit1 k) (Bit1 l) = dbl (sub k l)"
  by (simp_all add: dbl_def dbl_dec_def dbl_inc_def sub_def numeral.simps
    numeral_BitM is_num_normalize del: add_uminus_conv_diff add: diff_conv_add_uminus)

lemma add_neg_numeral_simps:
  "numeral m + - numeral n = sub m n"
  "- numeral m + numeral n = sub n m"
  "- numeral m + - numeral n = - (numeral m + numeral n)"
  by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize
    del: add_uminus_conv_diff add: diff_conv_add_uminus)

lemma add_neg_numeral_special:
  "1 + - numeral m = sub One m"
  "- numeral m + 1 = sub One m"
  "numeral m + - 1 = sub m One"
  "- 1 + numeral n = sub n One"
  "- 1 + - numeral n = - numeral (inc n)"
  "- numeral m + - 1 = - numeral (inc m)"
  "1 + - 1 = 0"
  "- 1 + 1 = 0"
  "- 1 + - 1 = - 2"
  by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize right_minus numeral_inc
    del: add_uminus_conv_diff add: diff_conv_add_uminus)

lemma diff_numeral_simps:
  "numeral m - numeral n = sub m n"
  "numeral m - - numeral n = numeral (m + n)"
  "- numeral m - numeral n = - numeral (m + n)"
  "- numeral m - - numeral n = sub n m"
  by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize
    del: add_uminus_conv_diff add: diff_conv_add_uminus)

lemma diff_numeral_special:
  "1 - numeral n = sub One n"
  "numeral m - 1 = sub m One"
  "1 - - numeral n = numeral (One + n)"
  "- numeral m - 1 = - numeral (m + One)"
  "- 1 - numeral n = - numeral (inc n)"
  "numeral m - - 1 = numeral (inc m)"
  "- 1 - - numeral n = sub n One"
  "- numeral m - - 1 = sub One m"
  "1 - 1 = 0"
  "- 1 - 1 = - 2"
  "1 - - 1 = 2"
  "- 1 - - 1 = 0"
  by (simp_all add: sub_def numeral_add numeral.simps is_num_normalize numeral_inc
    del: add_uminus_conv_diff add: diff_conv_add_uminus)

end

subsubsection {*
  Structures with multiplication: class @{text semiring_numeral}
*}

class semiring_numeral = semiring + monoid_mult
begin

subclass numeral ..

lemma numeral_mult: "numeral (m * n) = numeral m * numeral n"
  apply (induct n rule: num_induct)
  apply (simp add: numeral_One)
  apply (simp add: mult_inc numeral_inc numeral_add distrib_left)
  done

lemma numeral_times_numeral: "numeral m * numeral n = numeral (m * n)"
  by (rule numeral_mult [symmetric])

lemma mult_2: "2 * z = z + z"
  unfolding one_add_one [symmetric] distrib_right by simp

lemma mult_2_right: "z * 2 = z + z"
  unfolding one_add_one [symmetric] distrib_left by simp

end

subsubsection {*
  Structures with a zero: class @{text semiring_1}
*}

context semiring_1
begin

subclass semiring_numeral ..

lemma of_nat_numeral [simp]: "of_nat (numeral n) = numeral n"
  by (induct n,
    simp_all only: numeral.simps numeral_class.numeral.simps of_nat_add of_nat_1)

end

lemma nat_of_num_numeral [code_abbrev]:
  "nat_of_num = numeral"
proof
  fix n
  have "numeral n = nat_of_num n"
    by (induct n) (simp_all add: numeral.simps)
  then show "nat_of_num n = numeral n" by simp
qed

lemma nat_of_num_code [code]:
  "nat_of_num One = 1"
  "nat_of_num (Bit0 n) = (let m = nat_of_num n in m + m)"
  "nat_of_num (Bit1 n) = (let m = nat_of_num n in Suc (m + m))"
  by (simp_all add: Let_def)

subsubsection {*
  Equality: class @{text semiring_char_0}
*}

context semiring_char_0
begin

lemma numeral_eq_iff: "numeral m = numeral n \<longleftrightarrow> m = n"
  unfolding of_nat_numeral [symmetric] nat_of_num_numeral [symmetric]
    of_nat_eq_iff num_eq_iff ..

lemma numeral_eq_one_iff: "numeral n = 1 \<longleftrightarrow> n = One"
  by (rule numeral_eq_iff [of n One, unfolded numeral_One])

lemma one_eq_numeral_iff: "1 = numeral n \<longleftrightarrow> One = n"
  by (rule numeral_eq_iff [of One n, unfolded numeral_One])

lemma numeral_neq_zero: "numeral n \<noteq> 0"
  unfolding of_nat_numeral [symmetric] nat_of_num_numeral [symmetric]
  by (simp add: nat_of_num_pos)

lemma zero_neq_numeral: "0 \<noteq> numeral n"
  unfolding eq_commute [of 0] by (rule numeral_neq_zero)

lemmas eq_numeral_simps [simp] =
  numeral_eq_iff
  numeral_eq_one_iff
  one_eq_numeral_iff
  numeral_neq_zero
  zero_neq_numeral

end

subsubsection {*
  Comparisons: class @{text linordered_semidom}
*}

text {*  Could be perhaps more general than here. *}

context linordered_semidom
begin

lemma numeral_le_iff: "numeral m \<le> numeral n \<longleftrightarrow> m \<le> n"
proof -
  have "of_nat (numeral m) \<le> of_nat (numeral n) \<longleftrightarrow> m \<le> n"
    unfolding less_eq_num_def nat_of_num_numeral of_nat_le_iff ..
  then show ?thesis by simp
qed

lemma one_le_numeral: "1 \<le> numeral n"
using numeral_le_iff [of One n] by (simp add: numeral_One)

lemma numeral_le_one_iff: "numeral n \<le> 1 \<longleftrightarrow> n \<le> One"
using numeral_le_iff [of n One] by (simp add: numeral_One)

lemma numeral_less_iff: "numeral m < numeral n \<longleftrightarrow> m < n"
proof -
  have "of_nat (numeral m) < of_nat (numeral n) \<longleftrightarrow> m < n"
    unfolding less_num_def nat_of_num_numeral of_nat_less_iff ..
  then show ?thesis by simp
qed

lemma not_numeral_less_one: "\<not> numeral n < 1"
  using numeral_less_iff [of n One] by (simp add: numeral_One)

lemma one_less_numeral_iff: "1 < numeral n \<longleftrightarrow> One < n"
  using numeral_less_iff [of One n] by (simp add: numeral_One)

lemma zero_le_numeral: "0 \<le> numeral n"
  by (induct n) (simp_all add: numeral.simps)

lemma zero_less_numeral: "0 < numeral n"
  by (induct n) (simp_all add: numeral.simps add_pos_pos)

lemma not_numeral_le_zero: "\<not> numeral n \<le> 0"
  by (simp add: not_le zero_less_numeral)

lemma not_numeral_less_zero: "\<not> numeral n < 0"
  by (simp add: not_less zero_le_numeral)

lemmas le_numeral_extra =
  zero_le_one not_one_le_zero
  order_refl [of 0] order_refl [of 1]

lemmas less_numeral_extra =
  zero_less_one not_one_less_zero
  less_irrefl [of 0] less_irrefl [of 1]

lemmas le_numeral_simps [simp] =
  numeral_le_iff
  one_le_numeral
  numeral_le_one_iff
  zero_le_numeral
  not_numeral_le_zero

lemmas less_numeral_simps [simp] =
  numeral_less_iff
  one_less_numeral_iff
  not_numeral_less_one
  zero_less_numeral
  not_numeral_less_zero

end

subsubsection {*
  Multiplication and negation: class @{text ring_1}
*}

context ring_1
begin

subclass neg_numeral ..

lemma mult_neg_numeral_simps:
  "- numeral m * - numeral n = numeral (m * n)"
  "- numeral m * numeral n = - numeral (m * n)"
  "numeral m * - numeral n = - numeral (m * n)"
  unfolding mult_minus_left mult_minus_right
  by (simp_all only: minus_minus numeral_mult)

lemma mult_minus1 [simp]: "- 1 * z = - z"
  unfolding numeral.simps mult_minus_left by simp

lemma mult_minus1_right [simp]: "z * - 1 = - z"
  unfolding numeral.simps mult_minus_right by simp

end

subsubsection {*
  Equality using @{text iszero} for rings with non-zero characteristic
*}

context ring_1
begin

definition iszero :: "'a \<Rightarrow> bool"
  where "iszero z \<longleftrightarrow> z = 0"

lemma iszero_0 [simp]: "iszero 0"
  by (simp add: iszero_def)

lemma not_iszero_1 [simp]: "\<not> iszero 1"
  by (simp add: iszero_def)

lemma not_iszero_Numeral1: "\<not> iszero Numeral1"
  by (simp add: numeral_One)

lemma not_iszero_neg_1 [simp]: "\<not> iszero (- 1)"
  by (simp add: iszero_def)

lemma not_iszero_neg_Numeral1: "\<not> iszero (- Numeral1)"
  by (simp add: numeral_One)

lemma iszero_neg_numeral [simp]:
  "iszero (- numeral w) \<longleftrightarrow> iszero (numeral w)"
  unfolding iszero_def
  by (rule neg_equal_0_iff_equal)

lemma eq_iff_iszero_diff: "x = y \<longleftrightarrow> iszero (x - y)"
  unfolding iszero_def by (rule eq_iff_diff_eq_0)

text {* The @{text "eq_numeral_iff_iszero"} lemmas are not declared
@{text "[simp]"} by default, because for rings of characteristic zero,
better simp rules are possible. For a type like integers mod @{text
"n"}, type-instantiated versions of these rules should be added to the
simplifier, along with a type-specific rule for deciding propositions
of the form @{text "iszero (numeral w)"}.

bh: Maybe it would not be so bad to just declare these as simp
rules anyway? I should test whether these rules take precedence over
the @{text "ring_char_0"} rules in the simplifier.
*}

lemma eq_numeral_iff_iszero:
  "numeral x = numeral y \<longleftrightarrow> iszero (sub x y)"
  "numeral x = - numeral y \<longleftrightarrow> iszero (numeral (x + y))"
  "- numeral x = numeral y \<longleftrightarrow> iszero (numeral (x + y))"
  "- numeral x = - numeral y \<longleftrightarrow> iszero (sub y x)"
  "numeral x = 1 \<longleftrightarrow> iszero (sub x One)"
  "1 = numeral y \<longleftrightarrow> iszero (sub One y)"
  "- numeral x = 1 \<longleftrightarrow> iszero (numeral (x + One))"
  "1 = - numeral y \<longleftrightarrow> iszero (numeral (One + y))"
  "numeral x = 0 \<longleftrightarrow> iszero (numeral x)"
  "0 = numeral y \<longleftrightarrow> iszero (numeral y)"
  "- numeral x = 0 \<longleftrightarrow> iszero (numeral x)"
  "0 = - numeral y \<longleftrightarrow> iszero (numeral y)"
  unfolding eq_iff_iszero_diff diff_numeral_simps diff_numeral_special
  by simp_all

end

subsubsection {*
  Equality and negation: class @{text ring_char_0}
*}

class ring_char_0 = ring_1 + semiring_char_0
begin

lemma not_iszero_numeral [simp]: "\<not> iszero (numeral w)"
  by (simp add: iszero_def)

lemma neg_numeral_eq_iff: "- numeral m = - numeral n \<longleftrightarrow> m = n"
  by simp

lemma numeral_neq_neg_numeral: "numeral m \<noteq> - numeral n"
  unfolding eq_neg_iff_add_eq_0
  by (simp add: numeral_plus_numeral)

lemma neg_numeral_neq_numeral: "- numeral m \<noteq> numeral n"
  by (rule numeral_neq_neg_numeral [symmetric])

lemma zero_neq_neg_numeral: "0 \<noteq> - numeral n"
  unfolding neg_0_equal_iff_equal by simp

lemma neg_numeral_neq_zero: "- numeral n \<noteq> 0"
  unfolding neg_equal_0_iff_equal by simp

lemma one_neq_neg_numeral: "1 \<noteq> - numeral n"
  using numeral_neq_neg_numeral [of One n] by (simp add: numeral_One)

lemma neg_numeral_neq_one: "- numeral n \<noteq> 1"
  using neg_numeral_neq_numeral [of n One] by (simp add: numeral_One)

lemma neg_one_neq_numeral:
  "- 1 \<noteq> numeral n"
  using neg_numeral_neq_numeral [of One n] by (simp add: numeral_One)

lemma numeral_neq_neg_one:
  "numeral n \<noteq> - 1"
  using numeral_neq_neg_numeral [of n One] by (simp add: numeral_One)

lemma neg_one_eq_numeral_iff:
  "- 1 = - numeral n \<longleftrightarrow> n = One"
  using neg_numeral_eq_iff [of One n] by (auto simp add: numeral_One)

lemma numeral_eq_neg_one_iff:
  "- numeral n = - 1 \<longleftrightarrow> n = One"
  using neg_numeral_eq_iff [of n One] by (auto simp add: numeral_One)

lemma neg_one_neq_zero:
  "- 1 \<noteq> 0"
  by simp

lemma zero_neq_neg_one:
  "0 \<noteq> - 1"
  by simp

lemma neg_one_neq_one:
  "- 1 \<noteq> 1"
  using neg_numeral_neq_numeral [of One One] by (simp only: numeral_One not_False_eq_True)

lemma one_neq_neg_one:
  "1 \<noteq> - 1"
  using numeral_neq_neg_numeral [of One One] by (simp only: numeral_One not_False_eq_True)

lemmas eq_neg_numeral_simps [simp] =
  neg_numeral_eq_iff
  numeral_neq_neg_numeral neg_numeral_neq_numeral
  one_neq_neg_numeral neg_numeral_neq_one
  zero_neq_neg_numeral neg_numeral_neq_zero
  neg_one_neq_numeral numeral_neq_neg_one
  neg_one_eq_numeral_iff numeral_eq_neg_one_iff
  neg_one_neq_zero zero_neq_neg_one
  neg_one_neq_one one_neq_neg_one

end

subsubsection {*
  Structures with negation and order: class @{text linordered_idom}
*}

context linordered_idom
begin

subclass ring_char_0 ..

lemma neg_numeral_le_iff: "- numeral m \<le> - numeral n \<longleftrightarrow> n \<le> m"
  by (simp only: neg_le_iff_le numeral_le_iff)

lemma neg_numeral_less_iff: "- numeral m < - numeral n \<longleftrightarrow> n < m"
  by (simp only: neg_less_iff_less numeral_less_iff)

lemma neg_numeral_less_zero: "- numeral n < 0"
  by (simp only: neg_less_0_iff_less zero_less_numeral)

lemma neg_numeral_le_zero: "- numeral n \<le> 0"
  by (simp only: neg_le_0_iff_le zero_le_numeral)

lemma not_zero_less_neg_numeral: "\<not> 0 < - numeral n"
  by (simp only: not_less neg_numeral_le_zero)

lemma not_zero_le_neg_numeral: "\<not> 0 \<le> - numeral n"
  by (simp only: not_le neg_numeral_less_zero)

lemma neg_numeral_less_numeral: "- numeral m < numeral n"
  using neg_numeral_less_zero zero_less_numeral by (rule less_trans)

lemma neg_numeral_le_numeral: "- numeral m \<le> numeral n"
  by (simp only: less_imp_le neg_numeral_less_numeral)

lemma not_numeral_less_neg_numeral: "\<not> numeral m < - numeral n"
  by (simp only: not_less neg_numeral_le_numeral)

lemma not_numeral_le_neg_numeral: "\<not> numeral m \<le> - numeral n"
  by (simp only: not_le neg_numeral_less_numeral)

lemma neg_numeral_less_one: "- numeral m < 1"
  by (rule neg_numeral_less_numeral [of m One, unfolded numeral_One])

lemma neg_numeral_le_one: "- numeral m \<le> 1"
  by (rule neg_numeral_le_numeral [of m One, unfolded numeral_One])

lemma not_one_less_neg_numeral: "\<not> 1 < - numeral m"
  by (simp only: not_less neg_numeral_le_one)

lemma not_one_le_neg_numeral: "\<not> 1 \<le> - numeral m"
  by (simp only: not_le neg_numeral_less_one)

lemma not_numeral_less_neg_one: "\<not> numeral m < - 1"
  using not_numeral_less_neg_numeral [of m One] by (simp add: numeral_One)

lemma not_numeral_le_neg_one: "\<not> numeral m \<le> - 1"
  using not_numeral_le_neg_numeral [of m One] by (simp add: numeral_One)

lemma neg_one_less_numeral: "- 1 < numeral m"
  using neg_numeral_less_numeral [of One m] by (simp add: numeral_One)

lemma neg_one_le_numeral: "- 1 \<le> numeral m"
  using neg_numeral_le_numeral [of One m] by (simp add: numeral_One)

lemma neg_numeral_less_neg_one_iff: "- numeral m < - 1 \<longleftrightarrow> m \<noteq> One"
  by (cases m) simp_all

lemma neg_numeral_le_neg_one: "- numeral m \<le> - 1"
  by simp

lemma not_neg_one_less_neg_numeral: "\<not> - 1 < - numeral m"
  by simp

lemma not_neg_one_le_neg_numeral_iff: "\<not> - 1 \<le> - numeral m \<longleftrightarrow> m \<noteq> One"
  by (cases m) simp_all

lemma sub_non_negative:
  "sub n m \<ge> 0 \<longleftrightarrow> n \<ge> m"
  by (simp only: sub_def le_diff_eq) simp

lemma sub_positive:
  "sub n m > 0 \<longleftrightarrow> n > m"
  by (simp only: sub_def less_diff_eq) simp

lemma sub_non_positive:
  "sub n m \<le> 0 \<longleftrightarrow> n \<le> m"
  by (simp only: sub_def diff_le_eq) simp

lemma sub_negative:
  "sub n m < 0 \<longleftrightarrow> n < m"
  by (simp only: sub_def diff_less_eq) simp

lemmas le_neg_numeral_simps [simp] =
  neg_numeral_le_iff
  neg_numeral_le_numeral not_numeral_le_neg_numeral
  neg_numeral_le_zero not_zero_le_neg_numeral
  neg_numeral_le_one not_one_le_neg_numeral
  neg_one_le_numeral not_numeral_le_neg_one
  neg_numeral_le_neg_one not_neg_one_le_neg_numeral_iff

lemma le_minus_one_simps [simp]:
  "- 1 \<le> 0"
  "- 1 \<le> 1"
  "\<not> 0 \<le> - 1"
  "\<not> 1 \<le> - 1"
  by simp_all

lemmas less_neg_numeral_simps [simp] =
  neg_numeral_less_iff
  neg_numeral_less_numeral not_numeral_less_neg_numeral
  neg_numeral_less_zero not_zero_less_neg_numeral
  neg_numeral_less_one not_one_less_neg_numeral
  neg_one_less_numeral not_numeral_less_neg_one
  neg_numeral_less_neg_one_iff not_neg_one_less_neg_numeral

lemma less_minus_one_simps [simp]:
  "- 1 < 0"
  "- 1 < 1"
  "\<not> 0 < - 1"
  "\<not> 1 < - 1"
  by (simp_all add: less_le)

lemma abs_numeral [simp]: "abs (numeral n) = numeral n"
  by simp

lemma abs_neg_numeral [simp]: "abs (- numeral n) = numeral n"
  by (simp only: abs_minus_cancel abs_numeral)

lemma abs_neg_one [simp]:
  "abs (- 1) = 1"
  by simp

end

subsubsection {*
  Natural numbers
*}

lemma Suc_1 [simp]: "Suc 1 = 2"
  unfolding Suc_eq_plus1 by (rule one_add_one)

lemma Suc_numeral [simp]: "Suc (numeral n) = numeral (n + One)"
  unfolding Suc_eq_plus1 by (rule numeral_plus_one)

definition pred_numeral :: "num \<Rightarrow> nat"
  where [code del]: "pred_numeral k = numeral k - 1"

lemma numeral_eq_Suc: "numeral k = Suc (pred_numeral k)"
  unfolding pred_numeral_def by simp

lemma eval_nat_numeral:
  "numeral One = Suc 0"
  "numeral (Bit0 n) = Suc (numeral (BitM n))"
  "numeral (Bit1 n) = Suc (numeral (Bit0 n))"
  by (simp_all add: numeral.simps BitM_plus_one)

lemma pred_numeral_simps [simp]:
  "pred_numeral One = 0"
  "pred_numeral (Bit0 k) = numeral (BitM k)"
  "pred_numeral (Bit1 k) = numeral (Bit0 k)"
  unfolding pred_numeral_def eval_nat_numeral
  by (simp_all only: diff_Suc_Suc diff_0)

lemma numeral_2_eq_2: "2 = Suc (Suc 0)"
  by (simp add: eval_nat_numeral)

lemma numeral_3_eq_3: "3 = Suc (Suc (Suc 0))"
  by (simp add: eval_nat_numeral)

lemma numeral_1_eq_Suc_0: "Numeral1 = Suc 0"
  by (simp only: numeral_One One_nat_def)

lemma Suc_nat_number_of_add:
  "Suc (numeral v + n) = numeral (v + One) + n"
  by simp

(*Maps #n to n for n = 1, 2*)
lemmas numerals = numeral_One [where 'a=nat] numeral_2_eq_2

text {* Comparisons involving @{term Suc}. *}

lemma eq_numeral_Suc [simp]: "numeral k = Suc n \<longleftrightarrow> pred_numeral k = n"
  by (simp add: numeral_eq_Suc)

lemma Suc_eq_numeral [simp]: "Suc n = numeral k \<longleftrightarrow> n = pred_numeral k"
  by (simp add: numeral_eq_Suc)

lemma less_numeral_Suc [simp]: "numeral k < Suc n \<longleftrightarrow> pred_numeral k < n"
  by (simp add: numeral_eq_Suc)

lemma less_Suc_numeral [simp]: "Suc n < numeral k \<longleftrightarrow> n < pred_numeral k"
  by (simp add: numeral_eq_Suc)

lemma le_numeral_Suc [simp]: "numeral k \<le> Suc n \<longleftrightarrow> pred_numeral k \<le> n"
  by (simp add: numeral_eq_Suc)

lemma le_Suc_numeral [simp]: "Suc n \<le> numeral k \<longleftrightarrow> n \<le> pred_numeral k"
  by (simp add: numeral_eq_Suc)

lemma diff_Suc_numeral [simp]: "Suc n - numeral k = n - pred_numeral k"
  by (simp add: numeral_eq_Suc)

lemma diff_numeral_Suc [simp]: "numeral k - Suc n = pred_numeral k - n"
  by (simp add: numeral_eq_Suc)

lemma max_Suc_numeral [simp]:
  "max (Suc n) (numeral k) = Suc (max n (pred_numeral k))"
  by (simp add: numeral_eq_Suc)

lemma max_numeral_Suc [simp]:
  "max (numeral k) (Suc n) = Suc (max (pred_numeral k) n)"
  by (simp add: numeral_eq_Suc)

lemma min_Suc_numeral [simp]:
  "min (Suc n) (numeral k) = Suc (min n (pred_numeral k))"
  by (simp add: numeral_eq_Suc)

lemma min_numeral_Suc [simp]:
  "min (numeral k) (Suc n) = Suc (min (pred_numeral k) n)"
  by (simp add: numeral_eq_Suc)

text {* For @{term case_nat} and @{term rec_nat}. *}

lemma case_nat_numeral [simp]:
  "case_nat a f (numeral v) = (let pv = pred_numeral v in f pv)"
  by (simp add: numeral_eq_Suc)

lemma case_nat_add_eq_if [simp]:
  "case_nat a f ((numeral v) + n) = (let pv = pred_numeral v in f (pv + n))"
  by (simp add: numeral_eq_Suc)

lemma rec_nat_numeral [simp]:
  "rec_nat a f (numeral v) =
    (let pv = pred_numeral v in f pv (rec_nat a f pv))"
  by (simp add: numeral_eq_Suc Let_def)

lemma rec_nat_add_eq_if [simp]:
  "rec_nat a f (numeral v + n) =
    (let pv = pred_numeral v in f (pv + n) (rec_nat a f (pv + n)))"
  by (simp add: numeral_eq_Suc Let_def)

text {* Case analysis on @{term "n < 2"} *}

lemma less_2_cases: "n < 2 \<Longrightarrow> n = 0 \<or> n = Suc 0"
  by (auto simp add: numeral_2_eq_2)

text {* Removal of Small Numerals: 0, 1 and (in additive positions) 2 *}
text {* bh: Are these rules really a good idea? *}

lemma add_2_eq_Suc [simp]: "2 + n = Suc (Suc n)"
  by simp

lemma add_2_eq_Suc' [simp]: "n + 2 = Suc (Suc n)"
  by simp

text {* Can be used to eliminate long strings of Sucs, but not by default. *}

lemma Suc3_eq_add_3: "Suc (Suc (Suc n)) = 3 + n"
  by simp

lemmas nat_1_add_1 = one_add_one [where 'a=nat] (* legacy *)

subsection {* Particular lemmas concerning @{term 2} *}

context linordered_field_inverse_zero
begin

lemma half_gt_zero_iff:
  "0 < a / 2 \<longleftrightarrow> 0 < a" (is "?P \<longleftrightarrow> ?Q")
  by (auto simp add: field_simps)

lemma half_gt_zero [simp]:
  "0 < a \<Longrightarrow> 0 < a / 2"
  by (simp add: half_gt_zero_iff)

end

subsection {* Numeral equations as default simplification rules *}

declare (in numeral) numeral_One [simp]
declare (in numeral) numeral_plus_numeral [simp]
declare (in numeral) add_numeral_special [simp]
declare (in neg_numeral) add_neg_numeral_simps [simp]
declare (in neg_numeral) add_neg_numeral_special [simp]
declare (in neg_numeral) diff_numeral_simps [simp]
declare (in neg_numeral) diff_numeral_special [simp]
declare (in semiring_numeral) numeral_times_numeral [simp]
declare (in ring_1) mult_neg_numeral_simps [simp]

subsection {* Setting up simprocs *}

lemma mult_numeral_1: "Numeral1 * a = (a::'a::semiring_numeral)"
  by simp

lemma mult_numeral_1_right: "a * Numeral1 = (a::'a::semiring_numeral)"
  by simp

lemma divide_numeral_1: "a / Numeral1 = (a::'a::field)"
  by simp

lemma inverse_numeral_1:
  "inverse Numeral1 = (Numeral1::'a::division_ring)"
  by simp

text{*Theorem lists for the cancellation simprocs. The use of a binary
numeral for 1 reduces the number of special cases.*}

lemma mult_1s:
  fixes a :: "'a::semiring_numeral"
    and b :: "'b::ring_1"
  shows "Numeral1 * a = a"
    "a * Numeral1 = a"
    "- Numeral1 * b = - b"
    "b * - Numeral1 = - b"
  by simp_all

setup {*
  Reorient_Proc.add
    (fn Const (@{const_name numeral}, _) $ _ => true
    | Const (@{const_name uminus}, _) $ (Const (@{const_name numeral}, _) $ _) => true
    | _ => false)
*}

simproc_setup reorient_numeral
  ("numeral w = x" | "- numeral w = y") = Reorient_Proc.proc

subsubsection {* Simplification of arithmetic operations on integer constants. *}

lemmas arith_special = (* already declared simp above *)
  add_numeral_special add_neg_numeral_special
  diff_numeral_special

(* rules already in simpset *)
lemmas arith_extra_simps =
  numeral_plus_numeral add_neg_numeral_simps add_0_left add_0_right
  minus_zero
  diff_numeral_simps diff_0 diff_0_right
  numeral_times_numeral mult_neg_numeral_simps
  mult_zero_left mult_zero_right
  abs_numeral abs_neg_numeral

text {*
  For making a minimal simpset, one must include these default simprules.
  Also include @{text simp_thms}.
*}

lemmas arith_simps =
  add_num_simps mult_num_simps sub_num_simps
  BitM.simps dbl_simps dbl_inc_simps dbl_dec_simps
  abs_zero abs_one arith_extra_simps

lemmas more_arith_simps =
  neg_le_iff_le
  minus_zero left_minus right_minus
  mult_1_left mult_1_right
  mult_minus_left mult_minus_right
  minus_add_distrib minus_minus mult.assoc

lemmas of_nat_simps =
  of_nat_0 of_nat_1 of_nat_Suc of_nat_add of_nat_mult

text {* Simplification of relational operations *}

lemmas eq_numeral_extra =
  zero_neq_one one_neq_zero

lemmas rel_simps =
  le_num_simps less_num_simps eq_num_simps
  le_numeral_simps le_neg_numeral_simps le_minus_one_simps le_numeral_extra
  less_numeral_simps less_neg_numeral_simps less_minus_one_simps less_numeral_extra
  eq_numeral_simps eq_neg_numeral_simps eq_numeral_extra

lemma Let_numeral [simp]: "Let (numeral v) f = f (numeral v)"
  -- {* Unfold all @{text let}s involving constants *}
  unfolding Let_def ..

lemma Let_neg_numeral [simp]: "Let (- numeral v) f = f (- numeral v)"
  -- {* Unfold all @{text let}s involving constants *}
  unfolding Let_def ..

declaration {*
let
  fun number_of thy T n =
    if not (Sign.of_sort thy (T, @{sort numeral}))
    then raise CTERM ("number_of", [])
    else Numeral.mk_cnumber (Thm.ctyp_of thy T) n;
in
  K (
    Lin_Arith.add_simps (@{thms arith_simps} @ @{thms more_arith_simps}
      @ @{thms rel_simps}
      @ @{thms pred_numeral_simps}
      @ @{thms arith_special numeral_One}
      @ @{thms of_nat_simps})
    #> Lin_Arith.add_simps [@{thm Suc_numeral},
      @{thm Let_numeral}, @{thm Let_neg_numeral}, @{thm Let_0}, @{thm Let_1},
      @{thm le_Suc_numeral}, @{thm le_numeral_Suc},
      @{thm less_Suc_numeral}, @{thm less_numeral_Suc},
      @{thm Suc_eq_numeral}, @{thm eq_numeral_Suc},
      @{thm mult_Suc}, @{thm mult_Suc_right},
      @{thm of_nat_numeral}]
    #> Lin_Arith.set_number_of number_of)
end
*}

subsubsection {* Simplification of arithmetic when nested to the right. *}

lemma add_numeral_left [simp]:
  "numeral v + (numeral w + z) = (numeral(v + w) + z)"
  by (simp_all add: add.assoc [symmetric])

lemma add_neg_numeral_left [simp]:
  "numeral v + (- numeral w + y) = (sub v w + y)"
  "- numeral v + (numeral w + y) = (sub w v + y)"
  "- numeral v + (- numeral w + y) = (- numeral(v + w) + y)"
  by (simp_all add: add.assoc [symmetric])

lemma mult_numeral_left [simp]:
  "numeral v * (numeral w * z) = (numeral(v * w) * z :: 'a::semiring_numeral)"
  "- numeral v * (numeral w * y) = (- numeral(v * w) * y :: 'b::ring_1)"
  "numeral v * (- numeral w * y) = (- numeral(v * w) * y :: 'b::ring_1)"
  "- numeral v * (- numeral w * y) = (numeral(v * w) * y :: 'b::ring_1)"
  by (simp_all add: mult.assoc [symmetric])

hide_const (open) One Bit0 Bit1 BitM inc pow sqr sub dbl dbl_inc dbl_dec

subsection {* code module namespace *}

code_identifier
  code_module Num \<rightharpoonup> (SML) Arith and (OCaml) Arith and (Haskell) Arith

end


theory Huntington
  imports Main
begin

(*
  A proof that a Huntington Algebra is a Boolean Algebra, and vice versa

  Following
    http://math.colgate.edu/~amann/MA/robbins_complete.pdf
*)

no_notation disj (infixr "\<or>" 30)
no_notation conj (infixr "\<and>" 35)

(*  Definition of a boolean algebra *)
locale boolean_algebra =
  fixes disj :: "'b \<Rightarrow> 'b \<Rightarrow> 'b" (infixl "\<or>" 70)
    and conj :: "'b \<Rightarrow> 'b \<Rightarrow> 'b" (infixl "\<and>" 70)
    and neg :: "'b \<Rightarrow> 'b"
    and tt :: "'b"
    and ff :: "'b"
  assumes assoc_disj [simp]: "a \<or> (b \<or> c) = a \<or> b \<or> c"
      and comm_disj: "a \<or> b = b \<or> a"
      and assoc_conj [simp]: "a \<and> (b \<and> c) = a \<and> b \<and> c"
      and comm_conj: "a \<and> b = b \<and> a"
      and absorb1 [simp]: "a \<or> (a \<and> b) = a"
      and absorb2 [simp]: "a \<and> (a \<or> b) = a"
      and distrib_disj_over_conj: "a \<or> (b \<and> c) = (a \<or> b) \<and> (a \<or> c)"
      and distrib_conj_over_disj: "a \<and> (b \<or> c) = (a \<and> b) \<or> (a \<and> c)"
      and lem: "a \<or> neg a = tt"
      and noncontra: "a \<and> neg a = ff"
begin

lemma ac_rule_disj: "z \<or> y \<or> x = z \<or> x \<or> y"
  by (metis assoc_disj comm_disj)

lemma ac_rule_conj: "z \<and> y \<and> x = z \<and> x \<and> y"
  by (metis assoc_conj comm_conj)

lemma idempotence_disj[simp]: "x \<or> x = x"
proof -
  have "x \<or> x = x \<or> (x \<and> (x \<or> x))"
    by (subst absorb2, rule refl)
  also have "... = x"
    by (subst absorb1[where a="x" and b="x \<or> x"], rule refl)
  finally show ?thesis .
qed

lemma idempotence_conj[simp]: "x \<and> x = x"
  by (metis absorb1 absorb2)

lemma y_disj_absorb_iff_x_conj_absorb: "x \<or> y = y \<longleftrightarrow> x \<and> y = x"
  by (metis absorb1 absorb2 comm_conj comm_disj)

lemma neutral_disj_ff[simp]: "x \<or> ff = x"
  using absorb1 noncontra by fastforce

lemma neutral_conj_tt[simp]: "x \<and> tt = x"
  using absorb2 lem by fastforce

lemma absorbing_disj_tt[simp]: "x \<or> tt = tt"
  by (metis absorb2 comm_conj comm_disj neutral_conj_tt)

lemma absorbing_conj_ff[simp]: "x \<and> ff = ff"
  by (metis absorb2 comm_conj comm_disj neutral_disj_ff)

definition is_complement where
  "is_complement a b \<equiv> HOL.conj (a \<and> b = ff) (a \<or> b = tt)"

lemma complement_unique: "\<lbrakk> is_complement x y; is_complement x z \<rbrakk> \<Longrightarrow> y = z"
  unfolding is_complement_def
  by (metis (full_types) distrib_disj_over_conj comm_conj comm_disj idempotence_disj neutral_conj_tt)

lemma complement_neg: "is_complement x (neg x)"
  unfolding is_complement_def
  by (simp add: lem noncontra)

lemma double_negation_elim[simp]: "neg (neg x) = x"
  by (metis complement_unique is_complement_def comm_conj comm_disj lem noncontra)

lemma neg_injective: "neg x = neg y \<Longrightarrow> x = y"
  by (metis double_negation_elim)

lemma neg_ff_is_tt[simp]: "neg ff = tt"
  by (metis lem noncontra y_disj_absorb_iff_x_conj_absorb)

lemma neg_tt_is_ff[simp]: "neg tt = ff"
  using double_negation_elim neg_ff_is_tt by blast

(* The De Morgan rules *)
lemma demorgan_over_disj[simp]: "neg (x \<or> y) = neg x \<and> neg y"
proof -
  have "(x \<or> y) \<and> (neg x \<and> neg y) = (x \<and> neg x \<and> neg y) \<or> (y \<and> neg x \<and> neg y)"
    by (metis absorbing_conj_ff assoc_conj comm_conj distrib_conj_over_disj noncontra)
  also have "... = (ff \<and> neg y) \<or> (ff \<and> neg x)"
    using ac_rule_conj noncontra by force
  also have "... = ff"
    by (metis absorb1 absorbing_conj_ff comm_conj)
  finally have A: "(x \<or> y) \<and> (neg x \<and> neg y) = ff" .

  have "(x \<or> y) \<or> (neg x \<and> neg y) = (x \<or> y \<or> neg x) \<and> (x \<or> y \<or> neg y)"
    by (metis distrib_disj_over_conj)
  also have "... = (y \<or> tt) \<and> (x \<or> tt)"
    by (metis ac_rule_disj assoc_disj lem)
  also have "... = tt"
    by simp
  finally have B: "(x \<or> y) \<or> (neg x \<and> neg y) = tt" .

  have "is_complement (x \<or> y) (neg x \<and> neg y)"
    using A B is_complement_def by blast
  thus ?thesis
    using is_complement_def complement_neg complement_unique by blast
qed

lemma demorgan_over_conj[simp]: "neg (x \<and> y) = neg x \<or> neg y"
  by (metis demorgan_over_disj double_negation_elim)

(* The Huntington Equation *)
lemma huntington: "neg (neg x \<or> neg y) \<or> neg (neg x \<or> y) = x"
  by (metis double_negation_elim demorgan_over_disj distrib_conj_over_disj lem neutral_disj_ff)

lemma disj_dual_conj: "a \<or> b = neg (neg a \<and> neg b)"
  by simp

lemma conj_dual_disj: "a \<and> b = neg (neg a \<or> neg b)"
  by simp

end

(* Definition of a Huntington Algebra *)
locale huntington_algebra =
  fixes disj :: "'b \<Rightarrow> 'b \<Rightarrow> 'b" (infixl "\<or>" 70)
    and neg :: "'b \<Rightarrow> 'b"
  assumes assoc[simp]: "a \<or> (b \<or> c) = a \<or> b \<or> c"
      and comm: "a \<or> b = b \<or> a"
      and huntington[simp]: "neg (neg x \<or> neg y) \<or> neg (neg x \<or> y) = x"
begin

lemma ac_rule: "z \<or> y \<or> x = z \<or> x \<or> y"
  by (metis assoc comm)

lemma xnx_eq_nxnnx[simp]: "neg x \<or> neg (neg x) = x \<or> neg x"
proof -
  have "neg x \<or> neg (neg x) = neg (neg (neg (neg x)) \<or> neg x) \<or> neg (neg (neg (neg x)) \<or> neg (neg x)) \<or> neg (neg (neg x) \<or> neg x) \<or> neg (neg (neg x) \<or> neg (neg x))"
    by (metis huntington[where y="neg x"] assoc comm)
  also have "... = neg (neg x \<or> neg (neg (neg x))) \<or> neg (neg x \<or> neg (neg x)) \<or> neg (neg (neg x) \<or> neg (neg (neg x))) \<or> neg (neg (neg x) \<or> neg (neg x))"
    proof (rule arg_cong[where f="\<lambda>z. z \<or> neg (neg (neg x) \<or> neg (neg x))"])
      show "neg (neg (neg (neg x)) \<or> neg x) \<or> neg (neg (neg (neg x)) \<or> neg (neg x)) \<or> neg (neg (neg x) \<or> neg x) =
           neg (neg x \<or> neg (neg (neg x))) \<or> neg (neg x \<or> neg (neg x)) \<or> neg (neg (neg x) \<or> neg (neg (neg x)))"
        by (metis ac_rule comm)
    qed
  also have "... = x \<or> neg x"
    by (metis huntington[where y="neg (neg x)"] assoc comm)
  finally show ?thesis .
qed

lemma double_negation_elim[simp]: "neg (neg x) = x"
proof -
  have "neg (neg x) = neg (neg (neg (neg x)) \<or> neg (neg x)) \<or> neg (neg (neg (neg x)) \<or> neg x)"
    by (simp only: huntington[symmetric, where y="neg x"])
  also have "... = neg (neg x \<or> neg (neg (neg x))) \<or> neg (neg x \<or> neg (neg x))"
    by (simp only: xnx_eq_nxnnx comm)
  also have "... = x"
    by (simp only: huntington[where y="neg (neg x)"])
  finally show ?thesis .
qed

lemma neg_injective: "neg x = neg y \<Longrightarrow> x = y"
  by (metis double_negation_elim)

(* Define conj as the dual operation of disj *)
definition conj (infixl "\<and>" 70) where
  "a \<and> b = neg (neg a \<or> neg b)"

lemma assoc_conj[simp]: "a \<and> (b \<and> c) = a \<and> b \<and> c"
  unfolding conj_def
  by simp

lemma comm_conj: "a \<and> b = b \<and> a"
  unfolding conj_def
  by (simp add: comm)

lemma ac_rule_conj: "z \<and> y \<and> x = z \<and> x \<and> y"
  by (metis assoc_conj comm_conj)

lemma demorgan_over_disj: "neg (x \<or> y) = neg x \<and> neg y"
  unfolding conj_def
  by simp

lemma demorgan_over_conj[simp]: "neg (x \<and> y) = neg x \<or> neg y"
  unfolding conj_def
  using double_negation_elim by blast

lemma huntington2[simp]: "(x \<and> y) \<or> (x \<and> neg y) = x"
  unfolding conj_def
  using huntington by force

lemma tt_unique: "x \<or> neg x = y \<or> neg y"
proof -
  have "x \<or> neg x = (x \<and> neg y) \<or> (x \<and> neg (neg y)) \<or> (neg x \<and> neg y) \<or> (neg x \<and> neg (neg y))"
    by (metis assoc huntington2[where y="neg y"])
  also have "... = (neg y \<and> x) \<or> (neg y \<and> neg x) \<or> (y \<and> x) \<or> (y \<and> neg x)"
    by (simp only: double_negation_elim comm_conj assoc ac_rule)
  also have "... = y \<or> neg y"
    by (metis assoc comm huntington2)
  finally show ?thesis .
qed

lemma ff_unique: "x \<and> neg x = y \<and> neg y"
  unfolding conj_def
  by (metis tt_unique)

(* define tt as excluded middle *)
definition tt where
  "tt \<equiv> (THE y. \<forall>x. x \<or> neg x = y)"

definition ff where
  "ff \<equiv> neg tt"

(* show non-contradiction is false *)
lemma noncontra[simp]: "x \<and> neg x = ff"
proof -
  have "\<exists>!y. (\<forall>x. x \<or> neg x = y)"
    by (metis tt_unique)
  hence "\<forall>x. x \<or> neg x = (THE x. \<forall>xa. xa \<or> neg xa = x)"
    by (rule theI')
  hence "neg x \<or> x = (THE y. \<forall>x. x \<or> neg x = y)"
    by (metis comm)
  thus "x \<and> neg x = ff"
    unfolding ff_def tt_def
    by (simp add: conj_def)
qed

(* Show law of excluded middle *)
lemma lem[simp]: "x \<or> neg x = tt"
  by (metis demorgan_over_disj ff_def neg_injective noncontra)

lemma tt_dup[simp]: "tt \<or> tt = tt"
  by (metis assoc huntington demorgan_over_conj double_negation_elim noncontra xnx_eq_nxnnx)

lemma ff_dup[simp]: "ff \<or> ff = ff"
proof -
  have "ff \<or> ff = neg (tt \<or> tt) \<or> neg tt"
    using ff_def tt_dup by simp
  also have "... = neg tt"
    by (metis ff_def huntington2 demorgan_over_disj noncontra)
  also have "... = ff"
    by (simp only: ff_def)
  finally show "ff \<or> ff = ff" .
qed

lemma neutral_disj_ff[simp]: "x \<or> ff = x"
  by (metis assoc ff_dup huntington2 noncontra)

lemma neutral_conj_tt[simp]: "x \<and> tt = x"
  using ff_def neg_injective neutral_disj_ff by simp

lemma idempotence_disj[simp]: "x \<or> x = x"
  by (metis demorgan_over_disj huntington2 neg_injective neutral_disj_ff noncontra)

lemma idempotence_conj[simp]: "x \<and> x = x"
  by (metis huntington2 neutral_disj_ff noncontra)

lemma absorbing_disj_tt[simp]: "x \<or> tt = tt"
  by (metis assoc idempotence_disj lem)

lemma absorbing_conj_ff[simp]: "x \<and> ff = ff"
  by (metis ac_rule_conj comm_conj idempotence_conj noncontra)

lemma absorb1 [simp]: "a \<or> (a \<and> b) = a"
  by (metis comm huntington2 assoc idempotence_disj)

lemma absorb2 [simp]: "a \<and> (a \<or> b) = a"
  by (simp add: demorgan_over_disj neg_injective)

(* Show the distributive laws *)
lemma distrib_conj_over_disj: "x \<and> (y \<or> z) = (x \<and> y) \<or> (x \<and> z)"
proof -
  have "x \<and> (y \<or> z) = (x \<and> (y \<or> z) \<and> y) \<or> (x \<and> (y \<or> z) \<and> neg y)"
    by simp
  also have "... = (x \<and> y) \<or> (x \<and> (y \<or> z) \<and> neg y)"
    by (metis absorb2 ac_rule_conj comm_conj)
  also have "... = (x \<and> y \<and> z) \<or> (x \<and> y \<and> neg z) \<or> (x \<and> neg y \<and> z \<and> (y \<or> z)) \<or> (x \<and> (y \<or> z) \<and> neg y \<and> neg z)"
      by (metis ac_rule_conj assoc huntington2)
  also have "... = (x \<and> y \<and> z) \<or> (x \<and> y \<and> neg z) \<or> (x \<and> neg y \<and> z) \<or> (x \<and> (y \<or> z) \<and> neg (y \<or> z))"
    proof -
      have "x \<and> neg y \<and> z = x \<and> neg y \<and> z \<and> (y \<or> z)"
        by (metis absorb2 assoc_conj comm)
      then show ?thesis
        using demorgan_over_disj by force
    qed
  also have "... = (x \<and> y \<and> z) \<or> (x \<and> y \<and> neg z) \<or> (x \<and> neg y \<and> z)"
    by (metis absorbing_conj_ff assoc_conj neutral_disj_ff noncontra)
  also have "... = (x \<and> y \<and> z) \<or> (x \<and> y \<and> neg z) \<or> (((x \<and> z) \<and> y) \<or> ((x \<and> z) \<and> neg y))"
    by (simp add: ac_rule_conj)
  also have "... = (x \<and> y) \<or> (x \<and> z)"
    by (simp only: huntington2)
  finally show ?thesis .
qed

lemma distrib_disj_over_conj: "a \<or> (b \<and> c) = (a \<or> b) \<and> (a \<or> c)"
  by (metis conj_def demorgan_over_disj distrib_conj_over_disj double_negation_elim)
end

(*
  The main theorems

  Given a boolean algebra, we have a huntington algebra
*)
theorem B_imp_H: "boolean_algebra disj' conj' neg' tt ff \<Longrightarrow> huntington_algebra disj' neg'"
proof -
  assume B: "boolean_algebra disj' conj' neg' tt ff"
  show ?thesis
  proof unfold_locales
    show "\<And>a b c. disj' a (disj' b c) = disj' (disj' a b) c"
      using B boolean_algebra.assoc_disj by metis
  next
    show "\<And>a b. disj' a b = disj' b a"
      using B boolean_algebra.comm_disj by metis
  next
    show "\<And>x y. disj' (neg' (disj' (neg' x) (neg' y))) (neg' (disj' (neg' x) y)) = x"
      using B boolean_algebra.huntington by metis
  qed
qed

(*
  The main theorems

  Given a huntington algebra, we can construct a boolean algebra
*)
theorem H_imp_B: "\<lbrakk> huntington_algebra disj' neg'; conj' = huntington_algebra.conj disj' neg';
                    tt = huntington_algebra.tt disj' neg'; ff = huntington_algebra.ff disj' neg' \<rbrakk> \<Longrightarrow>
                  boolean_algebra disj' conj' neg' tt ff"
proof -
  assume H: "huntington_algebra disj' neg'"
     and A: "conj' = huntington_algebra.conj disj' neg'"
     and T: "tt = huntington_algebra.tt disj' neg'"
     and F: "ff = huntington_algebra.ff disj' neg'"

  show ?thesis
  proof unfold_locales
    show "\<And>a b c. disj' a (disj' b c) = disj' (disj' a b) c"
      by (meson H huntington_algebra.assoc)
  next
    show "\<And>a b. disj' a b = disj' b a"
      by (meson H huntington_algebra.comm)
  next
    show "\<And>a b c. conj' a (conj' b c) = conj' (conj' a b) c"
      by (simp only: H A huntington_algebra.assoc_conj)
  next
    show "\<And>a b. conj' a b = conj' b a"
      by (simp only: A H huntington_algebra.comm_conj)
  next
    show  "\<And>a b. disj' a (conj' a b) = a"
      by (simp only: H A huntington_algebra.absorb1)
  next
    show  "\<And>a b. conj' a (disj' a b) = a"
      by (simp only: H A huntington_algebra.absorb2)
  next
    show "\<And>a b c. disj' a (conj' b c) = conj' (disj' a b) (disj' a c)"
      by (simp only: H A huntington_algebra.distrib_disj_over_conj)
  next
    show  "\<And>a b c. conj' a (disj' b c) = disj' (conj' a b) (conj' a c)"
      by (simp only: H A huntington_algebra.distrib_conj_over_disj)
  next
    show "\<And>a. disj' a (neg' a) = tt"
      by (simp only: H T huntington_algebra.lem)
  next
    show "\<And>a. conj' a (neg' a) = ff"
      by (simp only: H A F huntington_algebra.noncontra)
  qed
qed

end


section\<open>Perfect Number Theorem\<close>

theory Perfect
imports Sigma
begin

definition  perfect :: "nat => bool" where
  "perfect m \<equiv> m>0 \<and> 2*m = sigma m"

theorem perfect_number_theorem:
  assumes even: "even m" and perfect: "perfect m"
  shows "\<exists> n . m = 2^n*(2^(n+1) - 1) \<and> prime ((2::nat)^(n+1) - 1)"
proof
  from perfect have m0: "m>0" by (auto simp add: perfect_def)

  let ?n = "multiplicity 2 m"
  let ?A = "m div 2^?n"
  let ?np = "(2::nat)^(?n+1) - 1"

  from even m0 have n1: "?n >= 1 " by (simp add: multiplicity_geI)

  have  "2^?n dvd m" by (rule multiplicity_dvd)
  hence "m = 2^?n*?A" by (simp only: dvd_mult_div_cancel)
  with m0 have mdef: "m=2^?n*?A \<and> coprime 2 ?A"
    using multiplicity_decompose [of m 2] by simp
  moreover with m0 have a0: "?A>0" by (metis nat_0_less_mult_iff)
  moreover
  { from perfect have "2*m=sigma(m)" by (simp add: perfect_def)
    with mdef have "2^(?n+1)*?A=sigma(2^?n*?A)" by auto
  } ultimately have "2^(?n+1)*?A=sigma(2^?n)*sigma(?A)"
    by (simp add: sigma_semimultiplicative)
  hence formula: "2^(?n+1)*?A=(?np)*sigma(?A)"
    by (simp only: sigma_prime_power_two)

  from n1 have "(2::nat)^(?n+1) >= 2^2" by (simp only: power_increasing)
  hence nplarger: "?np>= 3" by auto

  let ?B = "?A div ?np"

  from formula have "?np dvd ?A * 2^(?n+1)"
    by (auto simp add: ac_simps)
  then have "?np dvd ?A"
    using coprime_diff_one_left_nat [of "2 ^ (multiplicity 2 m + 1)"]
    by (auto simp add: coprime_dvd_mult_left_iff)
  then have bdef: "?np*?B = ?A"
    by simp
  with a0 have  b0: "?B>0" by (metis gr0I mult_is_0)

  from nplarger a0 have bsmallera: "?B < ?A" by auto

  have "?B = 1"
  proof (rule ccontr)
    assume "?B \<noteq> 1"
    with b0 bsmallera have "1<?B" "?B<?A" by auto
    moreover from bdef have "?B : divisors ?A"
      by (metis divisors_eq_dvd dvd_triv_right)
    ultimately have "1+?B+?A \<le> sigma ?A"
      using sigma_third_divisor by blast
    with nplarger have "?np*(1+?A+?B) \<le> ?np*(sigma ?A)"
      by (auto simp only: nat_mult_le_cancel1)
    with bdef have "?np+?A*?np + ?A*1 \<le> ?np*(sigma ?A)"
      by (simp add: mult.commute distrib_left)
    hence "?np+?A*(?np + 1) \<le> ?np*(sigma ?A)" by (simp only:add_mult_distrib2)
    with nplarger have "2^(?n+1)*?A < ?np*(sigma ?A)" by(simp add:mult.commute)
    with formula show "False" by auto
  qed

  with bdef have adef: "?A=?np" by auto
  with formula have "?np*2^(?n+1) = ?np * sigma(?A)" by auto
  with nplarger adef have "?A + 1=sigma(?A)" by auto
  with a0 have "prime ?A"
    by (simp add: prime_iff_sigma)
  with mdef adef show "m = 2^?n * ?np \<and> prime ?np" by simp
qed

theorem Euclid_book9_prop36:
  assumes p: "prime (2^(n+1) - (1::nat))"
  shows "perfect (2 ^ n * (2 ^ (n + 1) - 1))"
  unfolding perfect_def
proof (intro conjI; simp)
  from assms show "2 * 2^n > Suc 0" by (auto simp add: prime_nat_iff)
next
  have "2 \<noteq> ((2::nat)^(n+1) - 1)" by simp arith
  then have "coprime (2::nat) (2^(n+1) - 1)"
    by (metis p primes_coprime_nat two_is_prime_nat)
  moreover with p have "2^(n+1) - 1 > (0::nat)"
    by (auto simp add: prime_nat_iff)
  ultimately have  "sigma (2^n*(2^(n+1) - 1)) = (sigma(2^n))*(sigma(2^(n+1) - 1))"
    by (metis sigma_semimultiplicative two_is_prime_nat)
  also from assms have "... = (sigma(2^(n)))*(2^(n+1))"
    by (auto simp add: prime_imp_sigma)
  also have "... = (2^(n+1) - 1)*(2^(n+1))" by(simp add: sigma_prime_power_two)
  finally show "2*(2^n * (2*2^n - Suc 0)) = sigma(2^n*(2*2^n - Suc 0))" by auto
qed

end


\<^marker>\<open>creator Florian Kessler\<close>

theory Memory
  imports Big_Step_Small_Step_Equivalence "HOL-Library.Discrete" Max_Constant
begin

text \<open> We give a definition for the amount of memory that an IMP- program uses during its
       execution, and show that there is a bound that is linear in the number of steps the
       execution takes. \<close>

definition bit_length where "bit_length x \<equiv>  Discrete.log x + 1"

lemma bit_length_monotonic: "x \<le> y \<Longrightarrow> bit_length x \<le> bit_length y"
  by(auto simp: bit_length_def log_le_iff)

lemma bit_length_of_power_of_two: "y > 0 \<Longrightarrow> bit_length (2 ^ x * y) = x + bit_length y"
  apply(induction x)
  by(auto simp: bit_length_def mult.assoc)

text \<open> The amount of memory a single state uses. Note that we only consider registers that
       can be accessed by the program, hence the additional parameter 'c' in this definition. \<close>

definition state_memory :: "com \<Rightarrow> state \<Rightarrow> nat" where
"state_memory c s = fold (+) (map (\<lambda> r. bit_length (s r)) (remdups (all_variables c))) 0"

text \<open> We define something to be a memory bound for a program and an initial state, if it
       bounds every state that is reachable. \<close>

definition is_memory_bound :: "com \<Rightarrow> state \<Rightarrow> nat \<Rightarrow> bool" where
"is_memory_bound c s n \<equiv> (\<forall> t c' s'. (c, s) \<rightarrow>\<^bsup>t\<^esup> (c', s') \<longrightarrow> state_memory c' s' \<le> n)"

lemma x_leq_fold_max_l_x: "(x :: nat) \<le> fold max l x"
proof(induction l arbitrary: x)
  case (Cons a l)
  then show ?case by (auto intro: le_trans[where ?j = "max a x"])
qed auto

lemma fold_max_l_x_le_l_y: "(x :: nat) \<le> y \<Longrightarrow> fold max l x \<le> fold max l y"
  by (induction l arbitrary: x y) auto

lemma sum_of_list_leq_length_times_max: "length l * fold max l (0 :: nat) \<le> k \<Longrightarrow> fold (+) l 0 \<le> k"
proof(induction l arbitrary: k)
  case (Cons a l)
  let ?k = "length l * fold max l (0 :: nat)"
  have "fold (+) (a # l) 0 = a + fold (+) l 0" by (simp add: fold_plus_sum_list_rev)
  also have "... \<le> a + ?k" using Cons.IH[where ?k="?k"] by simp
  also have "... \<le> fold max l a + ?k"
    using x_leq_fold_max_l_x by simp
  also have "... \<le> fold max l a + length l * fold max l a"
    using fold_max_l_x_le_l_y by simp
  finally show ?case using Cons by auto
qed auto

lemma max_bit_length_bit_length: "max (bit_length x) (bit_length y) = bit_length (max x y)"
  by (simp add: bit_length_def log_mono max_of_mono)

lemma fold_max_map_bit_length: "l \<noteq> []
  \<Longrightarrow> fold max (map (\<lambda>x. bit_length (f x)) l) (bit_length a) = bit_length (fold max (map f l) a)"
proof(induction l arbitrary: a)
  case (Cons a l)
  then show ?case by (cases l) (auto simp: max_bit_length_bit_length)
qed auto

lemma fold_max_map_bit_length':
  assumes "l \<noteq> []"
  shows "fold max (map (\<lambda>x. bit_length (f x)) l) 0 = bit_length (fold max (map f l) 0)"
  using assms proof(induction l)
  case (Cons a l)
  then show ?case
    apply(auto simp: max_bit_length_bit_length)
    apply(cases l)
     apply simp
    apply(rule fold_max_map_bit_length )
    by simp
qed auto

lemma remdups_non_empty_iff[simp]: "remdups l \<noteq> [] \<longleftrightarrow> l \<noteq> []"
  by (induction l) auto

lemma fold_max_map_le_Max_range:
  "finite (range (f :: _ \<Rightarrow> nat)) \<Longrightarrow> fold max (map f l) x \<le> max x (Max (range f))"
  apply(induction l arbitrary: x)
   apply auto
  by (smt Max.in_idem max.assoc max.commute rangeI)

lemma fold_max_map_le_Max_range':
  "finite (range (f :: _ \<Rightarrow> nat)) \<Longrightarrow> fold max (map f l) 0 \<le> Max (range f)"
  using fold_max_map_le_Max_range
  by (metis max_0L)

lemma Max_register_bounds_state_memory: "finite (range s)
  \<Longrightarrow> state_memory c s \<le> num_variables c * bit_length (Max (range s))"
  by(auto simp: num_variables_def fold_max_map_bit_length' state_memory_def
          intro!: bit_length_monotonic fold_max_map_le_Max_range' sum_of_list_leq_length_times_max)

lemma finite_range_stays_finite_step: "(c1, s1) \<rightarrow> (c2, s2) \<Longrightarrow> finite (range s1)
  \<Longrightarrow> finite (range s2)"
proof(induction c1 s1 c2 s2 rule: small_step_induct)
  case (Assign x a s)
  then show ?case
    by (auto intro: finite_subset[where ?B = "range s"])
qed auto

lemma finite_range_stays_finite: "(c1, s1) \<rightarrow>\<^bsup>t\<^esup> (c2, s2) \<Longrightarrow> finite (range s1)
  \<Longrightarrow> finite (range s2)"
  apply(induction t arbitrary: c1 s1)
   using finite_range_stays_finite_step by auto

lemma Max_insert_le_when: "finite (range (s :: vname \<Rightarrow> nat)) \<Longrightarrow> y \<le> r \<Longrightarrow>  Max (range s) \<le> r
  \<Longrightarrow> Max (range (s(x := y))) \<le> r"
  apply auto
  apply(subst Max_insert)
    apply(metis Un_infinite image_Un sup_top_right)
   apply(auto)
  apply(subst Max_le_iff)
    apply(metis Un_infinite image_Un sup_top_right)
  by auto

lemma le_then_sub_le: "(a :: nat) \<le> b \<Longrightarrow> a - c \<le> b" by simp

lemma one_step_Max_increase: "(c1, s1) \<rightarrow> (c2, s2) \<Longrightarrow> finite (range s1)
  \<Longrightarrow> Max (range s2) \<le> 2 * (max (Max (range s1)) (max_constant c1))"
proof (induction c1 s1 c2 s2 rule: small_step_induct)
  case (Assign x a s)
  then show ?case
  proof (cases a)
    case (A x1)
    then show ?thesis
      using \<open>finite (range s)\<close>
      by (cases x1; fastforce simp: numeral_2_eq_2 trans_le_add1 intro: Max_insert_le_when)
  next
    case (Plus x1 x2)
    then show ?thesis
      using \<open>finite (range s)\<close>
      apply(cases x1; cases x2; auto simp only: intro!: Max_insert_le_when)
      by(auto simp add: numeral_2_eq_2 max.coboundedI1 intro!: add_le_mono)
  next
    case (Sub x1 x2)
    then show ?thesis
      using \<open>finite (range s)\<close>
      apply(cases x1; cases x2; auto simp only: intro!: Max_insert_le_when)
      by(auto simp: numeral_2_eq_2 max.coboundedI1
              intro!: le_then_sub_le trans_le_add1)
  next
    case (Parity x1)
    then show ?thesis
    proof (cases x1)
      case (N x1)
      then show ?thesis
        using \<open>finite (range s)\<close> Parity
        apply (auto simp only: intro!: Max_insert_le_when)
        by auto
    next
      case (V x2)
      then show ?thesis
        using \<open>finite (range s)\<close> Parity
        apply(auto simp only: intro!: Max_insert_le_when)
        apply auto
        apply(rule le_trans[where ?j="s x2"])
        by(auto simp add: numeral_2_eq_2 intro!: trans_le_add1)
    qed
  next
    case (RightShift x1)
    then show ?thesis
    proof (cases x1)
      case (N x1)
      then show ?thesis
        using \<open>finite (range s)\<close> RightShift
        apply (auto simp only: intro!: Max_insert_le_when)
        by auto
    next
      case (V x2)
      then show ?thesis
        using \<open>finite (range s)\<close> RightShift
        apply(auto simp only: intro!: Max_insert_le_when)
        apply auto
        apply(rule le_trans[where ?j="s x2"])
        by(auto simp add: numeral_2_eq_2 intro!: trans_le_add1)
    qed
  qed
next
  case (Seq2 c\<^sub>1 s c\<^sub>1' s' c\<^sub>2)
  then show ?case by simp
qed (linarith)+

lemma Max_increase: "(c1, s1) \<rightarrow>\<^bsup>t\<^esup> (c2, s2) \<Longrightarrow> finite (range s1)
  \<Longrightarrow> Max (range s2) \<le> (2 ^ t) * (max (Max (range s1)) (max_constant c1))"
proof (induction t arbitrary: c1 s1)
  case (Suc t)
  obtain c1' s1' where "(c1, s1) \<rightarrow> (c1', s1')" "(c1', s1') \<rightarrow>\<^bsup>t\<^esup> (c2, s2)"
    using \<open>(c1, s1) \<rightarrow>\<^bsup>Suc t\<^esup> (c2, s2)\<close>
    by auto
  have "Max (range s2) \<le> (2 ^ t) * (max (Max (range s1')) (max_constant c1'))"
    using Suc.IH \<open>finite (range s1)\<close>
      \<open>(c1', s1') \<rightarrow>\<^bsup>t\<^esup> (c2, s2)\<close> \<open>(c1, s1) \<rightarrow> (c1', s1')\<close>
      finite_range_stays_finite_step
    by presburger
  also have "... \<le> (2 ^ t) *
    (max (2 * (max (Max (range s1)) (max_constant c1))) (max_constant c1'))"
    using one_step_Max_increase[OF \<open>(c1, s1) \<rightarrow> (c1', s1')\<close> \<open>finite (range s1)\<close>]
    by simp
  also have "... \<le> (2 ^ Suc t) *
      (max (max (Max (range s1)) (max_constant c1))) (max_constant c1')"
    by simp
  also have "... \<le> (2 ^ Suc t) * max (Max (range s1)) (max_constant c1)"
    using max_constant_not_increasing_step[OF \<open>(c1, s1) \<rightarrow> (c1', s1')\<close>]
    by simp
  finally show ?case by simp
qed auto

text \<open> We show that there always is a linear bound for the memory consumption. \<close>

lemma linear_bound: "(c1, s1) \<Rightarrow>\<^bsup>t\<^esup> s2 \<Longrightarrow> finite (range s1)
  \<Longrightarrow> is_memory_bound c1 s1 ((num_variables c1)
      * (t + bit_length (max 1 (max (Max (range s1)) (max_constant c1)))))"
  apply (simp only: is_memory_bound_def)
proof
  let ?b = "(num_variables c1)
      * (t + bit_length (max 1 (max (Max (range s1)) (max_constant c1))))"

  assume "(c1, s1) \<Rightarrow>\<^bsup>t\<^esup> s2" "finite (range s1)"
  fix t'
  show "\<forall>c' s'.
             (c1, s1) \<rightarrow>\<^bsup>t'\<^esup> (c', s') \<longrightarrow>
             state_memory c' s' \<le> ?b"
  proof
    fix c'
    show "\<forall>s'. (c1, s1) \<rightarrow>\<^bsup>t'\<^esup> (c', s') \<longrightarrow>
               state_memory c' s' \<le> ?b"
    proof
      fix s'
      show "(c1, s1) \<rightarrow>\<^bsup>t'\<^esup> (c', s') \<longrightarrow>
               state_memory c' s' \<le> ?b"
      proof
        assume "(c1, s1) \<rightarrow>\<^bsup>t'\<^esup> (c', s')"

        hence "finite (range s')"
          using \<open>finite (range s1)\<close> finite_range_stays_finite
          by auto

        have "Max (range s') \<le> (2 ^ t') * (max (Max (range s1)) (max_constant c1))"
          using Max_increase \<open>(c1, s1) \<rightarrow>\<^bsup>t'\<^esup> (c', s')\<close> \<open>finite (range s1)\<close>
          by auto
        also have "... \<le> (2 ^ t) * (max (Max (range s1)) (max_constant c1))"
          using small_step_cant_run_longer_than_big_step
            \<open>(c1, s1) \<Rightarrow>\<^bsup>t\<^esup> s2\<close> \<open>(c1, s1) \<rightarrow>\<^bsup>t'\<^esup> (c', s')\<close>
          by simp

        finally have "state_memory c' s' \<le> num_variables c'
          * bit_length ((2 ^ t) * (max (Max (range s1)) (max_constant c1)))"
          using Max_register_bounds_state_memory[OF \<open>finite (range s')\<close>]
          by (meson bit_length_monotonic dual_order.trans mult_le_cancel1)
        also have "... \<le>  num_variables c'
          * bit_length ((2 ^ t) * (max 1 (max (Max (range s1)) (max_constant c1))))"
          using bit_length_monotonic
          by simp

        finally show "state_memory c' s' \<le> ?b"
          using num_variables_not_increasing[OF \<open>(c1, s1) \<rightarrow>\<^bsup>t'\<^esup> (c', s')\<close>] order_trans
          by(fastforce simp: bit_length_of_power_of_two)
      qed
    qed
  qed
qed

end


theory Skip
    imports "Extras"
begin

text \<open>Suppressing an element from a function\<close>

definition skip :: "'a \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> ('a \<Rightarrow> 'a)" where
"skip z f \<equiv> \<lambda> x. (if x = z then z else (if f x = z then f z else f x))"

lemma skip_id [simp]: "skip z f z = z"
  unfolding skip_def by simp

lemma skip_z_eq_fz: "f z = z \<Longrightarrow> x \<noteq> z \<Longrightarrow> (skip z f) x = f x"
  unfolding skip_def by simp

lemma skip_fz [simp]: "f x = z \<Longrightarrow> skip z f x = f z"
  by (metis skip_def)

lemma skip_invariant: "x \<noteq> z \<Longrightarrow> f x \<noteq> z \<Longrightarrow> skip z f x = f x"
  unfolding skip_def by simp

lemma inj_skip: "inj f \<Longrightarrow> inj (skip z f)"
  unfolding skip_def by (smt (verit, ccfv_SIG) injD inj_on_def)

lemma bij_skip: "bij f \<Longrightarrow> bij (skip z f)"
  by (metis bij_def inj_skip skip_def surj_def)

lemma skip_permutes:
  assumes "f permutes S"
  shows "skip z f permutes S - {z}"
proof (simp add: permutes_def; rule conjI)
  show "\<forall>x. (x \<in> S \<longrightarrow> x = z) \<longrightarrow> skip z f x = x"
    by (metis assms permutes_def skip_def)
  have "bij (skip z f)"
    by (meson assms bij_skip permutes_bij)
  then show "\<forall>y. \<exists>!x. skip z f x = y"
    by (simp add: bij_iff)
qed

section \<open>Suppressing an element from a permutation\<close>

definition skip_perm :: "'a \<Rightarrow> 'a perm \<Rightarrow> 'a perm" where
"skip_perm \<equiv> (\<lambda>z (p ::'a perm). Perm (skip z p))"

lemma apply_skip_perm: "(\<langle>$\<rangle>) (skip_perm z p) = skip z p"
unfolding skip_perm_def
proof
  obtain A where "A = set_perm p" by simp
  fix x show "(Perm (skip z p)) \<langle>$\<rangle> x = skip z p x"
  proof (rule apply_perm_Perm)
    show "finite A" by (simp add: \<open>A = set_perm p\<close>)
    show "inj_on (skip z ((\<langle>$\<rangle>) p)) A"
      by (meson inj_skip inj_on_apply_perm inj_on_subset subset_UNIV)
    show "\<And>x. x \<in> A \<Longrightarrow> skip z p x \<in> A"
      by (metis \<open>A = set_perm p\<close> apply_set_perm skip_def)
    show "\<And>x. x \<notin> A \<Longrightarrow> skip z p x = x"
      by (metis \<open>A = set_perm p\<close> in_set_permI skip_def)
   qed
 qed

lemma skip_perm_invariant: "x \<noteq> z \<Longrightarrow> p \<langle>$\<rangle> x \<noteq> z \<Longrightarrow> skip_perm z p x = p \<langle>$\<rangle> x"
  by (simp add: skip_invariant apply_skip_perm)

lemma skip_perm_notin: "z \<notin> set_perm p \<Longrightarrow> skip_perm z p = p"
proof -
  assume "z \<notin> set_perm p"
  then have "p \<langle>$\<rangle> z = z"
    by blast
  then have "skip z p = p"
    by (metis perm_eq_iff skip_id skip_z_eq_fz apply_skip_perm)
  then show ?thesis
    by (simp add: perm.apply_perm_inverse skip_perm_def)
qed

lemma skip_perm_permutes: "(p :: 'a perm) permutes S \<Longrightarrow> skip_perm z p permutes S - {z}"
  by (simp add: apply_skip_perm skip_permutes)

lemma set_perm_skip_id_cycle: "p \<langle>$\<rangle> z = z \<Longrightarrow> set_perm p = set_perm (skip_perm z p)"
  by (simp add: in_set_perm skip_perm_notin)

lemma set_perm_skip_2_cycle:
  fixes p :: "'a perm"
  assumes "p z \<noteq> z" "p (p z) = z"
  shows "set_perm p = set_perm (skip_perm z p) \<union> {z, p z}"
proof (rule subset_antisym; rule subsetI)
  fix x assume "x \<in> set_perm p"
  then have "x \<noteq> z \<and> x \<noteq> p z \<Longrightarrow> x \<in> set_perm (skip_perm z p)"
    by (metis apply_perm_neq_idI apply_skip_perm in_set_permI skip_def)
  then show "x \<in> set_perm (skip_perm z p) \<union> {z, p z}"
    by auto
next
  show "x \<in> set_perm p" if "x \<in> set_perm (skip_perm z p) \<union> {z, p z}" for x
    by (metis that Un_insert_right apply_perm_eq_same_iff(2) apply_skip_perm
        assms boolean_algebra_cancel.sup0 insert_iff skip_invariant)
qed

lemma set_perm_skip_n_cycle:
  fixes p :: "'a perm"
  assumes "p z \<noteq> z" "p (p z) \<noteq> z"
  shows "set_perm p = set_perm (skip_perm z p) \<union> {z}"
proof (rule subset_antisym; rule subsetI)
  fix x assume "x \<in> set_perm p"
  then show "x \<in> set_perm (skip_perm z p) \<union> {z}"
    by (metis apply_perm_eq_same_iff(2) apply_skip_perm assms(2) inf_sup_aci(5)
        insert_iff insert_is_Un skip_fz skip_invariant)
next
  fix x assume "x \<in> set_perm (skip_perm z p) \<union> {z}"
  then show "x \<in> set_perm p"
    by (metis UnE apply_perm_neq_idI apply_skip_perm assms(1) empty_iff in_set_permI
        insert_iff skip_invariant)
qed

lemma cycles_imp_cycles_skip:
  assumes "c \<in> cycles_of_perm p" (is "c \<in> ?C")
      and "c \<notin> cycles_of_perm (skip_perm z p)" (is "c \<notin> ?C'")
  shows "\<And> x. x \<noteq> c \<Longrightarrow> x \<in> cycles_of_perm p \<Longrightarrow> x \<in> cycles_of_perm (skip_perm z p)"
proof -
  have "z \<in> set_cycle c"
    by (smt (verit, ccfv_threshold) assms apply_cycle_in_set_iff apply_perm_cycle apply_skip_perm
        cycles_of_perm_altdef mem_Collect_eq skip_invariant)
  then have "c = perm_orbit p z"
    using assms(1) perm_orbit_eqI by fastforce
  have disj: "disjoint_cycles ?C" by auto
  fix x assume "x \<noteq> c"
  then show "x \<in> ?C \<Longrightarrow> x \<in> ?C'"
    by (smt (verit, ccfv_threshold) \<open>c \<in> ?C\<close> disj(1) IntI \<open>z \<in> set_cycle c\<close> apply_cycle_cycles_of_perm
        apply_perm_cycle apply_set_perm apply_skip_perm cycle_perm_same_iff cycles_of_perm_altdef
        cycles_of_perm_of_cycles disjoint_cycles_insert empty_iff insertE mem_Collect_eq
        mk_disjoint_insert perm_of_cycles_not_in set_perm_cycle skip_invariant)
qed

lemma skip_perm_cycle_invariant:
  assumes "x \<notin> set_cycle (perm_orbit p z)" "x \<in> set_perm p"
  shows "perm_orbit (skip_perm z p) x = perm_orbit p x"
  by (smt (verit) apply_cycle_cycles_of_perm apply_perm_cycle apply_perm_neq_idI assms
      cycles_imp_cycles_skip apply_skip_perm perm_orbit_eqI
      perm_orbit_in_cycles_of_perm skip_id skip_perm_notin start_in_perm_orbit_iff)

lemma perm_orbit_notin_skip_perm: "perm_orbit p z \<notin> cycles_of_perm (skip_perm z p)"
  by (metis apply_cycle_cycles_of_perm apply_cycle_perm_orbit' apply_skip_perm
      id_cycle_eq_perm_orbit_iff id_cycle_not_in_cycles_of_perm skip_id start_in_perm_orbit_iff)

theorem remove1_cycle_orbit: "delete_cycle z (perm_orbit p z) = perm_orbit (skip_perm z p) (p z)"
proof (rule cycle_eqI; rule; auto simp: conjI apply_cycle_delete)
  show "p \<langle>$\<rangle> z = z \<Longrightarrow> z = (skip_perm z p) \<langle>$\<rangle> z"
    by (simp add: apply_skip_perm)
  fix x
  show "apply_cycle (perm_orbit p z) x = z \<Longrightarrow> x \<noteq> z \<Longrightarrow>
         p \<langle>$\<rangle> z = apply_cycle (perm_orbit (skip_perm z p) (p \<langle>$\<rangle> z)) x"
    by (metis apply_cycle_perm_orbit apply_cycle_same_iff apply_perm_in_perm_orbit_iff
      apply_skip_perm skip_def start_in_perm_orbit_iff)
  show "p \<langle>$\<rangle> z \<noteq> z \<Longrightarrow> z = apply_cycle (perm_orbit (skip_perm z p) (p \<langle>$\<rangle> z)) z"
    by (metis apply_cycle_not_in_set apply_cycle_perm_orbit apply_skip_perm skip_id)

  assume *: "apply_cycle (perm_orbit p z) x \<noteq> z"  "x \<noteq> z"
  then consider "p z = x"
    | "x \<notin> set_cycle (perm_orbit p z)"
    | "p z \<noteq> x \<and> x \<in> set_cycle (perm_orbit p z)"
    by blast
  then show "apply_cycle (perm_orbit p z) x = apply_cycle (perm_orbit (skip_perm z p) (p \<langle>$\<rangle> z)) x"
  proof cases
    case 1
    then show ?thesis
      by (metis *(1) apply_cycle_perm_orbit apply_cycle_perm_orbit'
          apply_perm_in_perm_orbit_iff skip_perm_invariant start_in_perm_orbit)
  next
    case 2
    then have "apply_cycle (perm_orbit p z) x = x"
      by (transfer; simp)
    also have "apply_cycle (perm_orbit (skip_perm z p) (p \<langle>$\<rangle> z)) x = x"
      by (smt (z3) 2 apply_cycle_not_in_set apply_cycle_perm_orbit apply_perm_in_perm_orbit_iff
          apply_skip_perm perm_orbit_eqI perm_orbit_eq_id_cycle_iff skip_def start_in_perm_orbit_iff)
    ultimately show ?thesis by simp
next
  case 3
  then have "apply_cycle (perm_orbit p z) x = p x"
      by (meson apply_cycle_perm_orbit)
    also {
      have "skip_perm z p x = p x"
        by (metis \<open>apply_cycle (perm_orbit p z) x \<noteq> z\<close> \<open>x \<noteq> z\<close> skip_invariant
            apply_skip_perm calculation)
      define n where "n = (LEAST n. (p ^ Suc n) x = p z)"
      then have "((\<langle>$\<rangle>) (skip_perm z p) ^^ n) x = p z"
      proof (simp add: apply_skip_perm)
        assume n_def: "n = (LEAST n. (p * p ^ n) \<langle>$\<rangle> x = p \<langle>$\<rangle> z)"
        have "\<exists>m. (p * p ^ m) x = p z"
          by (metis 3 apply_perm_power apply_perm_sequence cycles_funpow)
        then have "(p * p ^ n) x = p z"
          using LeastI n_def by fast
        then have "(p ^ n) x = z"
          by (metis apply_inj_eq_iff apply_perm_sequence)
        then have "n > 0"
          using \<open>x \<noteq> z\<close> gr_zeroI by fastforce
        { fix l assume "l < n"
          then have "(p ^ l) x \<noteq> p z \<and> (p ^ l) x \<noteq> z"
            apply (safe)
            using 3 \<open>(p ^ n) \<langle>$\<rangle> x = z\<close> apply_inj_eq_iff apply_perm_sequence
                dual_order.strict_trans n_def not0_implies_Suc not_less_Least not_less_eq power_Suc
                power_Suc0_right by (smt (verit, del_insts) \<open>l < n\<close>)+
          from \<open>l < n\<close> have p_eq: "(p ^ l) x = ((skip z p) ^^ l) x"
          proof (induct l)
            case 0
            then show ?case by simp
          next
            case (Suc l)
            then show ?case
              by (smt (z3) Suc_lessD n_def
                   apply_perm_sequence apply_skip_perm funpow_simp_l not_less_Least power_Suc
                   skip_perm_invariant)
          qed
        }
        then have "(p ^ (n-1)) x = ((skip z p) ^^ (n-1)) x"
          by (simp add: \<open>0 < n\<close>)
        then show "(skip z ((\<langle>$\<rangle>) p) ^^ (LEAST n. (p * p ^ n) \<langle>$\<rangle> x = p \<langle>$\<rangle> z)) x = p \<langle>$\<rangle> z"
          by (smt (z3) One_nat_def Suc_pred \<open>(p ^ n) \<langle>$\<rangle> x = z\<close> \<open>0 < n\<close>
              n_def apply_perm_power funpow_simp_l skip_fz)
      qed
      then have "apply_cycle (perm_orbit (skip_perm z p) (p \<langle>$\<rangle> z)) x = p x"
        by (metis 3 \<open>(skip_perm z p) \<langle>$\<rangle> x = p \<langle>$\<rangle> x\<close> apply_cycle_perm_orbit funpow_cycles)
    }
    ultimately show ?thesis by simp
  next
  qed
qed

lemma cycles_skip_diff:
  assumes "x \<noteq> delete_cycle z (perm_orbit p z)"
      and "x \<in> cycles_of_perm (skip_perm z p)" (is "x \<in> ?C'")
    shows "x \<in> cycles_of_perm p"
proof -
  from assms(1) have "\<forall>y \<in> set_cycle x. y \<notin> set_cycle (perm_orbit (skip_perm z p) z)"
    by (simp add: apply_skip_perm)
  moreover have "x \<in> cycles_of_perm p \<Longrightarrow> \<forall>y \<in> set_cycle x. perm_orbit p y \<in> cycles_of_perm p"
    by (meson perm_orbit_in_cycles_of_perm set_cycle_of_perm_subset subset_iff)
  consider  (empty) "set_cycle (perm_orbit p z) = {}" |
            (size_two) "size (perm_orbit p z) = 2" |
            (union) "size (perm_orbit p z) > 2"
    by (metis One_nat_def gr_implies_not_zero less_2_cases_iff neqE perm_orbit_fixpoint
        set_cycle_empty_iff set_cycle_ex_funpow size_cycle_not_1' start_in_perm_orbit_iff)
  then show ?thesis
  proof cases
    case empty
    then show ?thesis
      by (metis assms(2) id_cycle_not_in_cycles_of_perm perm_orbit_in_cycles_of_perm
          set_cycle_empty_iff skip_perm_notin)
  next
    case size_two
    then have "{z, p z} = set_cycle (perm_orbit p z)"
      by (smt (z3) apply_cycle_in_set_iff apply_cycle_perm_orbit' card_2_iff card_set_cycle
      doubleton_eq_iff insert_absorb insert_iff perm_orbit_eq_id_cycle_iff set_cycle_empty_iff
      start_in_perm_orbit)
    also have "perm_orbit (skip_perm z p) (p z) = id_cycle"
      by (smt (verit, ccfv_threshold) calculation apply_cycle_in_set_iff apply_cycle_perm_orbit
 apply_skip_perm insertCI insertE is_singletonI is_singleton_conv_Ex1 perm_orbit_fixpoint skip_def)
    ultimately show ?thesis
      by (smt (z3) DiffD2 Diff_insert_absorb apply_perm_neq_idI apply_skip_perm assms(2)
          cycles_of_perm_def image_iff in_set_permI insertE perm_orbit_eq_id_cycle_iff skip_id
          skip_invariant skip_perm_cycle_invariant)
  next
    case union
    then have "size (perm_orbit p z) \<ge> 3" by simp
    define poz where "poz = perm_orbit p z"
    then have "delete_cycle z poz \<noteq> id_cycle"
      using \<open>size (perm_orbit p z) \<ge> 3\<close> apply transfer
      by (smt (z3) List.finite_set One_nat_def card.empty card.insert_remove cycle_relE
          cycle_rel_imp_same_set distinct_card empty_set filter_cong insert_absorb leD lessI
          list.size(3) not_numeral_le_zero numeral_3_eq_3 perm_orbit_impl set_minus_filter_out)
    also have remove1_poz: "delete_cycle z poz = perm_orbit (skip_perm z p) (p z)"
      by (simp add: poz_def remove1_cycle_orbit union)
    moreover have "perm_orbit p z = perm_orbit p (p z)"
      by (smt (verit, ccfv_threshold) apply_perm_in_perm_orbit_iff apply_set_perm apply_skip_perm
cycles_imp_cycles_skip disjoint_cycles_cycles_of_perms in_set_permI perm_of_cycles_in
 perm_of_cycles_of_perm perm_orbit_fixpoint perm_orbit_in_cycles_of_perm perm_orbit_notin_skip_perm
 skip_id start_in_perm_orbit)
    ultimately have "set_cycle (perm_orbit (skip_perm z p) (p z)) \<union> {z} = set_cycle (perm_orbit p z)"
      by (metis Un_insert_right poz_def boolean_algebra_cancel.sup0
          gr_implies_not_zero insert_Diff not_less_iff_gr_or_eq perm_orbit_eq_id_cycle_iff
          set_cycle_delete size_cycle_eq_0_iff' start_in_perm_orbit union)
    then show ?thesis
      by (smt (verit, ccfv_SIG) poz_def remove1_poz apply_cycle_cycles_of_perm
          apply_cycle_same_iff apply_set_perm apply_skip_perm assms cycles_of_perm_altdef
          mem_Collect_eq perm_orbit_eqI set_perm_cycle skip_def)
  qed
qed

lemma cycles_skip:
  assumes "z \<in> set_perm p"
  shows "cycles_of_perm p = cycles_of_perm (skip_perm z p) \<union>
       {perm_orbit p z} - {delete_cycle z (perm_orbit p z)}" (is "?C = ?C' \<union> {?poz} - {?poz'}")
proof (rule subset_antisym; rule subsetI)
  have disj: "disjoint_cycles ?C" "disjoint_cycles ?C'" by auto
  have poz_subset: "set_cycle ?poz' \<subseteq> set_cycle ?poz"
    by (metis DiffD1 apply_perm_neq_idI assms cycle_delete_swap equals0D set_cycle_delete
        set_cycle_empty_iff start_in_perm_orbit subsetI)
  have poz_in_C: "?poz \<in> ?C" using assms by (rule perm_orbit_in_cycles_of_perm)
  {
    fix x assume "x \<in> ?C"
    then have "z \<notin> set_cycle x \<Longrightarrow> x \<in> ?C'"
      by (metis apply_cycle_cycles_of_perm apply_perm_neq_idI apply_skip_perm assms
          cycles_imp_cycles_skip poz_in_C skip_def start_in_perm_orbit_iff)
      also have x_orbit: "z \<in> set_cycle x \<Longrightarrow> x = perm_orbit p z"
        using \<open>x \<in> ?C\<close> perm_orbit_eqI by fastforce
      have "?poz \<noteq> ?poz'"
        by (metis apply_cycle_delete apply_cycle_perm_orbit' apply_perm_neq_idI assms)
      hence "x \<noteq> ?poz'"
          by (smt (verit, ccfv_SIG) poz_subset \<open>x \<in> ?C\<close> x_orbit apply_perm_neq_idI cycles_funpow cycles_of_perm_def
              funpow_apply_perm_in_perm_orbit_iff imageE in_mono start_in_perm_orbit calculation disj)
      then show "x \<in> ?C' \<union> {?poz} - {?poz'}"
        using x_orbit calculation by blast
    }
  fix x assume x_in: "x \<in> ?C' \<union> {?poz} - {?poz'}"
  also have "?poz \<in> ?C"
    using assms by (rule perm_orbit_in_cycles_of_perm)
  moreover have "x \<noteq> ?poz' \<Longrightarrow> x \<in> ?C' \<Longrightarrow> x \<in> ?C"
    using cycles_skip_diff by fast
  ultimately show "x \<in> ?C" by fast
qed

section \<open>Permutation domain lemmas\<close>
context perm_on
begin
lemma cycle_count_skip:
  assumes "finite S" "z \<in> S"
  shows "count_cycles_on S p = count_cycles_on (S - {z}) (skip_perm z p) + (if p z = z then 1 else 0)"
proof -
  consider "p z = z" | "p z \<noteq> z \<and> p (p z) = z" | "p (p z) \<noteq> z" by blast
then show ?thesis
proof cases
  case 1
  have "set_perm p = set_perm (skip_perm z p)"
    by (metis apply_perm_neq_idI 1 skip_perm_notin)
  moreover have "card (S - set_perm p) = Suc (card (S - {z} - set_perm (skip_perm z p)))"
    by (smt (z3) 1 Diff_eq_empty_iff Diff_insert2 One_nat_def Suc_pred add_Suc_right
        add_diff_cancel_right' apply_perm_neq_idI assms calculation card_Diff_insert card_gt_0_iff
        finite_Diff subsetD zero_less_Suc)
  ultimately show ?thesis
    by (smt (z3) "1" Nat.add_0_right add_Suc_right apply_perm_neq_idI count_cycles_on_def
        perm_type_on_def size_replicate_mset One_nat_def size_union skip_perm_notin)
next
  case 2
  then have pz_id: "skip_perm z p (p z) = p z"
    by (simp add: apply_skip_perm)
  then have skip_z: "delete_cycle z (perm_orbit p z) = id_cycle"
    by (simp add: remove1_cycle_orbit)
  { have "cycles_of_perm p = cycles_of_perm (skip_perm z p) \<union> {perm_orbit p z}
                              - {delete_cycle z (perm_orbit p z)}"
      by (meson "2" apply_perm_eq_idI cycles_skip)
    then have "cycles_of_perm p = cycles_of_perm (skip_perm z p) \<union> {perm_orbit p z}"
        by (simp add: skip_z 2)
    moreover have "perm_orbit p z \<notin> cycles_of_perm (skip_perm z p)"
        by (simp add: perm_orbit_notin_skip_perm)
    ultimately have "card (cycles_of_perm p) = card (cycles_of_perm (skip_perm z p)) + 1"
      by (simp add: finite_cycles_of_perm)
  }
  moreover {
    have "set_perm p = set_perm (skip_perm z p) \<union> {z, p z}"
      by (meson 2 assms(1) set_perm_skip_2_cycle)
    also have "z \<notin> set_perm (skip_perm z p)"
      by (simp add: apply_skip_perm in_set_perm)
    moreover have "p z \<notin> set_perm (skip_perm z p)"
      using 2 \<open>(skip_perm z p) (p z) = p z\<close> by blast
    ultimately have "card (S - set_perm p) = card (S - {z} - set_perm (skip_perm z p)) - 1"
      by (smt (z3) Diff_iff Diff_insert2 Diff_insert_absorb Permutations.permutes_not_in
          Un_insert_right apply_perm_eq_same_iff(1) apply_set_perm assms
          boolean_algebra_cancel.sup0 card_Diff_insert permutes_p singletonD)
    }
  ultimately show ?thesis
    apply (simp add: perm_on.count_cycles_on_eq_card perm_on.intro skip_perm_permutes permutes_p)
    by (smt (verit, ccfv_threshold) "2" Diff_eq_empty_iff Diff_insert_absorb Suc_pred
        apply_perm_in_iff apply_perm_neq_idI assms card_gt_0_iff finite_Diff
        in_mono insertE mk_disjoint_insert pz_id set_perm_subset)
next
  case 3
  { then have "set_perm p = set_perm (skip_perm z p) \<union> {z}"
      by (metis set_perm_skip_n_cycle)
    also have "z \<notin> set_perm (skip_perm z p)"
      by (simp add: apply_skip_perm in_set_perm)
    ultimately have "S - set_perm p = S - {z} - set_perm (skip_perm z p)"
      by (metis Diff_insert2 Un_insert_right boolean_algebra_cancel.sup0)
  }
  also have "card (cycles_of_perm p) = card (cycles_of_perm (skip_perm z p))"
    by (smt (verit, ccfv_threshold) Diff_insert_absorb 3 Un_insert_right apply_set_perm
        boolean_algebra_cancel.sup0 card.infinite card_0_eq card_Diff_insert card_insert_le
        cycles_skip finite_cycles_of_perm insert_absorb insert_iff le_zero_eq
        perm_orbit_in_cycles_of_perm perm_orbit_notin_skip_perm remove1_cycle_orbit
        set_perm_skip_n_cycle)
  ultimately show ?thesis
    by (smt (z3) 3 add.right_neutral perm_on.count_cycles_on_eq_card
        perm_on.intro permutes_p skip_perm_permutes)
qed
qed

end
end


theory Ex2_4
  imports Main
begin

datatype bdd = Leaf bool | Branch bdd bdd

primrec eval :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bdd \<Rightarrow> bool" where
  "eval _ _ (Leaf b) = b"|
  "eval P n (Branch l r) = (if P n  then eval P (Suc n) l else eval P (Suc n) r)"

primrec bdd_unop :: "(bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd" where
  "bdd_unop  f (Leaf b)=  (Leaf (f b))"|
  "bdd_unop f (Branch l r) = Branch (bdd_unop f l) (bdd_unop f r)"

fun bdd_binop :: "(bool \<Rightarrow> bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd \<Rightarrow> bdd" where
  "bdd_binop f (Leaf b) (Leaf b2) = (Leaf (f b b2))"|
  "bdd_binop f (Leaf b) (Branch l r) =  Branch (bdd_binop f (Leaf b) l) (bdd_binop f (Leaf b) r)"|
  "bdd_binop f (Branch l r) (Leaf b) = Branch (bdd_binop f l (Leaf b)) (bdd_binop f r (Leaf b))"|
  "bdd_binop f (Branch l1 r1) (Branch l2 r2) = Branch (bdd_binop f l1 l2) (bdd_binop f r1 r2)"

theorem "size (bdd_unop f bdd) = size bdd" by (induction bdd, simp_all)

theorem "bdd_unop id bdd = bdd" by (induction bdd, simp_all)

theorem main1 : "\<forall>i . eval f i (bdd_unop f2 bdd) = f2 (eval f i bdd)" by (induction bdd ; simp)

theorem main2: "\<forall> i . eval f i (bdd_binop f2 bdd1 bdd2) = f2 (eval f i bdd1) (eval f i bdd2)"
proof (rule allI)
  fix i
  show  "eval f i (bdd_binop f2 bdd1 bdd2) = f2 (eval f i bdd1) (eval f i bdd2)"
  proof (induction bdd1 arbitrary  : i bdd2)
    case (Leaf x)
    then show ?case
    proof (induction bdd2 arbitrary : i)
      case (Leaf xx)
      then show ?case by simp
    next
      case (Branch bdd21 bdd22)
      then show ?case by simp
    qed
  next
    case (Branch bdd11 bdd12)
    assume hyp1:"\<And>i bdd2 . eval f i (bdd_binop f2 bdd11 bdd2) = f2 (eval f i bdd11) (eval f i bdd2)"
      and hyp2:"\<And> i bdd2 . eval f i (bdd_binop f2 bdd12 bdd2) = f2 (eval f i bdd12) (eval f i bdd2)"
    show ?case
    proof (cases "f i")
      case True
        assume c1:"f i"
      then show ?thesis
      proof (cases bdd2)
        case (Leaf x1)
        assume c2:"bdd2 = Leaf x1"
        have "eval f i (bdd_binop f2 (Branch bdd11 bdd12) bdd2) = eval f (Suc i) (bdd_binop f2 bdd11 bdd2)" using c1 c2 by simp
        also have "\<dots> = f2 (eval f (Suc i) bdd11) (eval f (Suc i) bdd2)" using hyp1 by simp
        also have "\<dots> = f2 (eval f i (Branch bdd11 bdd12)) (eval f i bdd2)" using c1 c2 by simp
        finally show ?thesis by assumption
      next
        case (Branch x21 x22)
        then show ?thesis using hyp1 c1 by simp
      qed
    next
      case False
      then show ?thesis using hyp1 hyp2 by (cases bdd2 , simp_all)
    qed
  qed
qed

definition bdd_and :: "bdd \<Rightarrow> bdd \<Rightarrow> bdd" where
  "bdd_and bdd1 bdd2 = bdd_binop (op \<and>) bdd1 bdd2"

definition "bdd_or =  bdd_binop op \<or>"

definition "bdd_not = bdd_unop (\<lambda>x \<Rightarrow> \<not>x)"

definition "bdd_xor = bdd_binop  (\<lambda> x y . (x \<and> \<not>y) \<or> (\<not>x \<and> y))"

theorem lem1 : "eval f i (bdd_and t1 t2) = (eval f i t1 \<and> eval f i t2)"
proof -
  have "\<forall> i . eval f i (bdd_binop op \<and> t1 t2) = op \<and> (eval f i t1) (eval f i t2)" by (rule main2)
  hence "eval f i (bdd_binop op \<and> t1 t2) = op \<and> (eval f i t1) (eval f i t2)" by (rule allE)
  thus ?thesis using bdd_and_def by simp
qed

theorem "\<forall>i .eval f i (bdd_or t1 t2) = (eval f i t1 \<or> eval f i t2)" using main2 by (simp add : bdd_or_def)

definition bxor :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
  "bxor a b = ((a \<and> \<not>b) \<or> (\<not>a \<and> b))"

notation
  bxor (infixl "<*>" 50)

theorem lem2 : "\<forall>i .eval f i (bdd_xor t1 t2) = (eval f i t1 <*> eval f i t2)" using main2 by (simp add : bdd_xor_def bxor_def)

theorem "\<forall>i .eval f i (bdd_not t1) = (\<not>(eval f i t1))" using  main1 by (simp add : bdd_not_def)

primrec bdd_var :: "nat \<Rightarrow> bdd" where
  "bdd_var 0 = Branch (Leaf True) (Leaf False)"|
  "bdd_var (Suc n) = Branch (bdd_var n) (bdd_var n)"

theorem "\<forall>i . eval f i (bdd_var n) = f (i + n)" by (induction n; simp)

datatype form = T | Var nat | And form form | Xor form form

definition "xor = bxor"

primrec evalf :: "(nat \<Rightarrow> bool) \<Rightarrow> form \<Rightarrow> bool" where
  "evalf e T = True"|
  "evalf e (Var i) = e i"|
  "evalf e (And f1 f2) = (evalf e f1 \<and> evalf e f2)"|
  "evalf e (Xor f1 f2) =  ((evalf e f1) <*> (evalf e f2))"

primrec mk_bdd :: "form \<Rightarrow> bdd" where
  "mk_bdd T = Leaf True"|
  "mk_bdd (Var i) = bdd_var i"|
  "mk_bdd (And f1 f2) =  bdd_and (mk_bdd f1) (mk_bdd f2)"|
  "mk_bdd (Xor f1 f2) = bdd_xor (mk_bdd f1) (mk_bdd f2)"

lemma helper1 : "f x = evalf f (Var x)" by (induction x, simp_all)

lemma helper2 : "f (x + n) = eval f n (bdd_var x)"
proof (induction x arbitrary : n)
  case 0
  then show ?case by simp
next
  case (Suc x)
    assume hyp:"\<And>n . f (x + n) = eval f n (bdd_var x)"
    then show ?case using hyp[of "Suc n"] by (cases "f (x + n)"; cases "f n" ; simp)
qed

theorem mk_bdd_correct : "eval e 0 (mk_bdd f) = evalf e f"
proof (induction f)
  case T
  then show ?case by simp
next
  case (Var x)
  then show ?case
  proof (induction x)
    case 0
    then show ?case by simp
  next
    case (Suc x)
    assume hyp:"eval e 0 (mk_bdd (Var x)) = evalf e (Var x)"
    then show ?case using helper1 helper2 by simp
  qed
next
  case (And f1 f2)
  assume hyp1:"eval e 0 (mk_bdd f1) = evalf e f1"
    and hyp2:"eval e 0 (mk_bdd f2) = evalf e f2"
  have "eval e 0 (mk_bdd (And f1 f2))  = eval e 0 (bdd_and (mk_bdd f1) (mk_bdd f2))" by simp
  also have "\<dots> = (eval e 0 (mk_bdd f1) \<and> eval e 0 (mk_bdd f2))" using lem1 by simp
  finally show ?case using hyp1 hyp2 by simp
next
  case (Xor f1 f2)
  then show ?case using lem2 by simp
qed

github-repos/isabelle/SvenWille-ExerciseSolutions_New/ExerciseSolutions_New-b8243e7a669846c64e2f5520dae88ff41265d233/Isabelle/2. Trees and other inductive data types/Ex2_4.thy


theory Part_2 imports Main

begin

(* 4.2 *)

inductive palindrome :: "'a list \<Rightarrow> bool" where
pempty: "palindrome []" |
psingle: "palindrome [x]" |
plist: "palindrome xs \<Longrightarrow> palindrome (a # (xs @ [a]))"

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
  apply(induction rule: palindrome.induct)
    apply(auto)
  done

(* 4.3 *)

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl': "star' r x x" |
step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

lemma [simp] : "star' r y z \<Longrightarrow> r x y \<Longrightarrow> star' r x z"
  apply(induction rule: star'.induct)
   apply(auto intro: refl' step')
  done

theorem star_star' : "star r x y \<Longrightarrow> star' r x y"
  apply(induction rule: star.induct)
   apply(auto simp add: refl')
  done

(* 4.4 *)

inductive iter :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
it0: "iter r 0 x x" |
itSS: "r x y \<Longrightarrow> iter r n y z \<Longrightarrow> iter r (Suc n) x z"

lemma star_imp_iter : "star r x y \<Longrightarrow> \<exists>n. iter r n x y"
  apply(induction rule: star.induct)
   apply(auto intro: it0 itSS)
  done

(* 4.5 *)

datatype alpha = a | b (* a == '(', b == ')' *)

(*
Grammar for balanced parentheses S
  S \<rightarrow> \<epsilon> | aSb | SS
*)
inductive S :: "alpha list \<Rightarrow> bool" where
S0: "S []" |
S1: "S w \<Longrightarrow> S (a # w @ [b])" (*S [a,b,a,b] \<rightarrow> S [a,b] \<rightarrow> S [] \<rightarrow> true *) |
S2: "S w \<Longrightarrow> S x \<Longrightarrow> S (w @ x)" (* S [a,b,a,b] \<rightarrow> S [a,b] \<and> S [a,b] \<rightarrow> true *)

(*
Second grammar for balanced parentheses T
  T \<rightarrow> \<epsilon> | TaTb
*)
inductive T :: "alpha list \<Rightarrow> bool" where
T0: "T []" |
T1: "T w \<Longrightarrow> T x \<Longrightarrow> T (w @ [a] @ x @ [b])"

lemma TS : "T w \<Longrightarrow> S w"
  apply(induction rule: T.induct)
   apply(auto intro: S0 S1 S2)
  done

lemma ST : "S w \<Longrightarrow> T w"
proof (induction rule: S.induct)
  case S0
  thus ?case by (simp add: T0)
next
  case S1
  thus ?case using T1 by blast
next
  case S2
  thus ?case using T1 by blast
qed

corollary SeqT: "S w \<longleftrightarrow> T w"
  apply(auto intro: ST TS)
  done

(* 4.6 *)

type_synonym vname = string
datatype aexp = N int | V vname | Plus aexp aexp

type_synonym val = int
type_synonym state = "vname \<Rightarrow> val"

fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val" where
"aval (N c) s = c" |
"aval (V x) s = s x" |
"aval (Plus c d) s = aval c s + aval d s"

inductive rel_aval :: "aexp \<Rightarrow> state \<Rightarrow> val \<Rightarrow> bool" where
ConstN: "rel_aval (N c) s c" |
ValV: "rel_aval (V x) s (s x)" |
PlusX: "rel_aval p s x \<Longrightarrow> rel_aval q s y \<Longrightarrow> rel_aval (Plus p q) s (x + y)"

lemma aval_rel_aval: "rel_aval c s v \<Longrightarrow> aval c s = v"
  apply(induction rule: rel_aval.induct)
    apply(auto)
  done

lemma aval_aval_rel: "aval c s = v \<Longrightarrow> rel_aval c s v"
  apply(induction c arbitrary: v)
    apply(auto intro: ConstN ValV PlusX)
  done

corollary "rel_aval c s v \<longleftrightarrow> aval c s = v"
  apply(auto intro: aval_rel_aval aval_aval_rel)
  done

(* 4.7 *)
datatype instr = LOADI val | LOAD vname | ADD

type_synonym stack = "val list"

fun exec1 :: "instr \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec1 (LOADI n) _ stk = Some (n # stk)" |
"exec1 ADD _ [] = None" |
"exec1 ADD _ [c] = None" |
"exec1 (LOAD x) s stk = Some (s(x) # stk)" |
"exec1 ADD _ (j # i # stk) = Some ((i + j) # stk)"

fun exec :: "instr list \<Rightarrow> state \<Rightarrow> stack \<Rightarrow> stack option" where
"exec [] _ stk = Some stk" |
"exec (i#is) s stk = (case (exec1 i s stk) of
                      Some c \<Rightarrow> exec is s c |
                      None \<Rightarrow> None)"

fun comp :: "aexp \<Rightarrow> instr list" where
"comp (N n) = [LOADI n]" |
"comp (V x ) = [LOAD x ]" |
"comp (Plus e\<^sub>1 e\<^sub>2) = comp e\<^sub>1 @ comp e\<^sub>2 @ [ADD]"

lemma [simp] : "exec is\<^sub>1 s stk = Some c \<Longrightarrow> exec (is\<^sub>1 @ is\<^sub>2) s stk = exec is\<^sub>2 s c"
  apply(induction is\<^sub>1 arbitrary: stk)
   apply(auto simp add: option.split)
  apply (metis option.case_eq_if option.simps(3))
  done

lemma "exec (comp c) s stk = Some (aval c s # stk)"
  apply(induction c arbitrary: stk)
    apply(auto)
  done

inductive ok :: "nat \<Rightarrow> instr list \<Rightarrow> nat \<Rightarrow> bool" where
okBase : "ok n [] n" |
ok1 : "ok n is n' \<Longrightarrow> ok n (is @ [LOADI k]) (Suc n')" |
ok2 : "ok n is n' \<Longrightarrow> ok n (is @ [LOAD x]) (Suc n')" |
ok3 : "ok n is (Suc (Suc n')) \<Longrightarrow> ok n (is @ [ADD]) (Suc n')"

lemma "ok 0 [LOAD k] (Suc 0)"
  apply (induction k)
   apply (metis append_self_conv2 ok.simps)
  apply (metis append_eq_Cons_conv ok.simps ok2)
  done

lemma "ok 0 [LOAD x, LOADI v, ADD] (Suc 0)"
  apply(induction x)
  apply(induction v)
    apply (metis append.left_neutral append_Cons ok1 ok2 ok3 okBase)
   apply (metis append.left_neutral append_Cons ok.simps okBase)
  apply (metis append.left_neutral append_Cons ok1 ok2 ok3 okBase)
  done

lemma "ok (Suc (Suc 0)) [LOAD x, ADD, ADD, LOAD y] (Suc (Suc 0))"
  using ok.cases by force

lemma "\<lbrakk> ok n is n'; length stk = n; exec is s stk = Some c \<rbrakk> \<Longrightarrow> length c = n'"
  using ok.cases by force