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

header {* Test cases *}

theory Native_Word_Test imports
  Uint32 Uint16 Uint8 Uint Native_Cast
  "~~/src/HOL/Library/Code_Test"
begin

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

context begin 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])"

end

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} *}

context begin 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])"
end

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} *}

context begin 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])"
end

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"} *}

context begin 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"
end

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 {* Tests for casts *}

definition test_casts :: bool
where "test_casts \<longleftrightarrow>
  map uint8_of_char [CHR ''a'', Char Nibble0 Nibble0, Char NibbleF NibbleF] = [97, 0, 255] \<and>
  map char_of_uint8 [65, 0, 255] = [CHR ''A'', Char Nibble0 Nibble0, Char NibbleF NibbleF] \<and>
  map uint8_of_uint32 [10, 0, 0xFE, 0xFFFFFFFF] = [10, 0, 0xFE, 0xFF] \<and>
  map uint32_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 uint32_of_uint16 [10, 0, 0xFFFF] = [10, 0, 0xFFFF]"

export_code test_casts checking SML Haskell? Scala
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
end
ML {* val true = @{code test_casts} *}

end


header "Graph Interface"
theory GraphSpec
imports Main Graph
  "../Collections/ICF/Collections"
  (*"../Collections/Lib/Proper_Iterator"*)
  (*"../Refine_Monadic/Refine_Autodet"*)
