theory NaDeA imports Main begin

type_synonym id = "char list"

datatype tm = Var nat | Fun id "tm list"

datatype fm = Falsity | Pre id "tm list" | Imp fm fm | Dis fm fm | Con fm fm | Exi fm | Uni fm

primrec
  semantics_term :: "(nat \<Rightarrow> 'a) \<Rightarrow> (id \<Rightarrow> 'a list \<Rightarrow> 'a) \<Rightarrow> tm \<Rightarrow> 'a"
and
  semantics_list :: "(nat \<Rightarrow> 'a) \<Rightarrow> (id \<Rightarrow> 'a list \<Rightarrow> 'a) \<Rightarrow> tm list \<Rightarrow> 'a list"
where
  "semantics_term e f (Var n) = e n" |
  "semantics_term e f (Fun i l) = f i (semantics_list e f l)" |
  "semantics_list e f [] = []" |
  "semantics_list e f (t # l) = semantics_term e f t # semantics_list e f l"

primrec
  semantics :: "(nat \<Rightarrow> 'a) \<Rightarrow> (id \<Rightarrow> 'a list \<Rightarrow> 'a) \<Rightarrow> (id \<Rightarrow> 'a list \<Rightarrow> bool) \<Rightarrow> fm \<Rightarrow> bool"
where
  "semantics e f g Falsity = False" |
  "semantics e f g (Pre i l) = g i (semantics_list e f l)" |
  "semantics e f g (Imp p q) = (if semantics e f g p then semantics e f g q else True)" |
  "semantics e f g (Dis p q) = (if semantics e f g p then True else semantics e f g q)" |
  "semantics e f g (Con p q) = (if semantics e f g p then semantics e f g q else False)" |
  "semantics e f g (Exi p) = (\<exists>x. semantics (\<lambda>n. if n = 0 then x else e (n - 1)) f g p)" |
  "semantics e f g (Uni p) = (\<forall>x. semantics (\<lambda>n. if n = 0 then x else e (n - 1)) f g p)"

primrec
  member :: "fm \<Rightarrow> fm list \<Rightarrow> bool"
where
  "member p [] = False" |
  "member p (q # z) = (if p = q then True else member p z)"

primrec
  new_term :: "id \<Rightarrow> tm \<Rightarrow> bool"
and
  new_list :: "id \<Rightarrow> tm list \<Rightarrow> bool"
where
  "new_term c (Var n) = True" |
  "new_term c (Fun i l) = (if i = c then False else new_list c l)" |
  "new_list c [] = True" |
  "new_list c (t # l) = (if new_term c t then new_list c l else False)"

primrec
  new :: "id \<Rightarrow> fm \<Rightarrow> bool"
where
  "new c Falsity = True" |
  "new c (Pre i l) = new_list c l" |
  "new c (Imp p q) = (if new c p then new c q else False)" |
  "new c (Dis p q) = (if new c p then new c q else False)" |
  "new c (Con p q) = (if new c p then new c q else False)" |
  "new c (Exi p) = new c p" |
  "new c (Uni p) = new c p"

primrec
  news :: "id \<Rightarrow> fm list \<Rightarrow> bool"
where
  "news c [] = True" |
  "news c (p # z) = (if new c p then news c z else False)"

primrec
  inc_term :: "tm \<Rightarrow> tm"
and
  inc_list :: "tm list \<Rightarrow> tm list"
where
  "inc_term (Var n) = Var (n + 1)" |
  "inc_term (Fun i l) = Fun i (inc_list l)" |
  "inc_list [] = []" |
  "inc_list (t # l) = inc_term t # inc_list l"

primrec
  sub_term :: "nat \<Rightarrow> tm \<Rightarrow> tm \<Rightarrow> tm"
and
  sub_list :: "nat \<Rightarrow> tm \<Rightarrow> tm list \<Rightarrow> tm list"
where
  "sub_term v s (Var n) = (if n < v then Var n else if n = v then s else Var (n - 1))" |
  "sub_term v s (Fun i l) = Fun i (sub_list v s l)" |
  "sub_list v s [] = []" |
  "sub_list v s (t # l) = sub_term v s t # sub_list v s l"

primrec
  sub :: "nat \<Rightarrow> tm \<Rightarrow> fm \<Rightarrow> fm"
where
  "sub v s Falsity = Falsity" |
  "sub v s (Pre i l) = Pre i (sub_list v s l)" |
  "sub v s (Imp p q) = Imp (sub v s p) (sub v s q)" |
  "sub v s (Dis p q) = Dis (sub v s p) (sub v s q)" |
  "sub v s (Con p q) = Con (sub v s p) (sub v s q)" |
  "sub v s (Exi p) = Exi (sub (v + 1) (inc_term s) p)" |
  "sub v s (Uni p) = Uni (sub (v + 1) (inc_term s) p)"

inductive
  OK :: "fm \<Rightarrow> fm list \<Rightarrow> bool"
where
Assume:
        "member p z \<Longrightarrow> OK p z" |
Boole:
        "OK Falsity ((Imp p Falsity) # z) \<Longrightarrow> OK p z" |
Imp_E:
        "OK (Imp p q) z \<Longrightarrow> OK p z \<Longrightarrow> OK q z" |
Imp_I:
        "OK q (p # z) \<Longrightarrow> OK (Imp p q) z" |
Dis_E:
        "OK (Dis p q) z \<Longrightarrow> OK r (p # z) \<Longrightarrow> OK r (q # z) \<Longrightarrow> OK r z" |
Dis_I1:
        "OK p z \<Longrightarrow> OK (Dis p q) z" |
Dis_I2:
        "OK q z \<Longrightarrow> OK (Dis p q) z" |
Con_E1:
        "OK (Con p q) z \<Longrightarrow> OK p z" |
Con_E2:
        "OK (Con p q) z \<Longrightarrow> OK q z" |
Con_I:
        "OK p z \<Longrightarrow> OK q z \<Longrightarrow> OK (Con p q) z" |
Exi_E:
        "OK (Exi p) z \<Longrightarrow> OK q ((sub 0 (Fun c []) p) # z) \<Longrightarrow> news c (p # q # z) \<Longrightarrow> OK q z" |
Exi_I:
        "OK (sub 0 t p) z \<Longrightarrow> OK (Exi p) z" |
Uni_E:
        "OK (Uni p) z \<Longrightarrow> OK (sub 0 t p) z" |
Uni_I:
        "OK (sub 0 (Fun c []) p) z \<Longrightarrow> news c (p # z) \<Longrightarrow> OK (Uni p) z"

lemma "OK (Imp (Pre ''A'' []) (Pre ''A'' [])) []" proof (rule Imp_I, rule Assume, simp) qed

lemma "OK (Imp (Pre ''A'' []) (Pre ''A'' [])) []"
proof -
  have "OK (Pre ''A'' []) [(Pre ''A'' [])]" proof (rule Assume) qed simp
  then show "OK (Imp (Pre ''A'' []) (Pre ''A'' [])) []" proof (rule Imp_I) qed
qed

fun
  put :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a"
where
  "put e v x = (\<lambda>n. if n < v then e n else if n = v then x else e (n - 1))"

lemma "put e 0 x = (\<lambda>n. if n = 0 then x else e (n - 1))" proof simp qed

lemma increment:
  "semantics_term (put e 0 x) f (inc_term t) = semantics_term e f t"
  "semantics_list (put e 0 x) f (inc_list l) = semantics_list e f l"
proof (induct t and l rule: semantics_term.induct semantics_list.induct) qed simp_all

lemma commute: "put (put e v x) 0 y = put (put e 0 y) (v + 1) x" proof force qed

fun
  all :: "(fm \<Rightarrow> bool) \<Rightarrow> fm list \<Rightarrow> bool"
where
  "all b z = (\<forall>p. if member p z then b p else True)"

lemma allhead: "all b (p # z) \<Longrightarrow> b p" proof simp qed

lemma alltail: "all b (p # z) \<Longrightarrow> all b z" proof simp qed

lemma allnew: "all (new c) z = news c z" proof (induct z) qed (simp, simp, metis)

lemma map':
  "new_term c t \<Longrightarrow> semantics_term e (f(c := m)) t = semantics_term e f t"
  "new_list c l \<Longrightarrow> semantics_list e (f(c := m)) l = semantics_list e f l"
proof (induct t and l rule: semantics_term.induct semantics_list.induct)
qed (simp, simp, metis, simp, simp, metis)

