(*  Title:      Native_Word_Test.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter {* Test cases *}

theory Native_Word_Test imports
  Uint64 Uint32 Uint16 Uint8 Uint Native_Cast
  "HOL-Library.Code_Test"
begin

section {* Tests for @{typ uint32} *}

notation sshiftr_uint32 (infixl ">>>" 55)

definition test_uint32 where
  "test_uint32 \<longleftrightarrow>
  (([ 0x100000001, -1, -4294967291, 0xFFFFFFFF, 0x12345678
    , 0x5A AND 0x36
    , 0x5A OR 0x36
    , 0x5A XOR 0x36
    , NOT 0x5A
    , 5 + 6, -5 + 6, -6 + 5, -5 + (- 6), 0xFFFFFFFFF + 1
    , 5 - 3, 3 - 5
    , 5 * 3, -5 * 3, -5 * -4, 0x12345678 * 0x87654321
    , 5 div 3, -5 div 3, -5 div -3, 5 div -3
    , 5 mod 3, -5 mod 3, -5 mod -3, 5 mod -3
    , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
    , set_bit 5 32 True, set_bit 5 32 False, set_bit (- 5) 32 True, set_bit (- 5) 32 False
    , 1 << 2, -1 << 3, 1 << 32, 1 << 0
    , 100 >> 3, -100 >> 3, 100 >> 32, -100 >> 32
    , 100 >>> 3, -100 >>> 3, 100 >>> 32, -100 >>> 32] :: uint32 list)
   =
    [ 1, 4294967295, 5, 4294967295, 305419896
    , 18
    , 126
    , 108
    , 4294967205
    , 11, 1, 4294967295, 4294967285, 0
    , 2, 4294967294
    , 15, 4294967281, 20, 1891143032
    , 1, 1431655763, 0, 0
    , 2, 2, 4294967291, 5
    , 21, 4294967295, 4, 4294967289
    , 5, 5, 4294967291, 4294967291
    , 4, 4294967288, 0, 1
    , 12, 536870899, 0, 0
    , 12, 4294967283, 0, 4294967295]) \<and>
  ([ (0x5 :: uint32) = 0x5, (0x5 :: uint32) = 0x6
   , (0x5 :: uint32) < 0x5, (0x5 :: uint32) < 0x6, (-5 :: uint32) < 6, (6 :: uint32) < -5
   , (0x5 :: uint32) \<le> 0x5, (0x5 :: uint32) \<le> 0x4, (-5 :: uint32) \<le> 6, (6 :: uint32) \<le> -5
   , (0x7FFFFFFF :: uint32) < 0x80000000, (0xFFFFFFFF :: uint32) < 0, (0x80000000 :: uint32) < 0x7FFFFFFF
   , (0x7FFFFFFF :: uint32) !! 0, (0x7FFFFFFF :: uint32) !! 31, (0x80000000 :: uint32) !! 31, (0x80000000 :: uint32) !! 32
   ]
  =
   [ True, False
   , False, True, False, True
   , True, False, False, True
   , True, False, False
   , True, False, True, False
   ]) \<and>
  ([integer_of_uint32 0, integer_of_uint32 0x7FFFFFFF, integer_of_uint32 0x80000000, integer_of_uint32 0xAAAAAAAA]
  =
   [0, 0x7FFFFFFF, 0x80000000, 0xAAAAAAAA])"

no_notation sshiftr_uint32 (infixl ">>>" 55)

export_code test_uint32 checking SML Haskell? OCaml? Scala

notepad begin
have test_uint32 by eval
have test_uint32 by code_simp
have test_uint32 by normalization
end

definition test_uint32' :: uint32
where "test_uint32' = 0 + 10 - 14 * 3 div 6 mod 3 << 3 >> 2"
ML {* val 0wx12 = @{code test_uint32'} *}

lemma "x AND y = x OR (y :: uint32)"
quickcheck[random, expect=counterexample]
quickcheck[exhaustive, expect=counterexample]
oops

lemma "(x :: uint32) AND x = x OR x"
quickcheck[narrowing, expect=no_counterexample]
by transfer simp

lemma "(f :: uint32 \<Rightarrow> unit) = g"
quickcheck[narrowing, size=3, expect=no_counterexample]
by(simp add: fun_eq_iff)

section {* Tests for @{typ uint16} *}

notation sshiftr_uint16 (infixl ">>>" 55)

definition test_uint16 where
  "test_uint16 \<longleftrightarrow>
  (([ 0x10001, -1, -65535, 0xFFFF, 0x1234
    , 0x5A AND 0x36
    , 0x5A OR 0x36
    , 0x5A XOR 0x36
    , NOT 0x5A
    , 5 + 6, -5 + 6, -6 + 5, -5 + -6, 0xFFFF + 1
    , 5 - 3, 3 - 5
    , 5 * 3, -5 * 3, -5 * -4, 0x1234 * 0x8765
    , 5 div 3, -5 div 3, -5 div -3, 5 div -3
    , 5 mod 3, -5 mod 3, -5 mod -3, 5 mod -3
    , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
    , set_bit 5 32 True, set_bit 5 32 False, set_bit (- 5) 32 True, set_bit (- 5) 32 False
    , 1 << 2, -1 << 3, 1 << 16, 1 << 0
    , 100 >> 3, -100 >> 3, 100 >> 16, -100 >> 16
    , 100 >>> 3, -100 >>> 3, 100 >>> 16, -100 >>> 16] :: uint16 list)
   =
    [ 1, 65535, 1, 65535, 4660
    , 18
    , 126
    , 108
    , 65445
    , 11, 1, 65535, 65525, 0
    , 2, 65534
    , 15, 65521, 20, 39556
    , 1, 21843, 0, 0
    , 2, 2, 65531, 5
    , 21, 65535, 4, 65529
    , 5, 5, 65531, 65531
    , 4, 65528, 0, 1
    , 12, 8179, 0, 0
    , 12, 65523, 0, 65535]) \<and>
  ([ (0x5 :: uint16) = 0x5, (0x5 :: uint16) = 0x6
   , (0x5 :: uint16) < 0x5, (0x5 :: uint16) < 0x6, (-5 :: uint16) < 6, (6 :: uint16) < -5
   , (0x5 :: uint16) \<le> 0x5, (0x5 :: uint16) \<le> 0x4, (-5 :: uint16) \<le> 6, (6 :: uint16) \<le> -5
   , (0x7FFF :: uint16) < 0x8000, (0xFFFF :: uint16) < 0, (0x8000 :: uint16) < 0x7FFF
   , (0x7FFF :: uint16) !! 0, (0x7FFF :: uint16) !! 15, (0x8000 :: uint16) !! 15, (0x8000 :: uint16) !! 16
   ]
  =
   [ True, False
   , False, True, False, True
   , True, False, False, True
   , True, False, False
   , True, False, True, False
   ]) \<and>
  ([integer_of_uint16 0, integer_of_uint16 0x7FFF, integer_of_uint16 0x8000, integer_of_uint16 0xAAAA]
  =
   [0, 0x7FFF, 0x8000, 0xAAAA])"

no_notation sshiftr_uint16 (infixl ">>>" 55)

export_code test_uint16 checking Haskell? Scala
export_code test_uint16 in SML_word

notepad begin
have test_uint16 by code_simp
have test_uint16 by normalization
end

lemma "(x :: uint16) AND x = x OR x"
quickcheck[narrowing, expect=no_counterexample]
by transfer simp

lemma "(f :: uint16 \<Rightarrow> unit) = g"
quickcheck[narrowing, size=3, expect=no_counterexample]
by(simp add: fun_eq_iff)

section {* Tests for @{typ uint8} *}

notation sshiftr_uint8 (infixl ">>>" 55)

definition test_uint8 where
  "test_uint8 \<longleftrightarrow>
  (([ 0x101, -1, -255, 0xFF, 0x12
    , 0x5A AND 0x36
    , 0x5A OR 0x36
    , 0x5A XOR 0x36
    , NOT 0x5A
    , 5 + 6, -5 + 6, -6 + 5, -5 + -6, 0xFF + 1
    , 5 - 3, 3 - 5
    , 5 * 3, -5 * 3, -5 * -4, 0x12 * 0x87
    , 5 div 3, -5 div 3, -5 div -3, 5 div -3
    , 5 mod 3, -5 mod 3, -5 mod -3, 5 mod -3
    , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
    , set_bit 5 32 True, set_bit 5 32 False, set_bit (- 5) 32 True, set_bit (- 5) 32 False
    , 1 << 2, -1 << 3, 1 << 8, 1 << 0
    , 100 >> 3, -100 >> 3, 100 >> 8, -100 >> 8
    , 100 >>> 3, -100 >>> 3, 100 >>> 8, -100 >>> 8] :: uint8 list)
   =
    [ 1, 255, 1, 255, 18
    , 18
    , 126
    , 108
    , 165
    , 11, 1, 255, 245, 0
    , 2, 254
    , 15, 241, 20, 126
    , 1, 83, 0, 0
    , 2, 2, 251, 5
    , 21, 255, 4, 249
    , 5, 5, 251, 251
    , 4, 248, 0, 1
    , 12, 19, 0, 0
    , 12, 243, 0, 255]) \<and>
  ([ (0x5 :: uint8) = 0x5, (0x5 :: uint8) = 0x6
   , (0x5 :: uint8) < 0x5, (0x5 :: uint8) < 0x6, (-5 :: uint8) < 6, (6 :: uint8) < -5
   , (0x5 :: uint8) \<le> 0x5, (0x5 :: uint8) \<le> 0x4, (-5 :: uint8) \<le> 6, (6 :: uint8) \<le> -5
   , (0x7F :: uint8) < 0x80, (0xFF :: uint8) < 0, (0x80 :: uint8) < 0x7F
   , (0x7F :: uint8) !! 0, (0x7F :: uint8) !! 7, (0x80 :: uint8) !! 7, (0x80 :: uint8) !! 8
   ]
  =
   [ True, False
   , False, True, False, True
   , True, False, False, True
   , True, False, False
   , True, False, True, False
   ]) \<and>
  ([integer_of_uint8 0, integer_of_uint8 0x7F, integer_of_uint8 0x80, integer_of_uint8 0xAA]
  =
   [0, 0x7F, 0x80, 0xAA])"

no_notation sshiftr_uint8 (infixl ">>>" 55)

export_code test_uint8 checking SML Haskell? Scala

notepad begin
have test_uint8 by eval
have test_uint8 by code_simp
have test_uint8 by normalization
end
ML_val {* val true = @{code test_uint8} *}

definition test_uint8' :: uint8
where "test_uint8' = 0 + 10 - 14 * 3 div 6 mod 3 << 3 >> 2"
ML {* val 0wx12 = @{code test_uint8'} *}

lemma "x AND y = x OR (y :: uint8)"
quickcheck[random, expect=counterexample]
quickcheck[exhaustive, expect=counterexample]
oops

lemma "(x :: uint8) AND x = x OR x"
quickcheck[narrowing, expect=no_counterexample]
by transfer simp

lemma "(f :: uint8 \<Rightarrow> unit) = g"
quickcheck[narrowing, size=3, expect=no_counterexample]
by(simp add: fun_eq_iff)

section {* Tests for @{typ "uint"} *}

notation sshiftr_uint (infixl ">>>" 55)

definition "test_uint \<equiv> let
  test_list1 = (let
      HS = uint_of_int ((2^(dflt_size - 1)))
    in
      ([ HS+HS+1, -1, -HS - HS + 5, HS + (HS - 1), 0x12
      , 0x5A AND 0x36
      , 0x5A OR 0x36
      , 0x5A XOR 0x36
      , NOT 0x5A
      , 5 + 6, -5 + 6, -6 + 5, -5 + -6, HS + (HS - 1) + 1
      , 5 - 3, 3 - 5
      , 5 * 3, -5 * 3, -5 * -4, 0x12345678 * 0x87654321]
    @ (if dflt_size > 4 then
      [ 5 div 3, -5 div 3, -5 div -3, 5 div -3
      , 5 mod 3, -5 mod 3, -5 mod -3, 5 mod -3
      , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
      , set_bit 5 dflt_size True, set_bit 5 dflt_size False, set_bit (- 5) dflt_size True, set_bit (- 5) dflt_size False
      , 1 << 2, -1 << 3, 1 << dflt_size, 1 << 0
      , 31 >> 3, -1 >> 3, 31 >> dflt_size, -1 >> dflt_size
      , 15 >>> 2, -1 >>> 3, 15 >>> dflt_size, -1 >>> dflt_size]
    else []) :: uint list));

  test_list2 = (let
      S=wivs_shift
    in
      ([ 1, -1, -S + 5, S - 1, 0x12
      , 0x5A AND 0x36
      , 0x5A OR 0x36
      , 0x5A XOR 0x36
      , NOT 0x5A
      , 5 + 6, -5 + 6, -6 + 5, -5 + -6, 0
      , 5 - 3, 3 - 5
      , 5 * 3, -5 * 3, -5 * -4, 0x12345678 * 0x87654321]
    @ (if dflt_size > 4 then
      [ 5 div 3, (S - 5) div 3, (S - 5) div (S - 3), 5 div (S - 3)
      , 5 mod 3, (S - 5) mod 3, (S - 5) mod (S - 3), 5 mod (S - 3)
      , set_bit 5 4 True, -1, set_bit 5 0 False, -7
      , 5, 5, -5, -5
      , 4, -8, 0, 1
      , 3, (S >> 3) - 1, 0, 0
      , 3, (S>>1) + (S >> 1) - 1, 0, -1]
    else []) :: int list));

  test_list_c1 = (let
      HS = uint_of_int ((2^(dflt_size - 1)))
    in
  [  (0x5 :: uint) = 0x5, (0x5 :: uint) = 0x6
   , (0x5 :: uint) < 0x5, (0x5 :: uint) < 0x6, (-5 :: uint) < 6, (6 :: uint) < -5
   , (0x5 :: uint) \<le> 0x5, (0x5 :: uint) \<le> 0x4, (-5 :: uint) \<le> 6, (6 :: uint) \<le> -5
   , (HS - 1) < HS, (HS + HS - 1) < 0, HS < HS - 1
   , (HS - 1) !! 0, (HS - 1 :: uint) !! (dflt_size - 1), (HS :: uint) !! (dflt_size - 1), (HS :: uint) !! dflt_size
   ]);

  test_list_c2 =
   [ True, False
   , False, dflt_size\<ge>2, dflt_size=3, dflt_size\<noteq>3
   , True, False, dflt_size=3, dflt_size\<noteq>3
   , True, False, False
   , dflt_size\<noteq>1, False, True, False
   ]
in
  test_list1 = map uint_of_int test_list2
\<and> test_list_c1 = test_list_c2"

no_notation sshiftr_uint (infixl ">>>" 55)

export_code test_uint checking SML Haskell? OCaml? Scala

lemma "test_uint"
quickcheck[exhaustive, expect=no_counterexample]
oops -- "FIXME: prove correctness of test by reflective means (not yet supported)"

lemma "x AND y = x OR (y :: uint)"
quickcheck[random, expect=counterexample]
quickcheck[exhaustive, expect=counterexample]
oops

lemma "(x :: uint) AND x = x OR x"
quickcheck[narrowing, expect=no_counterexample]
by transfer simp

lemma "(f :: uint \<Rightarrow> unit) = g"
quickcheck[narrowing, size=3, expect=no_counterexample]
by(simp add: fun_eq_iff)

section \<open> Tests for @{typ uint64} \<close>

notation sshiftr_uint64 (infixl ">>>" 55)

definition test_uint64 where
  "test_uint64 \<longleftrightarrow>
  (([ 0x10000000000000001, -1, -9223372036854775808, 0xFFFFFFFFFFFFFFFF, 0x1234567890ABCDEF
    , 0x5A AND 0x36
    , 0x5A OR 0x36
    , 0x5A XOR 0x36
    , NOT 0x5A
    , 5 + 6, -5 + 6, -6 + 5, -5 + (- 6), 0xFFFFFFFFFFFFFFFFFF + 1
    , 5 - 3, 3 - 5
    , 5 * 3, -5 * 3, -5 * -4, 0x1234567890ABCDEF * 0xFEDCBA0987654321
    , 5 div 3, -5 div 3, -5 div -3, 5 div -3
    , 5 mod 3, -5 mod 3, -5 mod -3, 5 mod -3
    , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
    , set_bit 5 64 True, set_bit 5 64 False, set_bit (- 5) 64 True, set_bit (- 5) 64 False
    , 1 << 2, -1 << 3, 1 << 64, 1 << 0
    , 100 >> 3, -100 >> 3, 100 >> 64, -100 >> 64
    , 100 >>> 3, -100 >>> 3, 100 >>> 64, -100 >>> 64] :: uint64 list)
   =
    [ 1, 18446744073709551615, 9223372036854775808, 18446744073709551615, 1311768467294899695
    , 18
    , 126
    , 108
    , 18446744073709551525
    , 11, 1, 18446744073709551615, 18446744073709551605, 0
    , 2, 18446744073709551614
    , 15, 18446744073709551601, 20, 14000077364136384719
    , 1, 6148914691236517203, 0, 0
    , 2, 2, 18446744073709551611, 5
    , 21, 18446744073709551615, 4, 18446744073709551609
    , 5, 5, 18446744073709551611, 18446744073709551611
    , 4, 18446744073709551608, 0, 1
    , 12, 2305843009213693939, 0, 0
    , 12, 18446744073709551603, 0, 18446744073709551615]) \<and>
  ([ (0x5 :: uint64) = 0x5, (0x5 :: uint64) = 0x6
   , (0x5 :: uint64) < 0x5, (0x5 :: uint64) < 0x6, (-5 :: uint64) < 6, (6 :: uint64) < -5
   , (0x5 :: uint64) \<le> 0x5, (0x5 :: uint64) \<le> 0x4, (-5 :: uint64) \<le> 6, (6 :: uint64) \<le> -5
   , (0x7FFFFFFFFFFFFFFF :: uint64) < 0x8000000000000000, (0xFFFFFFFFFFFFFFFF :: uint64) < 0, (0x8000000000000000 :: uint64) < 0x7FFFFFFFFFFFFFFF
   , (0x7FFFFFFFFFFFFFFF :: uint64) !! 0, (0x7FFFFFFFFFFFFFFF :: uint64) !! 63, (0x8000000000000000 :: uint64) !! 63, (0x8000000000000000 :: uint64) !! 64
   ]
  =
   [ True, False
   , False, True, False, True
   , True, False, False, True
   , True, False, False
   , True, False, True, False
   ]) \<and>
  ([integer_of_uint64 0, integer_of_uint64 0x7FFFFFFFFFFFFFFF, integer_of_uint64 0x8000000000000000, integer_of_uint64 0xAAAAAAAAAAAAAAAA]
  =
   [0, 0x7FFFFFFFFFFFFFFF, 0x8000000000000000, 0xAAAAAAAAAAAAAAAA])"

value [nbe] "[0x10000000000000001, -1, -9223372036854775808, 0xFFFFFFFFFFFFFFFF, 0x1234567890ABCDEF
    , 0x5A AND 0x36
    , 0x5A OR 0x36
    , 0x5A XOR 0x36
    , NOT 0x5A
    , 5 + 6, -5 + 6, -6 + 5, -5 + (- 6), 0xFFFFFFFFFFFFFFFFFF + 1
    , 5 - 3, 3 - 5
    , 5 * 3, -5 * 3, -5 * -4, 0x1234567890ABCDEF * 0xFEDCBA0987654321
    , 5 div 3, -5 div 3, -5 div -3, 5 div -3
    , 5 mod 3, -5 mod 3, -5 mod -3, 5 mod -3
    , set_bit 5 4 True, set_bit (- 5) 2 True, set_bit 5 0 False, set_bit (- 5) 1 False
    , set_bit 5 64 True, set_bit 5 64 False, set_bit (- 5) 64 True, set_bit (- 5) 64 False
    , 1 << 2, -1 << 3, 1 << 64, 1 << 0
    , 100 >> 3, -100 >> 3, 100 >> 64, -100 >> 64
    , 100 >>> 3, -100 >>> 3, 100 >>> 64, -100 >>> 64] :: uint64 list"

no_notation sshiftr_uint64 (infixl ">>>" 55)

export_code test_uint64 checking SML Haskell? OCaml? Scala

notepad begin
have test_uint64 by eval
have test_uint64 by code_simp
have test_uint64 by normalization
end
ML_val {* val true = @{code test_uint64} *}

definition test_uint64' :: uint64
where "test_uint64' = 0 + 10 - 14 * 3 div 6 mod 3 << 3 >> 2"

section {* Tests for casts *}

definition test_casts :: bool
where "test_casts \<longleftrightarrow>
  map uint8_of_char [CHR ''a'', 0, char_of_nat 255] = [97, 0, 255] \<and>
  map char_of_uint8 [65, 0, 255] = [CHR ''A'', 0, char_of_nat 255] \<and>
  map uint8_of_uint32 [10, 0, 0xFE, 0xFFFFFFFF] = [10, 0, 0xFE, 0xFF] \<and>
  map uint8_of_uint64 [10, 0, 0xFE, 0xFFFFFFFFFFFFFFFF] = [10, 0, 0xFE, 0xFF] \<and>
  map uint32_of_uint8 [10, 0, 0xFF] = [10, 0, 0xFF] \<and>
  map uint64_of_uint8 [10, 0, 0xFF] = [10, 0, 0xFF]"

definition test_casts' :: bool
where "test_casts' \<longleftrightarrow>
  map uint8_of_uint16 [10, 0, 0xFE, 0xFFFF] = [10, 0, 0xFE, 0xFF] \<and>
  map uint16_of_uint8 [10, 0, 0xFF] = [10, 0, 0xFF] \<and>
  map uint16_of_uint32 [10, 0, 0xFFFE, 0xFFFFFFFF] = [10, 0, 0xFFFE, 0xFFFF] \<and>
  map uint16_of_uint64 [10, 0, 0xFFFE, 0xFFFFFFFFFFFFFFFF] = [10, 0, 0xFFFE, 0xFFFF] \<and>
  map uint32_of_uint16 [10, 0, 0xFFFF] = [10, 0, 0xFFFF] \<and>
  map uint64_of_uint16 [10, 0, 0xFFFF] = [10, 0, 0xFFFF]"

definition test_casts'' :: bool
where "test_casts'' \<longleftrightarrow>
  map uint32_of_uint64 [10, 0, 0xFFFFFFFE, 0xFFFFFFFFFFFFFFFF] = [10, 0, 0xFFFFFFFE, 0xFFFFFFFF] \<and>
  map uint64_of_uint32 [10, 0, 0xFFFFFFFF] = [10, 0, 0xFFFFFFFF]"

export_code test_casts test_casts'' checking SML Haskell? Scala
export_code test_casts'' checking OCaml?
export_code test_casts' checking Haskell? Scala

notepad begin
  have test_casts by eval
  have test_casts by normalization
  have test_casts by code_simp
  have test_casts' by normalization
  have test_casts' by code_simp
  have test_casts'' by eval
  have test_casts'' by normalization
  have test_casts'' by code_simp
end
ML {*
  val true = @{code test_casts}
  val true = @{code test_casts''}
*}

end


(*  Title:       Conflict analysis/Monitor Consistent Interleaving
    Author:      Peter Lammich <peter.lammich@uni-muenster.de>
    Maintainer:  Peter Lammich <peter.lammich@uni-muenster.de>
*)
header "Monitor Consistent Interleaving"
theory ConsInterleave
imports Interleave Misc
begin
text_raw {*\label{thy:ConsInterleave}*}

text {* The monitor consistent interleaving operator is defined on two lists of arbitrary elements, provided an abstraction function @{term \<alpha>} that maps list elements to pairs of sets of monitors is available.
  @{term "\<alpha> e = (M,M')"} intuitively means that step @{term e} enters the monitors in @{term M} and passes (enters and leaves) the monitors in @{term M'}.
  The consistent interleaving describes all interleavings of the two lists that are consistent w.r.t. the monitor usage.
 *}

subsection "Monitors of lists of monitor pairs"
text {* The following defines the set of all monitors that occur in a list of pairs of monitors. This definition is used in the following context:
  @{text "mon_pl (map \<alpha> w)"} is the set of monitors used by a word @{text w} w.r.t. the abstraction @{text "\<alpha>"} *}
definition
  "mon_pl w == foldl (op \<union>) {} (map (\<lambda>e. fst e \<union> snd e) w)"

lemma mon_pl_empty[simp]: "mon_pl [] = {}"
  by (unfold mon_pl_def, auto)
lemma mon_pl_cons[simp]: "mon_pl (e#w) = fst e \<union> snd e \<union> mon_pl w"
  by (unfold mon_pl_def) (simp, subst foldl_un_empty_eq, auto)

lemma mon_pl_unconc: "!!b. mon_pl (a@b) = mon_pl a \<union> mon_pl b"
  by (induct a) auto

lemma mon_pl_ileq: "w\<preceq>w' \<Longrightarrow> mon_pl w \<subseteq> mon_pl w'"
  by (induct rule: less_eq_list_induct) auto

lemma mon_pl_set: "mon_pl w = \<Union>{ fst e \<union> snd e | e. e\<in>set w }"
  by (unfold mon_pl_def) (safe, auto simp add: Bex_def foldl_set)

fun
  cil :: "'a list \<Rightarrow> ('a \<Rightarrow> ('m set \<times> 'm set)) \<Rightarrow> 'a list \<Rightarrow> 'a list set"
    ("_ \<otimes>\<^bsub>_\<^esub> _" [64,64,64] 64) where
  -- "Interleaving with the empty word results in the empty word"
  "[] \<otimes>\<^bsub>\<alpha> \<^esub> w = {w}"
  | "w \<otimes>\<^bsub>\<alpha>\<^esub> [] = {w}"
  -- "If both words are not empty, we can take the first step of one word,
  interleave the rest with the other word and then append
  the first step to all result set elements, provided it does not allocate
  a monitor that is used by the other word"
  | "e1#w1 \<otimes>\<^bsub>\<alpha>\<^esub> e2#w2 = (
    if fst (\<alpha> e1) \<inter> mon_pl (map \<alpha> (e2#w2)) = {} then
      e1\<cdot>(w1 \<otimes>\<^bsub>\<alpha>\<^esub> e2#w2)
    else {}
  ) \<union> (
    if fst (\<alpha> e2) \<inter> mon_pl (map \<alpha> (e1#w1)) = {} then
      e2\<cdot>(e1#w1 \<otimes>\<^bsub>\<alpha>\<^esub> w2)
    else {}
  )"

text {* Note that this definition allows reentrant monitors, because it only checks that a monitor that is going to be entered by one word is not used in the {\em other} word. Thus the same word may enter the same monitor
  multiple times. *}

text {* The next lemmas are some auxiliary lemmas to simplify the handling of the consistent interleaving operator. *}
lemma cil_last_case_split[cases set, case_names left right]: "
  \<lbrakk> w\<in>e1#w1 \<otimes>\<^bsub>\<alpha>\<^esub> e2#w2;
    !!w'. \<lbrakk>w=e1#w'; w'\<in>(w1 \<otimes>\<^bsub>\<alpha>\<^esub> e2#w2);
           fst (\<alpha> e1) \<inter> mon_pl (map \<alpha> (e2#w2)) = {} \<rbrakk> \<Longrightarrow> P;
    !!w'. \<lbrakk>w=e2#w'; w'\<in>(e1#w1 \<otimes>\<^bsub>\<alpha>\<^esub> w2);
           fst (\<alpha> e2) \<inter> mon_pl (map \<alpha> (e1#w1)) = {} \<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
  by (auto elim: list_set_cons_cases split: split_if_asm)

lemma cil_cases[cases set, case_names both_empty left_empty right_empty app_left app_right]: "
  \<lbrakk> w\<in>wa\<otimes>\<^bsub>\<alpha>\<^esub>wb;
    \<lbrakk> w=[]; wa=[]; wb=[] \<rbrakk> \<Longrightarrow> P;
    \<lbrakk>wa=[]; w=wb\<rbrakk> \<Longrightarrow> P;
    \<lbrakk> w=wa; wb=[] \<rbrakk> \<Longrightarrow> P;
    !!ea wa' w'. \<lbrakk>w=ea#w'; wa=ea#wa'; w'\<in>wa'\<otimes>\<^bsub>\<alpha>\<^esub>wb;
                  fst (\<alpha> ea) \<inter> mon_pl (map \<alpha> wb) = {}  \<rbrakk> \<Longrightarrow> P;
    !!eb wb' w'. \<lbrakk>w=eb#w'; wb=eb#wb'; w'\<in>wa\<otimes>\<^bsub>\<alpha>\<^esub>wb';
                  fst (\<alpha> eb) \<inter> mon_pl (map \<alpha> wa) = {}  \<rbrakk> \<Longrightarrow> P
  \<rbrakk> \<Longrightarrow> P"
proof (induct wa \<alpha> wb rule: cil.induct)
  case 1 thus ?case by simp next
  case 2 thus ?case by simp next
  case (3 ea wa' \<alpha> eb wb')
  from "3.prems"(1) show ?thesis proof (cases rule: cil_last_case_split)
    case (left w') from "3.prems"(5)[OF left(1) _ left(2,3)] show ?thesis by simp next
    case (right w') from "3.prems"(6)[OF right(1) _ right(2,3)] show ?thesis by simp
  qed
qed

lemma cil_induct'[case_names both_empty left_empty right_empty append]: "\<lbrakk>
  \<And>\<alpha>. P \<alpha> [] [];
  \<And>\<alpha> ad ae. P \<alpha> [] (ad # ae);
  \<And>\<alpha> z aa. P \<alpha> (z # aa) [];
  \<And>\<alpha> e1 w1 e2 w2. \<lbrakk>
    \<lbrakk>fst (\<alpha> e1) \<inter> mon_pl (map \<alpha> (e2 # w2)) = {}\<rbrakk> \<Longrightarrow> P \<alpha> w1 (e2 # w2);
    \<lbrakk>fst (\<alpha> e2) \<inter> mon_pl (map \<alpha> (e1 # w1)) = {}\<rbrakk> \<Longrightarrow> P \<alpha> (e1 # w1) w2\<rbrakk>
  \<Longrightarrow> P \<alpha> (e1 # w1) (e2 # w2)
  \<rbrakk> \<Longrightarrow> P \<alpha> wa wb"
  apply (induct wa \<alpha> wb rule: cil.induct)
  apply (case_tac w)
  apply auto
  done

lemma cil_induct_fix\<alpha>: "\<lbrakk>
  P \<alpha> [] [];
  \<And>ad ae. P \<alpha> [] (ad # ae);
  \<And>z aa. P \<alpha> (z # aa) [];
  \<And>e1 w1 e2 w2.
    \<lbrakk>fst (\<alpha> e2) \<inter> mon_pl (map \<alpha> (e1 # w1)) = {} \<longrightarrow> P \<alpha> (e1 # w1) w2;
     fst (\<alpha> e1) \<inter> mon_pl (map \<alpha> (e2 # w2)) = {} \<longrightarrow> P \<alpha> w1 (e2 # w2)\<rbrakk>
     \<Longrightarrow> P \<alpha> (e1 # w1) (e2 # w2)\<rbrakk>
  \<Longrightarrow> P \<alpha> v w"
  apply (induct v \<alpha> w rule: cil.induct)
  apply (case_tac w)
  apply auto
  done

lemma cil_induct_fix\<alpha>'[case_names both_empty left_empty right_empty append]: "\<lbrakk>
  P \<alpha> [] [];
  \<And>ad ae. P \<alpha> [] (ad # ae);
  \<And>z aa. P \<alpha> (z # aa) [];
  \<And>e1 w1 e2 w2. \<lbrakk>
    fst (\<alpha> e1) \<inter> mon_pl (map \<alpha> (e2 # w2)) = {} \<Longrightarrow> P \<alpha> w1 (e2 # w2);
    fst (\<alpha> e2) \<inter> mon_pl (map \<alpha> (e1 # w1)) = {} \<Longrightarrow> P \<alpha> (e1 # w1) w2\<rbrakk>
    \<Longrightarrow> P \<alpha> (e1 # w1) (e2 # w2)
  \<rbrakk> \<Longrightarrow> P \<alpha> wa wb"
  apply (induct wa \<alpha> wb rule: cil.induct)
  apply (case_tac w)
  apply auto
  done

lemma cil_contains_empty[rule_format, simp]: "([] \<in> wa\<otimes>\<^bsub>\<alpha>\<^esub>wb) = (wa=[] \<and> wb=[])"
  by (induct wa \<alpha> wb rule: cil.induct) auto

lemma cil_cons_cases[cases set, case_names left right]: "\<lbrakk> e#w \<in> w1\<otimes>\<^bsub>\<alpha>\<^esub>w2;
  !!w1'. \<lbrakk>w1=e#w1'; w\<in>w1'\<otimes>\<^bsub>\<alpha>\<^esub>w2; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> w2) = {} \<rbrakk> \<Longrightarrow> P;
  !!w2'. \<lbrakk>w2=e#w2'; w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2'; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> w1) = {} \<rbrakk> \<Longrightarrow> P
\<rbrakk> \<Longrightarrow> P"
  by (cases rule: cil_cases) auto

lemma cil_set_induct[induct set, case_names empty left right]: "!!\<alpha> w1 w2. \<lbrakk>
    w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2;
    !!\<alpha>. P [] \<alpha> [] [];
    !!\<alpha> e w' w1' w2. \<lbrakk>w'\<in>w1'\<otimes>\<^bsub>\<alpha>\<^esub>w2; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> w2) = {};
                      P w' \<alpha> w1' w2 \<rbrakk> \<Longrightarrow> P (e#w') \<alpha> (e#w1') w2;
    !!\<alpha> e w' w2' w1. \<lbrakk>w'\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2'; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> w1) = {};
                      P w' \<alpha> w1 w2' \<rbrakk> \<Longrightarrow> P (e#w') \<alpha> w1 (e#w2')
  \<rbrakk> \<Longrightarrow> P w \<alpha> w1 w2"
  by (induct w) (auto intro!: cil_contains_empty elim: cil_cons_cases)

lemma cil_set_induct_fix\<alpha>[induct set, case_names empty left right]: "!!w1 w2. \<lbrakk>
    w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2;
    P [] \<alpha> [] [];
    !!e w' w1' w2. \<lbrakk>w'\<in>w1'\<otimes>\<^bsub>\<alpha>\<^esub>w2; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> w2) = {};
                    P w' \<alpha> w1' w2 \<rbrakk> \<Longrightarrow> P (e#w') \<alpha> (e#w1') w2;
    !!e w' w2' w1. \<lbrakk>w'\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2'; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> w1) = {};
                    P w' \<alpha> w1 w2' \<rbrakk> \<Longrightarrow> P (e#w') \<alpha> w1 (e#w2')
  \<rbrakk> \<Longrightarrow> P w \<alpha> w1 w2"
  by (induct w) (auto intro!: cil_contains_empty elim: cil_cons_cases)

lemma cil_cons1: "\<lbrakk>w\<in>wa\<otimes>\<^bsub>\<alpha>\<^esub>wb; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> wb) = {}\<rbrakk>
                  \<Longrightarrow> e#w \<in> e#wa \<otimes>\<^bsub>\<alpha>\<^esub> wb"
  by (cases wb) auto
lemma cil_cons2: "\<lbrakk>w\<in>wa\<otimes>\<^bsub>\<alpha>\<^esub>wb; fst (\<alpha> e) \<inter> mon_pl (map \<alpha> wa) = {}\<rbrakk>
                  \<Longrightarrow> e#w \<in> wa \<otimes>\<^bsub>\<alpha>\<^esub> e#wb"
  by (cases wa) auto

subsection "Properties of consistent interleaving"

-- {* Consistent interleaving is a restriction of interleaving *}

lemma cil_subset_il': "w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2 \<Longrightarrow> w\<in>w1\<otimes>w2"
  using cil_subset_il by (auto)

-- {* Consistent interleaving preserves the set of letters of both operands *}
lemma cil_set: "w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2 \<Longrightarrow> set w = set w1 \<union> set w2"
  by (induct rule: cil_set_induct_fix\<alpha>) auto
corollary cil_mon_pl: "w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2
  \<Longrightarrow> mon_pl (map \<alpha> w) = mon_pl (map \<alpha> w1) \<union> mon_pl (map \<alpha> w2)"
  by (subst mon_pl_unconc[symmetric]) (simp add: mon_pl_set cil_set, blast 20)

-- {* Consistent interleaving preserves the length of both operands *}
lemma cil_length[rule_format]: "\<forall>w\<in>wa\<otimes>\<^bsub>\<alpha>\<^esub>wb. length w = length wa + length wb"
  by (induct rule: cil.induct) auto

-- {* Consistent interleaving contains all letters of each operand in the original order *}
lemma cil_ileq: "w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2 \<Longrightarrow> w1\<preceq>w \<and> w2\<preceq>w"
  by (intro conjI cil_subset_il' ileq_interleave)

-- {* Consistent interleaving is commutative and associative*}
lemma cil_commute: "w\<otimes>\<^bsub>\<alpha>\<^esub>w' = w'\<otimes>\<^bsub>\<alpha>\<^esub>w"
  by (induct rule: cil.induct) auto

lemma cil_assoc1: "!!wl w1 w2 w3. \<lbrakk> w\<in>wl\<otimes>\<^bsub>\<alpha>\<^esub>w3; wl\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2 \<rbrakk>
  \<Longrightarrow> \<exists>wr. w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>wr \<and> wr\<in>w2\<otimes>\<^bsub>\<alpha>\<^esub>w3"
proof (induct w rule: length_compl_induct)
  case Nil thus ?case by auto
next
  case (Cons e w) from Cons.prems(1) show ?case proof (cases rule: cil_cons_cases)
    case (left wl') with Cons.prems(2) have "e#wl' \<in> w1\<otimes>\<^bsub>\<alpha>\<^esub>w2" by simp
    thus ?thesis proof (cases rule: cil_cons_cases[case_names left' right'])
      case (left' w1')
      from Cons.hyps[OF _ left(2) left'(2)] obtain wr where IHAPP: "w \<in> w1' \<otimes>\<^bsub>\<alpha>\<^esub> wr" "wr \<in> w2 \<otimes>\<^bsub>\<alpha>\<^esub> w3" by blast
      have "e#w\<in>e#w1'\<otimes>\<^bsub>\<alpha>\<^esub>wr" proof (rule cil_cons1[OF IHAPP(1)])
        from left left' cil_mon_pl[OF IHAPP(2)] show "fst (\<alpha> e) \<inter> mon_pl (map \<alpha> wr) = {}" by auto
      qed
      thus ?thesis using IHAPP(2) left' by blast
    next
      case (right' w2') from Cons.hyps[OF _ left(2) right'(2)] obtain wr where IHAPP: "w \<in> w1 \<otimes>\<^bsub>\<alpha>\<^esub> wr" "wr \<in> w2' \<otimes>\<^bsub>\<alpha>\<^esub> w3" by blast
      from IHAPP(2) left have "e#wr \<in> e#w2' \<otimes>\<^bsub>\<alpha>\<^esub> w3" by (auto intro: cil_cons1)
      moreover from right' IHAPP(1) have "e#w \<in> w1 \<otimes>\<^bsub>\<alpha>\<^esub> e#wr" by (auto intro: cil_cons2)
      ultimately show ?thesis using right' by blast
    qed
  next
    case (right w3') from Cons.hyps[OF _ right(2) Cons.prems(2)] obtain wr where IHAPP: "w \<in> w1 \<otimes>\<^bsub>\<alpha>\<^esub> wr" "wr \<in> w2 \<otimes>\<^bsub>\<alpha>\<^esub> w3'" by blast
    from IHAPP(2) right cil_mon_pl[OF Cons.prems(2)] have "e#wr \<in> w2 \<otimes>\<^bsub>\<alpha>\<^esub> e#w3'" by (auto intro: cil_cons2)
    moreover from IHAPP(1) right cil_mon_pl[OF Cons.prems(2)] have "e#w \<in> w1 \<otimes>\<^bsub>\<alpha>\<^esub> e#wr" by (auto intro: cil_cons2)
    ultimately show ?thesis using right by blast
  qed
qed

lemma cil_assoc2:
  assumes A: "w\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>wr" and B: "wr\<in>w2\<otimes>\<^bsub>\<alpha>\<^esub>w3"
  shows "\<exists>wl. w\<in>wl\<otimes>\<^bsub>\<alpha>\<^esub>w3 \<and> wl\<in>w1\<otimes>\<^bsub>\<alpha>\<^esub>w2"
proof -
  from A have A': "w\<in>wr\<otimes>\<^bsub>\<alpha>\<^esub>w1" by (simp add: cil_commute)
  from B have B': "wr\<in>w3\<otimes>\<^bsub>\<alpha>\<^esub>w2" by (simp add: cil_commute)
  from cil_assoc1[OF A' B'] obtain wl where "w \<in> w3 \<otimes>\<^bsub>\<alpha>\<^esub> wl \<and> wl \<in> w2 \<otimes>\<^bsub>\<alpha>\<^esub> w1" by blast
  thus ?thesis by (auto simp add: cil_commute)
qed

-- {* Parts of the abstraction can be moved to the operands *}
(* FIXME: ?? Something strange is going on with the simplification of \<alpha>\<circ>f and implicit \<eta>-contraction/expansion, hence this lengthy isar proof. Usually, this proof should be a just few lines apply-script !*)
lemma cil_map: "w\<in>w1 \<otimes>\<^bsub>(\<alpha>\<circ>f)\<^esub> w2 \<Longrightarrow> map f w \<in> map f w1 \<otimes>\<^bsub>\<alpha>\<^esub> map f w2"
proof (induct rule: cil_set_induct_fix\<alpha>)
  case empty thus ?case by auto
next
  case (left e w' w1' w2)
  have "f e # map f w' \<in> f e # map f w1' \<otimes>\<^bsub>\<alpha>\<^esub> map f w2" proof (rule cil_cons1)
    from left(2) have "fst ((\<alpha>\<circ>f) e) \<inter> mon_pl (map \<alpha> (map f w2)) = {}" by (simp only: map_map[symmetric])
    thus "fst (\<alpha> (f e)) \<inter> mon_pl (map \<alpha> (map f w2)) = {}" by (simp only: o_apply)
  qed (rule left(3))
  thus ?case by simp
next
  case (right e w' w2' w1)
  have "f e # map f w' \<in> map f w1 \<otimes>\<^bsub>\<alpha>\<^esub> f e # map f w2'" proof (rule cil_cons2)
    from right(2) have "fst ((\<alpha>\<circ>f) e) \<inter> mon_pl (map \<alpha> (map f w1)) = {}" by (simp only: map_map[symmetric])
    thus "fst (\<alpha> (f e)) \<inter> mon_pl (map \<alpha> (map f w1)) = {}" by (simp only: o_apply)
  qed (rule right(3))
  thus ?case by simp
qed

end


subsection "Top-Level Algorithm Proofs"
theory ExportProofs
  imports HeuristicProofs Exports
    (*"HOL-Library.Code_Real_Approx_By_Float"*)
    HOL.String "HOL-Library.Code_Target_Int" "HOL-Library.Code_Target_Nat" PrettyPrinting Show.Show_Real
begin

theorem "eval (Unpower f) L = eval f L" unfolding unpower_eval Unpower_def by auto

theorem VSLuckiest: "\<forall>xs. eval (VSLuckiest \<phi>) xs = eval \<phi> xs"
  unfolding VSLuckiest_def Unpower_def opt_def
  using QE_dnf_eval[OF luckiestFind_eval' opt_no_group] opt_no_group
  by fastforce

theorem VSLuckiestBlocks : "\<forall>xs. eval (VSLuckiestBlocks \<phi>) xs = eval \<phi> xs"
  unfolding VSLuckiestBlocks_def Unpower_def opt_group_def
  using QE_dnf'_eval[OF the_real_step_augment[OF luckiestFind_eval, of "\<lambda>x _ _. x"] opt]
  using opt
  by fastforce

theorem VSEquality : "\<forall>xs. eval (VSEquality \<phi>) xs = eval \<phi> xs"
  unfolding VSEquality_def Unpower_def opt_def
  using QE_dnf_eval[OF qe_eq_repeat_eval' opt_no_group]
  using  opt_no_group VSLuckiest
  by fastforce

theorem VSEqualityBlocks : "\<forall>xs. eval (VSEqualityBlocks \<phi>) xs = eval \<phi> xs"
  unfolding VSEqualityBlocks_def Unpower_def opt_group_def
  using QE_dnf'_eval[OF the_real_step_augment[OF qe_eq_repeat_eval, of "\<lambda>x _ _. x"] opt]
  using opt VSLuckiestBlocks
  by fastforce

theorem VSGeneralBlocks : "\<forall>xs. eval (VSGeneralBlocks \<phi>) xs = eval \<phi> xs"
  unfolding VSGeneralBlocks_def Unpower_def opt_group_def
  using QE_dnf'_eval[OF the_real_step_augment[OF gen_qe_eval, of "\<lambda>x _ _. x"] opt]
  using opt VSLuckiestBlocks
  by fastforce

theorem VSLuckyBlocks : "\<forall>xs. eval (VSLuckyBlocks \<phi>) xs = eval \<phi> xs"
  unfolding VSLuckyBlocks_def Unpower_def opt_group_def
  using QE_dnf'_eval[OF the_real_step_augment[OF luckyFind'_eval, of "\<lambda>x _ _. x"] opt]
  using opt VSLuckiestBlocks
  by fastforce

theorem VSLEGBlocks : "\<forall>xs. eval (VSLEGBlocks \<phi>) xs = eval \<phi> xs"
  unfolding VSLEGBlocks_def opt_group_def
  using VSEqualityBlocks VSGeneralBlocks VSLuckyBlocks
  by fastforce

theorem VSEqualityBlocksLimited : "\<forall>xs. eval (VSEqualityBlocksLimited \<phi>) xs = eval \<phi> xs"
  unfolding VSEqualityBlocksLimited_def Unpower_def opt_group_def
  using QE_dnf_eval[OF qe_eq_repeat_eval_augment opt] opt VSLuckiestBlocks
  by fastforce

theorem VSEquality_3_times : "\<forall>xs. eval (VSEquality_3_times \<phi>) xs = eval \<phi> xs"
  using VSEquality unfolding VSEquality_3_times_def by auto

theorem VSGeneral:  "\<forall>xs. eval (VSGeneral \<phi>) xs = eval \<phi> xs"
  unfolding VSGeneral_def Unpower_def Unpower_def opt_def
  using QE_dnf_eval[OF gen_qe_eval' opt_no_group]
  using  opt_no_group VSLuckiest
  by fastforce

theorem VSGeneralBlocksLimited:  "\<forall>xs. eval (VSGeneralBlocksLimited \<phi>) xs = eval \<phi> xs"
  unfolding VSGeneralBlocksLimited_def Unpower_def opt_group_def
  using QE_dnf_eval[OF gen_qe_eval_augment opt] opt VSLuckiestBlocks
  by fastforce

theorem VSBrowns:  "\<forall>xs. eval (VSBrowns \<phi>) xs = eval \<phi> xs"
  unfolding VSBrowns_def Unpower_def opt_group_def
  using QE_dnf_eval[OF step_augmenter_eval[of gen_qe brownsHeuristic, OF gen_qe_eval brownHueristic_less_than] opt] opt VSLuckiestBlocks
  by fastforce

theorem VSGeneral_3_times : "\<forall>xs. eval (VSGeneral_3_times \<phi>) xs = eval \<phi> xs"
  unfolding  VSGeneral_3_times_def  using VSGeneral
  by auto

theorem VSLucky: "\<forall>xs. eval (VSLucky \<phi>) xs = eval \<phi> xs"
  unfolding VSLucky_def Unpower_def opt_def
  using QE_dnf_eval[OF luckyFind_eval' opt_no_group] opt_no_group VSLuckiest
  by fastforce

theorem VSLuckyBlocksLimited: "\<forall>xs. eval (VSLuckyBlocksLimited \<phi>) xs = eval \<phi> xs"
  unfolding VSLuckyBlocksLimited_def Unpower_def opt_group_def
  using QE_dnf_eval[OF luckyFind_eval_augment opt] opt VSLuckiestBlocks
  by fastforce

theorem VSLEG: "\<forall>xs. eval (VSLEG \<phi>) xs = eval \<phi> xs"
  unfolding VSLEG_def
  using VSLucky VSEquality VSGeneral by auto

theorem VSHeuristic : "\<forall>xs. eval(VSHeuristic \<phi>) xs = eval \<phi> xs"
  unfolding VSHeuristic_def Unpower_def opt_group_def
  using QE_dnf_eval[OF superPicker_eval opt] opt VSLuckiestBlocks
  by fastforce

theorem VSLuckiestRepeat : "\<forall>xs. eval (VSLuckiestRepeat \<phi>) xs = eval \<phi> xs"
  unfolding VSLuckiestRepeat_def using repeatAmountOfQuantifiers_eval[OF] using VSLuckiest
  by blast

export_code
  print_mpoly
  VSGeneral VSEquality VSLucky VSLEG VSLuckiest
  VSGeneralBlocksLimited VSEqualityBlocksLimited VSLuckyBlocksLimited
  VSGeneralBlocks VSEqualityBlocks VSLuckyBlocks VSLEGBlocks VSLuckiestBlocks
  QE_dnf
  gen_qe qe_eq_repeat
  simpfm push_forall nnf Unpower
  is_quantifier_free is_solved
  add mult C V pow minus
  Eq Or is_quantifier_free

real_of_int real_mult real_div real_plus real_minus

VSGeneral_3_times VSEquality_3_times VSHeuristic VSLuckiestRepeat VSBrowns
in SML module_name VS

end


(*
    File:        MonoInj.thy
    Time-stamp:  <2020-06-22T03:48:21Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: Logics_ZF (of Isabelle2020)
*)

theory MonoInj imports ZF.Fixedpt ZF.Finite begin

definition mono_inj_pair :: "[i,i=>i,i=>i]=>o" where
 "mono_inj_pair(D,F,G) == (ALL x. x <= D --> G(F(x)) = x) &
        (ALL x y. x <= y & y <= D --> F(x) <= F(y)) &
        (ALL x y. x <= y & y <= F(D) --> G(x) <= G(y))"

lemma lfpI:
  assumes hmono: "bnd_mono(D,h)"
      and lb: "!!X. [| X <= D;  h(X) <= X |] ==> A <= X"
      and pfp: "h(A) <= A"
  shows "lfp(D,h) = A"
apply (rule equalityI)
apply (rule lfp_lowerbound)
apply (rule pfp)
apply (rule lb)
apply (rule subset_refl)
apply (rule hmono [THEN bnd_monoD1])
apply (rule lfp_greatest)
apply (rule hmono [THEN bnd_monoD1])
apply (rule lb)
apply assumption+
done

lemma mono_inj_pairI:
    "[| !!x. x <= D ==> G(F(x)) = x;
        !!x y. [| x <= y; y <= D |] ==> F(x) <= F(y);
        !!x y. [| x <= y; y <= F(D) |] ==> G(x) <= G(y)
    |] ==> mono_inj_pair(D,F,G)"
apply (unfold mono_inj_pair_def)
apply auto
done

lemma mono_inj_pairD1:
    "[| mono_inj_pair(D,F,G); x <= D |] ==> G(F(x)) = x"
apply (unfold mono_inj_pair_def)
apply auto
done

lemma mono_inj_pairD2:
    "[| mono_inj_pair(D,F,G); x <= y; y <= D |] ==> F(x) <= F(y)"
apply (unfold mono_inj_pair_def)
apply auto
done

lemma mono_inj_pairD3:
    "[| mono_inj_pair(D,F,G); x <= y; y <= F(D) |] ==> G(x) <= G(y)"
apply (unfold mono_inj_pair_def)
apply auto
done

lemma mono_inj_pair_lfp_subset:
    "mono_inj_pair(D,F,G) ==> F(lfp(D,h)) <= F(D)"
apply (erule mono_inj_pairD2)
apply (rule lfp_subset)
apply (rule subset_refl)
done

lemma mono_inj_pair_bnd_mono:
  assumes hinj: "mono_inj_pair(D,F,G)"
      and hmono: "bnd_mono(D,h)"
    shows "bnd_mono(F(D), %X. F(h(G(X))))"
apply (rule bnd_monoI)
apply (rule hinj [THEN mono_inj_pairD1, THEN ssubst])
apply (rule subset_refl)
apply (rule hinj [THEN mono_inj_pairD2])
apply (rule hmono [THEN bnd_monoD1])
apply (rule subset_refl)
apply (frule_tac x="X" in hinj [THEN mono_inj_pairD3])
apply (rule subset_refl)
apply (subst (asm) hinj [THEN mono_inj_pairD1])
apply (rule subset_refl)
apply (rule hinj [THEN mono_inj_pairD2])
apply (rule hmono [THEN bnd_monoD2])
apply (rule hinj [THEN mono_inj_pairD3])
apply assumption+
apply (rule hmono [THEN bnd_mono_subset])
apply assumption
done

lemma mono_inj_pair_pre_fixedpt:
  assumes hinj: "mono_inj_pair(D,F,G)"
      and hmono: "bnd_mono(D,h)"
    shows "F(h(G(F(lfp(D,h))))) <= F(lfp(D,h))"
apply (rule hinj [THEN mono_inj_pairD2])
apply (rule hinj [THEN mono_inj_pairD1, THEN ssubst])
apply (rule lfp_subset)
apply (rule hmono [THEN lfp_lemma2])
apply (rule lfp_subset)
done

lemma mono_inj_pair_lfp_lemma1:
  assumes hinj: "mono_inj_pair(D,F,G)"
      and hmono: "bnd_mono(D,h)"
      and dom_x: "X <= F(D)"
      and x_is_pfp: "F(h(G(X))) <= X"
    shows "h(h(G(X))) <= h(G(X))"
apply (subgoal_tac "G(X) <= D")
prefer 2
apply (rule hinj [THEN mono_inj_pairD1, THEN subst])
apply (rule subset_refl)
apply (rule hinj [THEN mono_inj_pairD3])
apply (rule dom_x)
apply (rule subset_refl)
apply (rule_tac P="%x. h(x) <= h(G(X))" in hinj [THEN mono_inj_pairD1, THEN subst])
apply (rule hmono [THEN bnd_mono_subset])
apply assumption
apply (rule hmono [THEN bnd_monoD2])
apply (rule hinj [THEN mono_inj_pairD3])
apply (rule x_is_pfp)
apply (rule dom_x)
apply assumption
done

lemma mono_inj_pair_lfp_lowerbound:
  assumes hinj: "mono_inj_pair(D,F,G)"
      and hmono: "bnd_mono(D,h)"
      and dom_x: "X <= F(D)"
      and x_is_pfp: "F(h(G(X))) <= X"
    shows "F(lfp(D,h)) <= X"
apply (subgoal_tac "h(G(X)) <= D")
prefer 2
apply (rule hmono [THEN bnd_mono_subset])
apply (rule hinj [THEN mono_inj_pairD1, THEN subst])
apply (rule subset_refl)
apply (rule hinj [THEN mono_inj_pairD3])
apply (rule dom_x)
apply (rule subset_refl)
apply (rule subset_trans [OF _ x_is_pfp])
apply (rule hinj [THEN mono_inj_pairD2])
apply (rule lfp_lowerbound)
apply (rule hinj [THEN mono_inj_pair_lfp_lemma1])
apply (rule hmono)
apply ((rule dom_x x_is_pfp) | assumption)+
done

lemma mono_inj_pair_lfp_eq:
  assumes hinj: "mono_inj_pair(D,F,G)"
      and hmono: "bnd_mono(D,h)"
    shows "lfp(F(D), %X. F(h(G(X)))) = F(lfp(D,h))"
apply (rule lfpI)
apply (rule mono_inj_pair_bnd_mono [OF hinj hmono])
apply (rule mono_inj_pair_lfp_lowerbound [OF hinj hmono])
apply assumption+
apply (rule mono_inj_pair_pre_fixedpt [OF hinj hmono])
done

lemma trivial_mono_inj_pair:
    "mono_inj_pair(D, %x. x, %x. x)"
apply (rule mono_inj_pairI)
apply (rule refl)
apply assumption+
done

lemma Pow_Union_mono_inj_pair:
    "mono_inj_pair(D, Pow, Union)"
apply (rule mono_inj_pairI)
apply (rule Union_Pow_eq)
apply (rule Pow_mono)
apply assumption
apply (rule Union_mono)
apply assumption
done

lemma Prod_range_mono_inj_pair:
    "b: B ==> mono_inj_pair(D, %X. B * X, range)"
apply (rule mono_inj_pairI)
apply (erule range_of_prod)
apply (rule Sigma_mono)
apply (rule_tac [3] range_mono)
apply (rule subset_refl)
apply assumption+
done

lemma Prod_domain_mono_inj_pair:
    "b: B ==> mono_inj_pair(D, %X. X * B, domain)"
apply (rule mono_inj_pairI)
apply (erule domain_of_prod)
apply (rule Sigma_mono)
apply (rule_tac [3] domain_mono)
apply ((rule subset_refl) | assumption)+
done

end


theory MuHO1_Semantics_Kleene
  imports MuHO1_Semantics_Tarski
begin

section "Algorithmic Semantics"

context ctx
begin

function approx_tm0 :: "(name \<Rightarrow> 'a) \<Rightarrow> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> tm0 \<Rightarrow> name \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a"
and approx_tm1 :: "(name \<Rightarrow> 'a) \<Rightarrow> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> tm1 \<Rightarrow> name \<Rightarrow> ('a \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> ('a \<Rightarrow> 'a)"
and sem_tm0_k :: "(name \<Rightarrow> 'a) \<Rightarrow> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> tm0 \<Rightarrow> 'a"
and sem_tm1_k :: "(name \<Rightarrow> 'a) \<Rightarrow> (name \<Rightarrow> ('a \<Rightarrow> 'a)) \<Rightarrow> tm1 \<Rightarrow> ('a \<Rightarrow> 'a)"
  where
"approx_tm0 \<eta>0 \<eta>1 \<phi> x init 0 = init" |
"approx_tm0 \<eta>0 \<eta>1 \<phi> x init (Suc n) =
    sem_tm0_k (\<eta>0(x := approx_tm0 \<eta>0 \<eta>1 \<phi> x init n)) \<eta>1 \<phi>" |

"approx_tm1 \<eta>0 \<eta>1 \<phi> x init 0 = init" |
"approx_tm1 \<eta>0 \<eta>1 \<phi> x init (Suc n) = sem_tm1_k \<eta>0 (\<eta>1(x := approx_tm1 \<eta>0 \<eta>1 \<phi> x init n)) \<phi>" |

"sem_tm0_k \<eta>0 \<eta>1 (Var0 x) = (\<eta>0 x)" |
"sem_tm0_k \<eta>0 \<eta>1 (Func0 f) = abs_func0 f" |
"sem_tm0_k \<eta>0 \<eta>1 (App \<phi> \<psi>) = (sem_tm1_k \<eta>0 \<eta>1 \<phi>) (sem_tm0_k \<eta>0 \<eta>1 \<psi>)" |
"sem_tm0_k \<eta>0 \<eta>1 (Mu0 X \<phi>) = approx_tm0 \<eta>0 \<eta>1 \<phi> X \<bottom> (card (UNIV::'a set))" |

"sem_tm1_k \<eta>0 \<eta>1 (Var1 x) = (\<eta>1 x)" |
"sem_tm1_k \<eta>0 \<eta>1 (Func1 f) = abs_func1 f" |
"sem_tm1_k \<eta>0 \<eta>1 (Lam x \<phi>) = (\<lambda>d. sem_tm0_k (\<eta>0(x := d)) \<eta>1 \<phi>)" |
"sem_tm1_k \<eta>0 \<eta>1 (Mu1 X \<phi>) = approx_tm1 \<eta>0 \<eta>1 \<phi> X (\<lambda>_. \<bottom>) (card (UNIV::('a\<Rightarrow>'a) set))"
  by pat_completeness auto
termination
  by size_change

lemma approx_tm0_mono:
  "\<lbrakk>\<And>\<eta>0 \<eta>1 \<eta>0' \<eta>1'.

   \<lbrakk> \<forall>z. \<eta>0 z \<le> \<eta>0' z;
     \<forall>f z. \<eta>1 f z \<le> \<eta>1' f z;
     \<forall>f. mono (\<eta>1 f);
     \<forall>f. mono (\<eta>1' f) \<rbrakk>
   \<Longrightarrow> sem_tm0_k \<eta>0 \<eta>1 \<phi> \<le> sem_tm0_k \<eta>0' \<eta>1' \<phi>;

    \<forall>z. \<eta>0 z \<le> \<eta>0' z;
    \<forall>f z. (\<eta>1 f) z \<le> (\<eta>1' f) z;
    \<forall>f. mono (\<eta>1 f);
    \<forall>f. mono (\<eta>1' f) \<rbrakk>
  \<Longrightarrow> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n \<le> approx_tm0 \<eta>0' \<eta>1' \<phi> x \<bottom> n"
  by (induction n) auto

lemma approx_tm1_mono:
  "\<lbrakk> \<And>\<eta>0 \<eta>1 \<eta>0' \<eta>1'.

   \<lbrakk> \<forall>z. \<eta>0 z \<le> \<eta>0' z;
     \<forall>f z. \<eta>1 f z \<le> \<eta>1' f z;
     \<forall>f. mono (\<eta>1 f);
     \<forall>f. mono (\<eta>1' f) \<rbrakk>
   \<Longrightarrow> sem_tm1_k \<eta>0 \<eta>1 \<phi>' \<le> sem_tm1_k \<eta>0' \<eta>1' \<phi>'
       \<and> mono (sem_tm1_k \<eta>0 \<eta>1 \<phi>')
       \<and> mono (sem_tm1_k \<eta>0' \<eta>1' \<phi>');

    \<forall>z. \<eta>0 z \<le> \<eta>0' z;
    \<forall>f z. (\<eta>1 f) z \<le> (\<eta>1' f) z;
    \<forall>f. mono (\<eta>1 f);
    \<forall>f. mono (\<eta>1' f) \<rbrakk>
  \<Longrightarrow> approx_tm1 \<eta>0 \<eta>1 \<phi>' x (\<lambda>_. \<bottom>) n \<le> approx_tm1 \<eta>0' \<eta>1' \<phi>' x (\<lambda>_. \<bottom>) n
      \<and> mono (approx_tm1 \<eta>0 \<eta>1 \<phi>' x (\<lambda>_. \<bottom>) n)
      \<and> mono (approx_tm1 \<eta>0' \<eta>1' \<phi>' x (\<lambda>_. \<bottom>) n)"
proof (induction n)
  case 0
  then show ?case
    by (simp add: monoI)
next
  case (Suc n)
  then show ?case
    by (smt (verit, ccfv_SIG) approx_tm1.simps(2) fun_upd_apply le_funD)
qed

theorem sem_k_mono:
  "\<And>\<eta>0 \<eta>1 \<eta>0' \<eta>1'.
  \<lbrakk> \<forall>z. \<eta>0 z \<le> \<eta>0' z;
    \<forall>f z. (\<eta>1 f) z \<le> (\<eta>1' f) z;
    \<forall>f. mono (\<eta>1 f);
    \<forall>f. mono (\<eta>1' f) \<rbrakk>
  \<Longrightarrow> sem_tm0_k \<eta>0 \<eta>1 \<phi> \<le> sem_tm0_k \<eta>0' \<eta>1' \<phi>"

  "\<And>\<eta>0 \<eta>1 \<eta>0' \<eta>1'.
  \<lbrakk> \<forall>z. \<eta>0 z \<le> \<eta>0' z;
    \<forall>f z. (\<eta>1 f) z \<le> (\<eta>1' f) z;
    \<forall>f. mono (\<eta>1 f);
    \<forall>f. mono (\<eta>1' f) \<rbrakk>
  \<Longrightarrow> sem_tm1_k \<eta>0 \<eta>1 \<phi>' \<le> sem_tm1_k \<eta>0' \<eta>1' \<phi>'
      \<and> mono (sem_tm1_k \<eta>0 \<eta>1 \<phi>') \<and> mono (sem_tm1_k \<eta>0' \<eta>1' \<phi>')"
proof (induction \<phi> and \<phi>')
  case (Var0 x)
  then show ?case
    by simp
next
  case (Func0 f)
  then show ?case
    by simp
next
  case (App x1 x2)
  have 1: "sem_tm0_k \<eta>0 \<eta>1 x2 \<le> sem_tm0_k \<eta>0' \<eta>1' x2"
    using App.IH(2) App.prems by simp

  have 2: "sem_tm1_k \<eta>0 \<eta>1 x1 \<le> sem_tm1_k \<eta>0' \<eta>1' x1"
     using App.IH(1) App.prems by simp

  with 1 have "(sem_tm1_k \<eta>0 \<eta>1 x1) (sem_tm0_k \<eta>0 \<eta>1 x2) \<le>
            (sem_tm1_k \<eta>0 \<eta>1 x1) (sem_tm0_k \<eta>0' \<eta>1' x2)"
    using App.IH(1) App.prems(3) monoD by blast
  with 2 have "(sem_tm1_k \<eta>0 \<eta>1 x1) (sem_tm0_k \<eta>0 \<eta>1 x2) \<le>
            (sem_tm1_k \<eta>0' \<eta>1' x1) (sem_tm0_k \<eta>0' \<eta>1' x2)"
    by (metis dual_order.trans le_fun_def)
  then show ?case by simp
next
  case (Mu0 x1a \<phi>)
  then show ?case
    by (simp add: approx_tm0_mono abs_func1_mono)
next
  case (Var1 x)
  then show ?case
    by (simp add: le_fun_def)
next
  case (Func1 f)
  then show ?case
    by (simp add: abs_func1_mono monoI)
next
  case (Lam x1 x2)
  then show ?case
    by (smt (verit, ccfv_threshold) dual_order.eq_iff fun_upd_apply
        le_funI monoI sem_tm1_k.simps(3))
next
  case (Mu1 x1a \<phi>)
  then show ?case
    by (simp add: approx_tm1_mono)
qed

lemma sem_tm1_k_fun_upd_mono: "\<lbrakk> \<forall>f. mono (\<eta>1 f); z \<le> z'; mono z; mono z' \<rbrakk>
  \<Longrightarrow> sem_tm1_k \<eta>0 (\<eta>1(x := z)) \<phi> \<le> sem_tm1_k \<eta>0 (\<eta>1(x := z')) \<phi>"
  by (smt (verit) dual_order.eq_iff fun_upd_apply le_funE sem_k_mono(2))

section "Equivalence of Algorithmic and Denotational Semantics"

lemma approx_tm0_mono_min:
  "\<forall>f. mono (\<eta>1 f)
  \<Longrightarrow> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n \<le> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc n)" for n
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case
    using sem_k_mono(1) by simp
qed

lemma approx_tm0_mono_min2:
  "\<lbrakk> \<forall>f. mono (\<eta>1 f); m \<ge> n \<rbrakk>
  \<Longrightarrow> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n \<le> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> m"
proof (induction m)
  case 0
  then show ?case
    by (simp add: approx_tm0_mono)
next
  case (Suc m)
  then show ?case
    by (metis approx_tm0_mono_min lift_Suc_mono_le)
qed

lemma approx_tm1_mono_min:
  "\<forall>f. mono (\<eta>1 f)
    \<Longrightarrow> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n \<le> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc n)"
proof (induction n)
  case 0
  then show ?case
    by (simp add: le_fun_def)
next
  case (Suc n)
  have 0: "approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc n) =
            sem_tm1_k \<eta>0 (\<eta>1(x := approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n)) \<phi>"
    by simp

  have 1: "approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc (Suc n)) =
          sem_tm1_k \<eta>0 (\<eta>1(x := approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc n))) \<phi>"
    by simp

  from 0 1 show ?case
    by (smt (verit) Suc.IH Suc.prems approx_tm1_mono sem_tm1_k_fun_upd_mono
        dual_order.eq_iff sem_k_mono(2))
qed

lemma approx_tm1_mono_min2:
  "\<lbrakk> \<forall>f. mono (\<eta>1 f); m \<ge> n \<rbrakk>
  \<Longrightarrow> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n \<le> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) m"
proof (induction m)
  case 0
  then show ?case
    by simp
next
  case (Suc m)
  then show ?case
    by (metis approx_tm1_mono_min lift_Suc_mono_le)
qed

lemma approx_tm0_stays_stable:
  assumes "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n = approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc n)"
    and "m \<ge> n"
    and "\<forall>f. mono (\<eta>1 f)"
    shows "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> m = approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n"
proof (rule order.antisym)
  show "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> m \<ge> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n"
    by (simp add: approx_tm0_mono_min2 assms(2) assms(3))

  show "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> m \<le> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n"
  proof (induction m)
    case 0
    then show ?case by simp
  next
    case (Suc m)
    then show ?case
    by (metis (no_types, lifting) dual_order.eq_iff approx_tm0_mono_min2
        assms(1) assms(3) le_SucE approx_tm0.simps(2) nat_le_linear)
  qed
qed

lemma inj_func_card:
  assumes "\<forall>i \<le> card S + 1. \<forall>i' \<le> card S + 1.
           i \<noteq> i' \<longrightarrow> f i \<noteq> f i'"
  shows "n \<le> card S + 1 \<longrightarrow> n \<le> card (\<Union>i\<le>n. {f i})"
proof (rule impI, induction n)
  case 0
  then show ?case
    by simp
next
  case (Suc n)
  have "\<forall>i\<le>n. \<forall>i'\<le>n. i \<noteq> i' \<longrightarrow> {f i} \<noteq> {f i'}"
    using Suc.prems assms by auto
  then have "\<forall>i\<le>n. {f i} \<noteq> {f (Suc n)}"
    using Suc.prems assms by auto
  then have 0: "\<not> ({f (Suc n)} \<subseteq> (\<Union>i\<le>n. {f i}))"
    by auto

  have "(\<Union>i\<le>Suc n. {f i}) = (\<Union>i\<le>n. {f i}) \<union> {f (Suc n)}"
    by (simp add: atMost_Suc)
  then have "card (\<Union>i\<le>Suc n. {f i}) = card ((\<Union>i\<le>n. {f i}) \<union> {f (Suc n)})"
    by auto
  with 0 have 1: "\<dots> = card (\<Union>i\<le>n. {f i}) + card ({f (Suc n)})"
    by simp

  have "Suc n \<le> card (\<Union>i\<le>n. {f i}) + 1"
    using Suc.IH Suc.prems by auto
  also have "\<dots> \<le> card ((\<Union>i\<le>n. {f i}) \<union> {f (Suc n)})"
    using 1 by auto
  also have "\<dots> \<le> card ((\<Union>i\<le>Suc n. {f i}))"
    by (simp add: atMost_Suc)
  finally show ?case by simp
qed

lemma approx_tm0_eventually_stable:
  assumes "\<forall>f. mono (\<eta>1 f)"
  shows "\<exists>n \<le> card (UNIV::'a set).
      approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n = approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc n)"
proof (rule ccontr)
  assume 0: "\<not> (\<exists>n\<le>(card (UNIV::'a set)).
      approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n = approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc n))"
  then have 1: "\<forall>m\<le>(card (UNIV::'a set)).
      approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> m < approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc m)"
    using approx_tm0_mono_min assms order_less_le by blast

    let ?A = "\<Union>i\<le>(card (UNIV::'a set) + 1).
                {(approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> i)}"

  have 2: "?A \<subseteq> (UNIV::'a set)"
    by auto

  from 0 1 have "\<forall>i\<le>(card (UNIV::'a set) + 1).
                 \<forall>i'\<le>(card (UNIV::'a set) + 1).
    i' \<noteq> i \<longrightarrow> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> i \<noteq> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> i'"
    using approx_tm0_mono_min approx_tm0_mono_min2 assms
    by (metis Suc_eq_plus1 antisym not_less_eq_eq)

  then have "\<forall>n\<le>(card (UNIV::'a set) + 1).
             n \<le> card (\<Union>i\<le>n. {(approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> i)})"
    using inj_func_card by metis
  then have 3: "card ?A > (card (UNIV::'a set))"
    by auto

  from 2 3 show False
    by (meson card_mono finite_UNIV leD)
qed

lemma approx_tm0_mu_final: "\<forall>f. mono (\<eta>1 f)
  \<Longrightarrow> approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (card (UNIV ::'a::finite_lattice set))
      = approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc (card (UNIV ::'a set)))"
  by (metis approx_tm0_eventually_stable approx_tm0_stays_stable le_SucI)

lemma approx_tm1_stays_stable:
  assumes "approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n = approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc n)"
    and "m \<ge> n"
    and "\<forall>f. mono (\<eta>1 f)"
  shows "approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) m = approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n"
proof (rule order.antisym)
  show "approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n \<le> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) m"
    by (simp add: approx_tm1_mono_min2 assms(2) assms(3))

  show "approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) m \<le> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n"
  proof (induction m)
    case 0
    then show ?case
      by (simp add: le_fun_def)
  next
    case (Suc m)
    then show ?case
      by (metis (no_types, lifting) approx_tm1.simps(2) approx_tm1_mono_min2
          assms(1) assms(3) dual_order.eq_iff le_SucE nat_le_linear)
  qed
qed

lemma approx_tm1_eventually_stable:
  assumes "\<forall>f. mono (\<eta>1 f)"
  shows "\<exists>n \<le> card (UNIV::('a\<Rightarrow>'a) set).
  approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n = approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc n)"
proof (rule ccontr)
  assume 0: "\<not> (\<exists>n\<le>card (UNIV::('a\<Rightarrow>'a) set).
            approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) n = approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc n))"
  then have 1: "\<forall>m\<le>card (UNIV::('a\<Rightarrow>'a) set).
                approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) m < approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc m)"
    using approx_tm1_mono_min assms order_le_imp_less_or_eq by blast

  let ?A = "\<Union>i\<le>(card (UNIV::('a\<Rightarrow>'a) set) + 1). {(approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) i)}"

  have 2: "?A \<subseteq> (UNIV::('a\<Rightarrow>'a::finite_lattice) set)"
    by auto

  from 0 1 have "\<forall>i\<le>(card (UNIV::('a\<Rightarrow>'a) set) + 1). \<forall>i'\<le>(card (UNIV::('a\<Rightarrow>'a) set) + 1).
    i < i' \<longrightarrow> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) i < approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) i'"
    using approx_tm1_mono_min2 assms
    by (smt (verit, del_insts) Suc_eq_plus1 dual_order.eq_iff le_funI not_less_eq_eq order_less_le)

  then have "\<forall>i\<le>(card (UNIV::('a\<Rightarrow>'a) set) + 1). \<forall>i'\<le>(card (UNIV::('a\<Rightarrow>'a) set) + 1).
    i \<noteq> i' \<longrightarrow> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) i \<noteq> approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) i'"
    using approx_tm1_mono_min2 assms
    by (metis linorder_neq_iff order_less_irrefl)

  then have "\<forall>n\<le>(card (UNIV::('a\<Rightarrow>'a) set) + 1).
              n \<le> card (\<Union>i\<le>n. {(approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) i)})"
    by (metis inj_func_card)
  then have 3: "card ?A > (card (UNIV::('a\<Rightarrow>'a) set))"
    by auto
  then have 4: "card ?A \<le> card (UNIV::('a\<Rightarrow>'a) set)"
    using card_mono finite_UNIV by blast

  from 3 4 show False  by simp
qed

lemma approx_tm1_mu_final: "\<forall>f. mono (\<eta>1 f) \<Longrightarrow>
      approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (card (UNIV::('a\<Rightarrow>'a::finite_lattice) set))
      = approx_tm1 \<eta>0 \<eta>1 \<phi> x (\<lambda>_. \<bottom>) (Suc (card (UNIV::('a\<Rightarrow>'a::finite_lattice) set)))"
      by (metis approx_tm1.simps(2) approx_tm1_eventually_stable approx_tm1_stays_stable)

lemma unfold_mu0:
  assumes "\<forall>f. mono (\<eta>1 f)"
  shows "sem_tm0 \<eta>0 \<eta>1 (Mu0 x1a \<phi>)
            = sem_tm0 (\<eta>0(x1a := sem_tm0 \<eta>0 \<eta>1 (Mu0 x1a \<phi>))) \<eta>1 \<phi>"
    (is "?l = ?r")
proof -
  have 0: "sem_tm0 \<eta>0 \<eta>1 (Mu0 x1a \<phi>) =
             \<Sqinter>{d. sem_tm0 (\<eta>0(x1a := d)) \<eta>1 \<phi> \<le> d}"
    by simp

  have 1: "sem_tm0 (\<eta>0(x1a := d)) \<eta>1 \<phi> \<le> d \<longrightarrow> ?l \<le> d" for d
    by (simp add: Inf_lower)
  then have 2: "(sem_tm0 (\<eta>0(x1a := d)) \<eta>1 \<phi> \<le> d)
        \<longrightarrow> (\<eta>0(x1a := ?l)) x \<le> (\<eta>0(x1a := d)) x" for x d
    by simp
  then have "sem_tm0 (\<eta>0(x1a := d)) \<eta>1 \<phi> \<le> d
        \<longrightarrow> ?r \<le> sem_tm0 (\<eta>0(x1a := d)) \<eta>1 \<phi>" for d
    by (simp add: assms sem_mono(1))
  then have "sem_tm0 (\<eta>0(x1a := d)) \<eta>1 \<phi> \<le> d \<longrightarrow> ?r \<le> d" for d
    using dual_order.trans by blast
  then have 3: "?r \<le> \<Sqinter>{d. sem_tm0 (\<eta>0(x1a := d)) \<eta>1 \<phi> \<le> d}"
    by (simp add: le_Inf_iff)
  with 1 2 have "sem_tm0 \<eta>0 \<eta>1 (Mu0 x1a \<phi>)
    \<le> sem_tm0 (\<eta>0(x1a := sem_tm0 \<eta>0 \<eta>1 (Mu0 x1a \<phi>))) \<eta>1 \<phi>"
    using assms sem_mono(1) by auto
  with 3 show ?thesis by simp
qed

lemma unfold_mu1:
  assumes "\<forall>f. mono (\<eta>1 f)"
  shows "sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>) = sem_tm1 \<eta>0 (\<eta>1(x1a := sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>))) \<phi>"
    (is "?l = ?r")
proof -
  have 0: "sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>) = \<Sqinter>{d. mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d}"
    by simp

  have 1: "mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d \<longrightarrow> ?l \<le> d" for d
    by (simp add: Inf_lower)
  then have " mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d \<longrightarrow> (\<eta>1(x1a := ?l)) x \<le> (\<eta>1(x1a := d)) x" for x d
    by auto
  with 1 have "mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d \<longrightarrow> ?r \<le> (sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi>)" for d
    by (meson dual_order.refl assms sem_mono(2) sem_tm_fun_upd_mono)
  then have "mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d \<longrightarrow> ?r \<le> d" for d
    using dual_order.trans by blast

  then have 2: "?r \<le> \<Sqinter>{d. mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d}"
    by (simp add: le_Inf_iff)
  with 0 1 have 3: "sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>)
                  \<le> sem_tm1 \<eta>0 (\<eta>1(x1a := sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>))) \<phi>"
    using sem_mono(2) assms
    by (smt (verit) dual_order.eq_iff fun_upd_apply le_fun_def)

  from 2 3 show ?thesis by simp
qed

theorem sem_k_eq_sem:
"\<And>\<eta>0 \<eta>1. \<forall>f. mono (\<eta>1 f) \<Longrightarrow> sem_tm0_k \<eta>0 \<eta>1 \<phi> = sem_tm0 \<eta>0 \<eta>1 \<phi>"

"\<And>\<eta>0 \<eta>1. \<forall>f. mono (\<eta>1 f) \<Longrightarrow> sem_tm1_k \<eta>0 \<eta>1 \<phi>' = sem_tm1 \<eta>0 \<eta>1 \<phi>'"
proof (induction \<phi> and \<phi>')
  case (Mu0 x \<phi>)

  have 1: "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n
            \<le> \<Sqinter>{d. sem_tm0 (\<eta>0(x := d)) \<eta>1 \<phi> \<le> d}" for n
  proof (induction n)
    case 0
    then show ?case
      by simp
  next
    case (Suc n)
    have 0: "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc n)
            = sem_tm0_k (\<eta>0(x := approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n)) \<eta>1 \<phi>"
      by simp
    then have 1: "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (Suc n)
            = sem_tm0 (\<eta>0(x := approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n)) \<eta>1 \<phi>"
      using Mu0.IH Mu0.prems by fastforce
    then have "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n \<le> sem_tm0 \<eta>0 \<eta>1 (Mu0 x \<phi>)"
      by (simp add: Suc)
    then have 2: "sem_tm0 (\<eta>0(x := approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> n)) \<eta>1 \<phi>
                  \<le> sem_tm0 (\<eta>0(x := sem_tm0 \<eta>0 \<eta>1 (Mu0 x \<phi>))) \<eta>1 \<phi>"
      using Mu0.prems sem_mono(1) by auto

   have "sem_tm0 \<eta>0 \<eta>1 (Mu0 x \<phi>) =
              sem_tm0 (\<eta>0(x := sem_tm0 \<eta>0 \<eta>1 (Mu0 x \<phi>))) \<eta>1 \<phi>"
      using Mu0.prems unfold_mu0 by blast
   with 0 1 2 show ?case
     by (metis sem_tm0.simps(4))
  qed

  let ?t = "approx_tm0 \<eta>0 \<eta>1 \<phi> x \<bottom> (card (UNIV::'a set))"

  have "sem_tm0 (\<eta>0(x := ?t)) \<eta>1 \<phi> \<le> ?t"
    by (metis approx_tm0.simps(2) approx_tm0_mu_final
        dual_order.eq_iff Mu0.IH Mu0.prems)
  then have 2: "?t \<ge> \<Sqinter>{d. sem_tm0 (\<eta>0(x := d)) \<eta>1 \<phi> \<le> d}"
    by (simp add: Inf_lower)

  from 1 2 show ?case
    by (simp add: order.antisym)
next
  case (Lam x \<phi>)
  then have "(\<lambda>d'. sem_tm0 (\<eta>0(x := d')) \<eta>1 \<phi>) d =
      (\<lambda>d'. sem_tm0_k (\<eta>0(x := d')) \<eta>1 \<phi>) d" for d
    by fastforce
  then show ?case
    by simp
next
  case (Mu1 x1a \<phi>)
  have 1: "approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>) n
    \<le> \<Sqinter>{d. mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d}" for n
  proof (induction n)
    case 0
    then show ?case
      by (simp add: le_fun_def)
  next
    case (Suc n)
    have 0: "approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>) (Suc n)
            = sem_tm1_k \<eta>0 (\<eta>1(x1a := approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>) n)) \<phi>"
      by simp
    then have 1: "approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>) (Suc n)
            = sem_tm1 \<eta>0 (\<eta>1(x1a := approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>) n)) \<phi>"
      using Mu1.IH Mu1.prems
      by (smt (verit, best) approx_tm1_mono dual_order.eq_iff fun_upd_apply sem_k_mono(2))
    then have "approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>) n \<le> sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>)"
      by (simp add: Suc)
    then have 2: "sem_tm1 \<eta>0 (\<eta>1(x1a := approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_.\<bottom>) n)) \<phi>
                  \<le> sem_tm1 \<eta>0 (\<eta>1(x1a := sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>))) \<phi>"
      by (smt (verit) Mu1.prems approx_tm1_mono dual_order.eq_iff sem_tm_fun_upd_mono
          ctx_axioms sem_k_mono(2) sem_mono(2))

    have "sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>) =
              sem_tm1 \<eta>0 (\<eta>1(x1a := sem_tm1 \<eta>0 \<eta>1 (Mu1 x1a \<phi>))) \<phi>"
      using Mu1.prems unfold_mu1 by blast
    with 0 1 2 show ?case
      by (metis sem_tm1.simps(4))
  qed

  let ?t = "approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_.\<bottom>) (card (UNIV::('a\<Rightarrow>'a) set))"

  have "?t = approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>)(Suc (card (UNIV::('a\<Rightarrow>'a) set)))"
    using Mu1.prems approx_tm1_mu_final by blast
  then have "sem_tm1 \<eta>0 (\<eta>1(x1a := ?t)) \<phi> \<le> ?t"
    by (smt (verit, best) dual_order.eq_iff approx_tm1_mono fun_upd_apply
        Mu1.IH Mu1.prems approx_tm1.simps(2) sem_k_mono(2))

  then have 2: "approx_tm1 \<eta>0 \<eta>1 \<phi> x1a (\<lambda>_. \<bottom>) (card (UNIV::('a\<Rightarrow>'a) set))
               \<ge> \<Sqinter>{d. mono d \<and> sem_tm1 \<eta>0 (\<eta>1(x1a := d)) \<phi> \<le> d}"
    by (smt (verit, best) Inf_lower Mu1.prems approx_tm1_mono dual_order.eq_iff
        mem_Collect_eq sem_k_mono(2))

  from 1 2 show ?case
    by (metis dual_order.eq_iff sem_tm1.simps(4) sem_tm1_k.simps(4))
qed auto

end end


subsection\<open>The reduction from \<open>3CNF-SAT\<close> To \<open>Set Cover\<close> is polynomial\<close>

theory TC_To_ChrN_Poly
  imports "../Polynomial_Reductions" "TC_To_ChrN"
begin

definition "size_NodesOf3C = (\<lambda>(E). card (\<Union>E))"
definition "size_chrN = (\<lambda>(E,k). card E)"
definition "mop_set_empty_set = REST [ {} \<mapsto> 1]"
definition "mop_amount_nodes E = SPECT [ card (\<Union>(E))+3 \<mapsto> 1 ]"

definition "translateGraph E S=
  SPECT [ S \<union> {{(v1::nat,0::nat),(v2,0)}|v1 v2. {v1,v2}\<in> E} \<mapsto> card (\<Union>E) * card (\<Union>E)]"

definition "add_completeGraph E S =
  SPECT [ S \<union> {{(0::nat,k),(0::nat,k')}|k k'. k \<in> {1..(card (\<Union>E))} \<and> k' \<in> {1..(card (\<Union>E))} \<and> k \<noteq> k'} \<mapsto>
          ((card (\<Union>E)) * ((card (\<Union>E))-1)) div 2]"

definition "connectGraphs E S =
  SPECT [ S \<union> {{(v1,0::nat),(0::nat,k)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}} \<mapsto> card (\<Union>E) * card (\<Union>E)]"

definition threeColToChrNum ::
  "nat set set \<Rightarrow> (((nat \<times> nat) set set) \<times> nat) nrest" where
  "threeColToChrNum = (\<lambda>E. do {
      b \<leftarrow> SPECT [ ugraph E \<mapsto> 1];
      if b then
        do {
          k \<leftarrow> mop_amount_nodes E;
          S \<leftarrow> mop_set_empty_set;
          S \<leftarrow> translateGraph E S;
          S \<leftarrow> add_completeGraph E S;
          S \<leftarrow> connectGraphs E S;
          RETURNT (S,k)
        }
      else RETURNT (({},0))
    })"

definition "size_SAT xs = length xs"
definition "threeColToChrNum_time n =  1 + 1 + 1 + (n*n)+ (n*n) + (n*n)"
definition "threeColToChrNum_space n = (n*n)+ (n*n) + (n*n)"

lemma finite_chrn_split1:
"finite (\<Union>E) \<Longrightarrow> finite {{(v1, 0), (v2, 0)} |v1 v2. v1 \<in> \<Union> E \<and> v2 \<in> \<Union> E} "
proof -
  assume asms: "finite (\<Union>E)"
  let ?S = "(((\<Union>E)\<times>{0}) \<times> (\<Union> E\<times> {0}))"
  from asms show ?thesis by (fastforce intro: finite_surj[where A = "?S"])
qed

lemma chro_part_sml_card: " (x::nat) * (x - 1) div 2 + x \<le> x* x"
  by (metis div_le_dividend le_square mult.comm_neutral
      ordered_cancel_comm_monoid_diff_class.le_diff_conv2 right_diff_distrib')

lemma threeColToChrNum_refines:
  "threeColToChrNum E \<le> SPEC (\<lambda>y. y = TC_chrN E) (\<lambda>_. enat (threeColToChrNum_time (size_NodesOf3C E)))"
  unfolding SPEC_def
  unfolding threeColToChrNum_time_def TC_chrN_def threeColToChrNum_def
       mop_amount_nodes_def mop_set_empty_set_def translateGraph_def add_completeGraph_def connectGraphs_def
  apply(rule T_specifies_I)
  apply(vcg' \<open>-\<close> rules: T_SPEC )
  apply (auto simp: size_NodesOf3C_def one_enat_def ugraph_def)
  by (metis diff_le_self div_le_dividend le_trans right_diff_distrib')

lemma chrNgraph_size_eval:"size_chrN (TC_chrN E) \<le>card (\<Union> E) * card (\<Union> E) +
                                                        card (\<Union> E) * card (\<Union> E) +
                                                        card (\<Union> E) * card (\<Union> E)"
proof (cases "ugraph E")
  case T:True
  define E_trans where E_trans_def:"E_trans= {{(v1::nat,0::nat),(v2,0)}|v1 v2. {v1,v2}\<in> E}"
  define connect where connect_def:"connect= {{(v1,0),(0,k)}|v1 k. v1\<in> (\<Union> E) \<and> k \<in> {1..(card (\<Union>E))}}"
  define graph_complete where graph_complete_def:"graph_complete=
    {{(0::nat,k),(0,k')}|k k'. k \<in> {1..(card (\<Union>E))} \<and> k' \<in> {1..(card (\<Union>E))} \<and> k \<noteq> k'}"

  from T have size_split:"size_chrN (TC_chrN E) = card (
              E_trans \<union>
              connect \<union>
              graph_complete)"
    unfolding TC_chrN_def size_chrN_def graph_complete_def connect_def E_trans_def
    by simp

  from T have finiteNodes:"finite (\<Union>E)"
    unfolding ugraph_def
    using finite_Union by fastforce

  from T chromatik_finite1 have fin1: "finite E_trans"
    unfolding E_trans_def
    by blast

  from finiteNodes chromatik_finite2 have fin2: "finite connect"
    unfolding connect_def
    by blast

  from finiteNodes chromatik_finite3 have fin3: "finite graph_complete"
    unfolding graph_complete_def
    by blast

  from chromatik_card1 T have card1:"card E_trans = card E"
    unfolding E_trans_def
    by blast

  from chromatik_card3 finiteNodes have card2:"card connect = card (\<Union>E) * card (\<Union>E)"
    unfolding connect_def
    by blast

  from chromatik_card4 finiteNodes have card3:"card graph_complete = card (\<Union>E) * (card (\<Union>E)-1) div 2"
    unfolding graph_complete_def
    by blast

  have "\<And>e. e\<in>connect \<Longrightarrow> e\<notin> E_trans"
  proof -
    fix e
    assume "e\<in> connect"
    from this obtain k where k_def:"(0,k)\<in> e \<and> k \<in>{1..card (\<Union> E)} "
      unfolding connect_def
      by blast
    have "\<forall> e'\<in> E_trans. \<forall> a b. (a,b) \<in> e'  \<longrightarrow> b = 0"
      unfolding E_trans_def
      by blast
    from this k_def have "\<forall>e'\<in>E_trans. (0, k) \<notin> e'"
      by auto
    from k_def this show "e\<notin> E_trans"
      by blast
  qed

  from this have disjoint1:"E_trans \<inter> connect = {}"
    by blast

  have disjoint2:"E_trans \<inter> graph_complete = {}"
    unfolding E_trans_def graph_complete_def
    by fastforce

  have "\<And>e. e\<in>connect \<Longrightarrow> e\<notin> graph_complete"
  proof -
    fix e
    assume "e\<in> connect"
    from this obtain v where v_def:"(v,0)\<in> e \<and> v \<in> (\<Union> E) "
      unfolding connect_def
      by blast
    have "\<forall> e'\<in> graph_complete. \<forall> a b. (a,b) \<in> e'  \<longrightarrow> b \<in> {1..card (\<Union> E)}"
      unfolding graph_complete_def
      by blast
    from this v_def have "\<forall>e'\<in>graph_complete. (v, 0) \<notin> e'"
      by auto
    from v_def this show "e\<notin> graph_complete"
      by blast
  qed

  from this have disjoint3:"connect \<inter> graph_complete = {}"
    by blast

  from disjoint1 disjoint2 disjoint3 fin1 fin2 fin3 have
    " card (E_trans \<union> connect \<union> graph_complete) =
      card E_trans + card connect + card graph_complete"
    by (simp add: card_Un_disjoint inf_sup_distrib2)

  from this size_split card1 card2 card3 have split_card:
    "size_chrN (TC_chrN E) = card E +
                                   (card (\<Union> E) * card (\<Union> E)) +
                                   (card (\<Union> E) * (card (\<Union> E) - 1) div 2)"
    by presburger

  define E_complete where E_complete_def: "E_complete = {{(v1::nat,0::nat),(v2,0)}|v1 v2. v1\<in> \<Union>E \<and> v2\<in> \<Union>E}"

  have E_complete_card:"finite (\<Union> E) \<Longrightarrow> card E_complete = (card (\<Union>E) * (card (\<Union>E)-1) div 2) + card (\<Union>E)"
  unfolding E_complete_def
  proof (induction "card (\<Union>E)" arbitrary: E)
    case 0
    from this have "\<Union>E = {}"
      by simp
    show ?case
      by (simp add: \<open>\<Union> E = {}\<close>)
  next
    case (Suc x)
    from Suc(2) have "\<Union>E \<noteq> {}"
      by fastforce
    from this Suc(2) Suc(3) obtain E' v where E'_def:
      "\<Union>E = \<Union>E' \<union> {v} \<and> \<Union>E' \<inter> {v} = {}"
      unfolding ugraph_def
      by (metis Int_empty_right Int_insert_right_if0
          Un_empty_right Un_insert_right all_not_in_conv
          ccpo_Sup_singleton mk_disjoint_insert)
    from E'_def Suc(2) have E'_card:"card (\<Union>E') = x"
      using Suc.prems by auto
    from Suc(3) E'_def have finE':"finite (\<Union>E')"
      by simp
    define graph where graph_def: "graph = {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 \<in> \<Union> E \<and> v2 \<in> \<Union> E}"
    define split1 where split1_def: "split1 = {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 \<in> \<Union> E' \<and> v2 \<in> \<Union> E'}"
    define split2 where split2_def: "split2 = {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 \<in> \<Union> E' \<and> v2 =v}"
    define split3 where split3_def: "split3 = {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 = v \<and> v2 \<in> \<Union> E'}"
    define split4 where split4_def: "split4 = {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 = v \<and> v2 = v}"

    from split2_def have split2_def': "split2 = {{(v1, 0::nat), (v, 0)} |v1. v1 \<in> \<Union> E'}"
      by fastforce
    from split3_def have split3_def': "split3 = {{(v, 0::nat), (v2, 0)} |v2. v2 \<in> \<Union> E'}"
      by fastforce
    from split2_def' split3_def' have sp2sp3_eq:"split2 = split3"
      by blast
    from split4_def have split4_def':"split4 = {{(v, 0::nat), (v, 0)}}"
      by blast

    define split_step where split_step_def:
      "split_step = {{(v1, 0::nat), (v2, 0)} |v1 v2. (v1 \<in> \<Union>E' \<or> v1 = v) \<and> (v2 \<in> \<Union>E' \<or> v2 = v)}"
    from E'_def have "{{(v1, 0), (v2, 0)} |v1 v2. v1 \<in> \<Union>E \<and> v2 \<in> \<Union>E} =
                  {{(v1, 0), (v2, 0)} |v1 v2. (v1 \<in> \<Union>E' \<or> v1 = v) \<and> (v2 \<in> \<Union>E' \<or> v2 = v)}"
      by auto
    from this have sp_1:" graph = split_step"
      unfolding split_step_def graph_def
      by blast

    have sp_2:"split_step =
          {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 \<in> \<Union> E' \<and> v2 \<in> \<Union> E'} \<union>
          {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 \<in> \<Union> E' \<and> v2 =v} \<union>
          {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 = v \<and> v2 \<in> \<Union> E'} \<union>
          {{(v1, 0::nat), (v2, 0)} |v1 v2. v1 = v \<and> v2 = v}"
      unfolding split_step_def
      by fast

    from sp_1 sp_2 have "graph = split1 \<union> split2 \<union> split3 \<union> split4"
      by (simp add: split1_def split2_def split3_def split4_def)

    from this sp2sp3_eq have graph_split:
      "graph = split1 \<union> split2 \<union> split4"
      by auto

    from Suc(1)[where E= E'] finE' E'_card split1_def have card1:
      "card split1 = (card (\<Union>E') * (card (\<Union>E')-1) div 2) + card (\<Union>E')"
      by auto
    from split2_def' have card2: "card split2 = card (\<Union>E')"
      using card_one_para2 finE' sp2sp3_eq split3_def' by fastforce
    have card3: "card split4 = 1"
      unfolding split4_def
      by force
    from E'_def have vNotinE'nodes:"v\<notin> \<Union>E'"
      by blast
    have "\<And>e. e\<in>split2 \<Longrightarrow> e\<notin> split1"
    proof -
      fix e
      assume "e\<in> split2"
      from this have vIn_e:"(v,0)\<in> e"
        unfolding split2_def'
        by blast
      have "\<forall> e'\<in> split1. \<forall>v'.(v',0) \<in> e' \<longrightarrow> v'\<in>\<Union>E'"
        unfolding split1_def
        by blast
      from this vNotinE'nodes have "\<forall>e'\<in>split1. (v, 0) \<notin> e'"
        by blast
      from vIn_e this show "e\<notin> split1"
        by blast
    qed
    from this have disjoint1: "split1 \<inter> split2 = {}"
      by blast

    from vNotinE'nodes have disjoint2: "split1 \<inter> split4 = {}"
      unfolding split1_def split4_def'
      by simp

    from vNotinE'nodes have disjoint3: "split2 \<inter> split4 = {}"
      unfolding split2_def split4_def'
      by simp

    from finE' have fin1: "finite split1"
      unfolding split1_def
      using finite_chrn_split1
      by blast

    from finE' have fin2: "finite split2"
      unfolding split2_def'
    proof -
      have "\<forall>f N. finite {r. \<exists>n. (r::(nat \<times> nat) set) = f (n::nat) \<and> n \<in> N} \<or> infinite N"
        by force
      then show "finite {{(n, 0::nat), (v, 0)} |n. n \<in> \<Union> E'}"
        by (meson finE')
    qed

    have fin3: "finite split4"
      unfolding split4_def'
      by blast

    from graph_split disjoint1 disjoint2 disjoint3 fin1 fin2 fin3 have
      "card graph = card split1 + card split2 + card split4"
      by (simp add: card_Un_disjoint inf_sup_distrib2)

    from this card1 card2 card3 E'_card have "card graph = (x * (x-1) div 2 + x) + x + 1"
      by argo

    from this have card_graph:"card graph =  ((x * (x-1)) + 2 *x) div 2 + Suc x"
      by simp
    have "((x * (x-1)) + 2 *x) = x* (x +1)"
      by (auto simp : right_diff_distrib')
    from this card_graph have "card graph = ((Suc x) * (x)) div 2 + Suc x"
      by simp
    from this Suc(2) show ?case
      unfolding graph_def
      by (metis diff_Suc_1)
  qed

  have finE_complete:"finite E_complete"
    unfolding E_complete_def
    using finiteNodes finite_chrn_split1 by blast

  have subset1:"E_trans \<subseteq> E_complete"
    unfolding E_complete_def E_trans_def
    by blast

  from finiteNodes subset1 E_complete_card card1 have chrN_card_sml1:
    "card E \<le> card (\<Union> E) * (card (\<Union> E) - 1) div 2 + card (\<Union> E)"
  proof -
    from subset1 finE_complete have "card E_trans \<le> card E_complete"
      using Finite_Set.card_mono
      by blast
    from this card1 E_complete_card finiteNodes show ?thesis
      by metis
  qed

  have chrN_card_sml2:"card (\<Union> E) * (card (\<Union> E) - 1) div 2 + card (\<Union> E) \<le> card (\<Union> E)* card (\<Union> E) "
    using chro_part_sml_card
    by blast

  from chrN_card_sml1 chrN_card_sml2 have chrN_card_sml3:"card E \<le>  card (\<Union> E)* card (\<Union> E)"
    by linarith

  from split_card chrN_card_sml3 show ?thesis
    apply auto
    by (metis One_nat_def add_le_mono div_le_dividend mult.commute mult_eq_if trans_le_add2)
next
  case False
  from this have "size_chrN (TC_chrN E) = card {}"
    unfolding TC_chrN_def size_chrN_def
    by simp
  then show ?thesis
    by simp
qed

lemma threeColToChrNum_size:
  "size_chrN (TC_chrN E) \<le> threeColToChrNum_space (size_NodesOf3C E)"
  using chrNgraph_size_eval
  unfolding threeColToChrNum_space_def size_NodesOf3C_def
  by blast

theorem threeColToChrNum_ispolyred: "ispolyred threeColToChrNum three_colorability chromaticNumber size_NodesOf3C size_chrN"
  unfolding ispolyred_def
  apply(rule exI[where x=TC_chrN])
  apply(rule exI[where x=threeColToChrNum_time])
  apply(rule exI[where x=threeColToChrNum_space])
  apply(safe)
  subgoal using threeColToChrNum_refines
    by simp
  subgoal using threeColToChrNum_size
    by simp
  subgoal unfolding poly_def threeColToChrNum_time_def apply(rule exI[where x=2]) by auto
  subgoal unfolding poly_def threeColToChrNum_space_def apply(rule exI[where x=2]) by auto
  using is_reduction_threeC_chrN
  apply (simp add:is_reduction_def )
done

end


theory LRE_Beh_26122022_075805
imports "Z_Machines.Z_Machine"
begin

subsection \<open> Introduction \<close>

text \<open> This theory file is to model the LRE_Beh state machine in Z Machine notations.\<close>

notation undefined ("???")

subsection \<open> type definition \<close>

datatype ('s, 'e) tag =
  State (ofState: 's) | Event (ofEvent: 'e)

abbreviation "is_Event x \<equiv> \<not> is_State x"

type_synonym ('s, 'e) rctrace = "('s, 'e) tag list"

definition wf_rcstore :: "('s, 'e) rctrace \<Rightarrow> 's \<Rightarrow> 's option \<Rightarrow> bool" where
[z_defs]: "wf_rcstore tr st final = (
     length(tr) > 0
   \<and> tr ! ((length tr) -1) = State st
   \<and> (final \<noteq> None \<longrightarrow> (\<forall>i<length tr. tr ! i = State (the final) \<longrightarrow> i= (length tr) -1))
   \<and> (filter is_State tr) ! (length (filter is_State tr) -1) = State  st)"

enumtype St = OCM | MOM | HCM | CAM | initial
definition [z_defs]: "St = {OCM, MOM, HCM, CAM, initial}"

enumtype Evt = endTask | reqOCM | reqMOM | reqVel | advVel | position
definition "Evt = {endTask, reqOCM, reqMOM, reqVel, advVel, position}"

consts StaticObsDist :: "integer"
consts MinSafeDist :: "integer"
consts HCMVel :: "integer"
consts MOMVel :: "integer"
consts Obsts :: "(integer\<times>integer) list"
consts ReqV :: "(integer\<times>integer) set"

text \<open> function definition \<close>

consts setVel :: " (integer\<times>integer) \<times> integer \<Rightarrow>(integer\<times>integer)"
consts CDA :: " (integer\<times>integer) \<times> (integer\<times>integer) list \<times> (integer\<times>integer) \<Rightarrow>integer"
consts maneuv :: " (integer\<times>integer) \<Rightarrow> (integer\<times>integer)"
consts dist :: " (integer\<times>integer) \<times> (integer\<times>integer) list \<Rightarrow>integer"
consts inOPEZ :: " (integer\<times>integer) \<Rightarrow> bool"

subsection \<open> State Space \<close>

zstore LRE_Beh =
  pos :: "(integer\<times>integer)"
  vel :: "(integer\<times>integer)"
  reqV :: "(integer\<times>integer)"

  st::"St"
  tr :: "(St, Evt) tag list"
  triggers:: "Evt set"
  where inv:
    "wf_rcstore tr st (Some final)"

subsection \<open> Operations \<close>

zoperation InitialToOCM =
  over LRE_Beh
  pre "st= initial"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr  @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation OCMToMOM =
  over LRE_Beh
  pre "st= OCM \<and> ((vel.1 * vel.1) + (vel.2 * vel.2))\<le>(3 * 3) \<and> dist(pos, Obsts)>10 \<and> \<not>inOPEZ(pos)"
  update "[st\<Zprime>= MOM
          ,vel\<Zprime> =setVel(vel, MOMVel)
         ,tr\<Zprime> =tr @ [Event reqMOM]@ [Event advVel] @ [State MOM]
         ,triggers\<Zprime> = {reqOCM, endTask}
         ]"

zoperation MOMToOCM =
  over LRE_Beh
  pre "st= MOM"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr @ [Event reqOCM] @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation HCMToOCM =
  over LRE_Beh
  pre "st= HCM"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr @ [Event reqOCM] @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation MOMToHCM =
  over LRE_Beh
  pre "st= MOM \<and> ((vel.1 * vel.1) + (vel.2 * vel.2))>(3 * 3) \<and> dist(pos, Obsts)\<le>StaticObsDist \<and> CDA(pos, Obsts, vel)>MinSafeDist \<and> \<not>inOPEZ(pos)"
  update "[st\<Zprime>= HCM
          ,vel\<Zprime> =setVel(vel, HCMVel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State HCM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation MOMToOCM_1 =
  over LRE_Beh
  pre "st= MOM \<and> inOPEZ(pos) \<and> (CDA(pos, Obsts, vel)>MinSafeDist \<or> dist(pos, Obsts)>StaticObsDist)"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr  @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation HCMToOCM_1 =
  over LRE_Beh
  pre "st= HCM \<and> inOPEZ(pos) \<and> (CDA(pos, Obsts, vel)>MinSafeDist \<or> dist(pos, Obsts)>StaticObsDist)"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr  @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation HCMToMOM =
  over LRE_Beh
  pre "st= HCM \<and> dist(pos, Obsts)>StaticObsDist \<and> \<not>inOPEZ(pos)"
  update "[st\<Zprime>= MOM
          ,vel\<Zprime> =setVel(vel, MOMVel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State MOM]
         ,triggers\<Zprime> = {reqOCM, endTask}
         ]"

zoperation OCMToOCM =
  over LRE_Beh
  params reqV_input \<in> "ReqV"
  pre "st= OCM"
  update "[st\<Zprime>= OCM
         ,reqV\<Zprime> =reqV_input
         ,vel\<Zprime> = reqV_input
         ,tr\<Zprime> =tr @ [Event reqVel]@ [Event advVel] @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation MOMToOCM_2 =
  over LRE_Beh
  pre "st= MOM"
  update "[st\<Zprime>= OCM
         ,vel\<Zprime> = (0, 0)
         ,tr\<Zprime> =tr @ [Event endTask]@ [Event advVel] @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation HCMToCAM =
  over LRE_Beh
  pre "st= HCM \<and> CDA(pos, Obsts, vel)\<le>MinSafeDist \<and> dist(pos, Obsts)\<le>StaticObsDist"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation MOMToCAM =
  over LRE_Beh
  pre "st= MOM \<and> CDA(pos, Obsts, vel)\<le>MinSafeDist \<and> dist(pos, Obsts)\<le>StaticObsDist"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation CAMToOCM =
  over LRE_Beh
  pre "st= CAM \<and> CDA(pos, Obsts, vel)>MinSafeDist"
  update "[st\<Zprime>= OCM
         ,vel\<Zprime> = (0, 0)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation CAMToOCM_1 =
  over LRE_Beh
  pre "st= CAM"
  update "[st\<Zprime>= OCM
         ,tr\<Zprime> =tr @ [Event reqOCM] @ [State OCM]
         ,triggers\<Zprime> = {reqMOM, reqVel}
         ]"

zoperation CAMToCAM =
  over LRE_Beh
  pre "st= CAM \<and> CDA(pos, Obsts, vel)\<le>MinSafeDist \<and> dist(pos, Obsts)\<le>StaticObsDist"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation MOMToCAM_1 =
  over LRE_Beh
  pre "st= MOM \<and> ((((pos.1 + vel.1)<0 \<or> (pos.1 + vel.1)>99) \<or> (pos.2 + vel.2)<0) \<or> (pos.2 + vel.2)>99)"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation HCMToCAM_1 =
  over LRE_Beh
  pre "st= HCM \<and> ((((pos.1 + vel.1)<0 \<or> (pos.1 + vel.1)>99) \<or> (pos.2 + vel.2)<0) \<or> (pos.2 + vel.2)>99)"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

zoperation CAMToCAM_1 =
  over LRE_Beh
  pre "st= CAM \<and> ((((pos.1 + vel.1)<0 \<or> (pos.1 + vel.1)>99) \<or> (pos.2 + vel.2)<0) \<or> (pos.2 + vel.2)>99)"
  update "[st\<Zprime>= CAM
          ,vel\<Zprime> =maneuv(vel)
         ,tr\<Zprime> =tr @ [Event advVel] @ [State CAM]
         ,triggers\<Zprime> = {reqOCM}
         ]"

definition Init :: "LRE_Beh subst" where
  [z_defs]:
  "Init =
  [st\<leadsto> ,
   tr\<leadsto> ,
   triggers\<leadsto> ,
   ]"
(*To be filled in by user*)

zmachine LRE_BehMachine =
  init Init
  invariant LRE_Beh_inv
  operations  InitialToOCM OCMToMOM MOMToOCM HCMToOCM MOMToHCM MOMToOCM_1 HCMToOCM_1 HCMToMOM OCMToOCM MOMToOCM_2 HCMToCAM MOMToCAM CAMToOCM CAMToOCM_1 CAMToCAM MOMToCAM_1 HCMToCAM_1 CAMToCAM_1

subsection \<open> Structural Invariants \<close>

lemma Init_inv [hoare_lemmas]: "Init establishes LRE_Beh_inv"
  by zpog_full

lemma InitialToOCM_inv [hoare_lemmas]: "InitialToOCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma OCMToMOM_inv [hoare_lemmas]: "OCMToMOM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToOCM_inv [hoare_lemmas]: "MOMToOCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToOCM_inv [hoare_lemmas]: "HCMToOCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToHCM_inv [hoare_lemmas]: "MOMToHCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToOCM_1_inv [hoare_lemmas]: "MOMToOCM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToOCM_1_inv [hoare_lemmas]: "HCMToOCM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToMOM_inv [hoare_lemmas]: "HCMToMOM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma OCMToOCM_inv [hoare_lemmas]: "OCMToOCM (reqV) preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToOCM_2_inv [hoare_lemmas]: "MOMToOCM_2() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToCAM_inv [hoare_lemmas]: "HCMToCAM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToCAM_inv [hoare_lemmas]: "MOMToCAM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma CAMToOCM_inv [hoare_lemmas]: "CAMToOCM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma CAMToOCM_1_inv [hoare_lemmas]: "CAMToOCM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma CAMToCAM_inv [hoare_lemmas]: "CAMToCAM() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma MOMToCAM_1_inv [hoare_lemmas]: "MOMToCAM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma HCMToCAM_1_inv [hoare_lemmas]: "HCMToCAM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

lemma CAMToCAM_1_inv [hoare_lemmas]: "CAMToCAM_1() preserves LRE_Beh_inv"
  by (zpog_full; auto)

subsection \<open> Safety Requirements \<close>

zexpr R1 is ""

lemma  "Init establishes R1"
  by zpog_full

lemma "InitialToOCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "OCMToMOM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToOCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToOCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToHCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToOCM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToOCM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToMOM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "OCMToOCM (reqV) preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToOCM_2() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToCAM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToCAM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "CAMToOCM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "CAMToOCM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "CAMToCAM() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "MOMToCAM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "HCMToCAM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

lemma "CAMToCAM_1() preserves R1 under LRE_Beh_inv"
  by (zpog_full; auto)

definition [z_defs]: "LRE_Beh_axioms = ()"

lemma LRE_Beh_deadlock_free: "LRE_Beh_axioms  \<Longrightarrow> deadlock_free LRE_BehMachine"
  unfolding LRE_BehMachine_def
  by deadlock_free
end


(*
    File:        Length.thy
    Time-stamp:  <2016-01-06T17:48:20Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory Length imports Lambda dLambda begin

definition LLength :: "i=>i" where
"LLength(M) == LTerm_rec(%x. 0, %x m r. succ(r),
                         %m n rm rn. succ(rm Un rn), M)"

definition Length :: "i=>i" where
"Length(M) == THE n. n: (INT m: M. {LLength(m)})"

lemma LLength_eqns:
  "LLength(LVar(x)) = 0"
  "LLength(LLam(x, M)) = succ(LLength(M))"
  "LLength(LApp(M, N)) = succ(LLength(M) Un LLength(N))"
apply (unfold LLength_def)
apply simp_all
done

lemma LLength_type:
  "M: LTerm ==> LLength(M): nat"
apply (erule LTerm.induct)
apply (simp_all only: LLength_eqns)
apply (assumption | rule nat_succI nat_UnI nat_0I)+
done

lemma LSkeltonEq_imp_LLength_eq:
  assumes major: "LSkeltonEq(M, N)"
  shows "LLength(M) = LLength(N)"
apply (rule major [THEN rev_mp])
apply (rule_tac x="N" in spec)
apply (rule major [THEN LSkeltonEqD1, THEN LTerm.induct])
apply (safe elim!: LSkeltonEq_LTermEs)
apply (simp_all add: LLength_eqns)
done

lemma Length_LAQ:
  "m: LTerm ==> Length(LAQ(m)) = LLength(m)"
apply (unfold Length_def)
apply (rule the_equality)
apply (rule INT_I)
apply (rule_tac [2] not_emptyI)
apply (erule_tac [2] LAQ_self)
apply (drule LAQ_D)
apply (drule LAlphaD1 [THEN LSkeltonEq_imp_LLength_eq])
apply blast
apply (drule INT_E)
apply (erule LAQ_self)
apply (erule singletonE)
apply assumption
done

lemma Length_type:
  "M: Term ==> Length(M): nat"
apply (erule TermE)
apply hypsubst
apply (simp only: Length_LAQ)
apply (erule LLength_type)
done

lemma Length_Var:
  "x: LVariable ==> Length(Var(x)) = 0"
apply (simp add: Term_LAQ Length_LAQ LLength_eqns)
done

lemma Length_Lam:
  "[| x: LVariable; M: Term |] ==>
        Length(Lam(x, M)) = succ(Length(M))"
apply (erule TermE)+
apply (simp add: Term_LAQ Length_LAQ LLength_eqns)
done

lemma Length_App:
  "[| M: Term; N: Term |] ==>
        Length(App(M, N)) = succ(Length(M) Un Length(N))"
apply (erule TermE)+
apply (simp add: Term_LAQ Length_LAQ LLength_eqns)
done

lemmas Length_eqns = Length_Var Length_Lam Length_App

lemma Length_induct:
  assumes major: "M: Term"
  and prem:
     "!!M. [| M: Term; ALL N: Term. Length(N) < Length(M) --> P(N) |]
           ==> P(M)"
  shows "P(M)"
apply (rule major [THEN rev_mp])
apply (rule_tac P="Length(M) = Length(M)" in rev_mp)
apply (rule_tac [2] P="%x. Length(M) = Length(x) --> x : Term --> P(x)" in major [THEN [2] bspec])
apply (rule_tac [2] P="%n. ALL M: Term. n = Length(M) --> M: Term --> P(M)" in
         major [THEN Length_type, THEN complete_induct0])
apply (rule refl)
apply safe
apply (erule prem)
apply safe
apply (erule bspec [THEN bspec, THEN mp, THEN mp])
apply (erule ltD)
apply (assumption | rule refl)+
done

lemma Term_induct2:
  assumes major: "M: Term"
  and prem1: "X: Fin(LVariable)"
  and
     "!! x . x: LVariable ==> P(Var(x))"
  and
     "!! x M . [| x: LVariable; x ~: X; M: Term; P(M) |]
          ==> P(Lam(x, M))"
  and
     "!! M N . [| M: Term; P(M); N: Term; P(N) |] ==> P(App(M, N))"
  shows "P(M)"
apply (rule major [THEN Length_induct])
apply (erule Term_cases)
apply safe
apply (rule_tac [2] prem1 [THEN [3] Infinite_LVariable_Alpha_lemma2,
          THEN bexE])
apply (erule_tac [2] asm_rl)+
apply (erule_tac [2] bexE conjE)+
apply (rotate_tac [1] 1)
apply (rotate_tac [2] 1)
apply (rotate_tac [3] 1)
prefer 2 apply simp
apply (simp_all add: Length_eqns)
apply (rule_tac [3] assms)
apply (rule_tac [2] assms)
apply (rule_tac [1] assms)
prefer 5
prefer 6
prefer 8
apply assumption+
apply (erule_tac [3] bspec [THEN mp])
apply (erule_tac [2] bspec [THEN mp])
apply (erule_tac [1] bspec [THEN mp])
apply (assumption | rule nat_into_Ord le_refl Length_type
         Un_upper1_le Un_upper2_le)+
done

lemmas Term_typechecks = Term_intros subst_type Length_type
lemmas Term_simps = Term_free_iffs Length_eqns subst_eqns FV_eqns

declare Term_typechecks [TC]
declare Term_simps [simp]

end