begin
  text {*
    This theory defines an ICF-style interface for graphs.
    *}

  type_synonym ('V,'W,'G) graph_\<alpha> = "'G \<Rightarrow> ('V,'W) graph"

  locale graph =
    fixes \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes invar :: "'G \<Rightarrow> bool"
    assumes finite[simp, intro!]:
      "invar g \<Longrightarrow> finite (nodes (\<alpha> g))"
      "invar g \<Longrightarrow> finite (edges (\<alpha> g))"
    assumes valid: "invar g \<Longrightarrow> valid_graph (\<alpha> g)"

  type_synonym ('V,'W,'G) graph_empty = "unit \<Rightarrow> 'G"
  locale graph_empty = graph +
    constrains \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes empty :: "unit \<Rightarrow> 'G"
    assumes empty_correct:
      "\<alpha> (empty ()) = Graph.empty"
      "invar (empty ())"

  type_synonym ('V,'W,'G) graph_add_node = "'V \<Rightarrow> 'G \<Rightarrow> 'G"
  locale graph_add_node = graph +
    constrains \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes add_node :: "'V \<Rightarrow> 'G \<Rightarrow> 'G"
    assumes add_node_correct:
      "invar g \<Longrightarrow> invar (add_node v g)"
      "invar g \<Longrightarrow> \<alpha> (add_node v g) = Graph.add_node v (\<alpha> g)"

  type_synonym ('V,'W,'G) graph_delete_node = "'V \<Rightarrow> 'G \<Rightarrow> 'G"
  locale graph_delete_node = graph +
    constrains \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes delete_node :: "'V \<Rightarrow> 'G \<Rightarrow> 'G"
    assumes delete_node_correct:
      "invar g \<Longrightarrow> invar (delete_node v g)"
      "invar g \<Longrightarrow> \<alpha> (delete_node v g) = Graph.delete_node v (\<alpha> g)"

  type_synonym ('V,'W,'G) graph_add_edge = "'V \<Rightarrow>'W \<Rightarrow> 'V \<Rightarrow> 'G \<Rightarrow> 'G"
  locale graph_add_edge = graph +
    constrains \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes add_edge :: "'V \<Rightarrow> 'W \<Rightarrow> 'V \<Rightarrow> 'G \<Rightarrow> 'G"
    assumes add_edge_correct:
      "invar g \<Longrightarrow> invar (add_edge v e v' g)"
      "invar g \<Longrightarrow> \<alpha> (add_edge v e v' g) = Graph.add_edge v e v' (\<alpha> g)"

  type_synonym ('V,'W,'G) graph_delete_edge = "'V \<Rightarrow>'W \<Rightarrow> 'V \<Rightarrow> 'G \<Rightarrow> 'G"
  locale graph_delete_edge = graph +
    constrains \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes delete_edge :: "'V \<Rightarrow> 'W \<Rightarrow> 'V \<Rightarrow> 'G \<Rightarrow> 'G"
    assumes delete_edge_correct:
      "invar g \<Longrightarrow> invar (delete_edge v e v' g)"
      "invar g \<Longrightarrow> \<alpha> (delete_edge v e v' g) = Graph.delete_edge v e v' (\<alpha> g)"

  type_synonym ('V,'W,'\<sigma>,'G) graph_nodes_it = "'G \<Rightarrow> ('V,'\<sigma>) set_iterator"

  locale graph_nodes_it_defs =
    fixes nodes_list_it :: "'G \<Rightarrow> ('V,'V list) set_iterator"
  begin
    definition "nodes_it g \<equiv> it_to_it (nodes_list_it g)"
  end

  locale graph_nodes_it = graph \<alpha> invar + graph_nodes_it_defs nodes_list_it
    for \<alpha> :: "'G \<Rightarrow> ('V,'W) graph" and invar and
    nodes_list_it :: "'G \<Rightarrow> ('V,'V list) set_iterator"
    +
    assumes nodes_list_it_correct:
      "invar g \<Longrightarrow> set_iterator (nodes_list_it g) (Graph.nodes (\<alpha> g))"
  begin
    lemma nodes_it_correct:
      "invar g \<Longrightarrow> set_iterator (nodes_it g) (Graph.nodes (\<alpha> g))"
      unfolding nodes_it_def
      apply (rule it_to_it_correct)
      by (rule nodes_list_it_correct)

    lemma pi_nodes_it[icf_proper_iteratorI]:
      "proper_it (nodes_it S) (nodes_it S)"
      unfolding nodes_it_def
      by (intro icf_proper_iteratorI)

    lemma nodes_it_proper[proper_it]:
      "proper_it' nodes_it nodes_it"
      apply (rule proper_it'I)
      by (rule pi_nodes_it)

  end

  type_synonym ('V,'W,'\<sigma>,'G) graph_edges_it
    = "'G \<Rightarrow> (('V\<times>'W\<times>'V),'\<sigma>) set_iterator"

  locale graph_edges_it_defs =
    fixes edges_list_it :: "('V,'W,('V\<times>'W\<times>'V) list,'G) graph_edges_it"
  begin
    definition "edges_it g \<equiv> it_to_it (edges_list_it g)"
  end

  locale graph_edges_it = graph \<alpha> invar + graph_edges_it_defs edges_list_it
    for \<alpha> :: "'G \<Rightarrow> ('V,'W) graph" and invar and
    edges_list_it :: "('V,'W,('V\<times>'W\<times>'V) list,'G) graph_edges_it"
    +
    assumes edges_list_it_correct:
      "invar g \<Longrightarrow> set_iterator (edges_list_it g) (Graph.edges (\<alpha> g))"
  begin
    lemma edges_it_correct:
      "invar g \<Longrightarrow> set_iterator (edges_it g) (Graph.edges (\<alpha> g))"
      unfolding edges_it_def
      apply (rule it_to_it_correct)
      by (rule edges_list_it_correct)

    lemma pi_edges_it[icf_proper_iteratorI]:
      "proper_it (edges_it S) (edges_it S)"
      unfolding edges_it_def
      by (intro icf_proper_iteratorI)

    lemma edges_it_proper[proper_it]:
      "proper_it' edges_it edges_it"
      apply (rule proper_it'I)
      by (rule pi_edges_it)

  end

  type_synonym ('V,'W,'\<sigma>,'G) graph_succ_it =
    "'G \<Rightarrow> 'V \<Rightarrow> ('W\<times>'V,'\<sigma>) set_iterator"

  locale graph_succ_it_defs =
    fixes succ_list_it :: "'G \<Rightarrow> 'V \<Rightarrow> ('W\<times>'V,('W\<times>'V) list) set_iterator"
  begin
    definition "succ_it g v \<equiv> it_to_it (succ_list_it g v)"
  end

  locale graph_succ_it = graph \<alpha> invar + graph_succ_it_defs succ_list_it
    for \<alpha> :: "'G \<Rightarrow> ('V,'W) graph" and invar and
    succ_list_it :: "'G \<Rightarrow> 'V \<Rightarrow> ('W\<times>'V,('W\<times>'V) list) set_iterator" +
    assumes succ_list_it_correct:
      "invar g \<Longrightarrow> set_iterator (succ_list_it g v) (Graph.succ (\<alpha> g) v)"
  begin
    lemma succ_it_correct:
      "invar g \<Longrightarrow> set_iterator (succ_it g v) (Graph.succ (\<alpha> g) v)"
      unfolding succ_it_def
      apply (rule it_to_it_correct)
      by (rule succ_list_it_correct)

    lemma pi_succ_it[icf_proper_iteratorI]:
      "proper_it (succ_it S v) (succ_it S v)"
      unfolding succ_it_def
      by (intro icf_proper_iteratorI)

    lemma succ_it_proper[proper_it]:
      "proper_it' (\<lambda>S. succ_it S v) (\<lambda>S. succ_it S v)"
      apply (rule proper_it'I)
      by (rule pi_succ_it)

  end

  subsection "Adjacency Lists"
  type_synonym ('V,'W) adj_list = "'V list \<times> ('V\<times>'W\<times>'V) list"

  definition adjl_\<alpha> :: "('V,'W) adj_list \<Rightarrow> ('V,'W) graph" where
    "adjl_\<alpha> l \<equiv> let (nl,el) = l in \<lparr>
      nodes = set nl \<union> fst`set el \<union> snd`snd`set el,
      edges = set el
    \<rparr>"

  (* TODO: Do we have naming conventions for such a lemma ? *)
  lemma adjl_is_graph: "graph adjl_\<alpha> (\<lambda>_. True)"
    apply (unfold_locales)
    unfolding adjl_\<alpha>_def
    by force+

  type_synonym ('V,'W,'G) graph_from_list = "('V,'W) adj_list \<Rightarrow> 'G"
  locale graph_from_list = graph +
    constrains \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes from_list :: "('V,'W) adj_list \<Rightarrow> 'G"
    assumes from_list_correct:
      "invar (from_list l)"
      "\<alpha> (from_list l) = adjl_\<alpha> l"

  type_synonym ('V,'W,'G) graph_to_list = "'G \<Rightarrow> ('V,'W) adj_list"
  locale graph_to_list = graph +
    constrains \<alpha> :: "'G \<Rightarrow> ('V,'W) graph"
    fixes to_list :: "'G \<Rightarrow> ('V,'W) adj_list"
    assumes to_list_correct:
      "invar g \<Longrightarrow> adjl_\<alpha> (to_list g) = \<alpha> g"

  subsection {* Record Based Interface *}
  record ('V,'W,'G) graph_ops =
    gop_\<alpha> :: "('V,'W,'G) graph_\<alpha>"
    gop_invar :: "'G \<Rightarrow> bool"
    gop_empty :: "('V,'W,'G) graph_empty"
    gop_add_node :: "('V,'W,'G) graph_add_node"
    gop_delete_node :: "('V,'W,'G) graph_delete_node"
    gop_add_edge :: "('V,'W,'G) graph_add_edge"
    gop_delete_edge :: "('V,'W,'G) graph_delete_edge"
    gop_from_list :: "('V,'W,'G) graph_from_list"
    gop_to_list :: "('V,'W,'G) graph_to_list"
    gop_nodes_list_it :: "'G \<Rightarrow> ('V,'V list) set_iterator"
    gop_edges_list_it :: "('V,'W,('V\<times>'W\<times>'V) list,'G) graph_edges_it"
    gop_succ_list_it :: "'G \<Rightarrow> 'V \<Rightarrow> ('W\<times>'V,('W\<times>'V) list) set_iterator"

  locale StdGraphDefs =
    graph_nodes_it_defs "gop_nodes_list_it ops"
    + graph_edges_it_defs "gop_edges_list_it ops"
    + graph_succ_it_defs "gop_succ_list_it ops"
    for ops :: "('V,'W,'G,'m) graph_ops_scheme"
  begin
    abbreviation \<alpha> where "\<alpha> \<equiv> gop_\<alpha> ops"
    abbreviation invar where "invar \<equiv> gop_invar ops"
    abbreviation empty where "empty \<equiv> gop_empty ops"
    abbreviation add_node where "add_node \<equiv> gop_add_node ops"
    abbreviation delete_node where "delete_node \<equiv> gop_delete_node ops"
    abbreviation add_edge where "add_edge \<equiv> gop_add_edge ops"
    abbreviation delete_edge where "delete_edge \<equiv> gop_delete_edge ops"
    abbreviation from_list where "from_list \<equiv> gop_from_list ops"
    abbreviation to_list where "to_list \<equiv> gop_to_list ops"
    abbreviation nodes_list_it where "nodes_list_it \<equiv> gop_nodes_list_it ops"
    abbreviation edges_list_it where "edges_list_it \<equiv> gop_edges_list_it ops"
    abbreviation succ_list_it  where "succ_list_it \<equiv> gop_succ_list_it ops"
  end

  locale StdGraph = StdGraphDefs +
    graph \<alpha> invar +
    graph_empty \<alpha> invar empty +
    graph_add_node \<alpha> invar add_node +
    graph_delete_node \<alpha> invar delete_node +
    graph_add_edge \<alpha> invar add_edge +
    graph_delete_edge \<alpha> invar delete_edge +
    graph_from_list \<alpha> invar from_list +
    graph_to_list \<alpha> invar to_list +
    graph_nodes_it \<alpha> invar nodes_list_it +
    graph_edges_it \<alpha> invar edges_list_it +
    graph_succ_it \<alpha> invar succ_list_it
  begin
    lemmas correct = empty_correct add_node_correct delete_node_correct
      add_edge_correct delete_edge_correct
      from_list_correct to_list_correct

  end

  subsection {* Refinement Framework Bindings *}
  lemma (in graph_nodes_it) nodes_it_is_iterator[refine_transfer]:
    "invar g \<Longrightarrow> set_iterator (nodes_it g) (nodes (\<alpha> g))"
    by (rule nodes_it_correct)

  lemma (in graph_edges_it) edges_it_is_iterator[refine_transfer]:
    "invar g \<Longrightarrow> set_iterator (edges_it g) (edges (\<alpha> g))"
    by (rule edges_it_correct)

  lemma (in graph_succ_it) succ_it_is_iterator[refine_transfer]:
    "invar g \<Longrightarrow> set_iterator (succ_it g v) (Graph.succ (\<alpha> g) v)"
    by (rule succ_it_correct)

  lemma (in graph) drh[refine_dref_RELATES]: "RELATES (build_rel \<alpha> invar)"
    by (simp add: RELATES_def)

  (*text {* Autodet bindings: *}

  lemma (in graph_nodes_it) graph_nodes_it_t[trans_uc]:
    "DETREFe g (build_rel \<alpha> invar) g' \<Longrightarrow>
      set_iterator (nodes_it g) (nodes g')"
    using nodes_it_correct by auto

  lemma (in graph_succ_it) graph_succ_it_t[trans_uc]:
    "DETREFe g (build_rel \<alpha> invar) g' \<Longrightarrow> DETREFe v Id v' \<Longrightarrow>
      set_iterator (succ_it g v) (succ g' v')"
    using succ_it_correct by auto

  lemma (in graph_edges_it) graph_edges_it_t[trans_uc]:
    "DETREFe g (build_rel \<alpha> invar) g' \<Longrightarrow>
      set_iterator (edges_it g) (edges g')"
    using edges_it_correct by auto*)

end


section \<open>Implementing Automata\<close>
(* Author: Peter Lammich *)
theory Automata_Impl
imports Digraph_Impl Automata
begin

subsection \<open>Indexed Generalized Buchi Graphs\<close>

consts
  i_igbg_eext :: "interface \<Rightarrow> interface \<Rightarrow> interface"

abbreviation "i_igbg Ie Iv \<equiv> \<langle>\<langle>Ie,Iv\<rangle>\<^sub>ii_igbg_eext,Iv\<rangle>\<^sub>ii_g_ext"

context begin interpretation autoref_syn .

lemma igbg_type[autoref_itype]:
  "igbg_num_acc ::\<^sub>i i_igbg Ie Iv \<rightarrow>\<^sub>i i_nat"
  "igbg_acc ::\<^sub>i i_igbg Ie Iv \<rightarrow>\<^sub>i Iv \<rightarrow>\<^sub>i \<langle>i_nat\<rangle>\<^sub>ii_set"
  "igb_graph_rec_ext
    ::\<^sub>i i_nat \<rightarrow>\<^sub>i (Iv \<rightarrow>\<^sub>i \<langle>i_nat\<rangle>\<^sub>ii_set) \<rightarrow>\<^sub>i Ie \<rightarrow>\<^sub>i \<langle>Ie,Iv\<rangle>\<^sub>ii_igbg_eext"
  by simp_all
end

record ('vi,'ei,'v0i,'acci) gen_igbg_impl = "('vi,'ei,'v0i) gen_g_impl" +
  igbgi_num_acc :: nat
  igbgi_acc :: 'acci

definition gen_igbg_impl_rel_eext_def_internal:
  "gen_igbg_impl_rel_eext Rm Racc \<equiv> { (
  \<lparr> igbgi_num_acc = num_acci, igbgi_acc = acci, \<dots>=mi \<rparr>,
  \<lparr> igbg_num_acc = num_acc, igbg_acc = acc, \<dots>=m \<rparr>)
  | num_acci acci mi num_acc acc m.
    (num_acci,num_acc)\<in>nat_rel
  \<and> (acci,acc)\<in>Racc
  \<and> (mi,m)\<in>Rm
  }"

lemma gen_igbg_impl_rel_eext_def:
  "\<langle>Rm,Racc\<rangle>gen_igbg_impl_rel_eext = { (
  \<lparr> igbgi_num_acc = num_acci, igbgi_acc = acci, \<dots>=mi \<rparr>,
  \<lparr> igbg_num_acc = num_acc, igbg_acc = acc, \<dots>=m \<rparr>)
  | num_acci acci mi num_acc acc m.
    (num_acci,num_acc)\<in>nat_rel
  \<and> (acci,acc)\<in>Racc
  \<and> (mi,m)\<in>Rm
  }"
  unfolding gen_igbg_impl_rel_eext_def_internal relAPP_def by simp

lemma gen_igbg_impl_rel_sv[relator_props]:
  "\<lbrakk>single_valued Racc; single_valued Rm\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Racc\<rangle>gen_igbg_impl_rel_eext)"
  unfolding gen_igbg_impl_rel_eext_def
  apply (rule single_valuedI)
  apply (clarsimp)
  apply (intro conjI)
  apply (rule single_valuedD[rotated], assumption+)
  apply (rule single_valuedD[rotated], assumption+)
  done

abbreviation gen_igbg_impl_rel_ext
  :: "_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> (_\<times>(_,_)igb_graph_rec_scheme) set"
  where "gen_igbg_impl_rel_ext Rm Racc
  \<equiv> \<langle>\<langle>Rm,Racc\<rangle>gen_igbg_impl_rel_eext\<rangle>gen_g_impl_rel_ext "

lemma gen_igbg_refine:
  fixes Rv Re Rv0 Racc
  assumes "TERM (Rv,Re,Rv0)"
  assumes "TERM (Racc)"
  shows
  "(igbgi_num_acc,igbg_num_acc)
    \<in> \<langle>Rv,Re,Rv0\<rangle>gen_igbg_impl_rel_ext Rm Racc \<rightarrow> nat_rel"
  "(igbgi_acc,igbg_acc)
    \<in> \<langle>Rv,Re,Rv0\<rangle>gen_igbg_impl_rel_ext Rm Racc \<rightarrow> Racc"
  "(gen_igbg_impl_ext, igb_graph_rec_ext)
    \<in> nat_rel \<rightarrow> Racc \<rightarrow> Rm \<rightarrow> \<langle>Rm,Racc\<rangle>gen_igbg_impl_rel_eext"
  unfolding gen_igbg_impl_rel_eext_def gen_g_impl_rel_ext_def
  by auto

subsubsection \<open>Implementation with bit-set\<close>

definition igbg_impl_rel_eext_internal_def:
  "igbg_impl_rel_eext Rm Rv \<equiv> \<langle>Rm, Rv \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel\<rangle>gen_igbg_impl_rel_eext"

lemma igbg_impl_rel_eext_def:
  "\<langle>Rm,Rv\<rangle>igbg_impl_rel_eext \<equiv> \<langle>Rm, Rv \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel\<rangle>gen_igbg_impl_rel_eext"
  unfolding igbg_impl_rel_eext_internal_def relAPP_def by simp

lemmas [autoref_rel_intf] = REL_INTFI[of igbg_impl_rel_eext i_igbg_eext]

lemma [relator_props, simp]:
  "\<lbrakk>Range Rv = UNIV; single_valued Rm\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rv\<rangle>igbg_impl_rel_eext)"
  unfolding igbg_impl_rel_eext_def by tagged_solver

lemma g_tag: "TERM (\<langle>Rv\<rangle>fun_set_rel,\<langle>Rv\<rangle>slg_rel,\<langle>Rv\<rangle>list_set_rel)" .
lemma frgv_tag: "TERM (\<langle>Rv\<rangle>list_set_rel,\<langle>Rv\<rangle>slg_rel,\<langle>Rv\<rangle>list_set_rel)" .
lemma igbg_bs_tag: "TERM (Rv \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel)" .

abbreviation "igbgv_impl_rel_ext Rm Rv
  \<equiv> \<langle>\<langle>Rm, Rv\<rangle>igbg_impl_rel_eext, Rv\<rangle>frgv_impl_rel_ext"

abbreviation "igbg_impl_rel_ext Rm Rv
  \<equiv> \<langle>\<langle>Rm, Rv\<rangle>igbg_impl_rel_eext, Rv\<rangle>g_impl_rel_ext"

type_synonym ('v,'m) igbgv_impl_scheme =
  "('v, \<lparr> igbgi_num_acc::nat, igbgi_acc::'v\<Rightarrow>integer, \<dots>::'m  \<rparr>)
    frgv_impl_scheme"
type_synonym ('v,'m) igbg_impl_scheme =
  "('v, \<lparr> igbgi_num_acc::nat, igbgi_acc::'v\<Rightarrow>integer, \<dots>::'m  \<rparr>)
    g_impl_scheme"

context fixes Rv :: "('vi\<times>'v) set" begin
lemmas [autoref_rules] = gen_igbg_refine[
  OF frgv_tag[of Rv] igbg_bs_tag[of Rv],
  folded frgv_impl_rel_ext_def igbg_impl_rel_eext_def]

lemmas [autoref_rules] = gen_igbg_refine[
  OF g_tag[of Rv] igbg_bs_tag[of Rv],
  folded g_impl_rel_ext_def igbg_impl_rel_eext_def]
end

schematic_goal "(?c::?'c,
    \<lambda>G x. if igbg_num_acc G = 0 \<and> 1\<in>igbg_acc G x then (g_E G `` {x}) else {}
  )\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal "(?c,
  \<lambda>V0 E num_acc acc.
    \<lparr> g_V = UNIV, g_E = E, g_V0 = V0, igbg_num_acc = num_acc, igbg_acc = acc \<rparr>
  )\<in>\<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>slg_rel \<rightarrow> nat_rel \<rightarrow> (R \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel)
    \<rightarrow> igbg_impl_rel_ext unit_rel R"
  apply (autoref (keep_goal))
  done

schematic_goal "(?c,
  \<lambda>V0 E num_acc acc.
    \<lparr> g_V = {}, g_E = E, g_V0 = V0, igbg_num_acc = num_acc, igbg_acc = acc \<rparr>
  )\<in>\<langle>R\<rangle>list_set_rel \<rightarrow> \<langle>R\<rangle>slg_rel \<rightarrow> nat_rel \<rightarrow> (R \<rightarrow> \<langle>nat_rel\<rangle>bs_set_rel)
    \<rightarrow> igbgv_impl_rel_ext unit_rel R"
  apply (autoref (keep_goal))
  done

subsection \<open>Indexed Generalized Buchi Automata\<close>

consts
  i_igba_eext :: "interface \<Rightarrow> interface \<Rightarrow> interface \<Rightarrow> interface"

abbreviation "i_igba Ie Iv Il
  \<equiv> \<langle>\<langle>\<langle>Ie,Iv,Il\<rangle>\<^sub>ii_igba_eext,Iv\<rangle>\<^sub>ii_igbg_eext,Iv\<rangle>\<^sub>ii_g_ext"
context begin interpretation autoref_syn .

lemma igba_type[autoref_itype]:
  "igba_L ::\<^sub>i i_igba Ie Iv Il \<rightarrow>\<^sub>i (Iv \<rightarrow>\<^sub>i Il \<rightarrow>\<^sub>i i_bool)"
  "igba_rec_ext ::\<^sub>i (Iv \<rightarrow>\<^sub>i Il \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i Ie \<rightarrow>\<^sub>i \<langle>Ie,Iv,Il\<rangle>\<^sub>ii_igba_eext"
  by simp_all
end

record ('vi,'ei,'v0i,'acci,'Li) gen_igba_impl =
  "('vi,'ei,'v0i,'acci)gen_igbg_impl" +
  igbai_L :: "'Li"

definition gen_igba_impl_rel_eext_def_internal:
  "gen_igba_impl_rel_eext Rm Rl  \<equiv> { (
  \<lparr> igbai_L = Li, \<dots>=mi \<rparr>,
  \<lparr> igba_L = L, \<dots>=m \<rparr>)
  | Li mi L m.
    (Li,L)\<in>Rl
  \<and> (mi,m)\<in>Rm
  }"

lemma gen_igba_impl_rel_eext_def:
  "\<langle>Rm,Rl\<rangle>gen_igba_impl_rel_eext = { (
  \<lparr> igbai_L = Li, \<dots>=mi \<rparr>,
  \<lparr> igba_L = L, \<dots>=m \<rparr>)
  | Li mi L m.
    (Li,L)\<in>Rl
  \<and> (mi,m)\<in>Rm
  }"
  unfolding gen_igba_impl_rel_eext_def_internal relAPP_def by simp

lemma gen_igba_impl_rel_sv[relator_props]:
  "\<lbrakk>single_valued Rl; single_valued Rm\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rl\<rangle>gen_igba_impl_rel_eext)"
  unfolding gen_igba_impl_rel_eext_def
  apply (rule single_valuedI)
  apply (clarsimp)
  apply (intro conjI)
  apply (rule single_valuedD[rotated], assumption+)
  apply (rule single_valuedD[rotated], assumption+)
  done

abbreviation gen_igba_impl_rel_ext
  :: "_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> (_ \<times> ('a,'b,'c) igba_rec_scheme) set"
  where "gen_igba_impl_rel_ext Rm Rl
    \<equiv> gen_igbg_impl_rel_ext (\<langle>Rm,Rl\<rangle>gen_igba_impl_rel_eext)"

lemma gen_igba_refine:
  fixes Rv Re Rv0 Racc Rl
  assumes "TERM (Rv,Re,Rv0)"
  assumes "TERM (Racc)"
  assumes "TERM (Rl)"
  shows
  "(igbai_L,igba_L)
    \<in> \<langle>Rv,Re,Rv0\<rangle>gen_igba_impl_rel_ext Rm Rl Racc \<rightarrow> Rl"
  "(gen_igba_impl_ext, igba_rec_ext)
    \<in> Rl \<rightarrow> Rm \<rightarrow> \<langle>Rm,Rl\<rangle>gen_igba_impl_rel_eext"
  unfolding gen_igba_impl_rel_eext_def gen_igbg_impl_rel_eext_def
    gen_g_impl_rel_ext_def
  by auto

subsubsection \<open>Implementation as function\<close>
definition igba_impl_rel_eext_internal_def:
  "igba_impl_rel_eext Rm Rv Rl \<equiv> \<langle>Rm, Rv \<rightarrow> Rl \<rightarrow> bool_rel\<rangle>gen_igba_impl_rel_eext"

lemma igba_impl_rel_eext_def:
  "\<langle>Rm,Rv,Rl\<rangle>igba_impl_rel_eext \<equiv> \<langle>Rm, Rv \<rightarrow> Rl \<rightarrow> bool_rel\<rangle>gen_igba_impl_rel_eext"
  unfolding igba_impl_rel_eext_internal_def relAPP_def by simp

lemmas [autoref_rel_intf] = REL_INTFI[of igba_impl_rel_eext i_igba_eext]

lemma [relator_props, simp]:
  "\<lbrakk>Range Rv = UNIV; single_valued Rm; Range Rl = UNIV\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rv,Rl\<rangle>igba_impl_rel_eext)"
  unfolding igba_impl_rel_eext_def by tagged_solver

lemma igba_f_tag: "TERM (Rv \<rightarrow> Rl \<rightarrow> bool_rel)" .

abbreviation "igbav_impl_rel_ext Rm Rv Rl
  \<equiv> igbgv_impl_rel_ext (\<langle>Rm, Rv, Rl\<rangle>igba_impl_rel_eext) Rv"

abbreviation "igba_impl_rel_ext Rm Rv Rl
  \<equiv> igbg_impl_rel_ext (\<langle>Rm, Rv, Rl\<rangle>igba_impl_rel_eext) Rv"

type_synonym ('v,'l,'m) igbav_impl_scheme =
  "('v, \<lparr> igbai_L :: 'v \<Rightarrow> 'l \<Rightarrow> bool , \<dots>::'m  \<rparr>)
    igbgv_impl_scheme"

type_synonym ('v,'l,'m) igba_impl_scheme =
  "('v, \<lparr> igbai_L :: 'v \<Rightarrow> 'l \<Rightarrow> bool , \<dots>::'m  \<rparr>)
    igbg_impl_scheme"

context
  fixes Rv :: "('vi\<times>'v) set"
  fixes Rl :: "('Li\<times>'l) set"
begin
lemmas [autoref_rules] = gen_igba_refine[
  OF frgv_tag[of Rv] igbg_bs_tag[of Rv] igba_f_tag[of Rv Rl],
  folded frgv_impl_rel_ext_def igbg_impl_rel_eext_def igba_impl_rel_eext_def]

lemmas [autoref_rules] = gen_igba_refine[
  OF g_tag[of Rv] igbg_bs_tag[of Rv] igba_f_tag[of Rv Rl],
  folded g_impl_rel_ext_def igbg_impl_rel_eext_def igba_impl_rel_eext_def]
end

thm autoref_itype

schematic_goal
  "(?c::?'c, \<lambda>G x l. if igba_L G x l then (g_E G `` {x}) else {} )\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  notes [autoref_tyrel] = TYRELI[of "Id :: ('a\<times>'a) set"]
  shows "(?c::?'c, \<lambda>E (V0::'a set) num_acc acc L.
  \<lparr> g_V = UNIV, g_E = E, g_V0 = V0,
    igbg_num_acc = num_acc, igbg_acc = acc, igba_L = L \<rparr>
  )\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  notes [autoref_tyrel] = TYRELI[of "Id :: ('a\<times>'a) set"]
  shows "(?c::?'c, \<lambda>E (V0::'a set) num_acc acc L.
  \<lparr> g_V = V0, g_E = E, g_V0 = V0,
    igbg_num_acc = num_acc, igbg_acc = acc, igba_L = L \<rparr>
  )\<in>?R"
  apply (autoref (keep_goal))
  done

subsection \<open>Generalized Buchi Graphs\<close>

consts
  i_gbg_eext :: "interface \<Rightarrow> interface \<Rightarrow> interface"

abbreviation "i_gbg Ie Iv \<equiv> \<langle>\<langle>Ie,Iv\<rangle>\<^sub>ii_gbg_eext,Iv\<rangle>\<^sub>ii_g_ext"

context begin interpretation autoref_syn .

lemma gbg_type[autoref_itype]:
  "gbg_F ::\<^sub>i i_gbg Ie Iv \<rightarrow>\<^sub>i \<langle>\<langle>Iv\<rangle>\<^sub>ii_set\<rangle>\<^sub>ii_set"
  "gb_graph_rec_ext ::\<^sub>i \<langle>\<langle>Iv\<rangle>\<^sub>ii_set\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i Ie \<rightarrow>\<^sub>i \<langle>Ie,Iv\<rangle>\<^sub>ii_gbg_eext"
  by simp_all
end

record ('vi,'ei,'v0i,'fi) gen_gbg_impl = "('vi,'ei,'v0i) gen_g_impl" +
  gbgi_F :: 'fi

definition gen_gbg_impl_rel_eext_def_internal:
  "gen_gbg_impl_rel_eext Rm Rf \<equiv> { (
  \<lparr> gbgi_F = Fi, \<dots>=mi \<rparr>,
  \<lparr> gbg_F = F, \<dots>=m \<rparr>)
  | Fi mi F m.
    (Fi,F)\<in>Rf
  \<and> (mi,m)\<in>Rm
  }"

lemma gen_gbg_impl_rel_eext_def:
  "\<langle>Rm,Rf\<rangle>gen_gbg_impl_rel_eext = { (
  \<lparr> gbgi_F = Fi, \<dots>=mi \<rparr>,
  \<lparr> gbg_F = F, \<dots>=m \<rparr>)
  | Fi mi F m.
    (Fi,F)\<in>Rf
  \<and> (mi,m)\<in>Rm
  }"
  unfolding gen_gbg_impl_rel_eext_def_internal relAPP_def by simp

lemma gen_gbg_impl_rel_sv[relator_props]:
  "\<lbrakk>single_valued Rm; single_valued Rf\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rf\<rangle>gen_gbg_impl_rel_eext)"
  unfolding gen_gbg_impl_rel_eext_def
  apply (rule single_valuedI)
  apply (clarsimp)
  apply (intro conjI)
  apply (rule single_valuedD[rotated], assumption+)
  apply (rule single_valuedD[rotated], assumption+)
  done

abbreviation gen_gbg_impl_rel_ext
  :: "_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> (_ \<times> ('q,_) gb_graph_rec_scheme) set"
  where "gen_gbg_impl_rel_ext Rm Rf
  \<equiv> \<langle>\<langle>Rm,Rf\<rangle>gen_gbg_impl_rel_eext\<rangle>gen_g_impl_rel_ext"

lemma gen_gbg_refine:
  fixes Rv Re Rv0 Rf
  assumes "TERM (Rv,Re,Rv0)"
  assumes "TERM (Rf)"
  shows
  "(gbgi_F,gbg_F)
    \<in> \<langle>Rv,Re,Rv0\<rangle>gen_gbg_impl_rel_ext Rm Rf \<rightarrow> Rf"
  "(gen_gbg_impl_ext, gb_graph_rec_ext)
    \<in> Rf \<rightarrow> Rm \<rightarrow> \<langle>Rm,Rf\<rangle>gen_gbg_impl_rel_eext"
  unfolding gen_gbg_impl_rel_eext_def gen_g_impl_rel_ext_def
  by auto

subsubsection \<open>Implementation with list of lists\<close>

definition gbg_impl_rel_eext_internal_def:
  "gbg_impl_rel_eext Rm Rv
  \<equiv> \<langle>Rm, \<langle>\<langle>Rv\<rangle>list_set_rel\<rangle>list_set_rel\<rangle>gen_gbg_impl_rel_eext"

lemma gbg_impl_rel_eext_def:
  "\<langle>Rm,Rv\<rangle>gbg_impl_rel_eext
    \<equiv> \<langle>Rm, \<langle>\<langle>Rv\<rangle>list_set_rel\<rangle>list_set_rel\<rangle>gen_gbg_impl_rel_eext"
  unfolding gbg_impl_rel_eext_internal_def relAPP_def by simp

lemmas [autoref_rel_intf] = REL_INTFI[of gbg_impl_rel_eext i_gbg_eext]

lemma [relator_props, simp]:
  "\<lbrakk>single_valued Rm; single_valued Rv\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rv\<rangle>gbg_impl_rel_eext)"
  unfolding gbg_impl_rel_eext_def by tagged_solver

lemma gbg_ls_tag: "TERM (\<langle>\<langle>Rv\<rangle>list_set_rel\<rangle>list_set_rel)" .

abbreviation "gbgv_impl_rel_ext Rm Rv
  \<equiv> \<langle>\<langle>Rm, Rv\<rangle>gbg_impl_rel_eext, Rv\<rangle>frgv_impl_rel_ext"

abbreviation "gbg_impl_rel_ext Rm Rv
  \<equiv> \<langle>\<langle>Rm, Rv\<rangle>gbg_impl_rel_eext, Rv\<rangle>g_impl_rel_ext"

context fixes Rv :: "('vi\<times>'v) set" begin
lemmas [autoref_rules] = gen_gbg_refine[
  OF frgv_tag[of Rv] gbg_ls_tag[of Rv],
  folded frgv_impl_rel_ext_def gbg_impl_rel_eext_def]

lemmas [autoref_rules] = gen_gbg_refine[
  OF g_tag[of Rv] gbg_ls_tag[of Rv],
  folded g_impl_rel_ext_def gbg_impl_rel_eext_def]
end

schematic_goal "(?c::?'c,
    \<lambda>G x. if gbg_F G = {} then (g_E G `` {x}) else {}
  )\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  notes [autoref_tyrel] = TYRELI[of "Id :: ('a\<times>'a) set"]
  shows "(?c::?'c, \<lambda>E (V0::'a set) F.
    \<lparr> g_V = {}, g_E = E, g_V0 = V0, gbg_F = F \<rparr>)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  notes [autoref_tyrel] = TYRELI[of "Id :: ('a\<times>'a) set"]
  shows "(?c::?'c, \<lambda>E (V0::'a set) F.
    \<lparr> g_V = UNIV, g_E = E, g_V0 = V0, gbg_F = insert {} F \<rparr>)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal "(?c::?'c, it_to_sorted_list (\<lambda>_ _. True) {1,2::nat} )\<in>?R"
  apply (autoref (keep_goal))
  done

subsection \<open>GBAs\<close>

consts
  i_gba_eext :: "interface \<Rightarrow> interface \<Rightarrow> interface \<Rightarrow> interface"

abbreviation "i_gba Ie Iv Il
  \<equiv> \<langle>\<langle>\<langle>Ie,Iv,Il\<rangle>\<^sub>ii_gba_eext,Iv\<rangle>\<^sub>ii_gbg_eext,Iv\<rangle>\<^sub>ii_g_ext"
context begin interpretation autoref_syn .

lemma gba_type[autoref_itype]:
  "gba_L ::\<^sub>i i_gba Ie Iv Il \<rightarrow>\<^sub>i (Iv \<rightarrow>\<^sub>i Il \<rightarrow>\<^sub>i i_bool)"
  "gba_rec_ext ::\<^sub>i (Iv \<rightarrow>\<^sub>i Il \<rightarrow>\<^sub>i i_bool) \<rightarrow>\<^sub>i Ie \<rightarrow>\<^sub>i \<langle>Ie,Iv,Il\<rangle>\<^sub>ii_gba_eext"
  by simp_all
end

record ('vi,'ei,'v0i,'acci,'Li) gen_gba_impl =
  "('vi,'ei,'v0i,'acci)gen_gbg_impl" +
  gbai_L :: "'Li"

definition gen_gba_impl_rel_eext_def_internal:
  "gen_gba_impl_rel_eext Rm Rl  \<equiv> { (
  \<lparr> gbai_L = Li, \<dots>=mi \<rparr>,
  \<lparr> gba_L = L, \<dots>=m \<rparr>)
  | Li mi L m.
    (Li,L)\<in>Rl
  \<and> (mi,m)\<in>Rm
  }"

lemma gen_gba_impl_rel_eext_def:
  "\<langle>Rm,Rl\<rangle>gen_gba_impl_rel_eext = { (
  \<lparr> gbai_L = Li, \<dots>=mi \<rparr>,
  \<lparr> gba_L = L, \<dots>=m \<rparr>)
  | Li mi L m.
    (Li,L)\<in>Rl
  \<and> (mi,m)\<in>Rm
  }"
  unfolding gen_gba_impl_rel_eext_def_internal relAPP_def by simp

lemma gen_gba_impl_rel_sv[relator_props]:
  "\<lbrakk>single_valued Rl; single_valued Rm\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rl\<rangle>gen_gba_impl_rel_eext)"
  unfolding gen_gba_impl_rel_eext_def
  apply (rule single_valuedI)
  apply (clarsimp)
  apply (intro conjI)
  apply (rule single_valuedD[rotated], assumption+)
  apply (rule single_valuedD[rotated], assumption+)
  done

abbreviation gen_gba_impl_rel_ext
  :: "_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> (_ \<times> ('a,'b,'c) gba_rec_scheme) set"
  where "gen_gba_impl_rel_ext Rm Rl
    \<equiv> gen_gbg_impl_rel_ext (\<langle>Rm,Rl\<rangle>gen_gba_impl_rel_eext)"

lemma gen_gba_refine:
  fixes Rv Re Rv0 Racc Rl
  assumes "TERM (Rv,Re,Rv0)"
  assumes "TERM (Racc)"
  assumes "TERM (Rl)"
  shows
  "(gbai_L,gba_L)
    \<in> \<langle>Rv,Re,Rv0\<rangle>gen_gba_impl_rel_ext Rm Rl Racc \<rightarrow> Rl"
  "(gen_gba_impl_ext, gba_rec_ext)
    \<in> Rl \<rightarrow> Rm \<rightarrow> \<langle>Rm,Rl\<rangle>gen_gba_impl_rel_eext"
  unfolding gen_gba_impl_rel_eext_def gen_gbg_impl_rel_eext_def
    gen_g_impl_rel_ext_def
  by auto

subsubsection \<open>Implementation as function\<close>
definition gba_impl_rel_eext_internal_def:
  "gba_impl_rel_eext Rm Rv Rl \<equiv> \<langle>Rm, Rv \<rightarrow> Rl \<rightarrow> bool_rel\<rangle>gen_gba_impl_rel_eext"

lemma gba_impl_rel_eext_def:
  "\<langle>Rm,Rv,Rl\<rangle>gba_impl_rel_eext \<equiv> \<langle>Rm, Rv \<rightarrow> Rl \<rightarrow> bool_rel\<rangle>gen_gba_impl_rel_eext"
  unfolding gba_impl_rel_eext_internal_def relAPP_def by simp

lemmas [autoref_rel_intf] = REL_INTFI[of gba_impl_rel_eext i_gba_eext]

lemma [relator_props, simp]:
  "\<lbrakk>Range Rv = UNIV; single_valued Rm; Range Rl = UNIV\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rv,Rl\<rangle>gba_impl_rel_eext)"
  unfolding gba_impl_rel_eext_def by tagged_solver

lemma gba_f_tag: "TERM (Rv \<rightarrow> Rl \<rightarrow> bool_rel)" .

abbreviation "gbav_impl_rel_ext Rm Rv Rl
  \<equiv> gbgv_impl_rel_ext (\<langle>Rm, Rv, Rl\<rangle>gba_impl_rel_eext) Rv"

abbreviation "gba_impl_rel_ext Rm Rv Rl
  \<equiv> gbg_impl_rel_ext (\<langle>Rm, Rv, Rl\<rangle>gba_impl_rel_eext) Rv"

context
  fixes Rv :: "('vi\<times>'v) set"
  fixes Rl :: "('Li\<times>'l) set"
begin
lemmas [autoref_rules] = gen_gba_refine[
  OF frgv_tag[of Rv] gbg_ls_tag[of Rv] gba_f_tag[of Rv Rl],
  folded frgv_impl_rel_ext_def gbg_impl_rel_eext_def gba_impl_rel_eext_def]

lemmas [autoref_rules] = gen_gba_refine[
  OF g_tag[of Rv] gbg_ls_tag[of Rv] gba_f_tag[of Rv Rl],
  folded g_impl_rel_ext_def gbg_impl_rel_eext_def gba_impl_rel_eext_def]
end

thm autoref_itype

schematic_goal
  "(?c::?'c, \<lambda>G x l. if gba_L G x l then (g_E G `` {x}) else {} )\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  notes [autoref_tyrel] = TYRELI[of "Id :: ('a\<times>'a) set"]
  shows "(?c::?'c, \<lambda>E (V0::'a set) F L.
  \<lparr> g_V = UNIV, g_E = E, g_V0 = V0,
    gbg_F = F, gba_L = L \<rparr>
  )\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  notes [autoref_tyrel] = TYRELI[of "Id :: ('a\<times>'a) set"]
  shows "(?c::?'c, \<lambda>E (V0::'a set) F L.
  \<lparr> g_V = V0, g_E = E, g_V0 = V0,
    gbg_F = F, gba_L = L \<rparr>
  )\<in>?R"
  apply (autoref (keep_goal))
  done

subsection \<open>Buchi Graphs\<close>

consts
  i_bg_eext :: "interface \<Rightarrow> interface \<Rightarrow> interface"

abbreviation "i_bg Ie Iv \<equiv> \<langle>\<langle>Ie,Iv\<rangle>\<^sub>ii_bg_eext,Iv\<rangle>\<^sub>ii_g_ext"

context begin interpretation autoref_syn .
lemma bg_type[autoref_itype]:
  "bg_F ::\<^sub>i i_bg Ie Iv \<rightarrow>\<^sub>i \<langle>Iv\<rangle>\<^sub>ii_set"
  "gb_graph_rec_ext ::\<^sub>i \<langle>\<langle>Iv\<rangle>\<^sub>ii_set\<rangle>\<^sub>ii_set \<rightarrow>\<^sub>i Ie \<rightarrow>\<^sub>i \<langle>Ie,Iv\<rangle>\<^sub>ii_bg_eext"
  by simp_all
end

record ('vi,'ei,'v0i,'fi) gen_bg_impl = "('vi,'ei,'v0i) gen_g_impl" +
  bgi_F :: 'fi

definition gen_bg_impl_rel_eext_def_internal:
  "gen_bg_impl_rel_eext Rm Rf \<equiv> { (
  \<lparr> bgi_F = Fi, \<dots>=mi \<rparr>,
  \<lparr> bg_F = F, \<dots>=m \<rparr>)
  | Fi mi F m.
    (Fi,F)\<in>Rf
  \<and> (mi,m)\<in>Rm
  }"

lemma gen_bg_impl_rel_eext_def:
  "\<langle>Rm,Rf\<rangle>gen_bg_impl_rel_eext = { (
  \<lparr> bgi_F = Fi, \<dots>=mi \<rparr>,
  \<lparr> bg_F = F, \<dots>=m \<rparr>)
  | Fi mi F m.
    (Fi,F)\<in>Rf
  \<and> (mi,m)\<in>Rm
  }"
  unfolding gen_bg_impl_rel_eext_def_internal relAPP_def by simp

lemma gen_bg_impl_rel_sv[relator_props]:
  "\<lbrakk>single_valued Rm; single_valued Rf\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rf\<rangle>gen_bg_impl_rel_eext)"
  unfolding gen_bg_impl_rel_eext_def
  apply (rule single_valuedI)
  apply (clarsimp)
  apply (intro conjI)
  apply (rule single_valuedD[rotated], assumption+)
  apply (rule single_valuedD[rotated], assumption+)
  done

abbreviation gen_bg_impl_rel_ext
  :: "_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> (_ \<times> ('q,_) b_graph_rec_scheme) set"
  where "gen_bg_impl_rel_ext Rm Rf
  \<equiv> \<langle>\<langle>Rm,Rf\<rangle>gen_bg_impl_rel_eext\<rangle>gen_g_impl_rel_ext"

lemma gen_bg_refine:
  fixes Rv Re Rv0 Rf
  assumes "TERM (Rv,Re,Rv0)"
  assumes "TERM (Rf)"
  shows
  "(bgi_F,bg_F)
    \<in> \<langle>Rv,Re,Rv0\<rangle>gen_bg_impl_rel_ext Rm Rf \<rightarrow> Rf"
  "(gen_bg_impl_ext, b_graph_rec_ext)
    \<in> Rf \<rightarrow> Rm \<rightarrow> \<langle>Rm,Rf\<rangle>gen_bg_impl_rel_eext"
  unfolding gen_bg_impl_rel_eext_def gen_g_impl_rel_ext_def
  by auto

subsubsection \<open>Implementation with Characteristic Functions\<close>

definition bg_impl_rel_eext_internal_def:
  "bg_impl_rel_eext Rm Rv
  \<equiv> \<langle>Rm, \<langle>Rv\<rangle>fun_set_rel\<rangle>gen_bg_impl_rel_eext"

lemma bg_impl_rel_eext_def:
  "\<langle>Rm,Rv\<rangle>bg_impl_rel_eext
    \<equiv> \<langle>Rm, \<langle>Rv\<rangle>fun_set_rel\<rangle>gen_bg_impl_rel_eext"
  unfolding bg_impl_rel_eext_internal_def relAPP_def by simp

lemmas [autoref_rel_intf] = REL_INTFI[of bg_impl_rel_eext i_bg_eext]

lemma [relator_props, simp]:
  "\<lbrakk>single_valued Rm; single_valued Rv; Range Rv = UNIV\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rv\<rangle>bg_impl_rel_eext)"
  unfolding bg_impl_rel_eext_def by tagged_solver

lemma bg_fs_tag: "TERM (\<langle>Rv\<rangle>fun_set_rel)" .

abbreviation "bgv_impl_rel_ext Rm Rv
  \<equiv> \<langle>\<langle>Rm, Rv\<rangle>bg_impl_rel_eext, Rv\<rangle>frgv_impl_rel_ext"

abbreviation "bg_impl_rel_ext Rm Rv
  \<equiv> \<langle>\<langle>Rm, Rv\<rangle>bg_impl_rel_eext, Rv\<rangle>g_impl_rel_ext"

context fixes Rv :: "('vi\<times>'v) set" begin
lemmas [autoref_rules] = gen_bg_refine[
  OF frgv_tag[of Rv] bg_fs_tag[of Rv],
  folded frgv_impl_rel_ext_def bg_impl_rel_eext_def]

lemmas [autoref_rules] = gen_bg_refine[
  OF g_tag[of Rv] bg_fs_tag[of Rv],
  folded g_impl_rel_ext_def bg_impl_rel_eext_def]
end

schematic_goal "(?c::?'c,
    \<lambda>G x. if x \<in> bg_F G then (g_E G `` {x}) else {}
  )\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  notes [autoref_tyrel] = TYRELI[of "Id :: ('a\<times>'a) set"]
  shows "(?c::?'c, \<lambda>E (V0::'a set) F.
    \<lparr> g_V = {}, g_E = E, g_V0 = V0, bg_F = F \<rparr>)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  notes [autoref_tyrel] = TYRELI[of "Id :: ('a\<times>'a) set"]
  shows "(?c::?'c, \<lambda>E (V0::'a set) F.
    \<lparr> g_V = UNIV, g_E = E, g_V0 = V0, bg_F = F \<rparr>)\<in>?R"
  apply (autoref (keep_goal))
  done

subsection \<open>System Automata\<close>

consts
  i_sa_eext :: "interface \<Rightarrow> interface \<Rightarrow> interface \<Rightarrow> interface"

abbreviation "i_sa Ie Iv Il \<equiv> \<langle>\<langle>Ie,Iv,Il\<rangle>\<^sub>ii_sa_eext,Iv\<rangle>\<^sub>ii_g_ext"

context begin interpretation autoref_syn .
term sa_L
lemma sa_type[autoref_itype]:
  "sa_L ::\<^sub>i i_sa Ie Iv Il \<rightarrow>\<^sub>i Iv \<rightarrow>\<^sub>i Il"
  "sa_rec_ext ::\<^sub>i (Iv \<rightarrow>\<^sub>i Il) \<rightarrow>\<^sub>i Ie \<rightarrow>\<^sub>i \<langle>Ie,Iv,Il\<rangle>\<^sub>ii_sa_eext"
  by simp_all
end

record ('vi,'ei,'v0i,'li) gen_sa_impl = "('vi,'ei,'v0i) gen_g_impl" +
  sai_L :: 'li

definition gen_sa_impl_rel_eext_def_internal:
  "gen_sa_impl_rel_eext Rm Rl \<equiv> { (
  \<lparr> sai_L = Li, \<dots>=mi \<rparr>,
  \<lparr> sa_L = L, \<dots>=m \<rparr>)
  | Li mi L m.
    (Li,L)\<in>Rl
  \<and> (mi,m)\<in>Rm
  }"

lemma gen_sa_impl_rel_eext_def:
  "\<langle>Rm,Rl\<rangle>gen_sa_impl_rel_eext = { (
  \<lparr> sai_L = Li, \<dots>=mi \<rparr>,
  \<lparr> sa_L = L, \<dots>=m \<rparr>)
  | Li mi L m.
    (Li,L)\<in>Rl
  \<and> (mi,m)\<in>Rm
  }"
  unfolding gen_sa_impl_rel_eext_def_internal relAPP_def by simp

lemma gen_sa_impl_rel_sv[relator_props]:
  "\<lbrakk>single_valued Rm; single_valued Rf\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rf\<rangle>gen_sa_impl_rel_eext)"
  unfolding gen_sa_impl_rel_eext_def
  apply (rule single_valuedI)
  apply (clarsimp)
  apply (intro conjI)
  apply (rule single_valuedD[rotated], assumption+)
  apply (rule single_valuedD[rotated], assumption+)
  done

abbreviation gen_sa_impl_rel_ext
  :: "_ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> _ \<Rightarrow> (_ \<times> ('q,'l,_) sa_rec_scheme) set"
  where "gen_sa_impl_rel_ext Rm Rf
  \<equiv> \<langle>\<langle>Rm,Rf\<rangle>gen_sa_impl_rel_eext\<rangle>gen_g_impl_rel_ext"

lemma gen_sa_refine:
  fixes Rv Re Rv0
  assumes "TERM (Rv,Re,Rv0)"
  assumes "TERM (Rl)"
  shows
  "(sai_L,sa_L)
    \<in> \<langle>Rv,Re,Rv0\<rangle>gen_sa_impl_rel_ext Rm Rl \<rightarrow> Rl"
  "(gen_sa_impl_ext, sa_rec_ext)
    \<in> Rl \<rightarrow> Rm \<rightarrow> \<langle>Rm,Rl\<rangle>gen_sa_impl_rel_eext"
  unfolding gen_sa_impl_rel_eext_def gen_g_impl_rel_ext_def
  by auto

subsubsection \<open>Implementation with Function\<close>

definition sa_impl_rel_eext_internal_def:
  "sa_impl_rel_eext Rm Rv Rl
  \<equiv> \<langle>Rm, Rv\<rightarrow>Rl\<rangle>gen_sa_impl_rel_eext"

lemma sa_impl_rel_eext_def:
  "\<langle>Rm,Rv,Rl\<rangle>sa_impl_rel_eext
    \<equiv> \<langle>Rm, Rv\<rightarrow>Rl\<rangle>gen_sa_impl_rel_eext"
  unfolding sa_impl_rel_eext_internal_def relAPP_def by simp

lemmas [autoref_rel_intf] = REL_INTFI[of sa_impl_rel_eext i_sa_eext]

lemma [relator_props, simp]:
  "\<lbrakk>single_valued Rm; single_valued Rl; Range Rv = UNIV\<rbrakk>
  \<Longrightarrow> single_valued (\<langle>Rm,Rv,Rl\<rangle>sa_impl_rel_eext)"
  unfolding sa_impl_rel_eext_def by tagged_solver

lemma sa_f_tag: "TERM (Rv\<rightarrow>Rl)" .

abbreviation "sav_impl_rel_ext Rm Rv Rl
  \<equiv> \<langle>\<langle>Rm, Rv, Rl\<rangle>sa_impl_rel_eext, Rv\<rangle>frgv_impl_rel_ext"

abbreviation "sa_impl_rel_ext Rm Rv Rl
  \<equiv> \<langle>\<langle>Rm, Rv, Rl\<rangle>sa_impl_rel_eext, Rv\<rangle>g_impl_rel_ext"

type_synonym ('v,'l,'m) sav_impl_scheme =
  "('v, \<lparr> sai_L :: 'v \<Rightarrow> 'l , \<dots>::'m  \<rparr>) frgv_impl_scheme"

type_synonym ('v,'l,'m) sa_impl_scheme =
  "('v, \<lparr> sai_L :: 'v \<Rightarrow> 'l , \<dots>::'m  \<rparr>) g_impl_scheme"

context fixes Rv :: "('vi\<times>'v) set" begin
lemmas [autoref_rules] = gen_sa_refine[
  OF frgv_tag[of Rv] sa_f_tag[of Rv],
  folded frgv_impl_rel_ext_def sa_impl_rel_eext_def]

lemmas [autoref_rules] = gen_sa_refine[
  OF g_tag[of Rv] sa_f_tag[of Rv],
  folded g_impl_rel_ext_def sa_impl_rel_eext_def]
end

schematic_goal "(?c::?'c,
    \<lambda>G x l. if sa_L G x = l then (g_E G `` {x}) else {}
  )\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  notes [autoref_tyrel] = TYRELI[of "Id :: ('a\<times>'a) set"]
  shows "(?c::?'c, \<lambda>E (V0::'a set) L.
    \<lparr> g_V = {}, g_E = E, g_V0 = V0, sa_L = L \<rparr>)\<in>?R"
  apply (autoref (keep_goal))
  done

schematic_goal
  notes [autoref_tyrel] = TYRELI[of "Id :: ('a\<times>'a) set"]
  shows "(?c::?'c, \<lambda>E (V0::'a set) L.
    \<lparr> g_V = UNIV, g_E = E, g_V0 = V0, sa_L = L \<rparr>)\<in>?R"
  apply (autoref (keep_goal))
  done

subsection \<open>Index Conversion\<close>

schematic_goal gbg_to_idx_ext_impl_aux:
  fixes Re and Rv :: "('qi \<times> 'q) set"
  assumes [autoref_ga_rules]: "is_bounded_hashcode Rv eq bhc"
  assumes [autoref_ga_rules]: "is_valid_def_hm_size TYPE('qi) (def_size)"
  shows "(?c, gbg_to_idx_ext :: _ \<Rightarrow> ('q, _) gb_graph_rec_scheme \<Rightarrow> _)
   \<in> (gbgv_impl_rel_ext Re Rv \<rightarrow> Ri)
    \<rightarrow> gbgv_impl_rel_ext Re Rv
    \<rightarrow> \<langle>igbgv_impl_rel_ext Ri Rv\<rangle>nres_rel"
  unfolding gbg_to_idx_ext_def[abs_def] F_to_idx_impl_def mk_acc_impl_def
  using [[autoref_trace_failed_id]]
  apply (autoref (keep_goal))
  done
concrete_definition gbg_to_idx_ext_impl
  for eq bhc def_size uses gbg_to_idx_ext_impl_aux

lemmas [autoref_rules] =
  gbg_to_idx_ext_impl.refine[
  OF SIDE_GEN_ALGO_D SIDE_GEN_ALGO_D]

schematic_goal gbg_to_idx_ext_code_aux:
  "RETURN ?c \<le> gbg_to_idx_ext_impl eq bhc def_size ecnv G"
  unfolding gbg_to_idx_ext_impl_def
  by (refine_transfer)
concrete_definition gbg_to_idx_ext_code
  for eq bhc ecnv G uses gbg_to_idx_ext_code_aux
lemmas [refine_transfer] = gbg_to_idx_ext_code.refine

term ahm_rel

context begin interpretation autoref_syn .

schematic_goal gba_to_idx_ext_impl_aux:
  fixes Re and Rv :: "('qi \<times> 'q) set"
  assumes [autoref_ga_rules]: "is_bounded_hashcode Rv eq bhc"
  assumes [autoref_ga_rules]: "is_valid_def_hm_size TYPE('qi) (def_size)"
  shows "(?c, gba_to_idx_ext :: _ \<Rightarrow> ('q, 'l, _) gba_rec_scheme \<Rightarrow> _)
   \<in> (gbav_impl_rel_ext Re Rv Rl\<rightarrow>Ri)
    \<rightarrow> gbav_impl_rel_ext Re Rv Rl
    \<rightarrow> \<langle>igbav_impl_rel_ext Ri Rv Rl\<rangle>nres_rel"
  using [[autoref_trace_failed_id]] unfolding ti_Lcnv_def[abs_def]
  apply (autoref (keep_goal))
  done
concrete_definition gba_to_idx_ext_impl for eq bhc uses gba_to_idx_ext_impl_aux
lemmas [autoref_rules] =
  gba_to_idx_ext_impl.refine[OF SIDE_GEN_ALGO_D SIDE_GEN_ALGO_D]

schematic_goal gba_to_idx_ext_code_aux:
  "RETURN ?c \<le> gba_to_idx_ext_impl eq bhc def_size ecnv G"
  unfolding gba_to_idx_ext_impl_def
  by (refine_transfer)
concrete_definition gba_to_idx_ext_code for ecnv G uses gba_to_idx_ext_code_aux
lemmas [refine_transfer] = gba_to_idx_ext_code.refine

subsection \<open>Degeneralization\<close>

context igb_graph begin

lemma degen_impl_aux_alt: "degeneralize_ext ecnv = (
      if num_acc = 0 then \<lparr>
        g_V = Collect (\<lambda>(q,x). x=0 \<and> q\<in>V),
        g_E= E_of_succ (\<lambda>(q,x). if x=0 then (\<lambda>q'. (q',0))`succ_of_E E q else {}),
        g_V0 = (\<lambda>q'. (q',0))`V0,
        bg_F = Collect (\<lambda>(q,x). x=0 \<and> q\<in>V),
        \<dots> = ecnv G
      \<rparr>
      else \<lparr>
        g_V = Collect (\<lambda>(q,x). x<num_acc \<and> q\<in>V),
        g_E = E_of_succ (\<lambda>(q,i).
          if i<num_acc then
            let
              i' = if i \<in> acc q then (i + 1) mod num_acc else i
            in (\<lambda>q'. (q',i'))`succ_of_E E q
          else {}
        ),
        g_V0 = (\<lambda>q'. (q',0))`V0,
        bg_F = Collect (\<lambda>(q,x). x=0 \<and> 0\<in>acc q),
        \<dots> = ecnv G
      \<rparr>)"
  unfolding degeneralize_ext_def
  apply (cases "num_acc = 0")
  apply simp_all
  apply (auto simp: E_of_succ_def succ_of_E_def split: if_split_asm) []
  apply (fastforce simp: E_of_succ_def succ_of_E_def split: if_split_asm) []
  done

schematic_goal degeneralize_ext_impl_aux:
  fixes Re Rv
  assumes [autoref_rules]: "(Gi,G) \<in> igbg_impl_rel_ext Re Rv"
  shows "(?c, degeneralize_ext)
  \<in> (igbg_impl_rel_ext Re Rv \<rightarrow> Re') \<rightarrow> bg_impl_rel_ext Re' (Rv \<times>\<^sub>r nat_rel)"
  unfolding degen_impl_aux_alt[abs_def]
  using [[autoref_trace_failed_id]]
  apply (autoref (keep_goal))
  done

end

definition [simp]:
  "op_igb_graph_degeneralize_ext ecnv G \<equiv> igb_graph.degeneralize_ext G ecnv"

lemma [autoref_op_pat]:
  "igb_graph.degeneralize_ext \<equiv> \<lambda>G ecnv. op_igb_graph_degeneralize_ext ecnv G"
  by simp

thm igb_graph.degeneralize_ext_impl_aux[param_fo]
concrete_definition degeneralize_ext_impl
  uses igb_graph.degeneralize_ext_impl_aux[param_fo]

thm degeneralize_ext_impl.refine

context begin interpretation autoref_syn .
lemma [autoref_rules]:
  fixes Re
  assumes "SIDE_PRECOND (igb_graph G)"
  assumes CNVR: "(ecnvi,ecnv) \<in> (igbg_impl_rel_ext Re Rv \<rightarrow> Re')"
  assumes GR: "(Gi,G)\<in>igbg_impl_rel_ext Re Rv"
  shows "(degeneralize_ext_impl Gi ecnvi,
    (OP op_igb_graph_degeneralize_ext
       ::: (igbg_impl_rel_ext Re Rv \<rightarrow> Re') \<rightarrow> igbg_impl_rel_ext Re Rv
        \<rightarrow> bg_impl_rel_ext Re' (Rv \<times>\<^sub>r nat_rel) )$ecnv$G )
  \<in> bg_impl_rel_ext Re' (Rv \<times>\<^sub>r nat_rel)"
proof -
  from assms have A: "igb_graph G" by simp

  show ?thesis
    apply simp
    using degeneralize_ext_impl.refine[OF A GR CNVR]
    .
qed

end
thm autoref_itype(1)

schematic_goal
  assumes [simp]: "igb_graph G"
  assumes [autoref_rules]: "(Gi,G)\<in>igbg_impl_rel_ext unit_rel nat_rel"
  shows "(?c::?'c, igb_graph.degeneralize_ext G (\<lambda>_. ())) \<in> ?R"
  apply (autoref (keep_goal))
  done

subsection \<open>Product Construction\<close>

context igba_sys_prod_precond begin

lemma prod_impl_aux_alt:
  "prod = (\<lparr>
    g_V = Collect (\<lambda>(q,s). q \<in> igba.V \<and> s \<in> sa.V),
    g_E = E_of_succ (\<lambda>(q,s).
      if igba.L q (sa.L s) then
        succ_of_E (igba.E) q \<times> succ_of_E sa.E s
      else
        {}
    ),
    g_V0 = igba.V0 \<times> sa.V0,
    igbg_num_acc = igba.num_acc,
    igbg_acc = \<lambda>(q,s). if s\<in>sa.V then igba.acc q else {}
  \<rparr>)"
  unfolding prod_def
  apply (auto simp: succ_of_E_def E_of_succ_def split: if_split_asm)
  done

schematic_goal prod_impl_aux:
  fixes Re
  (*assumes [autoref_rules]: "(eqq,(=)) \<in> Rq \<rightarrow> Rq \<rightarrow> bool_rel"
  assumes [autoref_rules]: "(eqs,(=)) \<in> Rs \<rightarrow> Rs \<rightarrow> bool_rel"*)
  assumes [autoref_rules]: "(Gi,G) \<in> igba_impl_rel_ext Re Rq Rl"
  assumes [autoref_rules]: "(Si,S) \<in> sa_impl_rel_ext Re2 Rs Rl"
  shows "(?c, prod) \<in> igbg_impl_rel_ext unit_rel (Rq \<times>\<^sub>r Rs)"
  unfolding prod_impl_aux_alt[abs_def]
  apply (autoref (keep_goal))
  done

end

definition [simp]: "op_igba_sys_prod \<equiv> igba_sys_prod_precond.prod"

lemma [autoref_op_pat]:
  "igba_sys_prod_precond.prod \<equiv> op_igba_sys_prod"
  by simp

thm igba_sys_prod_precond.prod_impl_aux[param_fo]
concrete_definition igba_sys_prod_impl
  uses igba_sys_prod_precond.prod_impl_aux[param_fo]

thm igba_sys_prod_impl.refine

context begin interpretation autoref_syn .
lemma [autoref_rules]:
  fixes Re
  assumes "SIDE_PRECOND (igba G)"
  assumes "SIDE_PRECOND (sa S)"
  assumes GR: "(Gi,G)\<in>igba_impl_rel_ext unit_rel Rq Rl"
  assumes SR: "(Si,S)\<in>sa_impl_rel_ext unit_rel Rs Rl"
  shows "(igba_sys_prod_impl Gi Si,
    (OP op_igba_sys_prod
       :::  igba_impl_rel_ext unit_rel Rq Rl
        \<rightarrow> sa_impl_rel_ext unit_rel Rs Rl
        \<rightarrow> igbg_impl_rel_ext unit_rel (Rq \<times>\<^sub>r Rs) )$G$S )
  \<in> igbg_impl_rel_ext unit_rel (Rq \<times>\<^sub>r Rs)"
proof -
  from assms interpret igba: igba G + sa: sa S by simp_all
  have A: "igba_sys_prod_precond G S" by unfold_locales

  show ?thesis
    apply simp
    using igba_sys_prod_impl.refine[OF A GR SR]
    .
qed

end

schematic_goal
  assumes [simp]: "igba G" "sa S"
  assumes [autoref_rules]: "(Gi,G)\<in>igba_impl_rel_ext unit_rel Rq Rl"
  assumes [autoref_rules]: "(Si,S)\<in>sa_impl_rel_ext unit_rel Rs Rl"
  shows "(?c::?'c,igba_sys_prod_precond.prod G S)\<in>?R"
  apply (autoref (keep_goal))
  done

end


(*  Title:      CoW/Lyndon_Schutzenberger.thy
    Author:     Štěpán Holub, Charles University
*)

theory Lyndon_Schutzenberger
  imports CoWBasic
begin

chapter \<open>Lyndon-Schützenberger Equation\<close>

text\<open>The Lyndon-Schützenberger equation is the following equation on words:
\[
x^ay^b = z^c,
\]
in this formalization denoted as @{term "x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c"}, with $2 \leq a,b,c$.
We formalize here a proof that the equation has periodic solutions only in free monoids, that is, that any three words
$x$, $y$ and $z$ satisfying the equality pairwise commute.
The result was first proved in @{cite LySch62} in a more general setting of free groups.
There are several proofs to be found in the literature (for instance @{cite Lo83 and Dmsi2006}).
The presented proof is the author's proof.
\<close>

text\<open>We set up a locale representing the Lyndon-Schützenberger Equation.\<close>

locale LS =
  fixes x a y b z c
  assumes a:  "2 \<le> a" and b: "2 \<le> b" and c: "2 \<le> c"   and eq: "x\<^sup>@a \<cdot> y\<^sup>@b = z\<^sup>@c"
begin

lemma a0: "a \<noteq> 0" and b0: "b \<noteq> 0"
      using a b by auto

text\<open>If $x^a$ or $y^b$ is sufficiently long, then the calim follows from the Periodicity Lemma.\<close>

lemma per_lemma_case:
  assumes "\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|"
  shows "x\<cdot>y=y\<cdot>x"
proof (cases "x = \<epsilon>")
  assume "x = \<epsilon>"
  thus "x\<cdot>y=y\<cdot>x" by simp
next
  assume "x \<noteq> \<epsilon>"
  hence "z\<^sup>@c \<noteq> \<epsilon>"
    using eq assms emp_pow[of c] by auto
  hence "x\<^sup>@a \<le>p (z\<^sup>@c)\<^sup>\<omega>"
    unfolding period_root_def using
    pref_ext[OF triv_pref[of "x\<^sup>@a" "y\<^sup>@b", unfolded eq], of "x\<^sup>@a"] by blast
  have "x \<^sup>@ a \<le>p x\<^sup>\<omega>"
    using \<open>x \<noteq> \<epsilon>\<close> a0 root_self[THEN per_drop_exp] by blast
  from two_pers[OF per_drop_exp[OF \<open>x\<^sup>@a \<le>p (z\<^sup>@c)\<^sup>\<omega>\<close>] this assms]
  have "z \<cdot> x = x \<cdot> z".
  hence "z\<^sup>@c\<cdot>x\<^sup>@a = x\<^sup>@a\<cdot>z\<^sup>@c"
    by (simp add: comm_add_exps)
  from this[folded eq, unfolded rassoc cancel, symmetric]
  have "x\<^sup>@a \<cdot> y\<^sup>@b = y\<^sup>@b \<cdot> x\<^sup>@a".
  from this[unfolded comm_pow_roots[OF a0 b0]]
  show "x \<cdot> y = y \<cdot> x".
qed

text\<open>The most challenging case is when $c = 3$.\<close>

lemma core_case:
  assumes
    "c = 3" and
    "b*\<^bold>|y\<^bold>| \<le> a*\<^bold>|x\<^bold>|" and "x \<noteq> \<epsilon>" and "y \<noteq> \<epsilon>" and
    lenx: "a*\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|" and
    leny: "b*\<^bold>|y\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>|"
  shows "x\<cdot>y = y\<cdot>x"
proof-
  have "a \<noteq> 0" and "b \<noteq> 0"
      using a b by auto

  \<comment>\<open>We first show that a = 2\<close>
  have "a*\<^bold>|x\<^bold>|+b*\<^bold>|y\<^bold>| = 3*\<^bold>|z\<^bold>|"
    using \<open>c = 3\<close> eq length_append[of "x\<^sup>@a" "y\<^sup>@b"]
    by (simp add: pow_len)
  hence "3*\<^bold>|z\<^bold>| \<le> a*\<^bold>|x\<^bold>| + a*\<^bold>|x\<^bold>|"
    using \<open>b*\<^bold>|y\<^bold>| \<le> a*\<^bold>|x\<^bold>|\<close>  by simp
  hence "3*\<^bold>|z\<^bold>| < 2*\<^bold>|z\<^bold>| + 2*\<^bold>|x\<^bold>|"
    using lenx by linarith
  hence "\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| < 3 * \<^bold>|x\<^bold>|" by simp
  from less_trans[OF lenx this, unfolded mult_less_cancel2]
  have "a = 2" using a by force

  hence "\<^bold>|y\<^bold>| \<le> \<^bold>|x\<^bold>|" using \<open>b*\<^bold>|y\<^bold>| \<le> a*\<^bold>|x\<^bold>|\<close> b
      pow_len[of x 2]  pow_len[of y b] mult_le_less_imp_less[of a b "\<^bold>|x\<^bold>|" "\<^bold>|y\<^bold>|"] not_le
    by auto
  have "x\<cdot>x\<cdot>y\<^sup>@b = z\<cdot>z\<cdot>z" using a eq \<open>c=3\<close> \<open>a=2\<close>
    by (simp add: numeral_2_eq_2 numeral_3_eq_3)

\<comment> \<open>Find words u, v, w\<close>
  have "\<^bold>|z\<^bold>| < \<^bold>|x\<cdot>x\<^bold>|"
    using \<open>\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| < 3 * \<^bold>|x\<^bold>|\<close> add.commute by auto
  from ruler_le[THEN prefD, OF triv_pref[of z "z\<cdot>z"] _ less_imp_le[OF this]]
  obtain w  where "z\<cdot>w = x\<cdot>x"
    using prefI[of "x\<cdot>x" "y\<^sup>@b" "z\<cdot>z\<cdot>z", unfolded rassoc, OF \<open>x\<cdot>x\<cdot>y\<^sup>@b = z\<cdot>z\<cdot>z\<close>] by fastforce

  have "\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|"
    using \<open>a = 2\<close> lenx by auto
  from ruler_le[THEN prefD, OF _ _ less_imp_le[OF this], of "x\<cdot>x\<cdot>y\<^sup>@b", OF triv_pref, unfolded \<open>x\<cdot>x\<cdot>y\<^sup>@b = z\<cdot>z\<cdot>z\<close>, OF triv_pref]
  obtain u :: "'a list" where "x\<cdot>u=z"
    by blast
  have "u \<noteq> \<epsilon>"
    using \<open>\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\<close> \<open>x\<cdot>u = z\<close> by auto
  have "x = u\<cdot>w" using  \<open>z\<cdot>w = x\<cdot>x\<close> \<open>x\<cdot>u = z\<close> by auto

  have "\<^bold>|x\<cdot>x\<^bold>| < \<^bold>|z\<cdot>z\<^bold>|"  by (simp add: \<open>\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\<close> add_less_mono)
  from ruler_le[OF triv_pref[of "x\<cdot>x" "y\<^sup>@b", unfolded  rassoc \<open>x\<cdot>x\<cdot>y\<^sup>@b = z\<cdot>z\<cdot>z\<close>, unfolded lassoc] triv_pref, OF less_imp_le[OF this]]
  have "z\<cdot>w \<le>p z\<cdot>z"
    unfolding \<open>z\<cdot>w = x\<cdot>x\<close>.
  obtain v :: "'a list" where "w \<cdot> v = x"
    using lq_pref[of w x]
   pref_prod_pref'[OF pref_cancel[OF \<open>z\<cdot>w \<le>p z\<cdot>z\<close>, folded \<open>x \<cdot> u = z\<close>, unfolded \<open>x = u \<cdot> w\<close> rassoc], folded  \<open>x = u \<cdot> w\<close>] by blast
  have "u\<cdot>w\<cdot>v \<noteq> \<epsilon>"
    by (simp add: \<open>u \<noteq> \<epsilon>\<close>)

\<comment> \<open>Express x, y and z in terms of  u, v and w\<close>
  hence "z = w\<cdot>v\<cdot>u"
    using \<open>w \<cdot> v = x\<close> \<open>x \<cdot> u = z\<close> by auto
  from \<open>x \<cdot> x \<cdot> y\<^sup>@b = z \<cdot> z \<cdot> z\<close>[unfolded this lassoc, folded \<open>z \<cdot> w = x \<cdot> x\<close>, unfolded this rassoc]
  have "w\<cdot>v \<cdot> u\<cdot>w \<cdot> y\<^sup>@b = w\<cdot>v\<cdot>u\<cdot>w\<cdot>v\<cdot>u\<cdot>w\<cdot>v\<cdot>u".
  hence "y\<^sup>@b = v\<cdot>u\<cdot>w\<cdot>v\<cdot>u"
    using pref_cancel by auto

\<comment> \<open>Double period of uwv\<close>
  from periodN_fac[OF _ \<open>u\<cdot>w\<cdot>v \<noteq> \<epsilon>\<close>, of v u "\<^bold>|y\<^bold>|", unfolded rassoc, folded this]
  have "periodN (u\<cdot>w\<cdot>v) \<^bold>|y\<^bold>|"
    using pow_per[OF \<open>y \<noteq> \<epsilon>\<close> b0] by blast
  have "u\<cdot>w\<cdot>v = x \<cdot>v"
    by (simp add: \<open>x = u \<cdot> w\<close>)
  have "u\<cdot>w\<cdot>v = u\<cdot> x"
    by (simp add: \<open>w \<cdot> v = x\<close>)
  have "u\<cdot>w\<cdot>v \<le>p u\<^sup>\<omega>"
    unfolding period_root_def
    using \<open>u \<cdot> w \<cdot> v = u \<cdot> x\<close>[unfolded \<open>x = u \<cdot> w\<close>] \<open>u \<noteq> \<epsilon>\<close> triv_pref[of "u \<cdot> u \<cdot> w" v]
    by force
  have "periodN (u\<cdot>w\<cdot>v) \<^bold>|u\<^bold>|"
    using \<open>u \<cdot> w \<cdot> v \<le>p u \<^sup>\<omega>\<close> by auto

\<comment> \<open>Common period d\<close>
  obtain d::nat where "d=gcd \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|"
    by simp
  have "\<^bold>|y\<^bold>| + \<^bold>|u\<^bold>| \<le> \<^bold>|u\<cdot>w\<cdot>v\<^bold>|" using \<open>\<^bold>|y\<^bold>| \<le> \<^bold>|x\<^bold>|\<close> length_append \<open>u\<cdot>w\<cdot>v = u\<cdot> x\<close>
    by simp
  hence "periodN (u\<cdot>w\<cdot>v) d"
    using \<open>periodN (u \<cdot> w \<cdot> v) \<^bold>|u\<^bold>|\<close> \<open>periodN (u \<cdot> w \<cdot> v) \<^bold>|y\<^bold>|\<close> \<open>d = gcd \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\<close> two_periodsN
    by blast

\<comment> \<open>Divisibility\<close>
  have "v\<cdot>u\<cdot>z=y\<^sup>@b"
    by (simp add: \<open>y\<^sup>@b = v \<cdot> u \<cdot> w \<cdot> v \<cdot> u\<close> \<open>z = w \<cdot> v \<cdot> u\<close>)
  have "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|"
    using \<open>x = u \<cdot> w\<close> \<open>w \<cdot> v = x\<close> length_append[of u w] length_append[of w v] add.commute[of "\<^bold>|u\<^bold>|" "\<^bold>|w\<^bold>|"] add_left_cancel
    by simp
  hence "d dvd \<^bold>|v\<^bold>|" using gcd_nat.cobounded1[of "\<^bold>|v\<^bold>|" "\<^bold>|y\<^bold>|"] gcd.commute[of "\<^bold>|y\<^bold>|" "\<^bold>|u\<^bold>|"]
    by (simp add: \<open>d = gcd \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\<close>)
  have "d dvd \<^bold>|u\<^bold>|"
    by (simp add: \<open>d = gcd  \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\<close>)
  have "\<^bold>|z\<^bold>| + \<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| = b*\<^bold>|y\<^bold>|"
    using  lenarg[OF \<open>v\<cdot>u\<cdot>z=y\<^sup>@b\<close>, unfolded length_append pow_len] by auto
  from dvd_add_left_iff[OF \<open>d dvd \<^bold>|v\<^bold>|\<close>, of "\<^bold>|z\<^bold>|+\<^bold>|u\<^bold>|", unfolded this dvd_add_left_iff[OF \<open>d dvd \<^bold>|u\<^bold>|\<close>, of "\<^bold>|z\<^bold>|"]]
  have "d dvd \<^bold>|z\<^bold>|"
    using \<open>d = gcd  \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\<close> dvd_mult by blast
  from lenarg[OF \<open>z = w \<cdot> v \<cdot> u\<close>, unfolded length_append pow_len]
  have "d dvd \<^bold>|w\<^bold>|"
    using \<open>d dvd \<^bold>|z\<^bold>|\<close>  \<open>d dvd \<^bold>|u\<^bold>|\<close> \<open>d dvd \<^bold>|v\<^bold>|\<close>  by (simp add: dvd_add_left_iff)
  hence "d dvd \<^bold>|x\<^bold>|"
    using \<open>d dvd \<^bold>|v\<^bold>|\<close> \<open>w \<cdot> v = x\<close> by force

\<comment> \<open>x and y commute\<close>
  have "x \<le>p u\<cdot>w\<cdot>v"
    by (simp add: \<open>x = u \<cdot> w\<close>)
  have "periodN x d" using per_pref'[OF \<open>x\<noteq>\<epsilon>\<close>  \<open>periodN (u\<cdot>w\<cdot>v) d \<close> \<open>x \<le>p u \<cdot>w\<cdot>v\<close>].
  hence "x \<in> (take d x)*"
    using \<open>d dvd \<^bold>|x\<^bold>|\<close>
    using root_divisor by blast

  hence "periodN u d " using \<open>x = u \<cdot> w\<close> per_pref'
    using \<open>periodN x d\<close> \<open>u \<noteq> \<epsilon>\<close> by blast
  have " take d x = take d u" using \<open>u\<noteq>\<epsilon>\<close>  \<open>x = u \<cdot> w\<close> pref_share_take
    by (simp add: \<open>d = gcd  \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\<close>)
  from root_divisor[OF \<open>periodN u d\<close> \<open>d dvd \<^bold>|u\<^bold>|\<close>, folded this]
  have "u \<in> (take d x)*".

  hence "z \<in> (take d x)*"
    using \<open>x\<cdot>u=z\<close> \<open>x \<in> (take d x)*\<close> add_roots by blast
  from root_pref_cancel'[OF _ root_pow_root[OF  \<open>x \<in> take d x*\<close>, of a],of "y\<^sup>@b", unfolded eq, OF root_pow_root[OF  this, of c]]
  have "y\<^sup>@b \<in> (take d x)*".
  from  commD[OF root_pow_root[OF  \<open>x \<in> take d x*\<close>, of a] this]
  show "x \<cdot> y = y \<cdot> x"
    unfolding comm_pow_roots[OF \<open>a \<noteq> 0\<close> \<open>b \<noteq> 0\<close>, of x y].
qed

end \<comment> \<open>locale LS\<close>

text\<open>The main proof is by induction on the length of $z$. It also uses the reverse symmetry of the equation which is
exploited by two interpretations of the locale @{term LS}. Note also that the case $|x^a| < |y^b|$ is solved by
using induction on $|z| + |y^b|$ instead of just on $|z|$.
\<close>

lemma Lyndon_Schutzenberger':
  "\<lbrakk> x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c;  2 \<le> a;  2 \<le> b; 2 \<le> c \<rbrakk>
  \<Longrightarrow> x\<cdot>y = y\<cdot>x"
proof (induction "\<^bold>|z\<^bold>| + b* \<^bold>|y\<^bold>|" arbitrary: x y z a b c  rule: less_induct)
  case less

  interpret LS x a y b z c using \<open> x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c\<close> \<open> 2 \<le>a \<close> \<open> 2 \<le> b\<close> \<open> 2 \<le> c\<close>
    by (simp add: LS.intro)
  interpret LSrev: LS "rev y" b "rev x" a "rev z" c
        using  LS.intro[OF b a c, of "rev y" "rev x" "rev z", folded rev_append rev_pow, unfolded rev_is_rev_conv, OF \<open>x\<^sup>@a \<cdot> y\<^sup>@b = z\<^sup>@c\<close>].

  have leneq: "a * \<^bold>|x\<^bold>| + b*\<^bold>|y\<^bold>| = c * \<^bold>|z\<^bold>|"
    using  eq unfolding pow_len[symmetric] length_append[symmetric] by simp
  have "a \<noteq> 0" and "b \<noteq> 0"
    using a b by auto

  show "x \<cdot> y = y \<cdot> x"
  proof (cases "x = \<epsilon> \<or> y = \<epsilon>")
    show "x = \<epsilon> \<or> y = \<epsilon> \<Longrightarrow> x \<cdot> y = y \<cdot> x"
      by auto
  next
    assume "\<not> (x = \<epsilon> \<or> y = \<epsilon>)" hence "x \<noteq> \<epsilon>" and "y \<noteq> \<epsilon>" by blast+
    show "x \<cdot> y = y \<cdot> x"
    proof (cases "\<^bold>|x \<^sup>@ a\<^bold>| < \<^bold>|y \<^sup>@ b\<^bold>|")

\<comment> \<open>WLOG assumption\<close>
      assume "\<^bold>|x\<^sup>@a\<^bold>| < \<^bold>|y\<^sup>@b\<^bold>|"
      have "\<^bold>|rev z\<^bold>| + a* \<^bold>|rev x\<^bold>| < \<^bold>|z\<^bold>| + b* \<^bold>|y\<^bold>|" using \<open>\<^bold>|x\<^sup>@a\<^bold>| < \<^bold>|y\<^sup>@b\<^bold>|\<close>
        by (simp add: pow_len)
      from "less.hyps"[OF this LSrev.eq b a c, symmetric]
      show "x \<cdot> y = y \<cdot> x"
        unfolding  rev_append[symmetric] rev_is_rev_conv by simp
    next
      assume " \<not> \<^bold>|x\<^sup>@a\<^bold>| < \<^bold>|y\<^sup>@b\<^bold>|" hence "\<^bold>|y\<^sup>@b\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|" by force
          \<comment> \<open>case solved by the Periodicity lemma\<close>
      consider (with_Periodicity_lemma)
        "\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| \<le> \<^bold>|x \<^sup>@ a\<^bold>| \<or> \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>| \<le> \<^bold>|y \<^sup>@ b\<^bold>|" |
        (without_Periodicity_lemma)
        "\<^bold>|x\<^sup>@a\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|" and "\<^bold>|y\<^sup>@b\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>|"
        using not_le_imp_less by blast
      thus "x \<cdot> y = y \<cdot> x"
      proof (cases)
        case with_Periodicity_lemma
        assume short: "\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>| \<or> \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>| \<le> \<^bold>|y\<^sup>@b\<^bold>|"
        have "x = \<epsilon> \<or> rev y = \<epsilon> \<Longrightarrow> x \<cdot> y = y \<cdot> x"
          by auto
        thus "x \<cdot> y = y \<cdot> x"
          using per_lemma_case LSrev.per_lemma_case short
          unfolding length_rev rev_append[symmetric] rev_is_rev_conv rev_pow[symmetric] by blast
      next
        case without_Periodicity_lemma
        assume lenx: "\<^bold>|x\<^sup>@a\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|" and leny: "\<^bold>|y\<^sup>@b\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>|"
        have ex: "\<exists> k. d = Suc (Suc k)" if "2 \<le> d" for d
          using nat_le_iff_add that by auto
        have "a * \<^bold>|x\<^bold>| + b*\<^bold>|y\<^bold>| < 4 * \<^bold>|z\<^bold>|"
          using ex[OF \<open>2 \<le> a\<close>] ex[OF \<open>2 \<le> b\<close>] lenx leny unfolding pow_len by auto
        hence "c < 4" using leneq by auto
        consider (c_is_3) "c = 3" | (c_is_2) "c = 2"
          using \<open>c < 4\<close> c by linarith
        then show "x \<cdot> y = y \<cdot> x"
        proof(cases)
          case c_is_3
          show "x \<cdot> y = y \<cdot> x"
            using
              core_case[OF \<open>c = 3\<close> \<open>\<^bold>|y\<^sup>@b\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|\<close>[unfolded pow_len] _ _ lenx[unfolded pow_len] leny[unfolded pow_len]]
              \<open>x \<noteq> \<epsilon>\<close> \<open>y \<noteq> \<epsilon>\<close>
            by blast
        next
          assume "c = 2"
          hence eq2: "x\<^sup>@a \<cdot> y\<^sup>@b = z \<cdot> z"
            by (simp add: eq pow2_list)
          from   dual_order.trans  le_cases[of "\<^bold>|x\<^sup>@a\<^bold>|" "\<^bold>|z\<^bold>|" "\<^bold>|z\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|", unfolded eq_len_iff[OF this]]
          have "\<^bold>|z\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|"
            using \<open>\<^bold>|y\<^sup>@b\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|\<close> by blast
          obtain a' where "Suc a' = a" and "1 \<le> a'"
            using \<open>2 \<le> a\<close> ex by auto
          from eq2[folded \<open>Suc a' = a\<close>, unfolded pow_Suc2_list rassoc]  pow_Suc2_list[of x a', unfolded this, symmetric]
          have eq3: "x \<^sup>@ a' \<cdot> x \<cdot> y \<^sup>@ b = z \<cdot> z" and aa':"x \<^sup>@ a' \<cdot> x = x \<^sup>@ a ".
          hence "\<^bold>|x\<^sup>@a'\<^bold>| < \<^bold>|z\<^bold>|"
            using \<open>Suc a' = a\<close> lenx pow_len by auto
          hence "\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|"
            using  mult_le_mono[of 1 a' "\<^bold>|z\<^bold>|" "\<^bold>|x\<^bold>|", OF \<open>1 \<le> a'\<close>, THEN leD] unfolding pow_len
            by linarith
          obtain u w where "x\<^sup>@a'\<cdot>u = z" and "w \<cdot> y\<^sup>@b = z"
            using eqd_prefE[OF eq3[unfolded rassoc] less_imp_le[OF \<open>\<^bold>|x\<^sup>@a'\<^bold>| < \<^bold>|z\<^bold>|\<close>], of thesis]
              eqd_prefE[OF eq2[symmetric]  \<open>\<^bold>|z\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|\<close>, of thesis] by fast

          have "x\<^sup>@a'\<cdot>x\<cdot>y\<^sup>@b = x\<^sup>@a'\<cdot>u\<cdot>w\<cdot>y\<^sup>@b"
           unfolding lassoc  \<open>x \<^sup>@ a' \<cdot> u = z\<close> \<open>w \<cdot> y\<^sup>@b = z\<close> aa' cancel eq2 by simp
          hence "u\<cdot>w=x"
            by auto
          hence "\<^bold>|w\<cdot>u\<^bold>| = \<^bold>|x\<^bold>|"
            using swap_len by blast

\<comment> \<open>Induction step: new equation with shorter z\<close>
          have "w\<^sup>@2\<cdot>y\<^sup>@b = (w\<cdot>u)\<^sup>@a"
            unfolding pow2_list using \<open>w \<cdot> y \<^sup>@ b = z\<close> \<open>x \<^sup>@ a' \<cdot> u = z\<close> \<open>u\<cdot>w=x\<close> pow_slide[of w u a', unfolded \<open>Suc a' = a\<close>] by simp
          from "less.hyps"[OF _ this _ b a, unfolded \<open>\<^bold>|w\<cdot>u\<^bold>| = \<^bold>|x\<^bold>|\<close>]
          have "y\<cdot>w = w\<cdot>y"
            using  \<open>\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\<close>  by force

          have "y \<cdot> z = z \<cdot> y"
            unfolding \<open>w \<cdot> y\<^sup>@b = z\<close>[symmetric] lassoc \<open>y\<cdot>w = w\<cdot>y\<close>
            by (simp add: pow_commutes_list)
          hence "z\<^sup>@c\<cdot>y\<^sup>@b = y\<^sup>@b\<cdot>z\<^sup>@c"
            by (simp add: comm_add_exps)
          from this[folded eq, unfolded lassoc]
          have "x\<^sup>@a\<cdot>y\<^sup>@b = y\<^sup>@b\<cdot>x\<^sup>@a"
            using cancel_right by blast
          from this[unfolded comm_pow_roots[OF \<open>a\<noteq>0\<close> \<open>b \<noteq> 0\<close>]]
          show "x \<cdot> y = y \<cdot> x".
        qed
      qed
    qed
  qed
qed

theorem Lyndon_Schutzenberger:
  assumes "x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c" and  "2 \<le> a"  and "2 \<le> b" and "2 \<le> c"
  shows  "x\<cdot>y = y\<cdot>x" and "x\<cdot>z = z\<cdot>x" and "y\<cdot>z = z\<cdot>y"
proof-
  show "x \<cdot> y = y \<cdot> x"
    using Lyndon_Schutzenberger'[OF assms].
  have "c \<noteq> 0" and  "b \<noteq> 0" using  \<open>2 \<le> c\<close> \<open>2 \<le> b\<close> by auto
  have "x \<cdot> x\<^sup>@a \<cdot> y\<^sup>@b = x\<^sup>@a \<cdot> y\<^sup>@b \<cdot> x" and "y \<cdot> x\<^sup>@a \<cdot> y\<^sup>@b = x\<^sup>@a \<cdot> y\<^sup>@b \<cdot> y"
    unfolding comm_add_exp[OF \<open>x \<cdot> y = y \<cdot> x\<close>[symmetric], of b] comm_add_exp[OF \<open>x \<cdot> y = y \<cdot> x\<close>, symmetric, of a]
    lassoc power_commutes by blast+
  thus "x\<cdot>z = z\<cdot>x" and "y\<cdot>z = z\<cdot>y"
    using comm_drop_exp[OF \<open>c \<noteq> 0\<close>] unfolding lassoc \<open>x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c\<close> by force+
qed

end