lemma map: "new c p \<Longrightarrow> semantics e (f(c := m)) g p = semantics e f g p"
proof (induct p arbitrary: e)
qed (simp, simp, metis map'(2), simp, metis, simp, metis, simp, metis, simp_all)

lemma allmap: "news c z \<Longrightarrow> all (semantics e (f(c := m)) g) z = all (semantics e f g) z"
proof (induct z) qed (simp, simp, metis map)

lemma substitute':
  "semantics_term e f (sub_term v s t) = semantics_term (put e v (semantics_term e f s)) f t"
  "semantics_list e f (sub_list v s l) = semantics_list (put e v (semantics_term e f s)) f l"
proof (induct t and l rule: semantics_term.induct semantics_list.induct) qed simp_all

lemma substitute: "semantics e f g (sub v t p) = semantics (put e v (semantics_term e f t)) f g p"
proof (induct p arbitrary: e v t)
  fix i l e v t
  show "semantics e f g (sub v t (Pre i l)) =
      semantics (put e v (semantics_term e f t)) f g (Pre i l)"
  proof (simp add: substitute'(2)) qed
next
  fix p e v t assume *: "semantics e' f g (sub v' t' p) =
      semantics (put e' v' (semantics_term e' f t')) f g p" for e' v' t'
  have "semantics e f g (sub v t (Exi p)) =
      (\<exists>x. semantics (put (put e 0 x) (v + 1) (semantics_term (put e 0 x) f (inc_term t))) f g p)"
    using * proof simp qed
  also have "... = (\<exists>x. semantics (put (put e v (semantics_term e f t)) 0 x) f g p)"
    using commute increment(1) proof metis qed
  finally show "semantics e f g (sub v t (Exi p)) =
      semantics (put e v (semantics_term e f t)) f g (Exi p)" proof simp qed
  have "semantics e f g (sub v t (Uni p)) =
      (\<forall>x. semantics (put (put e 0 x) (v + 1) (semantics_term (put e 0 x) f (inc_term t))) f g p)"
    using * proof simp qed
  also have "... = (\<forall>x. semantics (put (put e v (semantics_term e f t)) 0 x) f g p)"
    using commute increment(1) proof metis qed
  finally show "semantics e f g (sub v t (Uni p)) =
      semantics (put e v (semantics_term e f t)) f g (Uni p)" proof simp qed
qed simp_all

lemma soundness': "OK p z \<Longrightarrow> all (semantics e f g) z \<Longrightarrow> semantics e f g p"
proof (induct arbitrary: f rule: OK.induct)
  fix f p z assume "all (semantics e f g) z"
      "all (semantics e f' g) (Imp p Falsity # z) \<Longrightarrow> semantics e f' g Falsity" for f'
  then show "semantics e f g p" proof force qed
next
  fix f p q z r assume "all (semantics e f g) z"
      "all (semantics e f' g) z \<Longrightarrow> semantics e f' g (Dis p q)"
      "all (semantics e f' g) (p # z) \<Longrightarrow> semantics e f' g r"
      "all (semantics e f' g) (q # z) \<Longrightarrow> semantics e f' g r" for f'
  then show "semantics e f g r" proof (simp, metis) qed
next
  fix f p q z assume "all (semantics e f g) z"
      "all (semantics e f' g) z \<Longrightarrow> semantics e f' g (Con p q)" for f'
  then show "semantics e f g p" "semantics e f g q" proof (simp, metis, simp, metis) qed
next
  fix f p z q c assume *: "all (semantics e f g) z"
      "all (semantics e f' g) z \<Longrightarrow> semantics e f' g (Exi p)"
      "all (semantics e f' g) (sub 0 (Fun c []) p # z) \<Longrightarrow> semantics e f' g q"
      "news c (p # q # z)" for f'
  obtain x where "semantics (\<lambda>n. if n = 0 then x else e (n - 1)) f g p"
    using *(1) *(2) proof force qed
  then have "semantics (put e 0 x) f g p" proof simp qed
  then have "semantics (put e 0 x) (f(c := \<lambda>w. x)) g p"
    using *(4) allhead allnew map proof blast qed
  then have "semantics e (f(c := \<lambda>w. x)) g (sub 0 (Fun c []) p)"
    proof (simp add: substitute) qed
  moreover have "all (semantics e (f(c := \<lambda>w. x)) g) z"
    using *(1) *(4) alltail allnew allmap proof blast qed
  ultimately have "semantics e (f(c := \<lambda>w. x)) g q" using *(3) proof simp qed
  then show "semantics e f g q" using *(4) allhead alltail allnew map proof blast qed
next
  fix f z t p assume "all (semantics e f g) z"
      "all (semantics e f' g) z \<Longrightarrow> semantics e f' g (sub 0 t p)" for f'
  then have "semantics (put e 0 (semantics_term e f t)) f g p" proof (simp add: substitute) qed
  then show "semantics e f g (Exi p)" proof (simp, metis) qed
next
  fix f z t p assume "all (semantics e f g) z"
      "all (semantics e f' g) z \<Longrightarrow> semantics e f' g (Uni p)" for f'
  then show "semantics e f g (sub 0 t p)" proof (simp add: substitute) qed
next
  fix f c p z assume *: "all (semantics e f g) z"
      "all (semantics e f' g) z \<Longrightarrow> semantics e f' g (sub 0 (Fun c []) p)"
      "news c (p # z)" for f'
  have "semantics (\<lambda>n. if n = 0 then x else e (n - 1)) f g p" for x
  proof -
    have "all (semantics e (f(c := \<lambda>w. x)) g) z"
      using *(1) *(3) alltail allnew allmap proof blast qed
    then have "semantics e (f(c := \<lambda>w. x)) g (sub 0 (Fun c []) p)"
      using *(2) proof simp qed
    then have "semantics (\<lambda>n. if n = 0 then x else e (n - 1)) (f(c := \<lambda>w. x)) g p"
      proof (simp add: substitute) qed
    then show "semantics (\<lambda>n. if n = 0 then x else e (n - 1)) f g p"
      using *(3) allhead alltail allnew map proof blast qed
  qed
  then show "semantics e f g (Uni p)" proof simp qed
qed simp_all

theorem soundness: "OK p [] \<Longrightarrow> semantics e f g p" proof (simp add: soundness') qed

corollary "\<exists>p. OK p []" "\<exists>p. \<not> OK p []"
proof -
  have "OK (Imp p p) []" for p proof (rule Imp_I, rule Assume, simp) qed
  then show "\<exists>p. OK p []" proof iprover qed
next
  have "\<not> semantics (e :: nat \<Rightarrow> unit) f g Falsity" for e f g proof simp qed
  then show "\<exists>p. \<not> OK p []" using soundness proof iprover qed
qed

end


section "Solution to Day 3 of AoC 2020"

theory day3
  imports Main "HOL.Code_Numeral" string_utils list_natural_utils natural_utils
begin

text "This is a solution to the puzzle for day 3"

subsection "Input parsing"

definition is_tree :: "char \<Rightarrow> bool"
  where "is_tree c = (c = CHR ''#'')"

definition parse_input :: "string \<Rightarrow> bool list list"
  where "parse_input a = map (map is_tree) (split CHR ''\<newline>'' (trim a))"

subsection "Solution Algorithm"

fun trees_hit :: "bool list list \<Rightarrow> natural \<Rightarrow> natural \<Rightarrow> natural"
  where"trees_hit [] _ _ = 0"
  |"trees_hit (Cons h t) \<Delta>x x = ((count_bool ((nth_mod_len x h))) + (trees_hit t \<Delta>x (x+\<Delta>x)))"

definition scan_trajectory ::"bool list list \<Rightarrow> natural \<Rightarrow> natural \<Rightarrow> natural"
  where "scan_trajectory grid x y = (trees_hit (skip_each (y-1) grid) x 0)"

text "The solution to part1 counts the number of trees we will hit on a 3:1 slope"

fun part1 :: "string \<Rightarrow> natural"
  where "part1 a = (scan_trajectory (parse_input a) 3 1)"

text "In part 2 we need the product of a few different trajectory totals"

fun part2 :: "string \<Rightarrow> natural"
  where "part2 a = (let scan_grid = scan_trajectory (parse_input a) in prod_list (map2 scan_grid
    [1, 3, 5, 7, 1]
    [1, 1, 1, 1, 2]
  ))"

subsection "Testing"

text "We expect our test case to return 7"

definition example_input::string where "example_input = ''
..##.......
#...#...#..
.#....#..#.
..#.#...#.#
.#...##..#.
..#.##.....
.#.#.#....#
.#........#
#.##...#...
#...##....#
.#..#...#.#
''"

lemma "part1 example_input = 7"
  by eval

text "For part 2 the example should return 336"

lemma "part2 example_input = 336"
  by eval

export_code "part1" "part2" in Haskell module_name Solution

end


section "Bitvector based Sets of Naturals"
theory Impl_Bit_Set
imports
  "../../Iterator/Iterator"
  "../Intf/Intf_Set"
  "../../../Native_Word/Bits_Integer"
begin
  text {*
    Based on the Native-Word library, using bit-operations on arbitrary
    precision integers. Fast for sets of small numbers,
    direct and fast implementations of equal, union, inter, diff.

    Note: On Poly/ML 5.5.1, bit-operations on arbitrary precision integers are
      rather inefficient. Use MLton instead, here they are efficiently implemented.
    *}

  type_synonym bitset = integer

  definition bs_\<alpha> :: "bitset \<Rightarrow> nat set" where "bs_\<alpha> s \<equiv> { n . test_bit s n}"

context includes integer.lifting begin

  definition bs_empty :: "unit \<Rightarrow> bitset" where "bs_empty \<equiv> \<lambda>_. 0"

  lemma bs_empty_correct: "bs_\<alpha> (bs_empty ()) = {}"
    unfolding bs_\<alpha>_def bs_empty_def
    apply transfer
    by auto

  definition bs_isEmpty :: "bitset \<Rightarrow> bool" where "bs_isEmpty s \<equiv> s=0"

  lemma bs_isEmpty_correct: "bs_isEmpty s \<longleftrightarrow> bs_\<alpha> s = {}"
    unfolding bs_isEmpty_def bs_\<alpha>_def
    by transfer (auto simp: bin_eq_iff)

  term set_bit
  definition bs_insert :: "nat \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_insert i s \<equiv> set_bit s i True"

  lemma bs_insert_correct: "bs_\<alpha> (bs_insert i s) = insert i (bs_\<alpha> s)"
    unfolding bs_\<alpha>_def bs_insert_def
    apply transfer
    apply auto
    apply (metis bin_nth_sc_gen bin_set_conv_OR int_set_bit_True_conv_OR)
    apply (metis bin_nth_sc_gen bin_set_conv_OR int_set_bit_True_conv_OR)
    by (metis bin_nth_sc_gen bin_set_conv_OR int_set_bit_True_conv_OR)

  definition bs_delete :: "nat \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_delete i s \<equiv> set_bit s i False"

  lemma bs_delete_correct: "bs_\<alpha> (bs_delete i s) = (bs_\<alpha> s) - {i}"
    unfolding bs_\<alpha>_def bs_delete_def
    apply transfer
    apply auto
    apply (metis bin_nth_ops(1) int_set_bit_False_conv_NAND)
    apply (metis (full_types) bin_nth_sc set_bit_int_def)
    by (metis (full_types) bin_nth_sc_gen set_bit_int_def)

  definition bs_mem :: "nat \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_mem i s \<equiv> test_bit s i"

  lemma bs_mem_correct: "bs_mem i s \<longleftrightarrow> i\<in>bs_\<alpha> s"
    unfolding bs_mem_def bs_\<alpha>_def by transfer auto

  definition bs_eq :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_eq s1 s2 \<equiv> (s1=s2)"

  lemma bs_eq_correct: "bs_eq s1 s2 \<longleftrightarrow> bs_\<alpha> s1 = bs_\<alpha> s2"
    unfolding bs_eq_def bs_\<alpha>_def
    including integer.lifting
    apply transfer
    apply auto
    by (metis bin_eqI mem_Collect_eq test_bit_int_def)

  definition bs_subset_eq :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_subset_eq s1 s2 \<equiv> s1 AND NOT s2 = 0"

  lemma bs_subset_eq_correct: "bs_subset_eq s1 s2 \<longleftrightarrow> bs_\<alpha> s1 \<subseteq> bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_subset_eq_def
    apply transfer
    apply rule
    apply auto []
    apply (metis bin_nth_code(1) bin_nth_ops(1) bin_nth_ops(4))
    apply (auto intro!: bin_eqI simp: bin_nth_ops)
    done

  definition bs_disjoint :: "bitset \<Rightarrow> bitset \<Rightarrow> bool" where
    "bs_disjoint s1 s2 \<equiv> s1 AND s2 = 0"

  lemma bs_disjoint_correct: "bs_disjoint s1 s2 \<longleftrightarrow> bs_\<alpha> s1 \<inter> bs_\<alpha> s2 = {}"
    unfolding bs_\<alpha>_def bs_disjoint_def
    apply transfer
    apply rule
    apply auto []
    apply (metis bin_nth_code(1) bin_nth_ops(1))
    apply (auto intro!: bin_eqI simp: bin_nth_ops)
    done

  definition bs_union :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_union s1 s2 = s1 OR s2"

  lemma bs_union_correct: "bs_\<alpha> (bs_union s1 s2) = bs_\<alpha> s1 \<union> bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_union_def
    by transfer (auto simp: bin_nth_ops)

  definition bs_inter :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_inter s1 s2 = s1 AND s2"

  lemma bs_inter_correct: "bs_\<alpha> (bs_inter s1 s2) = bs_\<alpha> s1 \<inter> bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_inter_def
    by transfer (auto simp: bin_nth_ops)

  definition bs_diff :: "bitset \<Rightarrow> bitset \<Rightarrow> bitset" where
    "bs_diff s1 s2 = s1 AND NOT s2"

  lemma bs_diff_correct: "bs_\<alpha> (bs_diff s1 s2) = bs_\<alpha> s1 - bs_\<alpha> s2"
    unfolding bs_\<alpha>_def bs_diff_def
    by transfer (auto simp: bin_nth_ops)

  definition bs_UNIV :: "unit \<Rightarrow> bitset" where "bs_UNIV \<equiv> \<lambda>_. -1"

  lemma bs_UNIV_correct: "bs_\<alpha> (bs_UNIV ()) = UNIV"
    unfolding bs_\<alpha>_def bs_UNIV_def
    by transfer (auto)

  definition bs_complement :: "bitset \<Rightarrow> bitset" where
    "bs_complement s = NOT s"

  lemma bs_complement_correct: "bs_\<alpha> (bs_complement s) = - bs_\<alpha> s"
    unfolding bs_\<alpha>_def bs_complement_def
    by transfer (auto simp: bin_nth_ops)

end

  lemmas bs_correct[simp] =
    bs_empty_correct
    bs_isEmpty_correct
    bs_insert_correct
    bs_delete_correct
    bs_mem_correct
    bs_eq_correct
    bs_subset_eq_correct
    bs_disjoint_correct
    bs_union_correct
    bs_inter_correct
    bs_diff_correct
    bs_UNIV_correct
    bs_complement_correct

subsection {* Autoref Setup *}

definition bs_set_rel_def_internal:
  "bs_set_rel Rk \<equiv>
    if Rk=nat_rel then br bs_\<alpha> (\<lambda>_. True) else {}"
lemma bs_set_rel_def:
  "\<langle>nat_rel\<rangle>bs_set_rel \<equiv> br bs_\<alpha> (\<lambda>_. True)"
  unfolding bs_set_rel_def_internal relAPP_def by simp

lemmas [autoref_rel_intf] = REL_INTFI[of "bs_set_rel" i_set]

lemma bs_set_rel_sv[relator_props]: "single_valued (\<langle>nat_rel\<rangle>bs_set_rel)"
  unfolding bs_set_rel_def by auto

term bs_empty

lemma [autoref_rules]: "(bs_empty (),{})\<in>\<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_UNIV (),UNIV)\<in>\<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_isEmpty,op_set_isEmpty)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

term insert
lemma [autoref_rules]: "(bs_insert,insert)\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

term op_set_delete
lemma [autoref_rules]: "(bs_delete,op_set_delete)\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_mem,op \<in>)\<in>nat_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_eq,op =)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_subset_eq,op \<subseteq>)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_union,op \<union>)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_inter,op \<inter>)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_diff,op -)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_complement,uminus)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel"
  by (auto simp: bs_set_rel_def br_def)

lemma [autoref_rules]: "(bs_disjoint,op_set_disjoint)\<in>\<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel \<rightarrow> bool_rel"
  by (auto simp: bs_set_rel_def br_def)

export_code
    bs_empty
    bs_isEmpty
    bs_insert
    bs_delete
    bs_mem
    bs_eq
    bs_subset_eq
    bs_disjoint
    bs_union
    bs_inter
    bs_diff
    bs_UNIV
    bs_complement
 in SML

(*

    TODO: Iterator

  definition "maxbi s \<equiv> GREATEST i. s!!i"

  lemma cmp_BIT_append_conv[simp]: "i < i BIT b \<longleftrightarrow> ((i\<ge>0 \<and> b=1) \<or> i>0)"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma BIT_append_cmp_conv[simp]: "i BIT b < i \<longleftrightarrow> ((i<0 \<and> (i=-1 \<longrightarrow> b=0)))"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma BIT_append_eq[simp]: fixes i :: int shows "i BIT b = i \<longleftrightarrow> (i=0 \<and> b=0) \<or> (i=-1 \<and> b=1)"
    by (cases b) (auto simp: Bit_B0 Bit_B1)

  lemma int_no_bits_eq_zero[simp]:
    fixes s::int shows "(\<forall>i. \<not>s!!i) \<longleftrightarrow> s=0"
    apply clarsimp
    by (metis bin_eqI bin_nth_code(1))

  lemma int_obtain_bit:
    fixes s::int
    assumes "s\<noteq>0"
    obtains i where "s!!i"
    by (metis assms int_no_bits_eq_zero)

  lemma int_bit_bound:
    fixes s::int
    assumes "s\<ge>0" and "s!!i"
    shows "i \<le> Bits_Integer.log2 s"
  proof (rule ccontr)
    assume "\<not>i\<le>Bits_Integer.log2 s"
    hence "i>Bits_Integer.log2 s" by simp
    hence "i - 1 \<ge> Bits_Integer.log2 s" by simp
    hence "s AND bin_mask (i - 1) = s" by (simp add: int_and_mask `s\<ge>0`)
    hence "\<not> (s!!i)"
      by clarsimp (metis Nat.diff_le_self bin_nth_mask bin_nth_ops(1) leD)
    thus False using `s!!i` ..
  qed

  lemma int_bit_bound':
    fixes s::int
    assumes "s\<ge>0" and "s!!i"
    shows "i < Bits_Integer.log2 s + 1"
    using assms int_bit_bound by smt

  lemma int_obtain_bit_pos:
    fixes s::int
    assumes "s>0"
    obtains i where "s!!i" "i < Bits_Integer.log2 s + 1"
    by (metis assms int_bit_bound' int_no_bits_eq_zero less_imp_le less_irrefl)

  lemma maxbi_set: fixes s::int shows "s>0 \<Longrightarrow> s!!maxbi s"
    unfolding maxbi_def
    apply (rule int_obtain_bit_pos, assumption)
    apply (rule GreatestI, assumption)
    apply (intro allI impI)
    apply (rule int_bit_bound'[rotated], assumption)
    by auto

  lemma maxbi_max: fixes s::int shows "i>maxbi s \<Longrightarrow> \<not> s!!i"
    oops

  function get_maxbi :: "nat \<Rightarrow> int \<Rightarrow> nat" where
    "get_maxbi n s = (let
        b = 1<<n
      in
        if b\<le>s then get_maxbi (n+1) s
        else n
    )"
    by pat_completeness auto

  termination
    apply (rule "termination"[of "measure (\<lambda>(n,s). nat (s + 1 - (1<<n)))"])
    apply simp
    apply auto
    by (smt bin_mask_ge0 bin_mask_p1_conv_shift)

  partial_function (tailrec)
    bs_iterate_aux :: "nat \<Rightarrow> bitset \<Rightarrow> ('\<sigma> \<Rightarrow> bool) \<Rightarrow> (nat \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
    where "bs_iterate_aux i s c f \<sigma> = (
    if s < 1 << i then \<sigma>
    else if \<not>c \<sigma> then \<sigma>
    else if test_bit s i then bs_iterate_aux (i+1) s c f (f i \<sigma>)
    else bs_iterate_aux (i+1) s c f \<sigma>
  )"

  definition bs_iteratei :: "bitset \<Rightarrow> (nat,'\<sigma>) set_iterator" where
    "bs_iteratei s = bs_iterate_aux 0 s"

  definition bs_set_rel_def_internal:
    "bs_set_rel Rk \<equiv>
      if Rk=nat_rel then br bs_\<alpha> (\<lambda>_. True) else {}"
  lemma bs_set_rel_def:
    "\<langle>nat_rel\<rangle>bs_set_rel \<equiv> br bs_\<alpha> (\<lambda>_. True)"
    unfolding bs_set_rel_def_internal relAPP_def by simp

  definition "bs_to_list \<equiv> it_to_list bs_iteratei"

  lemma "(1::int)<<i = 2^i"
    by (simp add: shiftl_int_def)

  lemma
    fixes s :: int
    assumes "s\<ge>0"
    shows "s < 1<<i \<longleftrightarrow> Bits_Integer.log2 s \<le> i"
    using assms
  proof (induct i arbitrary: s)
    case 0 thus ?case by auto
  next
    case (Suc i)
    note GE=`0\<le>s`
    show ?case proof
      assume "s < 1 << Suc i"

      have "s \<le> (s >> 1) BIT 1"

      hence "(s >> 1) < (1<<i)" using GE apply auto
      with Suc.hyps[of "s div 2"]

    apply auto

  lemma "distinct (bs_to_list s)"
    unfolding bs_to_list_def it_to_list_def bs_iteratei_def[abs_def]
  proof -
    {
      fix l i
      assume "distinct l"
      show "distinct (bs_iterate_aux 0 s (\<lambda>_. True) (\<lambda>x l. l @ [x]) [])"

    }

    apply auto

    lemma "set (bs_to_list s) = bs_\<alpha> s"

  lemma autoref_iam_is_iterator[autoref_ga_rules]:
    shows "is_set_to_list nat_rel bs_set_rel bs_to_list"
    unfolding is_set_to_list_def is_set_to_sorted_list_def
    apply clarsimp
    unfolding it_to_sorted_list_def
    apply (refine_rcg refine_vcg)
    apply (simp_all add: bs_set_rel_def br_def)

  proof (clarsimp)

  definition

"iterate s c f \<sigma> \<equiv> let
    i=0;
    b=0;
    (_,_,s) = while
  in

  end"

*)

end


(*  Author:     Tobias Nipkow
    Copyright   1998 TUM
*)

header "From regular expressions to nondeterministic automata with epsilon"

theory RegExp2NAe
imports "../Regular-Sets/Regular_Exp" NAe
begin

type_synonym 'a bitsNAe = "('a,bool list)nae"

definition
 epsilon :: "'a bitsNAe" where
"epsilon = ([],%a s. {}, %s. s=[])"

definition
"atom"  :: "'a => 'a bitsNAe" where
"atom a = ([True],
            %b s. if s=[True] & b=Some a then {[False]} else {},
            %s. s=[False])"

definition
 or :: "'a bitsNAe => 'a bitsNAe => 'a bitsNAe" where
"or = (%(ql,dl,fl)(qr,dr,fr).
   ([],
    %a s. case s of
            [] => if a=None then {True#ql,False#qr} else {}
          | left#s => if left then True ## dl a s
                              else False ## dr a s,
    %s. case s of [] => False | left#s => if left then fl s else fr s))"

definition
 conc :: "'a bitsNAe => 'a bitsNAe => 'a bitsNAe" where
"conc = (%(ql,dl,fl)(qr,dr,fr).
   (True#ql,
    %a s. case s of
            [] => {}
          | left#s => if left then (True ## dl a s) Un
                                   (if fl s & a=None then {False#qr} else {})
                              else False ## dr a s,
    %s. case s of [] => False | left#s => ~left & fr s))"

definition
 star :: "'a bitsNAe => 'a bitsNAe" where
"star = (%(q,d,f).
   ([],
    %a s. case s of
            [] => if a=None then {True#q} else {}
          | left#s => if left then (True ## d a s) Un
                                   (if f s & a=None then {True#q} else {})
                              else {},
    %s. case s of [] => True | left#s => left & f s))"

primrec rexp2nae :: "'a rexp => 'a bitsNAe" where
"rexp2nae Zero       = ([], %a s. {}, %s. False)" |
"rexp2nae One        = epsilon" |
"rexp2nae(Atom a)    = atom a" |
"rexp2nae(Plus r s)  = or   (rexp2nae r) (rexp2nae s)" |
"rexp2nae(Times r s) = conc (rexp2nae r) (rexp2nae s)" |
"rexp2nae(Star r)    = star (rexp2nae r)"

declare split_paired_all[simp]

(******************************************************)
(*                     epsilon                        *)
(******************************************************)

lemma step_epsilon[simp]: "step epsilon a = {}"
by(simp add:epsilon_def step_def)

lemma steps_epsilon: "((p,q) : steps epsilon w) = (w=[] & p=q)"
by (induct "w") auto

lemma accepts_epsilon[simp]: "accepts epsilon w = (w = [])"
apply (simp add: steps_epsilon accepts_def)
apply (simp add: epsilon_def)
done

(******************************************************)
(*                       atom                         *)
(******************************************************)

lemma fin_atom: "(fin (atom a) q) = (q = [False])"
by(simp add:atom_def)

lemma start_atom: "start (atom a) = [True]"
by(simp add:atom_def)

(* Use {x. False} = {}? *)

lemma eps_atom[simp]:
 "eps(atom a) = {}"
by (simp add:atom_def step_def)

lemma in_step_atom_Some[simp]:
 "(p,q) : step (atom a) (Some b) = (p=[True] & q=[False] & b=a)"
by (simp add:atom_def step_def)

lemma False_False_in_steps_atom:
  "([False],[False]) : steps (atom a) w = (w = [])"
apply (induct "w")
 apply (simp)
apply (simp add: relcomp_unfold)
done

lemma start_fin_in_steps_atom:
  "(start (atom a), [False]) : steps (atom a) w = (w = [a])"
apply (induct "w")
 apply (simp add: start_atom rtrancl_empty)
apply (simp add: False_False_in_steps_atom relcomp_unfold start_atom)
done

lemma accepts_atom: "accepts (atom a) w = (w = [a])"
by (simp add: accepts_def start_fin_in_steps_atom fin_atom)

(******************************************************)
(*                      or                            *)
(******************************************************)

(***** lift True/False over fin *****)

lemma fin_or_True[iff]:
 "!!L R. fin (or L R) (True#p) = fin L p"
by(simp add:or_def)

lemma fin_or_False[iff]:
 "!!L R. fin (or L R) (False#p) = fin R p"
by(simp add:or_def)

(***** lift True/False over step *****)

(***** lift True/False over epsclosure *****)

lemma lemma1a:
 "(tp,tq) : (eps(or L R))^* ==>
 (!!p. tp = True#p ==> ? q. (p,q) : (eps L)^* & tq = True#q)"
apply (induct rule:rtrancl_induct)
 apply (blast)
apply (clarify)
apply (simp)
apply (blast intro: rtrancl_into_rtrancl)
done

lemma lemma1b:
 "(tp,tq) : (eps(or L R))^* ==>
 (!!p. tp = False#p ==> ? q. (p,q) : (eps R)^* & tq = False#q)"
apply (induct rule:rtrancl_induct)
 apply (blast)
apply (clarify)
apply (simp)
apply (blast intro: rtrancl_into_rtrancl)
done

lemma lemma2a:
 "(p,q) : (eps L)^*  ==> (True#p, True#q) : (eps(or L R))^*"
apply (induct rule: rtrancl_induct)
 apply (blast)
apply (blast intro: rtrancl_into_rtrancl)
done

lemma lemma2b:
 "(p,q) : (eps R)^*  ==> (False#p, False#q) : (eps(or L R))^*"
apply (induct rule: rtrancl_induct)
 apply (blast)
apply (blast intro: rtrancl_into_rtrancl)
done

lemma True_epsclosure_or[iff]:
 "(True#p,q) : (eps(or L R))^* = (? r. q = True#r & (p,r) : (eps L)^*)"
by (blast dest: lemma1a lemma2a)

lemma False_epsclosure_or[iff]:
 "(False#p,q) : (eps(or L R))^* = (? r. q = False#r & (p,r) : (eps R)^*)"
by (blast dest: lemma1b lemma2b)

(***** lift True/False over steps *****)

lemma lift_True_over_steps_or[iff]:
 "!!p. (True#p,q):steps (or L R) w = (? r. q = True # r & (p,r):steps L w)"
apply (induct "w")
 apply auto
apply force
done

lemma lift_False_over_steps_or[iff]:
 "!!p. (False#p,q):steps (or L R) w = (? r. q = False#r & (p,r):steps R w)"
apply (induct "w")
 apply auto
apply (force)
done

(***** Epsilon closure of start state *****)

lemma unfold_rtrancl2:
 "R^* = Id Un (R O R^*)"
apply (rule set_eqI)
apply (simp)
apply (rule iffI)
 apply (erule rtrancl_induct)
  apply (blast)
 apply (blast intro: rtrancl_into_rtrancl)
apply (blast intro: converse_rtrancl_into_rtrancl)
done

lemma in_unfold_rtrancl2:
 "(p,q) : R^* = (q = p | (? r. (p,r) : R & (r,q) : R^*))"
apply (rule unfold_rtrancl2[THEN equalityE])
apply (blast)
done

lemmas [iff] = in_unfold_rtrancl2[where ?p = "start(or L R)"] for L R

lemma start_eps_or[iff]:
 "!!L R. (start(or L R),q) : eps(or L R) =
       (q = True#start L | q = False#start R)"
by (simp add:or_def step_def)

lemma not_start_step_or_Some[iff]:
 "!!L R. (start(or L R),q) ~: step (or L R) (Some a)"
by (simp add:or_def step_def)

lemma steps_or:
 "(start(or L R), q) : steps (or L R) w =
 ( (w = [] & q = start(or L R)) |
   (? p.  q = True  # p & (start L,p) : steps L w |
          q = False # p & (start R,p) : steps R w) )"
apply (case_tac "w")
 apply (simp)
 apply (blast)
apply (simp)
apply (blast)
done

lemma start_or_not_final[iff]:
 "!!L R. ~ fin (or L R) (start(or L R))"
by (simp add:or_def)

lemma accepts_or:
 "accepts (or L R) w = (accepts L w | accepts R w)"
apply (simp add:accepts_def steps_or)
 apply auto
done

(******************************************************)
(*                      conc                          *)
(******************************************************)

(** True/False in fin **)

lemma in_conc_True[iff]:
 "!!L R. fin (conc L R) (True#p) = False"
by (simp add:conc_def)

lemma fin_conc_False[iff]:
 "!!L R. fin (conc L R) (False#p) = fin R p"
by (simp add:conc_def)

(** True/False in step **)

lemma True_step_conc[iff]:
 "!!L R. (True#p,q) : step (conc L R) a =
       ((? r. q=True#r & (p,r): step L a) |
        (fin L p & a=None & q=False#start R))"
by (simp add:conc_def step_def) (blast)

lemma False_step_conc[iff]:
 "!!L R. (False#p,q) : step (conc L R) a =
       (? r. q = False#r & (p,r) : step R a)"
by (simp add:conc_def step_def) (blast)

(** False in epsclosure **)

lemma lemma1b':
 "(tp,tq) : (eps(conc L R))^* ==>
  (!!p. tp = False#p ==> ? q. (p,q) : (eps R)^* & tq = False#q)"
apply (induct rule: rtrancl_induct)
 apply (blast)
apply (blast intro: rtrancl_into_rtrancl)
done

lemma lemma2b':
 "(p,q) : (eps R)^* ==> (False#p, False#q) : (eps(conc L R))^*"
apply (induct rule: rtrancl_induct)
 apply (blast)
apply (blast intro: rtrancl_into_rtrancl)
done

lemma False_epsclosure_conc[iff]:
 "((False # p, q) : (eps (conc L R))^*) =
 (? r. q = False # r & (p, r) : (eps R)^*)"
apply (rule iffI)
 apply (blast dest: lemma1b')
apply (blast dest: lemma2b')
done

(** False in steps **)

lemma False_steps_conc[iff]:
 "!!p. (False#p,q): steps (conc L R) w = (? r. q=False#r & (p,r): steps R w)"
apply (induct "w")
 apply (simp)
apply (simp)
apply (fast)  (*MUCH faster than blast*)
done

(** True in epsclosure **)

lemma True_True_eps_concI:
 "(p,q): (eps L)^* ==> (True#p,True#q) : (eps(conc L R))^*"
apply (induct rule: rtrancl_induct)
 apply (blast)
apply (blast intro: rtrancl_into_rtrancl)
done

lemma True_True_steps_concI:
 "!!p. (p,q) : steps L w ==> (True#p,True#q) : steps (conc L R) w"
apply (induct "w")
 apply (simp add: True_True_eps_concI)
apply (simp)
apply (blast intro: True_True_eps_concI)
done

lemma lemma1a':
 "(tp,tq) : (eps(conc L R))^* ==>
 (!!p. tp = True#p ==>
  (? q. tq = True#q & (p,q) : (eps L)^*) |
  (? q r. tq = False#q & (p,r):(eps L)^* & fin L r & (start R,q) : (eps R)^*))"
apply (induct rule: rtrancl_induct)
 apply (blast)
apply (blast intro: rtrancl_into_rtrancl)
done

lemma lemma2a':
 "(p, q) : (eps L)^* ==> (True#p, True#q) : (eps(conc L R))^*"
apply (induct rule: rtrancl_induct)
 apply (blast)
apply (blast intro: rtrancl_into_rtrancl)
done

lemma lem:
 "!!L R. (p,q) : step R None ==> (False#p, False#q) : step (conc L R) None"
by(simp add: conc_def step_def)

lemma lemma2b'':
 "(p,q) : (eps R)^* ==> (False#p, False#q) : (eps(conc L R))^*"
apply (induct rule: rtrancl_induct)
 apply (blast)
apply (drule lem)
apply (blast intro: rtrancl_into_rtrancl)
done

lemma True_False_eps_concI:
 "!!L R. fin L p ==> (True#p, False#start R) : eps(conc L R)"
by(simp add: conc_def step_def)

lemma True_epsclosure_conc[iff]:
 "((True#p,q) : (eps(conc L R))^*) =
 ((? r. (p,r) : (eps L)^* & q = True#r) |
  (? r. (p,r) : (eps L)^* & fin L r &
        (? s. (start R, s) : (eps R)^* & q = False#s)))"
apply (rule iffI)
 apply (blast dest: lemma1a')
apply (erule disjE)
 apply (blast intro: lemma2a')
apply (clarify)
apply (rule rtrancl_trans)
apply (erule lemma2a')
apply (rule converse_rtrancl_into_rtrancl)
apply (erule True_False_eps_concI)
apply (erule lemma2b'')
done

(** True in steps **)

lemma True_steps_concD[rule_format]:
 "!p. (True#p,q) : steps (conc L R) w -->
     ((? r. (p,r) : steps L w & q = True#r)  |
      (? u v. w = u@v & (? r. (p,r) : steps L u & fin L r &
              (? s. (start R,s) : steps R v & q = False#s))))"
apply (induct "w")
 apply (simp)
apply (simp)
apply (clarify del: disjCI)
 apply (erule disjE)
 apply (clarify del: disjCI)
 apply (erule disjE)
  apply (clarify del: disjCI)
  apply (erule allE, erule impE, assumption)
  apply (erule disjE)
   apply (blast)
  apply (rule disjI2)
  apply (clarify)
  apply (simp)
  apply (rule_tac x = "a#u" in exI)
  apply (simp)
  apply (blast)
 apply (blast)
apply (rule disjI2)
apply (clarify)
apply (simp)
apply (rule_tac x = "[]" in exI)
apply (simp)
apply (blast)
done

lemma True_steps_conc:
 "(True#p,q) : steps (conc L R) w =
 ((? r. (p,r) : steps L w & q = True#r)  |
  (? u v. w = u@v & (? r. (p,r) : steps L u & fin L r &
          (? s. (start R,s) : steps R v & q = False#s))))"
by (blast dest: True_steps_concD
    intro: True_True_steps_concI in_steps_epsclosure)

(** starting from the start **)

lemma start_conc:
  "!!L R. start(conc L R) = True#start L"
by (simp add: conc_def)

lemma final_conc:
 "!!L R. fin(conc L R) p = (? s. p = False#s & fin R s)"
by (simp add:conc_def split: list.split)

lemma accepts_conc:
 "accepts (conc L R) w = (? u v. w = u@v & accepts L u & accepts R v)"
apply (simp add: accepts_def True_steps_conc final_conc start_conc)
apply (blast)
done

(******************************************************)
(*                       star                         *)
(******************************************************)

lemma True_in_eps_star[iff]:
 "!!A. (True#p,q) : eps(star A) =
     ( (? r. q = True#r & (p,r) : eps A) | (fin A p & q = True#start A) )"
by (simp add:star_def step_def) (blast)

lemma True_True_step_starI:
  "!!A. (p,q) : step A a ==> (True#p, True#q) : step (star A) a"
by (simp add:star_def step_def)

lemma True_True_eps_starI:
  "(p,r) : (eps A)^* ==> (True#p, True#r) : (eps(star A))^*"
apply (induct rule: rtrancl_induct)
 apply (blast)
apply (blast intro: True_True_step_starI rtrancl_into_rtrancl)
done

lemma True_start_eps_starI:
 "!!A. fin A p ==> (True#p,True#start A) : eps(star A)"
by (simp add:star_def step_def)

lemma lem':
 "(tp,s) : (eps(star A))^* ==> (! p. tp = True#p -->
 (? r. ((p,r) : (eps A)^* |
        (? q. (p,q) : (eps A)^* & fin A q & (start A,r) : (eps A)^*)) &
       s = True#r))"
apply (induct rule: rtrancl_induct)
 apply (simp)
apply (clarify)
apply (simp)
apply (blast intro: rtrancl_into_rtrancl)
done

lemma True_eps_star[iff]:
 "((True#p,s) : (eps(star A))^*) =
 (? r. ((p,r) : (eps A)^* |
        (? q. (p,q) : (eps A)^* & fin A q & (start A,r) : (eps A)^*)) &
       s = True#r)"
apply (rule iffI)
 apply (drule lem')
 apply (blast)
(* Why can't blast do the rest? *)
apply (clarify)
apply (erule disjE)
apply (erule True_True_eps_starI)
apply (clarify)
apply (rule rtrancl_trans)
apply (erule True_True_eps_starI)
apply (rule rtrancl_trans)
apply (rule r_into_rtrancl)
apply (erule True_start_eps_starI)
apply (erule True_True_eps_starI)
done

(** True in step Some **)

lemma True_step_star[iff]:
 "!!A. (True#p,r): step (star A) (Some a) =
     (? q. (p,q): step A (Some a) & r=True#q)"
by (simp add:star_def step_def) (blast)

(** True in steps **)

(* reverse list induction! Complicates matters for conc? *)
lemma True_start_steps_starD[rule_format]:
 "!rr. (True#start A,rr) : steps (star A) w -->
 (? us v. w = concat us @ v &
             (!u:set us. accepts A u) &
             (? r. (start A,r) : steps A v & rr = True#r))"
apply (induct w rule: rev_induct)
 apply (simp)
 apply (clarify)
 apply (rule_tac x = "[]" in exI)
 apply (erule disjE)
  apply (simp)
 apply (clarify)
 apply (simp)
apply (simp add: O_assoc[symmetric] epsclosure_steps)
apply (clarify)
apply (erule allE, erule impE, assumption)
apply (clarify)
apply (erule disjE)
 apply (rule_tac x = "us" in exI)
 apply (rule_tac x = "v@[x]" in exI)
 apply (simp add: O_assoc[symmetric] epsclosure_steps)
 apply (blast)
apply (clarify)
apply (rule_tac x = "us@[v@[x]]" in exI)
apply (rule_tac x = "[]" in exI)
apply (simp add: accepts_def)
apply (blast)
done

lemma True_True_steps_starI:
  "!!p. (p,q) : steps A w ==> (True#p,True#q) : steps (star A) w"
apply (induct "w")
 apply (simp)
apply (simp)
apply (blast intro: True_True_eps_starI True_True_step_starI)
done

lemma steps_star_cycle:
 "(!u : set us. accepts A u) ==>
 (True#start A,True#start A) : steps (star A) (concat us)"
apply (induct "us")
 apply (simp add:accepts_def)
apply (simp add:accepts_def)
by(blast intro: True_True_steps_starI True_start_eps_starI in_epsclosure_steps)

(* Better stated directly with start(star A)? Loop in star A back to start(star A)?*)
lemma True_start_steps_star:
 "(True#start A,rr) : steps (star A) w =
 (? us v. w = concat us @ v &
             (!u:set us. accepts A u) &
             (? r. (start A,r) : steps A v & rr = True#r))"
apply (rule iffI)
 apply (erule True_start_steps_starD)
apply (clarify)
apply (blast intro: steps_star_cycle True_True_steps_starI)
done

(** the start state **)

lemma start_step_star[iff]:
  "!!A. (start(star A),r) : step (star A) a = (a=None & r = True#start A)"
by (simp add:star_def step_def)

lemmas epsclosure_start_step_star =
  in_unfold_rtrancl2[where ?p = "start (star A)"] for A

lemma start_steps_star:
 "(start(star A),r) : steps (star A) w =
 ((w=[] & r= start(star A)) | (True#start A,r) : steps (star A) w)"
apply (rule iffI)
 apply (case_tac "w")
  apply (simp add: epsclosure_start_step_star)
 apply (simp)
 apply (clarify)
 apply (simp add: epsclosure_start_step_star)
 apply (blast)
apply (erule disjE)
 apply (simp)
apply (blast intro: in_steps_epsclosure)
done

lemma fin_star_True[iff]: "!!A. fin (star A) (True#p) = fin A p"
by (simp add:star_def)

lemma fin_star_start[iff]: "!!A. fin (star A) (start(star A))"
by (simp add:star_def)

(* too complex! Simpler if loop back to start(star A)? *)
lemma accepts_star:
 "accepts (star A) w =
 (? us. (!u : set(us). accepts A u) & (w = concat us) )"
apply(unfold accepts_def)
apply (simp add: start_steps_star True_start_steps_star)
apply (rule iffI)
 apply (clarify)
 apply (erule disjE)
  apply (clarify)
  apply (simp)
  apply (rule_tac x = "[]" in exI)
  apply (simp)
 apply (clarify)
 apply (rule_tac x = "us@[v]" in exI)
 apply (simp add: accepts_def)
 apply (blast)
apply (clarify)
apply (rule_tac xs = "us" in rev_exhaust)
 apply (simp)
 apply (blast)
apply (clarify)
apply (simp add: accepts_def)
apply (blast)
done

(***** Correctness of r2n *****)

lemma accepts_rexp2nae:
 "!!w. accepts (rexp2nae r) w = (w : lang r)"
apply (induct "r")
     apply (simp add: accepts_def)
    apply simp
   apply (simp add: accepts_atom)
  apply (simp add: accepts_or)
 apply (simp add: accepts_conc Regular_Set.conc_def)
apply (simp add: accepts_star in_star_iff_concat subset_iff Ball_def)
done

end


(*
    Author:      René Thiemann
                 Akihisa Yamada
    License:     BSD
*)
section \<open>Improved Code Equations\<close>

text \<open>This theory contains improved code equations for certain algorithms.\<close>

theory Improved_Code_Equations
imports
  "HOL-Computational_Algebra.Polynomial"
  "HOL-Library.Code_Target_Nat"
begin

subsection \<open>@{const divmod_integer}.\<close>

text \<open>We improve @{thm divmod_integer_code} by deleting @{const sgn}-expressions.\<close>

text \<open>We guard the application of divmod-abs' with the condition @{term "x \<ge> 0 \<and> y \<ge> 0"},
  so that application can be ensured on non-negative values. Hence, one can drop "abs" in
   target language setup.\<close>

definition divmod_abs' where
  "x \<ge> 0 \<Longrightarrow> y \<ge> 0 \<Longrightarrow> divmod_abs' x y = Code_Numeral.divmod_abs x y"

(* led to an another 10 % improvement on factorization example *)

lemma divmod_integer_code''[code]: "divmod_integer k l =
  (if k = 0 then (0, 0)
    else if l > 0 then
            (if k > 0 then divmod_abs' k l
             else case divmod_abs' (- k) l of (r, s) \<Rightarrow>
                  if s = 0 then (- r, 0) else (- r - 1, l - s))
    else if l = 0 then (0, k)
    else apsnd uminus
            (if k < 0 then divmod_abs' (-k) (-l)
             else case divmod_abs' k (-l) of (r, s) \<Rightarrow>
                  if s = 0 then (- r, 0) else (- r - 1, - l - s)))"
   unfolding divmod_integer_code
   by (cases "l = 0"; cases "l < 0"; cases "l > 0"; auto split: prod.splits simp: divmod_abs'_def divmod_abs_def)

code_printing \<comment> \<open>FIXME illusion of partiality\<close>
  constant divmod_abs' \<rightharpoonup>
    (SML) "IntInf.divMod/ ( _,/ _ )"
    and (Eval) "Integer.div'_mod/ ( _ )/ ( _ )"
    and (OCaml) "Z.div'_rem"
    and (Haskell) "divMod/ ( _ )/ ( _ )"
    and (Scala) "!((k: BigInt) => (l: BigInt) =>/ if (l == 0)/ (BigInt(0), k) else/ (k '/% l))"

subsection \<open>@{const Euclidean_Rings.divmod_nat}.\<close>
text \<open>We implement @{const Euclidean_Rings.divmod_nat} via @{const divmod_integer}
  instead of invoking both division and modulo separately,
  and we further simplify the case-analysis which is
  performed in @{thm divmod_integer_code''}.\<close>

lemma divmod_nat_code'[code]: "Euclidean_Rings.divmod_nat m n = (
  let k = integer_of_nat m; l = integer_of_nat n
  in map_prod nat_of_integer nat_of_integer
  (if k = 0 then (0, 0)
    else if l = 0 then (0,k) else
            divmod_abs' k l))"
  using divmod_nat_code [of m n]
  by (simp add: divmod_abs'_def integer_of_nat_eq_of_nat Let_def)

subsection \<open>@{const binomial}\<close>

lemma binomial_code[code]:
  "n choose k = (if k \<le> n then fact n div (fact k * fact (n - k)) else 0)"
  using binomial_eq_0[of n k] binomial_altdef_nat[of k n] by simp

end


(*  Author:  Florian Haftmann, TU Muenchen
*)

subsection \<open>Rounded division: modulus centered towars zero.\<close>

theory Rounded_Division
  imports Main
begin

definition rounded_divide :: \<open>int \<Rightarrow> int \<Rightarrow> int\<close>  (infixl \<open>rdiv\<close> 70)
  where \<open>k rdiv l = (k + l div 2 + of_bool (l < 0)) div l\<close>

definition rounded_modulo :: \<open>int \<Rightarrow> int \<Rightarrow> int\<close>  (infixl \<open>rmod\<close> 70)
  where \<open>k rmod l = k - k rdiv l * l\<close>

lemma rdiv_mult_rmod_eq:
  \<open>k rdiv l * l + k rmod l = k\<close>
  by (simp add: rounded_divide_def rounded_modulo_def)

lemma mult_rdiv_rmod_eq:
  \<open>l * (k rdiv l) + k rmod l = k\<close>
  using rdiv_mult_rmod_eq [of k l] by (simp add: ac_simps)

lemma rmod_rdiv_mult_eq:
  \<open>k rmod l + k rdiv l * l = k\<close>
  using rdiv_mult_rmod_eq [of k l] by (simp add: ac_simps)

lemma rmod_mult_rdiv_eq:
  \<open>k rmod l + l * (k rdiv l) = k\<close>
  using rdiv_mult_rmod_eq [of k l] by (simp add: ac_simps)

lemma minus_rdiv_mult_eq_rmod:
  \<open>k - k rdiv l * l = k rmod l\<close>
  by (rule add_implies_diff [symmetric]) (fact rmod_rdiv_mult_eq)

lemma minus_mult_rdiv_eq_rmod:
  \<open>k - l * (k rdiv l) = k rmod l\<close>
  by (rule add_implies_diff [symmetric]) (fact rmod_mult_rdiv_eq)

lemma minus_rmod_eq_rdiv_mult:
  \<open>k - k rmod l = k rdiv l * l\<close>
  by (rule add_implies_diff [symmetric]) (fact rdiv_mult_rmod_eq)

lemma minus_rmod_eq_mult_rdiv:
  \<open>k - k rmod l = l * (k rdiv l)\<close>
  by (rule add_implies_diff [symmetric]) (fact mult_rdiv_rmod_eq)

lemma rdiv_0_eq [simp]:
  \<open>k rdiv 0 = 0\<close>
  by (simp add: rounded_divide_def)

lemma rmod_0_eq [simp]:
  \<open>k rmod 0 = k\<close>
  by (simp add: rounded_modulo_def)

lemma rdiv_1_eq [simp]:
  \<open>k rdiv 1 = k\<close>
  by (simp add: rounded_divide_def)

lemma rmod_1_eq [simp]:
  \<open>k rmod 1 = 0\<close>
  by (simp add: rounded_modulo_def)

lemma zero_rdiv_eq [simp]:
  \<open>0 rdiv k = 0\<close>
  by (auto simp add: rounded_divide_def not_less zdiv_eq_0_iff)

lemma zero_rmod_eq [simp]:
  \<open>0 rmod k = 0\<close>
  by (simp add: rounded_modulo_def)

lemma nonzero_mult_rdiv_cancel_right:
  \<open>k * l rdiv l = k\<close> if \<open>l \<noteq> 0\<close>
  using that by (auto simp add: rounded_divide_def ac_simps)

lemma rdiv_self_eq [simp]:
  \<open>k rdiv k = 1\<close> if \<open>k \<noteq> 0\<close>
  using that nonzero_mult_rdiv_cancel_right [of k 1] by simp

lemma rmod_self_eq [simp]:
  \<open>k rmod k = 0\<close>
  by (cases \<open>k = 0\<close>) (simp_all add: rounded_modulo_def)

end


(*   Author:      Florian Haftmann, TU Muenchen; based on existing material on complex numbers\<close>
*)

section \<open>Gauss Numbers: integral gauss numbers\<close>

theory Gauss_Numbers
  imports "HOL-Library.Rounded_Division"
begin

codatatype gauss = Gauss (Re: int) (Im: int)

lemma gauss_eqI [intro?]:
  \<open>x = y\<close> if \<open>Re x = Re y\<close> \<open>Im x = Im y\<close>
  by (rule gauss.expand) (use that in simp)

lemma gauss_eq_iff:
  \<open>x = y \<longleftrightarrow> Re x = Re y \<and> Im x = Im y\<close>
  by (auto intro: gauss_eqI)

subsection \<open>Basic arithmetic\<close>

instantiation gauss :: comm_ring_1
begin

primcorec zero_gauss :: \<open>gauss\<close>
  where
    \<open>Re 0 = 0\<close>
  | \<open>Im 0 = 0\<close>

primcorec one_gauss :: \<open>gauss\<close>
  where
    \<open>Re 1 = 1\<close>
  | \<open>Im 1 = 0\<close>

primcorec plus_gauss :: \<open>gauss \<Rightarrow> gauss \<Rightarrow> gauss\<close>
  where
    \<open>Re (x + y) = Re x + Re y\<close>
  | \<open>Im (x + y) = Im x + Im y\<close>

primcorec uminus_gauss :: \<open>gauss \<Rightarrow> gauss\<close>
  where
    \<open>Re (- x) = - Re x\<close>
  | \<open>Im (- x) = - Im x\<close>

primcorec minus_gauss :: \<open>gauss \<Rightarrow> gauss \<Rightarrow> gauss\<close>
  where
    \<open>Re (x - y) = Re x - Re y\<close>
  | \<open>Im (x - y) = Im x - Im y\<close>

primcorec times_gauss :: \<open>gauss \<Rightarrow> gauss \<Rightarrow> gauss\<close>
  where
    \<open>Re (x * y) = Re x * Re y - Im x * Im y\<close>
  | \<open>Im (x * y) = Re x * Im y + Im x * Re y\<close>

instance
  by standard (simp_all add: gauss_eq_iff algebra_simps)

end

lemma of_nat_gauss:
  \<open>of_nat n = Gauss (int n) 0\<close>
  by (induction n) (simp_all add: gauss_eq_iff)

lemma numeral_gauss:
  \<open>numeral n = Gauss (numeral n) 0\<close>
proof -
  have \<open>numeral n = (of_nat (numeral n) :: gauss)\<close>
    by simp
  also have \<open>\<dots> = Gauss (of_nat (numeral n)) 0\<close>
    by (simp add: of_nat_gauss)
  finally show ?thesis
    by simp
qed

lemma of_int_gauss:
  \<open>of_int k = Gauss k 0\<close>
  by (simp add: gauss_eq_iff of_int_of_nat of_nat_gauss)

lemma conversion_simps [simp]:
  \<open>Re (numeral m) = numeral m\<close>
  \<open>Im (numeral m) = 0\<close>
  \<open>Re (of_nat n) = int n\<close>
  \<open>Im (of_nat n) = 0\<close>
  \<open>Re (of_int k) = k\<close>
  \<open>Im (of_int k) = 0\<close>
  by (simp_all add: numeral_gauss of_nat_gauss of_int_gauss)

lemma gauss_eq_0:
  \<open>z = 0 \<longleftrightarrow> (Re z)\<^sup>2 + (Im z)\<^sup>2 = 0\<close>
  by (simp add: gauss_eq_iff sum_power2_eq_zero_iff)

lemma gauss_neq_0:
  \<open>z \<noteq> 0 \<longleftrightarrow> (Re z)\<^sup>2 + (Im z)\<^sup>2 > 0\<close>
  by (simp add: gauss_eq_0 sum_power2_ge_zero less_le)

lemma Re_sum [simp]:
  \<open>Re (sum f s) = (\<Sum>x\<in>s. Re (f x))\<close>
  by (induct s rule: infinite_finite_induct) auto

lemma Im_sum [simp]:
  \<open>Im (sum f s) = (\<Sum>x\<in>s. Im (f x))\<close>
  by (induct s rule: infinite_finite_induct) auto

instance gauss :: idom
proof
  fix x y :: gauss
  assume \<open>x \<noteq> 0\<close> \<open>y \<noteq> 0\<close>
  then show \<open>x * y \<noteq> 0\<close>
    by (simp_all add: gauss_eq_iff)
      (smt (verit, best) mult_eq_0_iff mult_neg_neg mult_neg_pos mult_pos_neg mult_pos_pos)
qed

subsection \<open>The Gauss Number $i$\<close>

primcorec imaginary_unit :: gauss  (\<open>\<i>\<close>)
  where
    \<open>Re \<i> = 0\<close>
  | \<open>Im \<i> = 1\<close>

lemma Gauss_eq:
  \<open>Gauss a b = of_int a + \<i> * of_int b\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_eq:
  \<open>a = of_int (Re a) + \<i> * of_int (Im a)\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_i_not_zero [simp]:
  \<open>\<i> \<noteq> 0\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_i_not_one [simp]:
  \<open>\<i> \<noteq> 1\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_i_not_numeral [simp]:
  \<open>\<i> \<noteq> numeral n\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_i_not_neg_numeral [simp]:
  \<open>\<i> \<noteq> - numeral n\<close>
  by (simp add: gauss_eq_iff)

lemma i_mult_i_eq [simp]:
  \<open>\<i> * \<i> = - 1\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_i_mult_minus [simp]:
  \<open>\<i> * (\<i> * x) = - x\<close>
  by (simp flip: mult.assoc)

lemma i_squared [simp]:
  \<open>\<i>\<^sup>2 = - 1\<close>
  by (simp add: power2_eq_square)

lemma i_even_power [simp]:
  \<open>\<i> ^ (n * 2) = (- 1) ^ n\<close>
  unfolding mult.commute [of n] power_mult by simp

lemma Re_i_times [simp]:
  \<open>Re (\<i> * z) = - Im z\<close>
  by simp

lemma Im_i_times [simp]:
  \<open>Im (\<i> * z) = Re z\<close>
  by simp

lemma i_times_eq_iff:
  \<open>\<i> * w = z \<longleftrightarrow> w = - (\<i> * z)\<close>
  by auto

lemma is_unit_i [simp]:
  \<open>\<i> dvd 1\<close>
  by (rule dvdI [of _ _ \<open>- \<i>\<close>]) simp

lemma gauss_numeral [code_post]:
  \<open>Gauss 0 0 = 0\<close>
  \<open>Gauss 1 0 = 1\<close>
  \<open>Gauss (- 1) 0 = - 1\<close>
  \<open>Gauss (numeral n) 0 = numeral n\<close>
  \<open>Gauss (- numeral n) 0 = - numeral n\<close>
  \<open>Gauss 0 1 = \<i>\<close>
  \<open>Gauss 0 (- 1) = - \<i>\<close>
  \<open>Gauss 0 (numeral n) = numeral n * \<i>\<close>
  \<open>Gauss 0 (- numeral n) = - numeral n * \<i>\<close>
  \<open>Gauss 1 1 = 1 + \<i>\<close>
  \<open>Gauss (- 1) 1 = - 1 + \<i>\<close>
  \<open>Gauss (numeral n) 1 = numeral n + \<i>\<close>
  \<open>Gauss (- numeral n) 1 = - numeral n + \<i>\<close>
  \<open>Gauss 1 (- 1) = 1 - \<i>\<close>
  \<open>Gauss 1 (numeral n) = 1 + numeral n * \<i>\<close>
  \<open>Gauss 1 (- numeral n) = 1 - numeral n * \<i>\<close>
  \<open>Gauss (- 1) (- 1) = - 1 - \<i>\<close>
  \<open>Gauss (numeral n) (- 1) = numeral n - \<i>\<close>
  \<open>Gauss (- numeral n) (- 1) = - numeral n - \<i>\<close>
  \<open>Gauss (- 1) (numeral n) = - 1 + numeral n * \<i>\<close>
  \<open>Gauss (- 1) (- numeral n) = - 1 - numeral n * \<i>\<close>
  \<open>Gauss (numeral m) (numeral n) = numeral m + numeral n * \<i>\<close>
  \<open>Gauss (- numeral m) (numeral n) = - numeral m + numeral n * \<i>\<close>
  \<open>Gauss (numeral m) (- numeral n) = numeral m - numeral n * \<i>\<close>
  \<open>Gauss (- numeral m) (- numeral n) = - numeral m - numeral n * \<i>\<close>
  by (simp_all add: gauss_eq_iff)

subsection \<open>Gauss Conjugation\<close>

primcorec cnj :: \<open>gauss \<Rightarrow> gauss\<close>
  where
    \<open>Re (cnj z) = Re z\<close>
  | \<open>Im (cnj z) = - Im z\<close>

lemma gauss_cnj_cancel_iff [simp]:
  \<open>cnj x = cnj y \<longleftrightarrow> x = y\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_cnj_cnj [simp]:
  \<open>cnj (cnj z) = z\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_cnj_zero [simp]:
  \<open>cnj 0 = 0\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_cnj_zero_iff [iff]:
  \<open>cnj z = 0 \<longleftrightarrow> z = 0\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_cnj_one_iff [simp]:
  \<open>cnj z = 1 \<longleftrightarrow> z = 1\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_cnj_add [simp]:
  \<open>cnj (x + y) = cnj x + cnj y\<close>
  by (simp add: gauss_eq_iff)

lemma cnj_sum [simp]:
  \<open>cnj (sum f s) = (\<Sum>x\<in>s. cnj (f x))\<close>
  by (induct s rule: infinite_finite_induct) auto

lemma gauss_cnj_diff [simp]:
  \<open>cnj (x - y) = cnj x - cnj y\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_cnj_minus [simp]:
  \<open>cnj (- x) = - cnj x\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_cnj_one [simp]:
  \<open>cnj 1 = 1\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_cnj_mult [simp]:
  \<open>cnj (x * y) = cnj x * cnj y\<close>
  by (simp add: gauss_eq_iff)

lemma cnj_prod [simp]:
  \<open>cnj (prod f s) = (\<Prod>x\<in>s. cnj (f x))\<close>
  by (induct s rule: infinite_finite_induct) auto

lemma gauss_cnj_power [simp]:
  \<open>cnj (x ^ n) = cnj x ^ n\<close>
  by (induct n) simp_all

lemma gauss_cnj_numeral [simp]:
  \<open>cnj (numeral w) = numeral w\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_cnj_of_nat [simp]:
  \<open>cnj (of_nat n) = of_nat n\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_cnj_of_int [simp]:
  \<open>cnj (of_int z) = of_int z\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_cnj_i [simp]:
  \<open>cnj \<i> = - \<i>\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_add_cnj:
  \<open>z + cnj z = of_int (2 * Re z)\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_diff_cnj:
  \<open>z - cnj z = of_int (2 * Im z) * \<i>\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_mult_cnj:
  \<open>z * cnj z = of_int ((Re z)\<^sup>2 + (Im z)\<^sup>2)\<close>
  by (simp add: gauss_eq_iff power2_eq_square)

lemma cnj_add_mult_eq_Re:
  \<open>z * cnj w + cnj z * w = of_int (2 * Re (z * cnj w))\<close>
  by (simp add: gauss_eq_iff)

lemma gauss_In_mult_cnj_zero [simp]:
  \<open>Im (z * cnj z) = 0\<close>
  by simp

subsection \<open>Algebraic division\<close>

instantiation gauss :: idom_modulo
begin

primcorec divide_gauss :: \<open>gauss \<Rightarrow> gauss \<Rightarrow> gauss\<close>
  where
    \<open>Re (x div y) = (Re x * Re y + Im x * Im y) rdiv ((Re y)\<^sup>2 + (Im y)\<^sup>2)\<close>
  | \<open>Im (x div y) = (Im x * Re y - Re x * Im y) rdiv ((Re y)\<^sup>2 + (Im y)\<^sup>2)\<close>

primcorec modulo_gauss :: \<open>gauss \<Rightarrow> gauss \<Rightarrow> gauss\<close>
  where
    \<open>Re (x mod y) = Re x -
      ((Re x * Re y + Im x * Im y) rdiv ((Re y)\<^sup>2 + (Im y)\<^sup>2) * Re y -
       (Im x * Re y - Re x * Im y) rdiv ((Re y)\<^sup>2 + (Im y)\<^sup>2) * Im y)\<close>
  | \<open>Im (x mod y) = Im x -
      ((Re x * Re y + Im x * Im y) rdiv ((Re y)\<^sup>2 + (Im y)\<^sup>2) * Im y +
       (Im x * Re y - Re x * Im y) rdiv ((Re y)\<^sup>2 + (Im y)\<^sup>2) * Re y)\<close>

instance proof
  fix x y :: gauss
  show \<open>x div 0 = 0\<close>
    by (simp add: gauss_eq_iff)
  show \<open>x * y div y = x\<close> if \<open>y \<noteq> 0\<close>
  proof -
    define Y where \<open>Y = (Re y)\<^sup>2 + (Im y)\<^sup>2\<close>
    moreover have \<open>Y > 0\<close>
      using that by (simp add: gauss_eq_0 less_le Y_def)
    have *: \<open>Im y * (Im y * Re x) + Re x * (Re y * Re y) = Re x * Y\<close>
      \<open>Im x * (Im y * Im y) + Im x * (Re y * Re y) = Im x * Y\<close>
      \<open>(Im y)\<^sup>2 + (Re y)\<^sup>2 = Y\<close>
      by (simp_all add: power2_eq_square algebra_simps Y_def)
    from \<open>Y > 0\<close> show ?thesis
      by (simp add: gauss_eq_iff algebra_simps) (simp add: * nonzero_mult_rdiv_cancel_right)
  qed
  show \<open>x div y * y + x mod y = x\<close>
    by (simp add: gauss_eq_iff)
qed

end

instantiation gauss :: euclidean_ring
begin

definition euclidean_size_gauss :: \<open>gauss \<Rightarrow> nat\<close>
  where \<open>euclidean_size x = nat ((Re x)\<^sup>2 + (Im x)\<^sup>2)\<close>

instance proof
  show \<open>euclidean_size (0::gauss) = 0\<close>
    by (simp add: euclidean_size_gauss_def)
  show \<open>euclidean_size (x mod y) < euclidean_size y\<close> if \<open>y \<noteq> 0\<close> for x y :: gauss
  proof-
    define X and Y and R and I
      where \<open>X = (Re x)\<^sup>2 + (Im x)\<^sup>2\<close> and \<open>Y = (Re y)\<^sup>2 + (Im y)\<^sup>2\<close>
        and \<open>R = Re x * Re y + Im x * Im y\<close> and \<open>I = Im x * Re y - Re x * Im y\<close>
    with that have \<open>0 < Y\<close> and rhs: \<open>int (euclidean_size y) = Y\<close>
      by (simp_all add: gauss_neq_0 euclidean_size_gauss_def)
    have \<open>X * Y = R\<^sup>2 + I\<^sup>2\<close>
      by (simp add: R_def I_def X_def Y_def power2_eq_square algebra_simps)
    let ?lhs = \<open>X - I * (I rdiv Y) - R * (R rdiv Y)
        - I rdiv Y * (I rmod Y) - R rdiv Y * (R rmod Y)\<close>
    have \<open>?lhs = X + Y * (R rdiv Y) * (R rdiv Y) + Y * (I rdiv Y) * (I rdiv Y)
        - 2 * (R rdiv Y * R + I rdiv Y * I)\<close>
      by (simp flip: minus_rmod_eq_mult_rdiv add: algebra_simps)
    also have \<open>\<dots> = (Re (x mod y))\<^sup>2 + (Im (x mod y))\<^sup>2\<close>
      by (simp add: X_def Y_def R_def I_def algebra_simps power2_eq_square)
    finally have lhs: \<open>int (euclidean_size (x mod y)) = ?lhs\<close>
      by (simp add: euclidean_size_gauss_def)
    have \<open>?lhs * Y = (I rmod Y)\<^sup>2 + (R rmod Y)\<^sup>2\<close>
      apply (simp add: algebra_simps power2_eq_square \<open>X * Y = R\<^sup>2 + I\<^sup>2\<close>)
      apply (simp flip: mult.assoc add.assoc minus_rmod_eq_mult_rdiv)
      apply (simp add: algebra_simps)
      done
    also have \<open>\<dots> \<le> (Y div 2)\<^sup>2 + (Y div 2)\<^sup>2\<close>
      by (rule add_mono) (use \<open>Y > 0\<close> abs_rmod_less_equal [of Y] in \<open>simp_all add: power2_le_iff_abs_le\<close>)
    also have \<open>\<dots> < Y\<^sup>2\<close>
      using \<open>Y > 0\<close> by (cases \<open>Y = 1\<close>) (simp_all add: power2_eq_square mult_le_less_imp_less flip: mult.assoc)
    finally have \<open>?lhs * Y < Y\<^sup>2\<close> .
    with \<open>Y > 0\<close> have \<open>?lhs < Y\<close>
      by (simp add: power2_eq_square)
    then have \<open>int (euclidean_size (x mod y)) < int (euclidean_size y)\<close>
      by (simp only: lhs rhs)
    then show ?thesis
      by simp
  qed
  show \<open>euclidean_size x \<le> euclidean_size (x * y)\<close> if \<open>y \<noteq> 0\<close> for x y :: gauss
  proof -
    from that have \<open>euclidean_size y > 0\<close>
      by (simp add: euclidean_size_gauss_def gauss_neq_0)
    then have \<open>euclidean_size x \<le> euclidean_size x * euclidean_size y\<close>
      by simp
    also have \<open>\<dots> = nat (((Re x)\<^sup>2 + (Im x)\<^sup>2) * ((Re y)\<^sup>2 + (Im y)\<^sup>2))\<close>
      by (simp add: euclidean_size_gauss_def nat_mult_distrib)
    also have \<open>\<dots> = euclidean_size (x * y)\<close>
      by (simp add: euclidean_size_gauss_def eq_nat_nat_iff) (simp add: algebra_simps power2_eq_square)
    finally show ?thesis .
  qed
qed

end

end


section "Priority Queues Based on Braun Trees 2"

theory Priority_Queue_Braun2
imports Priority_Queue_Braun
begin

text \<open>This is the version verified by Jean-Christophe Filliâtre with the help of the Why3 system
\<^url>\<open>http://toccata.lri.fr/gallery/braun_trees.en.html\<close>.
Only the deletion function (\<open>del_min2\<close> below) differs from Paulson's version.
But the difference turns out to be minor --- see below.\<close>

subsection "Function \<open>del_min2\<close>"

fun le_root :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> bool" where
"le_root a t = (t = Leaf \<or> a \<le> value t)"

fun replace_min :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"replace_min x (Node l _ r) =
  (if le_root x l & le_root x r then Node l x r
   else
     let a = value l in
     if le_root a r then Node (replace_min x l) a r
     else Node l (value r) (replace_min x r))"

fun merge :: "'a::linorder tree \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"merge l Leaf = l" |
"merge (Node l1 a1 r1) (Node l2 a2 r2) =
   (if a1 \<le> a2 then Node (Node l2 a2 r2) a1 (merge l1 r1)
    else let (x, l') = del_left (Node l1 a1 r1)
         in Node (replace_min x (Node l2 a2 r2)) a2 l')"

fun del_min2 where
"del_min2 Leaf = Leaf" |
"del_min2 (Node l x r) = merge l r"

subsection "Correctness Proof"

text \<open>It turns out that @{const replace_min} is just @{const sift_down} in disguise:\<close>

lemma replace_min_sift_down: "braun (Node l a r) \<Longrightarrow> replace_min x (Node l a r) = sift_down l x r"
by(induction l x r rule: sift_down.induct)(auto)

text \<open>This means that @{const del_min2} is merely a slight optimization of @{const del_min}:
instead of calling @{const del_left} right away, @{const merge} can take advantage of the case
where the smaller element is at the root of the left heap and can be moved up without complications.
However, on average this is just the case on the first level.\<close>

text \<open>Function @{const merge}:\<close>

lemma mset_tree_merge:
  "braun (Node l x r) \<Longrightarrow> mset_tree(merge l r) = mset_tree l + mset_tree r"
by(induction l r rule: merge.induct)
  (auto simp: Let_def tree.set_sel(2) mset_sift_down replace_min_sift_down
        simp del: replace_min.simps dest!: del_left_mset split!: prod.split)

lemma heap_merge:
  "\<lbrakk> braun (Node l x r); heap l; heap r \<rbrakk> \<Longrightarrow> heap(merge l r)"
proof(induction l r rule: merge.induct)
  case 1 thus ?case by simp
next
  case (2 l1 a1 r1 l2 a2 r2)
  show ?case
  proof cases
    assume "a1 \<le> a2"
    thus ?thesis using 2 by(auto simp: ball_Un mset_tree_merge simp flip: set_mset_tree)
  next
    assume "\<not> a1 \<le> a2"
    let ?l = "Node l1 a1 r1" let ?r = "Node l2 a2 r2"
    have "braun ?r" using "2.prems"(1) by auto
    obtain x l' where dl: "del_left ?l = (x, l')" by (metis surj_pair)
    from del_left_heap[OF this _ "2.prems"(2)] have "heap l'" by auto
    have hr: "heap(replace_min x ?r)" using \<open>braun ?r\<close> "2.prems"(3)
      by(simp add: heap_sift_down neq_Leaf_iff replace_min_sift_down del: replace_min.simps)
    have 0: "\<forall>x \<in> set_tree ?l. a2 \<le> x" using "2.prems"(2) \<open>\<not> a1 \<le> a2\<close> by (auto simp: ball_Un)
    moreover have "set_tree l' \<subseteq> set_tree ?l" "x \<in> set_tree ?l"
      using del_left_mset[OF dl] by (auto simp flip: set_mset_tree dest:in_diffD simp: union_iff)
    ultimately have 1: "\<forall>x \<in> set_tree l'. a2 \<le> x" by blast
    have "\<forall>x \<in> set_tree ?r. a2 \<le> x" using \<open>heap ?r\<close> by auto
    thus ?thesis
      using \<open>\<not> a1 \<le> a2\<close> dl \<open>heap(replace_min x ?r)\<close> \<open>heap l'\<close> \<open>x \<in> set_tree ?l\<close> 0 1 \<open>braun ?r\<close>
      by(auto simp: mset_sift_down replace_min_sift_down simp flip: set_mset_tree
              simp del: replace_min.simps)
  qed
next
  case 3 thus ?case by simp
qed

lemma del_left_braun_size:
  "del_left t = (x,t') \<Longrightarrow> braun t \<Longrightarrow> t \<noteq> Leaf \<Longrightarrow> braun t' \<and> size t = size t' + 1"
by (simp add: del_left_braun del_left_size)

lemma braun_size_merge:
  "braun (Node l x r) \<Longrightarrow> braun(merge l r) \<and> size(merge l r) = size l + size r"
apply(induction l r rule: merge.induct)
apply(auto simp: size_sift_down braun_sift_down replace_min_sift_down
           simp del: replace_min.simps
           dest!: del_left_braun_size split!: prod.split)
done

text \<open>Last step: prove all axioms of the priority queue specification:\<close>

interpretation braun: Priority_Queue
where empty = Leaf and is_empty = "\<lambda>h. h = Leaf"
and insert = insert and del_min = del_min2
and get_min = "value" and invar = "\<lambda>h. braun h \<and> heap h"
and mset = mset_tree
proof(standard, goal_cases)
  case 1 show ?case by simp
next
  case 2 show ?case by simp
next
  case 3 show ?case by(simp add: mset_insert)
next
  case 4 thus ?case by(auto simp: mset_tree_merge neq_Leaf_iff)
next
  case 5 thus ?case using get_min mset_tree.simps(1) by blast
next
  case 6 thus ?case by(simp)
next
  case 7 thus ?case by(simp add: heap_insert braun_insert)
next
  case 8 thus ?case by(auto simp: heap_merge braun_size_merge neq_Leaf_iff)
qed

end


(*
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
                Tobias Nipkow, TUM
*)

theory Tilings imports Main begin

section{* Inductive Tiling *}

inductive_set
  tiling :: "'a set set \<Rightarrow> 'a set set"
  for A :: "'a set set" where
empty [simp, intro]: "{} \<in> tiling A" |
Un [simp, intro]:    "\<lbrakk> a \<in> A; t \<in> tiling A; a \<inter> t = {} \<rbrakk>
                         \<Longrightarrow> a \<union> t \<in> tiling A"

lemma tiling_UnI [intro]:
  "\<lbrakk> t \<in> tiling A; u \<in> tiling A; t \<inter> u = {} \<rbrakk> \<Longrightarrow>  t \<union> u \<in> tiling A"
apply (induct set: tiling)
apply (auto simp add: Un_assoc)
done

lemma tiling_Diff1E:
assumes "t-a \<in> tiling A" and "a \<in> A" and "a \<subseteq> t"
shows "t \<in> tiling A"
proof -
  from assms(2-3) have  "EX r. t = r Un a & r Int a = {}"
    by (metis Diff_disjoint Int_commute Un_Diff_cancel Un_absorb1 Un_commute)
  thus ?thesis using assms(1,2)
    by (auto simp:Un_Diff)
       (metis Compl_Diff_eq Diff_Compl Diff_empty Int_commute Un_Diff_cancel
              Un_commute double_complement tiling.Un)
qed

lemma tiling_finite:
  assumes "\<And>a. a \<in> A \<Longrightarrow> finite a"
  shows "t \<in> tiling A \<Longrightarrow> finite t"
apply (induct set: tiling)
using assms apply auto
done

section{* The Mutilated Chess Board Cannot be Tiled by Dominoes *}

text {* The originator of this problem is Max Black, according to J A
Robinson. It was popularized as the \emph{Mutilated Checkerboard Problem} by
J McCarthy.  *}

inductive_set domino :: "(nat \<times> nat) set set" where
horiz [simp]: "{(i, j), (i, Suc j)} \<in> domino" |
vertl [simp]: "{(i, j), (Suc i, j)} \<in> domino"

lemma domino_finite: "d \<in> domino \<Longrightarrow> finite d"
by (erule domino.cases, auto)

declare tiling_finite[OF domino_finite, simp]

text {* \medskip Sets of squares of the given colour *}

definition
  coloured :: "nat \<Rightarrow> (nat \<times> nat) set" where
  "coloured b = {(i, j). (i + j) mod 2 = b}"

abbreviation
  whites  :: "(nat \<times> nat) set" where
  "whites \<equiv> coloured 0"

abbreviation
  blacks  :: "(nat \<times> nat) set" where
  "blacks \<equiv> coloured (Suc 0)"

text {* \medskip Chess boards *}

lemma Sigma_Suc1 [simp]:
  "{0..< Suc n} \<times> B = ({n} \<times> B) \<union> ({0..<n} \<times> B)"
by auto

lemma Sigma_Suc2 [simp]:
  "A \<times> {0..< Suc n} = (A \<times> {n}) \<union> (A \<times> {0..<n})"
by auto

lemma dominoes_tile_row [intro!]: "{i} \<times> {0..< 2*n} \<in> tiling domino"
apply (induct n)
apply (simp_all del:Un_insert_left add: Un_assoc [symmetric])
done

lemma dominoes_tile_matrix: "{0..<m} \<times> {0..< 2*n} \<in> tiling domino"
by (induct m) auto

text {* \medskip @{term coloured} and Dominoes *}

lemma coloured_insert [simp]:
  "coloured b \<inter> (insert (i, j) t) =
   (if (i + j) mod 2 = b then insert (i, j) (coloured b \<inter> t)
    else coloured b \<inter> t)"
by (auto simp add: coloured_def)

lemma domino_singletons:
  "d \<in> domino \<Longrightarrow>
   (\<exists>i j. whites \<inter> d = {(i, j)}) \<and>
   (\<exists>m n. blacks \<inter> d = {(m, n)})"
apply (erule domino.cases)
 apply (auto simp add: mod_Suc)
done

text {* \medskip Tilings of dominoes *}

declare
  Int_Un_distrib [simp]
  Diff_Int_distrib [simp]

lemma tiling_domino_0_1:
  "t \<in> tiling domino ==> card(whites \<inter> t) = card(blacks \<inter> t)"
apply (induct set: tiling)
 apply (drule_tac [2] domino_singletons)
 apply (auto)
apply (subgoal_tac "\<forall>p C. C \<inter> a = {p} --> p \<notin> t")
  -- {* this lemma tells us that both ``inserts'' are non-trivial *}
 apply (simp (no_asm_simp))
apply blast
done

text {* \medskip Final argument is surprisingly complex *}

theorem gen_mutil_not_tiling:
  "t \<in> tiling domino ==>
  (i + j) mod 2 = 0 ==> (m + n) mod 2 = 0 ==>
  {(i, j), (m, n)} \<subseteq> t
  ==> (t - {(i,j)} - {(m,n)}) \<notin> tiling domino"
apply (rule notI)
apply (subgoal_tac
  "card (whites \<inter> (t - {(i,j)} - {(m,n)})) <
   card (blacks \<inter> (t - {(i,j)} - {(m,n)}))")
 apply (force simp only: tiling_domino_0_1)
apply (simp add: tiling_domino_0_1 [symmetric])
apply (simp add: coloured_def card_Diff2_less)
done

text {* Apply the general theorem to the well-known case *}

theorem mutil_not_tiling:
  "t = {0..< 2 * Suc m} \<times> {0..< 2 * Suc n}
   ==> t - {(0,0)} - {(Suc(2 * m), Suc(2 * n))} \<notin> tiling domino"
apply (rule gen_mutil_not_tiling)
 apply (blast intro!: dominoes_tile_matrix)
apply auto
done

section{* The Mutilated Chess Board Can be Tiled by Ls *}

text{* Remove a arbitrary square from a chess board of size $2^n \times 2^n$.
The result can be tiled by L-shaped tiles:
\begin{picture}(8,8)
\put(0,0){\framebox(4,4){}}
\put(4,0){\framebox(4,4){}}
\put(0,4){\framebox(4,4){}}
\end{picture}.
The four possible L-shaped tiles are obtained by dropping
one of the four squares from $\{(x,y),(x+1,y),(x,y+1),(x+1,y+1)\}$: *}

definition "L2 (x::nat) (y::nat) = {(x,y), (x+1,y), (x, y+1)}"
definition "L3 (x::nat) (y::nat) = {(x,y), (x+1,y), (x+1, y+1)}"
definition "L0 (x::nat) (y::nat) = {(x+1,y), (x,y+1), (x+1, y+1)}"
definition "L1 (x::nat) (y::nat) = {(x,y), (x,y+1), (x+1, y+1)}"

text{* All tiles: *}

definition Ls :: "(nat * nat) set set" where
"Ls \<equiv> { L0 x y | x y. True} \<union> { L1 x y | x y. True} \<union>
      { L2 x y | x y. True} \<union> { L3 x y | x y. True}"

lemma LinLs: "L0 i j : Ls & L1 i j : Ls & L2 i j : Ls & L3 i j : Ls"
by(fastforce simp:Ls_def)

text{* Square $2^n \times 2^n$ grid, shifted by $i$ and $j$: *}

definition "square2 (n::nat) (i::nat) (j::nat) = {i..< 2^n+i} \<times> {j..< 2^n+j}"

lemma in_square2[simp]:
  "(a,b) : square2 n i j \<longleftrightarrow> i\<le>a \<and> a<2^n+i \<and> j\<le>b \<and> b<2^n+j"
by(simp add:square2_def)

lemma square2_Suc: "square2 (Suc n) i j =
  square2 n i j \<union> square2 n (2^n + i) j \<union> square2 n i (2^n + j) \<union>
  square2 n (2^n + i) (2^n + j)"
by(auto simp:square2_def)

lemma square2_disj: "square2 n i j \<inter> square2 n x y = {} \<longleftrightarrow>
  (2^n+i \<le> x \<or> 2^n+x \<le> i) \<or> (2^n+j \<le> y \<or> 2^n+y \<le> j)" (is "?A = ?B")
proof-
  { assume ?B hence ?A by(auto simp:square2_def) }
  moreover
  { assume "\<not> ?B"
    hence "(max i x, max j y) : square2 n i j \<inter> square2 n x y" by simp
    hence "\<not> ?A" by blast }
  ultimately show ?thesis by blast
qed

text{* Some specific lemmas: *}

lemma pos_pow2: "(0::nat) < 2^(n::nat)"
by simp

declare nat_zero_less_power_iff[simp del] zero_less_power[simp del]

lemma Diff_insert_if: shows
  "B \<noteq> {} \<Longrightarrow> a:A \<Longrightarrow> A - insert a B = (A-B - {a})" and
  "B \<noteq> {} \<Longrightarrow> a ~: A \<Longrightarrow> A - insert a B = A-B"
by auto

lemma DisjI1: "A Int B = {} \<Longrightarrow> (A-X) Int B = {}"
by blast
lemma DisjI2: "A Int B = {} \<Longrightarrow> A Int (B-X) = {}"
by blast

text{* The main theorem: *}

theorem Ls_can_tile: "i \<le> a \<Longrightarrow> a < 2^n + i \<Longrightarrow> j \<le> b \<Longrightarrow> b < 2^n + j
  \<Longrightarrow> square2 n i j - {(a,b)} : tiling Ls"
proof(induct n arbitrary: a b i j)
  case 0 thus ?case by (simp add:square2_def)
next
  case (Suc n) note IH = Suc(1) and a = Suc(2-3) and b = Suc(4-5)
  hence "a<2^n+i \<and> b<2^n+j \<or>
         2^n+i\<le>a \<and> a<2^(n+1)+i \<and> b<2^n+j \<or>
         a<2^n+i \<and> 2^n+j\<le>b \<and> b<2^(n+1)+j \<or>
         2^n+i\<le>a \<and> a<2^(n+1)+i \<and> 2^n+j\<le>b \<and> b<2^(n+1)+j" (is "?A|?B|?C|?D")
    by simp arith
  moreover
  { assume "?A"
    hence "square2 n i j - {(a,b)} : tiling Ls" using IH a b by auto
    moreover have "square2 n (2^n+i) j - {(2^n+i,2^n+j - 1)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n i (2^n+j) - {(2^n+i - 1, 2^n+j)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n (2^n+i) (2^n+j) - {(2^n+i, 2^n+j)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    ultimately
    have "square2 (n+1) i j - {(a,b)} - L0 (2^n+i - 1) (2^n+j - 1) \<in> tiling Ls"
      using  a b `?A`
      by (clarsimp simp: square2_Suc L0_def Un_Diff Diff_insert_if)
         (fastforce intro!: tiling_UnI DisjI1 DisjI2 square2_disj[THEN iffD2]
                   simp:Int_Un_distrib2)
  } moreover
  { assume "?B"
    hence "square2 n (2^n+i) j - {(a,b)} : tiling Ls" using IH a b by auto
    moreover have "square2 n i j - {(2^n+i - 1,2^n+j - 1)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n i (2^n+j) - {(2^n+i - 1, 2^n+j)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n (2^n+i) (2^n+j) - {(2^n+i, 2^n+j)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    ultimately
    have "square2 (n+1) i j - {(a,b)} - L1 (2^n+i - 1) (2^n+j - 1) \<in> tiling Ls"
      using  a b `?B`
      by (simp add: square2_Suc L1_def Un_Diff Diff_insert_if le_diff_conv2)
         (fastforce intro!: tiling_UnI DisjI1 DisjI2 square2_disj[THEN iffD2]
                   simp:Int_Un_distrib2)
  } moreover
  { assume "?C"
    hence "square2 n i (2^n+j) - {(a,b)} : tiling Ls" using IH a b by auto
    moreover have "square2 n i j - {(2^n+i - 1,2^n+j - 1)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n (2^n+i) j - {(2^n+i, 2^n+j - 1)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n (2^n+i) (2^n+j) - {(2^n+i, 2^n+j)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    ultimately
    have "square2 (n+1) i j - {(a,b)} - L3 (2^n+i - 1) (2^n+j - 1) \<in> tiling Ls"
      using  a b `?C`
      by (simp add: square2_Suc L3_def Un_Diff Diff_insert_if le_diff_conv2)
         (fastforce intro!: tiling_UnI DisjI1 DisjI2 square2_disj[THEN iffD2]
                   simp:Int_Un_distrib2)
  } moreover
  { assume "?D"
    hence "square2 n (2^n+i) (2^n+j) -{(a,b)} : tiling Ls" using IH a b by auto
    moreover have "square2 n i j - {(2^n+i - 1,2^n+j - 1)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n (2^n+i) j - {(2^n+i, 2^n+j - 1)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    moreover have "square2 n i (2^n+j) - {(2^n+i - 1, 2^n+j)} : tiling Ls"
      by(rule IH)(insert pos_pow2[of n], auto)
    ultimately
    have "square2 (n+1) i j - {(a,b)} - L2 (2^n+i - 1) (2^n+j - 1) \<in> tiling Ls"
      using  a b `?D`
      by (simp add: square2_Suc L2_def Un_Diff Diff_insert_if le_diff_conv2)
         (fastforce intro!: tiling_UnI DisjI1 DisjI2 square2_disj[THEN iffD2]
                   simp:Int_Un_distrib2)
  } moreover
  have "?A \<Longrightarrow> L0 (2^n + i - 1) (2^n + j - 1) \<subseteq> square2 (n+1) i j - {(a, b)}"
    using a b by(simp add:L0_def) arith moreover
  have "?B \<Longrightarrow> L1 (2^n + i - 1) (2^n + j - 1) \<subseteq> square2 (n+1) i j - {(a, b)}"
    using a b by(simp add:L1_def) arith moreover
  have "?C \<Longrightarrow> L3 (2^n + i - 1) (2^n + j - 1) \<subseteq> square2 (n+1) i j - {(a, b)}"
    using a b by(simp add:L3_def) arith moreover
  have "?D \<Longrightarrow> L2 (2^n + i - 1) (2^n + j - 1) \<subseteq> square2 (n+1) i j - {(a, b)}"
    using a b by(simp add:L2_def) arith
  ultimately show ?case by simp (metis LinLs tiling_Diff1E)
qed

corollary Ls_can_tile00:
  "a < 2^n \<Longrightarrow> b < 2^n \<Longrightarrow> square2 n 0 0 - {(a, b)} \<in> tiling Ls"
by(rule Ls_can_tile) auto

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_nat_NMSortTDCount
  imports "../../Test_Base"
begin

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

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
  "plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun minus :: "Nat => Nat => Nat" where
  "minus (Z) y = Z"
| "minus (S z) (S y2) = minus z y2"

(*fun did not finish the proof*)
function nmsorttdhalf1 :: "Nat => Nat" where
  "nmsorttdhalf1 x =
   (if (x = (S Z)) then Z else
      (case x of
         Z => Z
         | S y => plus (S Z) (nmsorttdhalf1 (minus x (S (S Z))))))"
  by pat_completeness auto

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 y l) = plus (S Z) (length l)"

fun le :: "Nat => Nat => bool" where
  "le (Z) y = True"
| "le (S z) (Z) = False"
| "le (S z) (S x2) = le z x2"

fun lmerge :: "Nat list => Nat list => Nat list" where
  "lmerge (nil2) y = y"
| "lmerge (cons2 z x2) (nil2) = cons2 z x2"
| "lmerge (cons2 z x2) (cons2 x3 x4) =
     (if le z x3 then cons2 z (lmerge x2 (cons2 x3 x4)) else
        cons2 x3 (lmerge (cons2 z x2) x4))"

fun take :: "Nat => 'a list => 'a list" where
  "take x y =
   (if le x Z then nil2 else
      (case y of
         nil2 => nil2
         | cons2 z xs => (case x of S x2 => cons2 z (take x2 xs))))"

fun drop :: "Nat => 'a list => 'a list" where
  "drop x y =
   (if le x Z then y else
      (case y of
         nil2 => nil2
         | cons2 z xs1 => (case x of S x2 => drop x2 xs1)))"

(*fun did not finish the proof*)
function nmsorttd :: "Nat list => Nat list" where
  "nmsorttd (nil2) = nil2"
| "nmsorttd (cons2 y (nil2)) = cons2 y (nil2)"
| "nmsorttd (cons2 y (cons2 x2 x3)) =
     (let k :: Nat = nmsorttdhalf1 (length (cons2 y (cons2 x2 x3)))
     in lmerge
          (nmsorttd (take k (cons2 y (cons2 x2 x3))))
          (nmsorttd (drop k (cons2 y (cons2 x2 x3)))))"
  by pat_completeness auto

fun count :: "'a => 'a list => Nat" where
  "count x (nil2) = Z"
| "count x (cons2 z ys) =
     (if (x = z) then plus (S Z) (count x ys) else count x ys)"

theorem property0 :
  "((count x (nmsorttd xs)) = (count x xs))"
  oops

end


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

datatype Nat = Z | S "Nat"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y2) = x x2 y2"

fun min :: "Nat => Nat => Nat" where
  "min (Z) z = Z"
| "min (S z2) (Z) = Z"
| "min (S z2) (S y1) = S (min z2 y1)"

fun t2 :: "Nat => Nat => bool" where
  "t2 (Z) z = True"
| "t2 (S z2) (Z) = False"
| "t2 (S z2) (S x2) = t2 z2 x2"

theorem property0 :(*This problem is similar to TIP_prop_33.thy*)
  "((x (min a b) b) = (t2 b a))"
  find_proof DInd
  apply (induct rule: TIP_prop_34.x.induct)
     apply auto
  done

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Partial Equivalence Relations\<close>
theory Partial_Equivalence_Relations
  imports
    Binary_Relations_Symmetric
    Preorders
begin

definition "partial_equivalence_rel_on P R \<equiv> transitive_on P R \<and> symmetric_on P R"

lemma partial_equivalence_rel_onI [intro]:
  assumes "transitive_on P R"
  and "symmetric_on P R"
  shows "partial_equivalence_rel_on P R"
  unfolding partial_equivalence_rel_on_def using assms by blast

lemma partial_equivalence_rel_onE [elim]:
  assumes "partial_equivalence_rel_on P R"
  obtains "transitive_on P R" "symmetric_on P R"
  using assms unfolding partial_equivalence_rel_on_def by blast

lemma partial_equivalence_rel_on_rel_self_if_rel_dom:
  assumes "partial_equivalence_rel_on (P :: 'a \<Rightarrow> bool) (R :: 'a \<Rightarrow> 'a \<Rightarrow> bool)"
  and "P x" "P y"
  and "R x y"
  shows "R x x"
  using assms by (blast dest: symmetric_onD transitive_onD)

lemma partial_equivalence_rel_on_rel_self_if_rel_codom:
  assumes "partial_equivalence_rel_on (P :: 'a \<Rightarrow> bool) (R :: 'a \<Rightarrow> 'a \<Rightarrow> bool)"
  and "P x" "P y"
  and "R x y"
  shows "R y y"
  using assms by (blast dest: symmetric_onD transitive_onD)

lemma partial_equivalence_rel_on_rel_inv_iff_partial_equivalence_rel_on [iff]:
  "partial_equivalence_rel_on P R\<inverse> \<longleftrightarrow> partial_equivalence_rel_on (P :: 'a \<Rightarrow> bool) (R :: 'a \<Rightarrow> _)"
  by blast

definition "partial_equivalence_rel (R :: 'a \<Rightarrow> _) \<equiv> partial_equivalence_rel_on (\<top> :: 'a \<Rightarrow> bool) R"

lemma partial_equivalence_rel_eq_partial_equivalence_rel_on:
  "partial_equivalence_rel (R :: 'a \<Rightarrow> _) = partial_equivalence_rel_on (\<top> :: 'a \<Rightarrow> bool) R"
  unfolding partial_equivalence_rel_def ..

lemma partial_equivalence_relI [intro]:
  assumes "transitive R"
  and "symmetric R"
  shows "partial_equivalence_rel R"
  unfolding partial_equivalence_rel_eq_partial_equivalence_rel_on using assms
  by (intro partial_equivalence_rel_onI transitive_on_if_transitive symmetric_on_if_symmetric)

lemma reflexive_on_in_field_if_partial_equivalence_rel:
  assumes "partial_equivalence_rel R"
  shows "reflexive_on (in_field R) R"
  using assms unfolding partial_equivalence_rel_eq_partial_equivalence_rel_on
  by (intro reflexive_onI) (blast
    intro: top1I partial_equivalence_rel_on_rel_self_if_rel_dom
    partial_equivalence_rel_on_rel_self_if_rel_codom)

lemma partial_equivalence_relE [elim]:
  assumes "partial_equivalence_rel R"
  obtains "preorder_on (in_field R) R" "symmetric R"
  using assms unfolding partial_equivalence_rel_eq_partial_equivalence_rel_on
  by (elim partial_equivalence_rel_onE)
  (auto intro: reflexive_on_in_field_if_partial_equivalence_rel
    simp flip: transitive_eq_transitive_on symmetric_eq_symmetric_on)

lemma partial_equivalence_rel_on_if_partial_equivalence_rel:
  fixes P :: "'a \<Rightarrow> bool" and R :: "'a \<Rightarrow> _"
  assumes "partial_equivalence_rel R"
  shows "partial_equivalence_rel_on P R"
  using assms by (elim partial_equivalence_relE preorder_on_in_fieldE)
  (intro partial_equivalence_rel_onI transitive_on_if_transitive
    symmetric_on_if_symmetric)

lemma partial_equivalence_rel_rel_inv_iff_partial_equivalence_rel [iff]:
  "partial_equivalence_rel R\<inverse> \<longleftrightarrow> partial_equivalence_rel R"
  unfolding partial_equivalence_rel_eq_partial_equivalence_rel_on by blast

corollary in_codom_eq_in_dom_if_partial_equivalence_rel:
  assumes "partial_equivalence_rel R"
  shows "in_codom R = in_dom R"
  using assms reflexive_on_in_field_if_partial_equivalence_rel
    in_codom_eq_in_dom_if_reflexive_on_in_field
  by auto

lemma partial_equivalence_rel_rel_comp_self_eq_self:
  assumes "partial_equivalence_rel R"
  shows "(R \<circ>\<circ> R) = R"
  using assms by (intro ext) (blast dest: symmetricD)

lemma partial_equivalence_rel_if_partial_equivalence_rel_on_in_field:
  assumes "partial_equivalence_rel_on (in_field R) R"
  shows "partial_equivalence_rel R"
  using assms by (intro partial_equivalence_relI)
  (auto intro: transitive_if_transitive_on_in_field symmetric_if_symmetric_on_in_field)

corollary partial_equivalence_rel_on_in_field_iff_partial_equivalence_rel [iff]:
  "partial_equivalence_rel_on (in_field R) R \<longleftrightarrow> partial_equivalence_rel R"
  using partial_equivalence_rel_if_partial_equivalence_rel_on_in_field
    partial_equivalence_rel_on_if_partial_equivalence_rel
  by blast

subsubsection \<open>Instantiations\<close>

lemma partial_equivalence_rel_eq: "partial_equivalence_rel (=)"
  using transitive_eq symmetric_eq by (rule partial_equivalence_relI)

lemma partial_equivalence_rel_top: "partial_equivalence_rel \<top>"
  using transitive_top symmetric_top by (rule partial_equivalence_relI)

end