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

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

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

datatype Form = x "Form" "Form" | Not "Form" | Var "int"

fun y :: "'a list => 'a list => 'a list" where
  "y (nil2) y2 = y2"
| "y (cons2 z2 xs) y2 = cons2 z2 (y xs y2)"

fun or2 :: "bool list => bool" where
  "or2 (nil2) = False"
| "or2 (cons2 y2 xs) = (y2 | (or2 xs))"

fun models7 :: "int => ((int, bool) pair) list =>
                ((int, bool) pair) list" where
  "models7 z (nil2) = nil2"
| "models7 z (cons2 z2 xs) =
     (if (z ~= (case z2 of pair2 x2 y22 => x2)) then
        cons2 z2 (models7 z xs)
        else
        models7 z xs)"

fun models6 :: "int => ((int, bool) pair) list => bool list" where
  "models6 z (nil2) = nil2"
| "models6 z (cons2 (pair2 y22 True) x2) = models6 z x2"
| "models6 z (cons2 (pair2 y22 False) x2) =
     cons2 (z = y22) (models6 z x2)"

fun models5 :: "int => ((int, bool) pair) list =>
                ((int, bool) pair) list" where
  "models5 z (nil2) = nil2"
| "models5 z (cons2 z2 xs) =
     (if (z ~= (case z2 of pair2 x2 y22 => x2)) then
        cons2 z2 (models5 z xs)
        else
        models5 z xs)"

fun models4 :: "int => ((int, bool) pair) list => bool list" where
  "models4 z (nil2) = nil2"
| "models4 z (cons2 (pair2 y22 True) x2) =
     cons2 (z = y22) (models4 z x2)"
| "models4 z (cons2 (pair2 y22 False) x2) = models4 z x2"

function models :: "(((int, bool) pair) list) list => Form =>
                    (((int, bool) pair) list) list => (((int, bool) pair) list) list"
  and
  models2 :: "Form => (((int, bool) pair) list) list =>
                     (((int, bool) pair) list) list"
  and
  models3 :: "Form => ((int, bool) pair) list =>
                     (((int, bool) pair) list) list" where
  "models z q (nil2) = models2 q z"
| "models z q (cons2 z2 x2) = cons2 z2 (models z q x2)"
| "models2 q (nil2) = nil2"
| "models2 q (cons2 y2 z2) = models z2 q (models3 q y2)"
| "models3 (x p q) y2 = models2 q (models3 p y2)"
| "models3 (Not (x r q2)) y2 =
     y (models3 (Not r) y2) (models3 (x r (Not q2)) y2)"
| "models3 (Not (Not p2)) y2 = models3 p2 y2"
| "models3 (Not (Var x2)) y2 =
     (if (~ (or2 (models4 x2 y2))) then
        cons2 (cons2 (pair2 x2 False) (models5 x2 y2)) (nil2)
        else
        nil2)"
| "models3 (Var x3) y2 =
     (if (~ (or2 (models6 x3 y2))) then
        cons2 (cons2 (pair2 x3 True) (models7 x3 y2)) (nil2)
        else
        nil2)"
  by pat_completeness auto

fun valid :: "Form => bool" where
  "valid z =
   (case models3 (Not z) (nil2) of
      nil2 => True
      | cons2 y2 z2 => False)"

theorem property0 :
  "((valid (x p q)) = (valid (x q p)))"
  oops

end


theory nat_acc_alt_mul_comm
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

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

fun accaltmul :: "Nat => Nat => Nat" where
"accaltmul (Z) y = Z"
| "accaltmul (S z) (Z) = Z"
| "accaltmul (S z) (S x2) =
     S (accplus z (accplus x2 (accaltmul z x2)))"

(*hipster accplus accaltmul *)

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

end


theory invariant
imports mem_spec "HOL-Eisbach.Eisbach_Tools" (*"~~/src/HOL/Word/Word"*)
begin

text\<open>
this theory defines the invariant and its lemmas.
\<close>

section \<open>invariants\<close>

subsection \<open>defs of invariants\<close>
text\<open>
we consider multi-threaded execution on mono-core.
A thread is the currently executing thread iff it is in RUNNING state.
\<close>
definition inv_cur :: "State \<Rightarrow> bool"
where "inv_cur s \<equiv> \<forall>t. cur s = Some t \<longleftrightarrow> thd_state s t = RUNNING"

abbreviation dist_list :: "'a list \<Rightarrow> bool"
where "dist_list l \<equiv> \<forall>i j. i < length l \<and> j < length l \<and> i \<noteq> j \<longrightarrow> l!i \<noteq> l!j"                      \<comment> \<open> elements in a list are different with each other    \<close>

text\<open>
the relation of thread state and wait queue.
here we dont consider other modules of zephyr, so blocked thread is in wait que of mailboxs.
\<close>
definition inv_thd_waitq :: "State \<Rightarrow> bool"
where "inv_thd_waitq s \<equiv>
  (\<forall>p\<in>OSMailBoxs s. \<forall>t\<in> set (wait_q (OSMailbox_info s p)). thd_state s t = BLOCKED)                 \<comment> \<open> thread in waitq is BLOCKED    \<close>
 \<and> (\<forall>t. thd_state s t = BLOCKED \<longrightarrow> (\<exists>p\<in>OSMailBoxs s. t \<in> set (wait_q (OSMailbox_info s p))))       \<comment> \<open> BLOCKED thread is in a waitq    \<close>
 \<and> (\<forall>p\<in>OSMailBoxs s. dist_list (wait_q (OSMailbox_info s p)))                                  \<comment> \<open>  threads in a waitq are different with each other, which means
                                                                                a thread could not waiting for the same pool two times    \<close>
 \<and> (\<forall>p q. p\<in>OSMailBoxs s \<and> q\<in>OSMailBoxs s \<and> p \<noteq> q \<longrightarrow> (\<nexists>t. t \<in> set (wait_q (OSMailbox_info s p))
                                                  \<and> t\<in> set (wait_q (OSMailbox_info s q))))"       \<comment> \<open>threads of two waitqs are different, which means
                                                                                a thread could not waiting for two pools    \<close>

definition inv_thd_waitq_mid :: "State \<Rightarrow>Thread \<Rightarrow> bool"
where "inv_thd_waitq_mid s tx \<equiv>
  (\<forall>p\<in>OSMailBoxs s. \<forall>t\<in> set (wait_q (OSMailbox_info s p)). thd_state s t = BLOCKED)                 \<comment> \<open> thread in waitq is BLOCKED    \<close>
 \<and>(\<forall>t \<noteq> tx. thd_state s t = BLOCKED \<longrightarrow> (\<exists>p\<in>OSMailBoxs s. t \<in> set (wait_q (OSMailbox_info s p))))       \<comment> \<open> BLOCKED thread is in a waitq    \<close>
 \<and> (\<forall>p\<in>OSMailBoxs s. dist_list (wait_q (OSMailbox_info s p)))                                  \<comment> \<open>  threads in a waitq are different with each other, which means
                                                                                a thread could not waiting for the same pool two times    \<close>
 \<and> (\<forall>p q. p\<in>OSMailBoxs s \<and> q\<in>OSMailBoxs s \<and> p \<noteq> q \<longrightarrow> (\<nexists>t. t \<in> set (wait_q (OSMailbox_info s p))
                                                  \<and> t\<in> set (wait_q (OSMailbox_info s q))))"       \<comment> \<open>threads of two waitqs are different, which means
                                                                                a thread could not waiting for two pools    \<close>

definition inv_thd_waitq_mid0 :: "State  \<Rightarrow> bool"
where "inv_thd_waitq_mid0 s  \<equiv>
  (\<forall>p\<in>OSMailBoxs s. \<forall>t\<in> set (wait_q (OSMailbox_info s p)). thd_state s t = BLOCKED)
 \<and> (\<forall>p\<in>OSMailBoxs s. dist_list (wait_q (OSMailbox_info s p)))
 \<and> (\<forall>p q. p\<in>OSMailBoxs s \<and> q\<in>OSMailBoxs s \<and> p \<noteq> q \<longrightarrow> (\<nexists>t. t \<in> set (wait_q (OSMailbox_info s p))
                                                  \<and> t\<in> set (wait_q (OSMailbox_info s q)))) "

definition inv_thd_waitq_mid1 :: "State \<Rightarrow>Thread  \<Rightarrow> bool"
where "inv_thd_waitq_mid1 s tx \<equiv>
  \<forall>t \<noteq> tx. thd_state s t = BLOCKED \<longrightarrow> (\<exists>p\<in>OSMailBoxs s. t \<in> set (wait_q (OSMailbox_info s p)))
 \<and> thd_state s tx = BLOCKED "

definition inv_thd_waitq_mid2 :: "State \<Rightarrow>Thread  \<Rightarrow> bool"
where "inv_thd_waitq_mid2 s tx \<equiv>
 ( \<forall>t \<noteq> tx. thd_state s t = BLOCKED \<longrightarrow> (\<exists>p\<in>OSMailBoxs s. t \<in> set (wait_q (OSMailbox_info s p))))
 \<and> thd_state s tx = READY "

definition inv_thd_waitq_mid3 :: "State \<Rightarrow> bool"                   (* inv_thd_waiq = inv_thd_waitq_mid0 + inv_thd_waitq_mid3 *)
where "inv_thd_waitq_mid3 s  \<equiv>
  (\<forall>t . thd_state s t = BLOCKED \<longrightarrow> (\<exists>p\<in>OSMailBoxs s. t \<in> set (wait_q (OSMailbox_info s p))))"

definition inv_thd_waitq_mid4 :: "State \<Rightarrow>Thread  \<Rightarrow> bool"         (* inv_thd_waiq_mid4 = inv_thd_waitq_mid0 + inv_thd_waitq_mid1 *)
where "inv_thd_waitq_mid4 s tx \<equiv>
 ( \<forall>t \<noteq> tx. thd_state s t = BLOCKED \<longrightarrow> (\<exists>p\<in>OSMailBoxs s. t \<in> set (wait_q (OSMailbox_info s p))))
 \<and> thd_state s tx = BLOCKED \<and> (\<forall>p\<in>OSMailBoxs s. tx \<notin>  set (wait_q (OSMailbox_info s p)))
 \<and> (\<forall>p\<in>OSMailBoxs s. \<forall>t\<in> set (wait_q (OSMailbox_info s p)). thd_state s t = BLOCKED)
 \<and> (\<forall>p\<in>OSMailBoxs s. dist_list (wait_q (OSMailbox_info s p)))
 \<and> (\<forall>p q. p\<in>OSMailBoxs s \<and> q\<in>OSMailBoxs s \<and> p \<noteq> q \<longrightarrow> (\<nexists>t. t \<in> set (wait_q (OSMailbox_info s p))
                                                  \<and> t\<in> set (wait_q (OSMailbox_info s q)))) "

definition inv_thd_waitq_midx :: "State \<Rightarrow>Thread  \<Rightarrow> bool"         (* inv_thd_waiq_mid4 = inv_thd_waitq_mid0 + inv_thd_waitq_mid1 *)
where "inv_thd_waitq_midx s tx \<equiv>
 ( \<forall>t \<noteq> tx. thd_state s t = BLOCKED \<longrightarrow> (\<exists>p\<in>OSMailBoxs s. t \<in> set (wait_q (OSMailbox_info s p))))
 \<and> (\<forall>p\<in>OSMailBoxs s. \<forall>t\<in> set (wait_q (OSMailbox_info s p)). thd_state s t = BLOCKED)
 \<and> (\<forall>p\<in>OSMailBoxs s. dist_list (wait_q (OSMailbox_info s p)))
 \<and> (\<forall>p q. p\<in>OSMailBoxs s \<and> q\<in>OSMailBoxs s \<and> p \<noteq> q \<longrightarrow> (\<nexists>t. t \<in> set (wait_q (OSMailbox_info s p))
                                                  \<and> t\<in> set (wait_q (OSMailbox_info s q)))) "

lemma waitq_to_waitq_midx:"pevent \<in> OSMailBoxs V \<Longrightarrow> inv_thd_waitq V \<Longrightarrow> inv_thd_waitq_midx V (hd(wait_q (OSMailbox_info V pevent)))"
  apply(simp add:inv_thd_waitq_def inv_thd_waitq_midx_def)
  apply auto
  done

definition inv_thd_waitq_mid5 :: "State \<Rightarrow>Thread  \<Rightarrow> bool"                 (* inv_thd_waiq_mid5 = inv_thd_waitq_mid0 + inv_thd_waitq_mid2 *)
where "inv_thd_waitq_mid5 s tx \<equiv>
 ( \<forall>t \<noteq> tx. thd_state s t = BLOCKED \<longrightarrow> (\<exists>p\<in>OSMailBoxs s. t \<in> set (wait_q (OSMailbox_info s p))))
 \<and> thd_state s tx = READY
 \<and> (\<forall>p\<in>OSMailBoxs s. \<forall>t\<in> set (wait_q (OSMailbox_info s p)). thd_state s t = BLOCKED)
 \<and> (\<forall>p\<in>OSMailBoxs s. dist_list (wait_q (OSMailbox_info s p)))
 \<and> (\<forall>p q. p\<in>OSMailBoxs s \<and> q\<in>OSMailBoxs s \<and> p \<noteq> q \<longrightarrow> (\<nexists>t. t \<in> set (wait_q (OSMailbox_info s p))
                                                  \<and> t\<in> set (wait_q (OSMailbox_info s q)))) "

definition inv_thd_waitq_mid6 :: "State \<Rightarrow>Thread  \<Rightarrow> bool"                 (* inv_thd_waiq_mid5 = inv_thd_waitq_mid0 + inv_thd_waitq_mid2 *)
where "inv_thd_waitq_mid6 s tx \<equiv>
 ( \<forall>t \<noteq> tx. thd_state s t = BLOCKED \<longrightarrow> (\<exists>p\<in>OSMailBoxs s. t \<in> set (wait_q (OSMailbox_info s p))))
 \<and> thd_state s tx = READY
 \<and> (\<forall>p\<in>OSMailBoxs s. \<forall>t\<in> set (wait_q (OSMailbox_info s p)). t\<noteq>tx \<longrightarrow> thd_state s t = BLOCKED)
 \<and> (\<forall>p\<in>OSMailBoxs s. dist_list (wait_q (OSMailbox_info s p)))
 \<and> (\<forall>p q. p\<in>OSMailBoxs s \<and> q\<in>OSMailBoxs s \<and> p \<noteq> q \<longrightarrow> (\<nexists>t. t \<in> set (wait_q (OSMailbox_info s p))
                                                  \<and> t\<in> set (wait_q (OSMailbox_info s q)))) "

lemma sad:"\<forall>t tx s. inv_thd_waitq_mid5 s tx \<Longrightarrow> \<forall>s. inv_thd_waitq s"
  apply(simp add:inv_thd_waitq_mid6_def inv_thd_waitq_def)apply auto

lemma mid2_to_mid3:"\<forall>t tx s. inv_thd_waitq_mid2 s tx \<and> inv_thd_waitq_mid0 s  \<Longrightarrow> \<forall>s . inv_thd_waitq_mid3 s \<and> inv_thd_waitq_mid0 s \<Longrightarrow>  \<forall>s. inv_thd_waitq s"
  apply(simp add:inv_thd_waitq_def inv_thd_waitq_mid_def inv_thd_waitq_mid2_def inv_thd_waitq_mid3_def inv_thd_waitq_mid0_def)
  done

lemma mid:"\<forall>t tx s. inv_thd_waitq_mid5 s tx \<Longrightarrow> \<forall>t s. inv_thd_waitq s"
  apply(simp add:inv_thd_waitq_mid5_def inv_thd_waitq_def mid2_to_mid3)
  apply(metis (full_types) Thread_State_Type.distinct(3) length_greater_0_conv nth_mem)
  done

lemma mid2:"\<forall>t x. inv_thd_waitq x \<Longrightarrow> \<forall>t x pevent. pevent \<in> OSMailBoxs x\<longrightarrow> inv_thd_waitq x\<lparr>OSMailbox_info := (OSMailbox_info x)(pevent := OSMailbox_info x pevent\<lparr>wait_q := tl (wait_q (OSMailbox_info x pevent))\<rparr>)\<rparr>"

definition inv :: "State \<Rightarrow> bool"
where "inv s \<equiv> inv_cur s \<and> inv_thd_waitq s"

method simp_inv = (simp add:inv_def  inv_thd_waitq_def)

method unfold_inv = (unfold inv_def inv_thd_waitq_def inv_cur_def)[1]

subsection \<open>initial state $s_0$\<close>

text\<open>
we dont consider mailbox_init, only define s0 to show the state after memory pool initialization.
\<close>
axiomatization s0::State where
  s0a1: "cur s0 = None" and
  s0a2: "tick s0 = 0" and
  s0a3: "thd_state s0 = (\<lambda>t. READY)" and
  s0a4: "OSMailBoxs s0 \<noteq> {}" and
  s0a5: "\<forall>p\<in>OSMailBoxs s0. wait_q (OSMailbox_info s0 p) = []" and
  s0a6: "\<forall>p\<in>OSMailBoxs s0. let mp = OSMailbox_info s0 p in  msgPtr mp = None"

lemma s0_inv_cur: "inv_cur s0"
  apply (simp add: inv_cur_def)
  apply (simp add: s0a1 s0a3)
  done

lemma s0_inv_thd_waitq: "inv_thd_waitq s0"
  apply(simp add: inv_thd_waitq_def)
  apply(simp add: s0a1 s0a2 s0a3 s0a4 s0a5)
  done

lemma s0_inv: "inv s0"
  apply(unfold inv_def)
  using s0_inv_cur apply simp
  using s0_inv_thd_waitq apply simp
  done

(*====================================================================*)
lemma sat:"stable {s. inv s} {(s,t). inv s \<longrightarrow> inv t} "
  apply(simp add:stable_def)
  done

lemma asdtt:"stable A C \<Longrightarrow> B \<subseteq> C \<Longrightarrow> stable A B"
  apply(simp add:stable_def)
  apply auto
  done

lemma tt:"\<Gamma> (Event) \<turnstile> RG[A,B,C,D] \<Longrightarrow> R\<subseteq>B \<Longrightarrow> \<Gamma> (Event) \<turnstile> RG[A,R,C,D]"
  apply (simp add:Evt_sat_RG_def)
  apply(simp add:Pre\<^sub>f_def Post\<^sub>f_def guard_def
                 Rely\<^sub>f_def Guar\<^sub>f_def getrgformula_def)
  by (metis Evt_conseq order_refl)
(*\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>\<comment>*)
term "UNIV"
lemma testq:"\<lbrace>True\<rbrace> = UNIV"
  apply auto
  done
lemma tst:"stable \<lbrace>True\<rbrace> \<lbrace>True\<rbrace>"
  apply auto
  apply(simp add:stable_def)
  done
(*{(s,t). s = t} \<equiv> Id"*)
lemma tst2:"{(s,t). s = t} = Id"
  apply auto
  done
(*=====================================================================*)

end


section \<open>Preliminaries\<close>

(*<*)
theory Preliminaries
imports "List-Index.List_Index"
begin
(*>*)

subsection \<open>Iterated Function Update\<close>

abbreviation fun_upds ("_[_ :=\<^sup>* _]" [90, 0, 0] 91) where
  "f[xs :=\<^sup>* ys] \<equiv> fold (\<lambda>(x, y) f. f(x := y)) (zip xs ys) f"

fun restrict where
  "restrict A (x # xs) (y # ys) = (if x \<in> A then y # restrict (A - {x}) xs ys else restrict A xs ys)"
| "restrict A _ _ = []"

fun extend :: "nat set \<Rightarrow> nat list \<Rightarrow> 'a list \<Rightarrow> 'a list set" where
  "extend A (x # xs) ys = (if x \<in> A
     then (\<Union>zs \<in> extend (A - {x}) xs (tl ys). {hd ys # zs})
     else (\<Union>z \<in> UNIV. \<Union>zs \<in> extend A xs ys. {z # zs}))"
| "extend A _ _ = {[]}"

fun lookup where
  "lookup (x # xs) (y # ys) z = (if x = z then y else lookup xs ys z)"
| "lookup _ _ _ = undefined"

lemma extend_nonempty: "extend A xs ys \<noteq> {}"
  by (induct xs arbitrary: A ys) auto

lemma length_extend: "zs \<in> extend A xs ys \<Longrightarrow> length zs = length xs"
  by (induct xs arbitrary: A ys zs) (auto split: if_splits)

lemma ex_lookup_extend: "x \<notin> A \<Longrightarrow> x \<in> set xs \<Longrightarrow> \<exists>zs \<in> extend A xs ys. lookup xs zs x = d"
proof (induct xs arbitrary: A ys)
  case (Cons a xs)
  from Cons(1)[of "A - {a}" "tl ys"] Cons(1)[of A ys] Cons(2-) show ?case
    by (auto simp: ex_in_conv extend_nonempty)
qed simp

lemma restrict_extend: "A \<subseteq> set xs \<Longrightarrow> length ys = card A \<Longrightarrow> zs \<in> extend A xs ys \<Longrightarrow> restrict A xs zs = ys"
proof (induct xs arbitrary: A ys zs)
  case (Cons a xs)
  then have "finite A"
    by (elim finite_subset) auto
  with Cons(1)[of "A - {a}" "tl ys" "tl zs"] Cons(1)[of A ys "tl zs"] Cons(2-) show ?case
    by (cases ys) (auto simp: subset_insert_iff split: if_splits)
qed simp

lemma fun_upds_notin[simp]: "length xs = length ys \<Longrightarrow> x \<notin> set xs \<Longrightarrow> (\<sigma>[xs :=\<^sup>* ys]) x = \<sigma> x"
  by (induct xs ys arbitrary: \<sigma> rule: list_induct2) auto

lemma fun_upds_twist: "length xs = length ys \<Longrightarrow> a \<notin> set xs \<Longrightarrow> \<sigma>(a := x)[xs :=\<^sup>* ys] = (\<sigma>[xs :=\<^sup>* ys])(a := x)"
  by (induct xs ys arbitrary: \<sigma> rule: list_induct2) (auto simp: fun_upd_twist)

lemma fun_upds_twist_apply: "length xs = length ys \<Longrightarrow> a \<notin> set xs \<Longrightarrow> a \<noteq> b \<Longrightarrow> (\<sigma>(a := x)[xs :=\<^sup>* ys]) b = (\<sigma>[xs :=\<^sup>* ys]) b"
  by (induct xs ys arbitrary: \<sigma> rule: list_induct2) (auto simp: fun_upd_twist)

lemma fun_upds_extend:
  "x \<in> A \<Longrightarrow> A \<subseteq> set xs \<Longrightarrow> distinct xs \<Longrightarrow> sorted xs \<Longrightarrow> length ys = card A \<Longrightarrow> zs \<in> extend A xs ys \<Longrightarrow>
    (\<sigma>[xs :=\<^sup>* zs]) x = (\<sigma>[sorted_list_of_set A :=\<^sup>* ys]) x"
proof (induct xs arbitrary: A ys zs \<sigma>)
  case (Cons a xs)
  then have fin[simp]: "finite A"
    by (elim finite_subset) auto
  from Cons(2-) have "a \<in> A \<Longrightarrow> Min A = a" if "a \<in> A"
    by (intro Min_eqI) auto
  with Cons(2) fin have *: "a \<in> A \<Longrightarrow> sorted_list_of_set A = a # sorted_list_of_set (A - {a})"
    by (subst sorted_list_of_set_nonempty) auto
  show ?case
    using Cons(1)[of "A - {a}" "tl ys"] Cons(1)[of A ys] Cons(2-)
    by (cases ys; cases "x = a")
      (auto simp add: subset_insert_iff * fun_upds_twist_apply length_extend simp del: fun_upd_apply split: if_splits)
qed simp

lemma fun_upds_map_self: "\<sigma>[xs :=\<^sup>* map \<sigma> xs] = \<sigma>"
  by (induct xs arbitrary: \<sigma>) auto

lemma fun_upds_single: "distinct xs \<Longrightarrow> \<sigma>[xs :=\<^sup>* map (\<sigma>(y := d)) xs] = (if y \<in> set xs then \<sigma>(y := d) else \<sigma>)"
  by (induct xs arbitrary: \<sigma>) (auto simp: fun_upds_twist)

subsection \<open>Lists and Sets\<close>

lemma find_index_less_size: "\<exists>x \<in> set xs. P x \<Longrightarrow> find_index P xs < size xs"
  by (induct xs) auto

lemma index_less_size: "x \<in> set xs \<Longrightarrow> index xs x < size xs"
  by (simp add: index_def find_index_less_size)

lemma fun_upds_in: "length xs = length ys \<Longrightarrow> distinct xs \<Longrightarrow> x \<in> set xs \<Longrightarrow> (\<sigma>[xs :=\<^sup>* ys]) x = ys ! index xs x"
  by (induct xs ys arbitrary: \<sigma> rule: list_induct2) auto

lemma remove_nth_index: "remove_nth (index ys y) ys = remove1 y ys"
  by (induct ys) auto

lemma index_remove_nth: "distinct xs \<Longrightarrow> x \<in> set xs \<Longrightarrow> index (remove_nth i xs) x = (if index xs x < i then index xs x else if i = index xs x then length xs - 1 else index xs x - 1)"
  by (induct i xs rule: remove_nth.induct) (auto simp: not_less intro!: Suc_pred split: if_splits)

lemma insert_nth_nth_index:
  "y \<noteq> z \<Longrightarrow> y \<in> set ys \<Longrightarrow> z \<in> set ys \<Longrightarrow> length ys = Suc (length xs) \<Longrightarrow> distinct ys \<Longrightarrow>
  insert_nth (index ys y) x xs ! index ys z =
  xs ! index (remove1 y ys) z"
  by (subst nth_insert_nth;
      auto simp: remove_nth_index[symmetric] index_remove_nth dest: index_less_size intro!: arg_cong[of _ _ "nth xs"] index_eqI)

lemma index_lt_index_remove: "index xs x < index xs y \<Longrightarrow> index xs x = index (remove1 y xs) x"
  by (induct xs) auto

lemma index_gt_index_remove: "index xs x > index xs y \<Longrightarrow> index xs x = Suc (index (remove1 y xs) x)"
proof (induct xs)
  case (Cons z xs)
  then show ?case
    by (cases "z = x") auto
qed simp

lemma lookup_map[simp]: "x \<in> set xs \<Longrightarrow> lookup xs (map f xs) x = f x"
  by (induct xs) auto

lemma in_set_remove_cases: "P z \<Longrightarrow> (\<forall>x \<in> set (remove1 z xs). P x) \<Longrightarrow> x \<in> set xs \<Longrightarrow> P x"
  by (cases "x = z") auto

lemma insert_remove_id: "x \<in> X \<Longrightarrow> X = insert x (X - {x})"
  by auto

lemma infinite_surj: "infinite A \<Longrightarrow> A \<subseteq> f ` B \<Longrightarrow> infinite B"
  by (elim contrapos_nn finite_surj)

class infinite =
  fixes to_nat :: "'a \<Rightarrow> nat"
  assumes surj_to_nat: "surj to_nat"
begin

lemma infinite_UNIV: "infinite (UNIV :: 'a set)"
  using surj_to_nat by (intro infinite_surj[of UNIV to_nat]) auto

end

instantiation nat :: infinite begin
definition to_nat_nat :: "nat \<Rightarrow> nat" where "to_nat_nat = id"
instance by standard (auto simp: to_nat_nat_def)
end

instantiation list :: (type) infinite begin
definition to_nat_list :: "'a list \<Rightarrow> nat" where "to_nat_list = length"
instance by standard (auto simp: image_iff to_nat_list_def intro!: exI[of _ "replicate _ _"])
end

subsection \<open>Equivalence Closure and Classes\<close>

definition symcl where
  "symcl r = {(x, y). (x, y) \<in> r \<or> (y, x) \<in> r}"

definition transymcl where
  "transymcl r = trancl (symcl r)"

lemma symclp_symcl_eq[pred_set_conv]: "symclp (\<lambda>x y. (x, y) \<in> r) = (\<lambda>x y. (x, y) \<in> symcl r)"
  by (auto simp: symclp_def symcl_def fun_eq_iff)

definition "classes Qeq = quotient (Field Qeq) (transymcl Qeq)"

lemma Field_symcl[simp]: "Field (symcl r) = Field r"
  unfolding symcl_def Field_def by auto

lemma Domain_symcl[simp]: "Domain (symcl r) = Field r"
  unfolding symcl_def Field_def by auto

lemma Field_trancl[simp]: "Field (trancl r) = Field r"
  unfolding Field_def by auto

lemma Field_transymcl[simp]: "Field (transymcl r) = Field r"
  unfolding transymcl_def by auto

lemma eqclass_empty_iff[simp]: "r `` {x} = {} \<longleftrightarrow> x \<notin> Domain r"
  by auto

lemma sym_symcl[simp]: "sym (symcl r)"
  unfolding symcl_def sym_def by auto

lemma in_symclI:
  "(a,b) \<in> r \<Longrightarrow> (a,b) \<in> symcl r"
  "(a,b) \<in> r \<Longrightarrow> (b,a) \<in> symcl r"
  by (auto simp: symcl_def)

lemma sym_transymcl: "sym (transymcl r)"
  by (simp add: sym_trancl transymcl_def)

lemma symcl_insert:
  "symcl (insert (x, y) Qeq) = insert (y, x) (insert (x, y) (symcl Qeq))"
  by (auto simp: symcl_def)

lemma equiv_transymcl: "Equiv_Relations.equiv (Field Qeq) (transymcl Qeq)"
  by (auto simp: Equiv_Relations.equiv_def sym_trancl refl_on_def transymcl_def
    dest: FieldI1 FieldI2 Field_def[THEN equalityD1, THEN set_mp]
    intro: r_r_into_trancl[of x _ _ x for x]  elim!: in_symclI)

lemma equiv_quotient_no_empty_class: "Equiv_Relations.equiv A r \<Longrightarrow> {} \<notin> A // r"
  by (auto simp: quotient_def refl_on_def sym_def Equiv_Relations.equiv_def)

lemma classes_cover: "\<Union>(classes Qeq) = Field Qeq"
  by (simp add: Union_quotient classes_def equiv_transymcl)

lemma classes_disjoint: "X \<in> classes Qeq \<Longrightarrow> Y \<in> classes Qeq \<Longrightarrow> X = Y \<or> X \<inter> Y = {}"
  using quotient_disj[OF equiv_transymcl]
  by (auto simp: classes_def)

lemma classes_nonempty: "{} \<notin> classes Qeq"
  using equiv_quotient_no_empty_class[OF equiv_transymcl]
  by (auto simp: classes_def)

definition "class x Qeq = (if \<exists>X \<in> classes Qeq. x \<in> X then Some (THE X. X \<in> classes Qeq \<and> x \<in> X) else None)"

lemma class_Some_eq: "class x Qeq = Some X \<longleftrightarrow> X \<in> classes Qeq \<and> x \<in> X"
  unfolding class_def
  by (auto 0 3 dest: classes_disjoint del: conjI intro!: the_equality[of _ X]
   conjI[of "(\<exists>X\<in>classes Qeq. x \<in> X)"] intro: theI[where P="\<lambda>X. X \<in> classes Qeq \<and> x \<in> X"])

lemma class_None_eq: "class x Qeq = None \<longleftrightarrow> x \<notin> Field Qeq"
  by (simp add: class_def classes_cover[symmetric] split: if_splits)

lemma insert_Image_triv: "x \<notin> r \<Longrightarrow> insert (x, y) Qeq `` r = Qeq `` r"
  by auto

lemma Un1_Image_triv: "Domain B \<inter> r = {} \<Longrightarrow> (A \<union> B) `` r = A `` r"
  by auto

lemma Un2_Image_triv: "Domain A \<inter> r = {} \<Longrightarrow> (A \<union> B) `` r = B `` r"
  by auto

lemma classes_empty: "classes {} = {}"
  unfolding classes_def by auto

lemma ex_class: "x \<in> Field Qeq \<Longrightarrow> \<exists>X. class x Qeq = Some X \<and> x \<in> X"
  by (metis Union_iff class_Some_eq classes_cover)

lemma equivD:
  "Equiv_Relations.equiv A r \<Longrightarrow> refl_on A r"
  "Equiv_Relations.equiv A r \<Longrightarrow> sym r"
  "Equiv_Relations.equiv A r \<Longrightarrow> trans r"
  by (blast elim: Equiv_Relations.equivE)+

lemma transymcl_into:
  "(x, y) \<in> r \<Longrightarrow> (x, y) \<in> transymcl r"
  "(x, y) \<in> r \<Longrightarrow> (y, x) \<in> transymcl r"
  unfolding transymcl_def by (blast intro: in_symclI r_into_trancl')+

lemma transymcl_self:
  "(x, y) \<in> r \<Longrightarrow> (x, x) \<in> transymcl r"
  "(x, y) \<in> r \<Longrightarrow> (y, y) \<in> transymcl r"
  unfolding transymcl_def by (blast intro: in_symclI(1) in_symclI(2) r_r_into_trancl)+

lemma transymcl_trans: "(x, y) \<in> transymcl r \<Longrightarrow> (y, z) \<in> transymcl r \<Longrightarrow> (x, z) \<in> transymcl r"
  using equiv_transymcl[THEN equivD(3), THEN transD] .

lemma transymcl_sym: "(x, y) \<in> transymcl r \<Longrightarrow> (y, x) \<in> transymcl r"
  using equiv_transymcl[THEN equivD(2), THEN symD] .

lemma edge_same_class: "X \<in> classes Qeq \<Longrightarrow> (a, b) \<in> Qeq \<Longrightarrow> a \<in> X \<longleftrightarrow> b \<in> X"
  unfolding classes_def by (elim quotientE) (auto elim!: transymcl_trans transymcl_into)

lemma Field_transymcl_self: "a \<in> Field Qeq \<Longrightarrow> (a, a) \<in> transymcl Qeq"
  by (auto simp: Field_def transymcl_def[symmetric] transymcl_self)

lemma transymcl_insert: "transymcl (insert (a, b) Qeq) = transymcl Qeq \<union> {(a,a),(b,b)} \<union>
   ((transymcl Qeq \<union> {(a, a), (b, b)}) O {(a, b), (b, a)} O (transymcl Qeq \<union> {(a, a), (b, b)}) - transymcl Qeq)"
  by (auto simp: relcomp_def relcompp_apply transymcl_def symcl_insert trancl_insert2 dest: trancl_trans)

lemma transymcl_insert_both_new: "a \<notin> Field Qeq \<Longrightarrow> b \<notin> Field Qeq \<Longrightarrow>
  transymcl (insert (a, b) Qeq) = transymcl Qeq \<union> {(a,a),(b,b),(a,b),(b,a)}"
  unfolding transymcl_insert
  by (auto dest: FieldI1 FieldI2)

lemma transymcl_insert_same_class: "(x, y) \<in> transymcl Qeq \<Longrightarrow> transymcl (insert (x, y) Qeq) = transymcl Qeq"
  by (auto 0 3 simp: transymcl_insert intro: transymcl_sym transymcl_trans)

lemma classes_insert: "classes (insert (x, y) Qeq) =
  (case (class x Qeq, class y Qeq) of
    (Some X, Some Y) \<Rightarrow> if X = Y then classes Qeq else classes Qeq - {X, Y} \<union> {X \<union> Y}
  | (Some X, None) \<Rightarrow> classes Qeq - {X} \<union> {insert y X}
  | (None, Some Y) \<Rightarrow> classes Qeq - {Y} \<union> {insert x Y}
  | (None, None) \<Rightarrow> classes Qeq \<union> {{x,y}})"
proof ((cases "class x Qeq"; cases "class y Qeq"), goal_cases NN NS SN SS)
  case NN
  then have "classes (insert (x, y) Qeq) = classes Qeq \<union> {{x, y}}"
    by (fastforce simp: class_None_eq classes_def transymcl_insert_both_new insert_Image_triv quotientI
      elim!: quotientE dest: FieldI1  intro: quotient_def[THEN Set.equalityD2, THEN set_mp] intro!: disjI1)
  with NN show ?case
    by auto
next
  case (NS Y)
  then have "insert x Y = transymcl (insert (x, y) Qeq) `` {x}"
    unfolding transymcl_insert using FieldI1[of x _ "transymcl Qeq"]
    relcompI[OF insertI1 relcompI[OF insertI1 insertI2[OF insertI2[OF transymcl_trans[OF transymcl_sym]]]],
      of _ y Qeq _ x x "insert (y,y) (transymcl Qeq)" "{(y,x)}" "(x, x)" "(y, y)"]
    by (auto simp: class_None_eq class_Some_eq classes_def
      dest: FieldI1 FieldI2 elim!: quotientE intro: transymcl_sym transymcl_trans)
  then have *: "insert x Y \<in> classes (insert (x, y) Qeq)"
    by (auto simp: class_None_eq class_Some_eq classes_def  intro!: quotientI)
  moreover from * NS have "Y \<notin> classes (insert (x, y) Qeq)"
    using classes_disjoint[of Y "insert (x, y) Qeq" "insert x Y"] classes_cover[of Qeq]
    by (auto simp: class_None_eq class_Some_eq)
  moreover {
    fix Z
    assume Z: "Z \<noteq> Y" "Z \<in> classes Qeq"
    then obtain z where z: "z \<in> Field Qeq" "Z = transymcl Qeq `` {z}"
      by (auto elim!: quotientE simp: classes_def)
    with NS Z have "z \<in> Z" "z \<noteq> x" "z \<noteq> y" "(z, x) \<notin> transymcl Qeq" "(z, y) \<notin> transymcl Qeq"
      using classes_disjoint[of Z "Qeq" Y] classes_nonempty[of Qeq]
      by (auto simp: class_None_eq class_Some_eq disjoint_iff Field_transymcl_self
        dest: FieldI2 intro: transymcl_trans)
    with NS Z * have "transymcl Qeq `` {z} = transymcl (insert (x, y) Qeq) `` {z}"
      unfolding transymcl_insert
      by (intro trans[OF _ Un1_Image_triv[symmetric]]) (auto simp: class_None_eq class_Some_eq)
    with z have "Z \<in> classes (insert (x, y) Qeq)"
      by (auto simp: classes_def intro!: quotientI)
  }
  moreover {
    fix Z
    assume Z: "Z \<noteq> insert x Y" "Z \<in> classes (insert (x, y) Qeq)"
    then obtain z where z: "z \<in> Field (insert (x, y) Qeq)" "Z = transymcl (insert (x, y) Qeq) `` {z}"
      by (auto elim!: quotientE simp: classes_def)
    with NS Z * have "z \<in> Z" "z \<noteq> x" "z \<noteq> y" "(z, x) \<notin> transymcl (insert (x, y) Qeq)" "(z, y) \<notin> transymcl (insert (x, y) Qeq)"
      using classes_disjoint[of Z "insert (x, y) Qeq" "insert x Y"] classes_nonempty[of "insert (x, y) Qeq"]
      by (auto simp: class_None_eq class_Some_eq Field_transymcl_self transymcl_into(2)
        intro: transymcl_trans)
    with NS Z * have "transymcl (insert (x, y) Qeq) `` {z} = transymcl Qeq `` {z}"
      unfolding transymcl_insert
      by (intro trans[OF Un1_Image_triv]) (auto simp: class_None_eq class_Some_eq)
    with z \<open>z \<noteq> x\<close> \<open>z \<noteq> y\<close> have "Z \<in> classes Qeq"
      by (auto simp: classes_def intro!: quotientI)
  }
  ultimately have "classes (insert (x, y) Qeq) = classes Qeq - {Y} \<union> {insert x Y}"
    by blast
  with NS show ?case
    by auto
next
  case (SN X)
  then have "insert y X = transymcl (insert (x, y) Qeq) `` {x}"
    unfolding transymcl_insert using FieldI1[of x _ "transymcl Qeq"]
    by (auto simp: class_None_eq class_Some_eq classes_def
      dest: FieldI1 FieldI2 elim!: quotientE intro: transymcl_sym transymcl_trans)
  then have *: "insert y X \<in> classes (insert (x, y) Qeq)"
    by (auto simp: class_None_eq class_Some_eq classes_def  intro!: quotientI)
  moreover from * SN have "X \<notin> classes (insert (x, y) Qeq)"
    using classes_disjoint[of X "insert (x, y) Qeq" "insert y X"] classes_cover[of Qeq]
    by (auto simp: class_None_eq class_Some_eq)
  moreover {
    fix Z
    assume Z: "Z \<noteq> X" "Z \<in> classes Qeq"
    then obtain z where z: "z \<in> Field Qeq" "Z = transymcl Qeq `` {z}"
      by (auto elim!: quotientE simp: classes_def)
    with SN Z have "z \<in> Z" "z \<noteq> x" "z \<noteq> y" "(z, x) \<notin> transymcl Qeq" "(z, y) \<notin> transymcl Qeq"
      using classes_disjoint[of Z "Qeq" X] classes_nonempty[of Qeq]
      by (auto simp: class_None_eq class_Some_eq disjoint_iff Field_transymcl_self
        dest: FieldI2 intro: transymcl_trans)
    with SN Z * have "transymcl Qeq `` {z} = transymcl (insert (x, y) Qeq) `` {z}"
      unfolding transymcl_insert
      by (intro trans[OF _ Un1_Image_triv[symmetric]]) (auto simp: class_None_eq class_Some_eq)
    with z have "Z \<in> classes (insert (x, y) Qeq)"
      by (auto simp: classes_def intro!: quotientI)
  }
  moreover {
    fix Z
    assume Z: "Z \<noteq> insert y X" "Z \<in> classes (insert (x, y) Qeq)"
    then obtain z where z: "z \<in> Field (insert (x, y) Qeq)" "Z = transymcl (insert (x, y) Qeq) `` {z}"
      by (auto elim!: quotientE simp: classes_def)
    with SN Z * have "z \<in> Z" "z \<noteq> x" "z \<noteq> y" "(z, x) \<notin> transymcl (insert (x, y) Qeq)" "(z, y) \<notin> transymcl (insert (x, y) Qeq)"
      using classes_disjoint[of Z "insert (x, y) Qeq" "insert y X"] classes_nonempty[of "insert (x, y) Qeq"]
      by (auto simp: class_None_eq class_Some_eq Field_transymcl_self transymcl_into(2)
        intro: transymcl_trans)
    with SN Z * have "transymcl (insert (x, y) Qeq) `` {z} = transymcl Qeq `` {z}"
      unfolding transymcl_insert
      by (intro trans[OF Un1_Image_triv]) (auto simp: class_None_eq class_Some_eq)
    with z \<open>z \<noteq> x\<close> \<open>z \<noteq> y\<close> have "Z \<in> classes Qeq"
      by (auto simp: classes_def intro!: quotientI)
  }
  ultimately have "classes (insert (x, y) Qeq) = classes Qeq - {X} \<union> {insert y X}"
    by blast
  with SN show ?case
    by auto
next
  case (SS X Y)
  moreover from SS have XY: "X \<in> classes Qeq" "Y \<in> classes Qeq" "x \<in> X" "y \<in> Y" "x \<in> Field Qeq" "y \<in> Field Qeq"
    using class_None_eq[of x Qeq] class_None_eq[of y Qeq] class_Some_eq[of x Qeq X] class_Some_eq[of y Qeq Y]
    by auto
  moreover from XY have "X = Y \<Longrightarrow> classes (insert (x, y) Qeq) = classes Qeq"
    unfolding classes_def
    by (subst transymcl_insert_same_class)
      (auto simp: classes_def insert_absorb elim!: quotientE intro: transymcl_sym transymcl_trans)
  moreover
  {
    assume neq: "X \<noteq> Y"
    from XY have "X = transymcl Qeq `` {x}" "Y = transymcl Qeq `` {y}"
      by (auto simp: classes_def elim!: quotientE intro: transymcl_sym transymcl_trans)
    with XY have XY_eq:
      "X \<union> Y = transymcl (insert (x, y) Qeq) `` {x}"
      "X \<union> Y = transymcl (insert (x, y) Qeq) `` {y}"
      unfolding transymcl_insert by auto
    then have *: "X \<union> Y \<in> classes (insert (x, y) Qeq)"
      by (auto simp: classes_def quotientI)
    moreover
    from * XY neq have **: "X \<notin> classes (insert (x, y) Qeq)" "Y \<notin> classes (insert (x, y) Qeq)"
      using classes_disjoint[OF *, of X] classes_disjoint[OF *, of Y] classes_disjoint[of X Qeq Y]
      by auto
    moreover {
      fix Z
      assume Z: "Z \<noteq> X" "Z \<noteq> Y" "Z \<in> classes Qeq"
      then obtain z where z: "z \<in> Field Qeq" "Z = transymcl Qeq `` {z}"
        by (auto elim!: quotientE simp: classes_def)
      with XY Z have "z \<in> Z" "z \<noteq> x" "z \<noteq> y" "(z, x) \<notin> transymcl Qeq" "(z, y) \<notin> transymcl Qeq"
        using classes_disjoint[of Z Qeq X] classes_disjoint[of Z Qeq Y] classes_nonempty[of Qeq]
        by (auto simp: disjoint_iff Field_transymcl_self dest: FieldI2 intro: transymcl_trans)
      with XY Z * have "transymcl Qeq `` {z} = transymcl (insert (x, y) Qeq) `` {z}"
        unfolding transymcl_insert
        by (intro trans[OF _ Un1_Image_triv[symmetric]]) (auto simp: class_None_eq class_Some_eq)
      with z have "Z \<in> classes (insert (x, y) Qeq)"
        by (auto simp: classes_def intro!: quotientI)
    }
    moreover {
      fix Z
      assume Z: "Z \<noteq> X \<union> Y" "Z \<in> classes (insert (x, y) Qeq)"
      then obtain z where z: "z \<in> Field (insert (x, y) Qeq)" "Z = transymcl (insert (x, y) Qeq) `` {z}"
        by (auto elim!: quotientE simp: classes_def)
      with XY Z neq XY_eq have "z \<in> Z" "z \<noteq> x" "z \<noteq> y" "(z, x) \<notin> transymcl (insert (x, y) Qeq)" "(z, y) \<notin> transymcl (insert (x, y) Qeq)"
        using classes_disjoint[OF *, of Z] classes_disjoint[of X Qeq Y]
        by (auto simp: Field_transymcl_self)
      with XY Z * have "transymcl (insert (x, y) Qeq) `` {z} = transymcl Qeq `` {z}"
        unfolding transymcl_insert
        by (intro trans[OF Un1_Image_triv]) (auto simp: class_None_eq class_Some_eq)
      with z \<open>z \<noteq> x\<close> \<open>z \<noteq> y\<close> have "Z \<in> classes Qeq"
        by (auto simp: classes_def intro!: quotientI)
    }
    ultimately have "classes (insert (x, y) Qeq) = classes Qeq - {X, Y} \<union> {X \<union> Y}"
      by blast
  }
  ultimately show ?case
    by auto
qed

lemma classes_intersect_find_not_None:
  assumes "\<forall>V\<in>classes (set xys). V \<inter> A \<noteq> {}" "xys \<noteq> []"
  shows "find (\<lambda>(x, y). x \<in> A \<or> y \<in> A) xys \<noteq> None"
proof -
  from assms(2) obtain x y where "(x, y) \<in> set xys" by (cases xys) auto
  with assms(1) obtain X where x: "class x (set xys) = Some X" "X \<inter> A \<noteq> {}"
    using ex_class[of "x" "set xys"]
    by (auto simp: class_Some_eq Field_def)
  then obtain a where "a \<in> A" "a \<in> X"
    by blast
  with x have "(a, x) \<in> transymcl (set xys)"
    using equiv_class_eq[OF equiv_transymcl, of _ _ "set xys"]
    by (fastforce simp: class_Some_eq classes_def elim!: quotientE)
  then obtain b where "(a, b) \<in> symcl (set xys)"
    by (auto simp: transymcl_def elim: converse_tranclE)
  with \<open>a \<in> A\<close> show ?thesis
    by (auto simp: find_None_iff symcl_def)
qed

(*<*)
end
(*>*)


header{* The First Monotonicity Calculus  *}
theory Mcalc
imports Mono
begin

context ProblemIk begin

subsection{* Naked variables *}

fun nvT where
"nvT (Var x) = {x}"
|
"nvT (Fn f Tl) = {}"

fun nvA where
"nvA (Eq T1 T2) = nvT T1 \<union> nvT T2"
|
"nvA (Pr p Tl) = {}"

fun nvL where
"nvL (Pos at) = nvA at"
|
"nvL (Neg at) = {}"

definition "nvC c \<equiv> \<Union> set (map nvL c)"

definition "nvPB \<equiv> \<Union> c \<in> \<Phi>. nvC c"

lemma nvT_vars[simp]: "x \<in> nvT T \<Longrightarrow> x \<in> vars T"
by (induct T) (auto split: if_splits)

lemma nvA_varsA[simp]: "x \<in> nvA at \<Longrightarrow> x \<in> varsA at"
by (cases at, auto)

lemma nvL_varsL[simp]: "x \<in> nvL l \<Longrightarrow> x \<in> varsL l"
by (cases l, auto)

lemma nvC_varsC[simp]: "x \<in> nvC c \<Longrightarrow> x \<in> varsC c"
unfolding varsC_def nvC_def by(induct c, auto)

lemma nvPB_varsPB[simp]: "x \<in> nvPB \<Longrightarrow> x \<in> varsPB \<Phi>"
unfolding varsPB_def nvPB_def by auto

subsection{* The calculus *}

inductive mcalc (infix "\<turnstile>" 40) where
 [simp]: "infTp \<sigma> \<Longrightarrow> \<sigma> \<turnstile> c"
|[simp]: "(\<forall> x \<in> nvC c. tpOfV x \<noteq> \<sigma>) \<Longrightarrow> \<sigma> \<turnstile> c"

lemma mcalc_iff: "\<sigma> \<turnstile> c \<longleftrightarrow> infTp \<sigma> \<or> (\<forall> x \<in> nvC c. tpOfV x \<noteq> \<sigma>)"
unfolding mcalc.simps by simp

end (* context ProblemIk *)

locale ProblemIkMcalc = ProblemIk wtFsym wtPsym arOf resOf parOf \<Phi> infTp
for wtFsym :: "'fsym \<Rightarrow> bool" and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp
+ assumes mcalc: "\<And> \<sigma> c. c \<in> \<Phi> \<Longrightarrow> \<sigma> \<turnstile> c"

locale ModelIkMcalc =
ModelIk wtFsym wtPsym arOf resOf parOf \<Phi> infTp intT intF intP +
ProblemIkMcalc wtFsym wtPsym arOf resOf parOf \<Phi> infTp
for wtFsym :: "'fsym \<Rightarrow> bool" and wtPsym :: "'psym \<Rightarrow> bool"
and arOf :: "'fsym \<Rightarrow> 'tp list"
and resOf and parOf and \<Phi> and infTp and intT and intF and intP

subsection{* Extension of a structure to an infinite structure
by adding indistinguishable elements *}

context ModelIkMcalc begin

text{* The projection from univ to a structure: *}

definition proj where "proj \<sigma> a \<equiv> if intT \<sigma> a then a else pickT \<sigma>"

lemma intT_proj[simp]: "intT \<sigma> (proj \<sigma> a)"
unfolding proj_def using pickT by auto

lemma proj_id[simp]: "intT \<sigma> a \<Longrightarrow> proj \<sigma> a = a"
unfolding proj_def by auto

lemma surj_proj:
assumes "intT \<sigma> a"   shows "\<exists> b. proj \<sigma> b = a"
using assms by (intro exI[of _ a]) simp

definition "I_intT \<sigma> (a::univ) \<equiv> infTp \<sigma> \<longrightarrow> intT \<sigma> a"
definition "I_intF f al \<equiv> intF f (map2 proj (arOf f) al)"
definition "I_intP p al \<equiv> intP p (map2 proj (parOf p) al)"

lemma not_infTp_I_intT[simp]: "\<not> infTp \<sigma> \<Longrightarrow> I_intT \<sigma> a" unfolding I_intT_def by simp

lemma infTp_I_intT[simp]: "infTp \<sigma> \<Longrightarrow> I_intT \<sigma> a = intT \<sigma> a" unfolding I_intT_def by simp

lemma NE_I_intT: "NE (I_intT \<sigma>)"
using NE_intT by (cases "infTp \<sigma>", auto)

lemma I_intF:
assumes f: "wtFsym f" and al: "list_all2 I_intT (arOf f) al"
shows "I_intT (resOf f) (I_intF f al)"
unfolding I_intT_def I_intF_def apply safe apply(rule intF[OF f])
using al unfolding list_all2_length by auto

lemma Tstruct_I_intT: "Tstruct I_intT"
apply default using NE_I_intT .

lemma inf_I_intT: "infinite {a. I_intT \<sigma> a}"
by (cases "infTp \<sigma>", auto)

lemma InfStruct: "IInfStruct I_intT I_intF I_intP"
apply default using NE_I_intT I_intF Tstruct_I_intT inf_I_intT by auto

end (* context ModelIkMcalc *)

sublocale ModelIkMcalc < InfStruct where
intT = I_intT and intF = I_intF and intP = I_intP
using InfStruct .

subsection{* The soundness of the calculus *}

text{* In what follows, ``Ik'' stands for the original
(augmented with infiniteness-knowledge)
and ``I'' for the infinite structure constructed from it
through the above sublocale statement. *}

context ModelIkMcalc begin

text{* The environment translation along the projection: *}
definition "transE \<xi> \<equiv> \<lambda> x. proj (tpOfV x) (\<xi> x)"

lemma wtE_transE[simp]: "I.wtE \<xi> \<Longrightarrow> Ik.wtE (transE \<xi>)"
unfolding Ik.wtE_def I.wtE_def transE_def by auto

abbreviation "Ik_intT \<equiv> intT"
abbreviation "Ik_intF \<equiv> intF"
abbreviation "Ik_intP \<equiv> intP"

lemma Ik_intT_int:
assumes wt: "Ik.wt T" and \<xi>: "I.wtE \<xi>"
and snv: "\<And> \<sigma>. infTp \<sigma> \<or> (\<forall> x \<in> nvT T. tpOfV x \<noteq> \<sigma>)"
shows "Ik_intT (tpOf T) (I.int \<xi> T)"
proof(cases "\<exists> x. T = Var x")
  case True then obtain x where T: "T = Var x" by auto
  show ?thesis proof(cases "infTp (tpOf T)")
    case True thus ?thesis using T using wtE_transE[OF \<xi>]
    by (metis I.wt_int I_intT_def \<xi> wt)
  next
    case False hence "\<forall> x \<in> nvT T. tpOfV x \<noteq> tpOf T" using snv by auto
    hence "Ik.full (tpOf T)" using T by (cases T, simp_all)
    thus ?thesis unfolding Ik.full_def by simp
  qed
next
  case False hence nonVar: "\<not> (\<exists> x. T = Var x)" by (cases T, auto)
  thus ?thesis using nonVar wt apply(induct T, force)
  unfolding I_intF_def tpOf.simps int.simps
  apply(rule Ik.intF, simp) apply(rule listAll2_map2I) by auto
qed

lemma int_transE_proj:
assumes wt: "Ik.wt T"
shows "Ik.int (transE \<xi>) T = proj (tpOf T) (I.int \<xi> T)"
using wt proof (induct T)
  case (Fn f Tl)
  have 0: "Ik_intT (resOf f) (I_intF f (map (int \<xi>) Tl))" (is "Ik_intT ?\<sigma> ?a")
  unfolding I_intF_def apply(rule Ik.intF)
  using Fn unfolding list_all2_length list_all_iff by auto
  have 1: "proj ?\<sigma> ?a = ?a" using proj_id[OF 0] .
  show ?case
  unfolding Ik.int.simps int.simps tpOf.simps 1
  unfolding I_intF_def apply(rule arg_cong[of _ _ "intF f"])
  proof (rule nth_equalityI, safe)
    have l[simp]: "length (arOf f) = length Tl" using Fn by simp
    fix i assume "i < length (map (Ik.int (transE \<xi>)) Tl)"
    hence i[simp]: "i < length Tl" by simp
    have 0: "arOf f ! i = tpOf (Tl ! i)" using Fn by simp
    have [simp]: "Ik.int (transE \<xi>) (Tl ! i) = proj (arOf f ! i) (I.int \<xi> (Tl ! i))"
    unfolding 0 using Fn by (auto simp: list_all_length transE_def)
    show "map (Ik.int (transE \<xi>)) Tl ! i =
          map2 proj (arOf f) (map (I.int \<xi>) Tl) ! i"
    using Fn unfolding list_all_length by simp
  qed(insert Fn, simp)
qed simp

lemma int_transE_snv[simp]:
assumes wt: "Ik.wt T" and \<xi>: "I.wtE \<xi>" and snv: "\<And> \<sigma>. infTp \<sigma> \<or> (\<forall> x \<in> nvT T. tpOfV x \<noteq> \<sigma>)"
shows "Ik.int (transE \<xi>) T = I.int \<xi> T"
unfolding int_transE_proj[OF wt] apply(rule proj_id)
using Ik_intT_int[OF wt \<xi> snv] .

lemma int_transE_Fn:
assumes wt: "list_all wt Tl" and f: "wtFsym f" and \<xi>: "I.wtE \<xi>"
and ar: "arOf f = map tpOf Tl"
shows "Ik.int (transE \<xi>) (Fn f Tl) = I.int \<xi> (Fn f Tl)"
apply(rule int_transE_snv) using assms by auto

lemma intP_transE[simp]:
assumes wt: "list_all wt Tl" and p: "wtPsym p" and ar: "parOf p = map tpOf Tl"
shows "Ik_intP p (map (Ik.int (transE \<xi>)) Tl) = I_intP p (map (I.int \<xi>) Tl)"
unfolding I_intP_def apply(rule arg_cong[of _ _ "Ik_intP p"])
apply(rule nth_equalityI) using assms
using int_transE_proj unfolding list_all_length by auto

lemma satA_snvA_transE[simp]:
assumes wtA: "Ik.wtA at" and \<xi>: "I.wtE \<xi>"
and pA: "\<And> \<sigma>. infTp \<sigma> \<or> (\<forall> x \<in> nvA at. tpOfV x \<noteq> \<sigma>)"
shows "Ik.satA (transE \<xi>) at \<longleftrightarrow> I.satA \<xi> at"
using assms apply (cases at, simp_all add: ball_Un) by (metis int_transE_snv)

(* The next contrapositive twist is crucial for proving satL_transE: *)
lemma satA_transE[simp]:
assumes wtA: "Ik.wtA at" and "I.satA \<xi> at"
shows "Ik.satA (transE \<xi>) at"
using assms apply(cases at) using int_transE_proj by auto

lemma satL_snvL_transE[simp]:
assumes wtL: "Ik.wtL l" and \<xi>: "I.wtE \<xi>"
and pL: "\<And> \<sigma>. infTp \<sigma> \<or> (\<forall> x \<in> nvL l. tpOfV x \<noteq> \<sigma>)" and "Ik.satL (transE \<xi>) l"
shows "I.satL \<xi> l"
using assms by (cases l) auto

lemma satC_snvC_transE[simp]:
assumes wtC: "Ik.wtC c" and \<xi>: "I.wtE \<xi>"
and pC: "\<And> \<sigma>. \<sigma> \<turnstile> c" and "Ik.satC (transE \<xi>) c"
shows "I.satC \<xi> c"
using assms unfolding Ik.mcalc_iff Ik.satC_def satC_def Ik.wtC_def nvC_def
unfolding list_all_iff list_ex_iff apply simp by (metis nth_mem satL_snvL_transE)

lemma satPB_snvPB_transE[simp]:
assumes \<xi>: "I.wtE \<xi>"  shows "I.satPB \<xi> \<Phi>"
using Ik.wt_\<Phi> Ik.sat_\<Phi>[OF wtE_transE[OF \<xi>]]
using mcalc \<xi> unfolding Ik.satPB_def satPB_def Ik.wtPB_def nvPB_def by auto

lemma I_SAT: "I.SAT \<Phi>" unfolding I.SAT_def by auto

lemma InfModel: "IInfModel I_intT I_intF I_intP"
apply default using I_SAT .

end (* context ModelIkMcalc *)

sublocale ModelIkMcalc < InfModel where
intT = I_intT and intF = I_intF and intP = I_intP
using InfModel .

context ProblemIkMcalc begin

abbreviation "MModelIkMcalc \<equiv> ModelIkMcalc wtFsym wtPsym arOf resOf parOf \<Phi> infTp"

end (* context ProblemIkMcalc *)

text{* Final theorem in sublocale form: Any problem that passes the
  monotonicity calculus is monotonic:  *}

sublocale ProblemIkMcalc < MonotProblem
apply default using monot .

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics for Isabelle/Isar.

    Copyright (C) 2005, 2006  Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*)

section \<open>More on rings\<close>

theory Ring_ZF_1 imports Ring_ZF Group_ZF_3

begin

text\<open>This theory is devoted to the part of ring theory specific the
  construction of real numbers in the \<open>Real_ZF_x\<close> series of theories.
  The goal is to
  show that classes of almost homomorphisms form a ring.\<close>

subsection\<open>The ring of classes of almost homomorphisms\<close>

text\<open>Almost homomorphisms do not form a ring as the regular homomorphisms
  do because the lifted group operation is not distributive with respect to
  composition -- we have $s\circ (r\cdot q) \neq s\circ r\cdot s\circ q$ in
  general. However, we do have
  $s\circ (r\cdot q) \approx s\circ r\cdot s\circ q$ in the sense of the
  equivalence relation defined by the group of finite range
  functions (that is a normal subgroup of almost homomorphisms,
  if the group is abelian). This allows to define a natural ring structure
  on the classes of almost homomorphisms.\<close>

text\<open>The next lemma provides a formula useful for proving that two sides
  of the distributive law equation for almost homomorphisms are almost
  equal.\<close>

lemma (in group1) Ring_ZF_1_1_L1:
  assumes A1: "s\<in>AH" "r\<in>AH" "q\<in>AH" and A2: "n\<in>G"
  shows
  "((s\<circ>(r\<bullet>q))`(n))\<cdot>(((s\<circ>r)\<bullet>(s\<circ>q))`(n))\<inverse>= \<delta>(s,\<langle> r`(n),q`(n)\<rangle>)"
  "((r\<bullet>q)\<circ>s)`(n) = ((r\<circ>s)\<bullet>(q\<circ>s))`(n)"
proof -
  from groupAssum isAbelian A1 have T1:
    "r\<bullet>q \<in> AH" "s\<circ>r \<in> AH"  "s\<circ>q \<in> AH" "(s\<circ>r)\<bullet>(s\<circ>q) \<in> AH"
    "r\<circ>s \<in> AH" "q\<circ>s \<in> AH"  "(r\<circ>s)\<bullet>(q\<circ>s) \<in> AH"
    using Group_ZF_3_2_L15 Group_ZF_3_4_T1 by auto
  from A1 A2 have T2: "r`(n) \<in> G" "q`(n) \<in> G" "s`(n) \<in> G"
    "s`(r`(n)) \<in> G" "s`(q`(n)) \<in> G" "\<delta>(s,\<langle> r`(n),q`(n)\<rangle>) \<in> G"
    "s`(r`(n))\<cdot>s`(q`(n)) \<in> G" "r`(s`(n)) \<in> G" "q`(s`(n)) \<in> G"
    "r`(s`(n))\<cdot>q`(s`(n)) \<in> G"
    using AlmostHoms_def apply_funtype Group_ZF_3_2_L4B
    group0_2_L1 monoid0.group0_1_L1 by auto
  with T1 A1 A2 isAbelian show
    "((s\<circ>(r\<bullet>q))`(n))\<cdot>(((s\<circ>r)\<bullet>(s\<circ>q))`(n))\<inverse>= \<delta>(s,\<langle> r`(n),q`(n)\<rangle>)"
    "((r\<bullet>q)\<circ>s)`(n) = ((r\<circ>s)\<bullet>(q\<circ>s))`(n)"
    using Group_ZF_3_2_L12 Group_ZF_3_4_L2 Group_ZF_3_4_L1 group0_4_L6A
    by auto
qed

text\<open>The sides of the distributive law equations for almost homomorphisms
  are almost equal.\<close>

lemma (in group1) Ring_ZF_1_1_L2:
  assumes A1: "s\<in>AH" "r\<in>AH" "q\<in>AH"
  shows
  "s\<circ>(r\<bullet>q) \<approx> (s\<circ>r)\<bullet>(s\<circ>q)"
  "(r\<bullet>q)\<circ>s = (r\<circ>s)\<bullet>(q\<circ>s)"
proof -
  from A1 have "\<forall>n\<in>G. \<langle> r`(n),q`(n)\<rangle> \<in> G\<times>G"
    using AlmostHoms_def apply_funtype by auto
  moreover from A1 have "{\<delta>(s,x). x \<in> G\<times>G} \<in> Fin(G)"
    using AlmostHoms_def by simp
  ultimately have "{\<delta>(s,\<langle> r`(n),q`(n)\<rangle>). n\<in>G} \<in> Fin(G)"
    by (rule Finite1_L6B)
  with A1 have
    "{((s\<circ>(r\<bullet>q))`(n))\<cdot>(((s\<circ>r)\<bullet>(s\<circ>q))`(n))\<inverse>. n \<in> G} \<in> Fin(G)"
    using Ring_ZF_1_1_L1 by simp
  moreover from groupAssum isAbelian A1 A1 have
    "s\<circ>(r\<bullet>q) \<in> AH" "(s\<circ>r)\<bullet>(s\<circ>q) \<in> AH"
    using Group_ZF_3_2_L15 Group_ZF_3_4_T1 by auto
  ultimately show "s\<circ>(r\<bullet>q) \<approx> (s\<circ>r)\<bullet>(s\<circ>q)"
    using Group_ZF_3_4_L12 by simp
  from groupAssum isAbelian A1 have
    "(r\<bullet>q)\<circ>s : G\<rightarrow>G" "(r\<circ>s)\<bullet>(q\<circ>s) : G\<rightarrow>G"
    using Group_ZF_3_2_L15 Group_ZF_3_4_T1 AlmostHoms_def
    by auto
  moreover from A1 have
    "\<forall>n\<in>G. ((r\<bullet>q)\<circ>s)`(n) = ((r\<circ>s)\<bullet>(q\<circ>s))`(n)"
    using Ring_ZF_1_1_L1 by simp
  ultimately show "(r\<bullet>q)\<circ>s = (r\<circ>s)\<bullet>(q\<circ>s)"
    using fun_extension_iff by simp
qed

text\<open>The essential condition to show the distributivity for the
  operations defined on classes of almost homomorphisms.\<close>

lemma (in group1) Ring_ZF_1_1_L3:
  assumes A1: "R = QuotientGroupRel(AH,Op1,FR)"
  and A2: "a \<in> AH//R" "b \<in> AH//R" "c \<in> AH//R"
  and A3: "A = ProjFun2(AH,R,Op1)" "M = ProjFun2(AH,R,Op2)"
  shows "M`\<langle>a,A`\<langle> b,c\<rangle>\<rangle> = A`\<langle>M`\<langle> a,b\<rangle>,M`\<langle> a,c\<rangle>\<rangle> \<and>
  M`\<langle>A`\<langle> b,c\<rangle>,a\<rangle> = A`\<langle>M`\<langle> b,a\<rangle>,M`\<langle> c,a\<rangle>\<rangle>"
proof
  from A2 obtain s q r where D1: "s\<in>AH" "r\<in>AH" "q\<in>AH"
    "a = R``{s}" "b = R``{q}" "c = R``{r}"
    using quotient_def by auto
  from A1 have T1:"equiv(AH,R)"
      using Group_ZF_3_3_L3 by simp
  with A1 A3 D1 groupAssum isAbelian have
    "M`\<langle>  a,A`\<langle> b,c\<rangle> \<rangle> = R``{s\<circ>(q\<bullet>r)}"
    using Group_ZF_3_3_L4 EquivClass_1_L10
    Group_ZF_3_2_L15 Group_ZF_3_4_L13A by simp
  also have "R``{s\<circ>(q\<bullet>r)} = R``{(s\<circ>q)\<bullet>(s\<circ>r)}"
  proof -
    from T1 D1 have "equiv(AH,R)" "s\<circ>(q\<bullet>r)\<approx>(s\<circ>q)\<bullet>(s\<circ>r)"
      using Ring_ZF_1_1_L2 by auto
    with A1 show ?thesis using equiv_class_eq by simp
  qed
  also from A1 T1 D1 A3 have
    "R``{(s\<circ>q)\<bullet>(s\<circ>r)} = A`\<langle>M`\<langle> a,b\<rangle>,M`\<langle> a,c\<rangle>\<rangle>"
    using Group_ZF_3_3_L4 Group_ZF_3_4_T1 EquivClass_1_L10
    Group_ZF_3_3_L3 Group_ZF_3_4_L13A EquivClass_1_L10 Group_ZF_3_4_T1
    by simp
  finally show "M`\<langle>a,A`\<langle> b,c\<rangle>\<rangle> = A`\<langle>M`\<langle> a,b\<rangle>,M`\<langle> a,c\<rangle>\<rangle>" by simp
  from A1 A3 T1 D1 groupAssum isAbelian show
    "M`\<langle>A`\<langle> b,c\<rangle>,a\<rangle> = A`\<langle>M`\<langle> b,a\<rangle>,M`\<langle> c,a\<rangle>\<rangle>"
    using Group_ZF_3_3_L4 EquivClass_1_L10 Group_ZF_3_4_L13A
      Group_ZF_3_2_L15 Ring_ZF_1_1_L2 Group_ZF_3_4_T1 by simp
qed

text\<open>The projection of the first group operation on almost homomorphisms
  is distributive with respect to the second group operation.\<close>

lemma (in group1) Ring_ZF_1_1_L4:
  assumes A1: "R = QuotientGroupRel(AH,Op1,FR)"
  and A2: "A = ProjFun2(AH,R,Op1)" "M = ProjFun2(AH,R,Op2)"
  shows "IsDistributive(AH//R,A,M)"
proof -
  from A1 A2 have "\<forall>a\<in>(AH//R).\<forall>b\<in>(AH//R).\<forall>c\<in>(AH//R).
  M`\<langle>a,A`\<langle> b,c\<rangle>\<rangle> = A`\<langle>M`\<langle> a,b\<rangle>, M`\<langle> a,c\<rangle>\<rangle> \<and>
  M`\<langle>A`\<langle> b,c\<rangle>, a\<rangle> = A`\<langle>M`\<langle> b,a\<rangle>,M`\<langle> c,a\<rangle>\<rangle>"
    using Ring_ZF_1_1_L3 by simp
  then show ?thesis using IsDistributive_def by simp
qed

text\<open>The classes of almost homomorphisms form a ring.\<close>

theorem (in group1) Ring_ZF_1_1_T1:
  assumes "R = QuotientGroupRel(AH,Op1,FR)"
  and "A = ProjFun2(AH,R,Op1)" "M = ProjFun2(AH,R,Op2)"
  shows "IsAring(AH//R,A,M)"
  using assms QuotientGroupOp_def Group_ZF_3_3_T1 Group_ZF_3_4_T2
    Ring_ZF_1_1_L4 IsAring_def by simp

end


(*
  This file contains all the Isabelle shallow embedding to C correspondence theorems for word
  array functions.
*)
theory WordArray_SVCorres
  imports WordArray_Shallow WordArray_VAbsFun
begin

subsection "Shallow Word Array Value Relation"
text
  "The shallow embedding of a word array is a list of words. Currently we only support word
   arrays with primitive words as values. In the future, we hope to extend this to elements which
   are non-linear."

overloading
  valRel_WordArrayUX \<equiv> valRel
begin
  definition valRel_WordArrayUX:
    "\<And>\<xi> x v. valRel_WordArrayUX (\<xi> :: (funtyp,vabstyp) vabsfuns) (x :: (('a :: len8) word) WordArray) (v :: (funtyp, vabstyp) vval) \<equiv>
      (if len_of TYPE('a) = 8 then
        \<exists>xs. v = VAbstract (VWA (TPrim (Num U8)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. (xs ! i) = VPrim (LU8 (ucast (x ! i))))
      else if len_of TYPE('a) = 16 then
        \<exists>xs. v = VAbstract (VWA (TPrim (Num U16)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. (xs ! i) = VPrim (LU16 (ucast (x ! i))))
      else if len_of TYPE('a) = 32 then
        \<exists>xs. v = VAbstract (VWA (TPrim (Num U32)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. (xs ! i) = VPrim (LU32 (ucast (x ! i))))
      else if len_of TYPE('a) = 64 then
        \<exists>xs. v = VAbstract (VWA (TPrim (Num U64)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. (xs ! i) = VPrim (LU64 (ucast (x ! i))))
      else False)"
end

(* Alternate definitions for the valRel relations for word arrays

overloading
  valRel_WordArrayU8 \<equiv> valRel
begin
  definition valRel_WordArrayU8:
    "\<And>\<xi> x v. valRel_WordArrayU8 (\<xi> :: (funtyp,vabstyp) vabsfuns) (x :: (8 word) WordArray) (v :: (funtyp, vabstyp) vval) \<equiv>
      \<exists>xs. v = VAbstract (VWA (TPrim (Num U8)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. xs ! i = VPrim (LU8 (x ! i)))"
end

overloading
  valRel_WordArrayU16 \<equiv> valRel
begin
  definition valRel_WordArrayU16:
    "\<And>\<xi> x v. valRel_WordArrayU16 (\<xi> :: (funtyp,vabstyp) vabsfuns) (x :: (16 word) WordArray) (v :: (funtyp, vabstyp) vval) \<equiv>
      \<exists>xs. v = VAbstract (VWA (TPrim (Num U16)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. xs ! i = VPrim (LU16 (x ! i)))"
end

overloading
  valRel_WordArrayU32 \<equiv> valRel
begin
  definition valRel_WordArrayU32:
    "\<And>\<xi> x v. valRel_WordArrayU32 (\<xi> :: (funtyp,vabstyp) vabsfuns) (x :: (32 word) WordArray) (v :: (funtyp, vabstyp) vval) \<equiv>
      \<exists>xs. v = VAbstract (VWA (TPrim (Num U32)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. xs ! i = VPrim (LU32 (x ! i)))"
end

overloading
  valRel_WordArrayU64 \<equiv> valRel
begin
  definition valRel_WordArrayU64:
    "\<And>\<xi> x v. valRel_WordArrayU64 (\<xi> :: (funtyp,vabstyp) vabsfuns) (x :: (64 word) WordArray) (v :: (funtyp, vabstyp) vval) \<equiv>
      \<exists>xs. v = VAbstract (VWA (TPrim (Num U64)) xs) \<and> length x = length xs \<and> (\<forall>i < length xs. xs ! i = VPrim (LU64 (x ! i)))"
end

*)

context WordArray begin

section "Shallow to Deep Corresondence Lemmas (@{term scorres}) for Word Array Functions"

lemmas valRel_WordArray_simps = valRel_WordArrayUX

subsection "wordarray_length"
text
  "@{term wordarray_length} returns the length of a word array.

   Below is a proof tactic to prove @{term scorres} for wordarray_length. The proof is
   quite simple as @{term scorres} can be proven by simplifying the @{term valRel} definitions
   and by applying the @{term v_sem} introduction rules."
ML \<open>
fun wa_length_tac ctxt =
let
  fun clarsimp_add thms i = Clasimp.clarsimp_tac (add_simps thms ctxt) i;
  fun clarsimp_split thm i = Clasimp.clarsimp_tac (Splitter.add_split thm ctxt) i
  val base_simpset = @{thms scorres_def valRel_records wordarray_length' valRel_WordArray_simps};
in
  clarsimp_add base_simpset 1
  THEN clarsimp_split @{thm if_split_asm} 1
  THEN ALLGOALS (fn a =>
    etac @{thm v_sem_appE} a
    THEN etac @{thm v_sem_afunE} a
    THEN etac @{thm v_sem_varE} a
    THEN clarsimp_add @{thms val_wa_length_def} a
    THEN TRYALL (fn i => rtac @{thm FalseE} i
      THEN etac @{thm v_sem_afunE} i
      THEN clarsimp_add [] i))
end;
\<close>

lemma
  "\<xi>p' ''wordarray_length'' =  val_wa_length \<Longrightarrow>
  scorres ((wordarray_length:: ('a :: len8) word WordArray \<Rightarrow> 32 word))
          (AFun ''wordarray_length'' ts ls) \<gamma> \<xi>p'"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_afunE)
  apply (clarsimp simp: val_wa_length_def  wordarray_length' valRel_WordArray_simps split: if_splits)
  done

lemma scorres_wordarray_length:
  "\<lbrakk>i < length \<gamma>; \<xi>p' ''wordarray_length'' =  val_wa_length;
    valRel \<xi>p' (v:: ('a :: len8) word WordArray) (\<gamma> ! i)\<rbrakk>
    \<Longrightarrow> scorres (wordarray_length v) (App (AFun ''wordarray_length'' ts ls) (Var i)) \<gamma> \<xi>p'"
  by (tactic \<open>wa_length_tac @{context}\<close>)

\<comment>\<open> Proofs for alternate definition of @{term valRel} for word arrays \<close>
(*lemma scorres_wordarray_length_u8:
  "\<lbrakk>valRel \<xi>p (v:: 8 word WordArray) v'\<rbrakk>
    \<Longrightarrow> scorres (wordarray_length v) (App (AFun ''wordarray_length'' ts) (Var 0)) [v'] \<xi>p"
  by (tactic \<open>wa_length_tac @{context}\<close>)

lemma scorres_wordarray_length_u16:
  "\<lbrakk>valRel \<xi>p (v:: 16 word WordArray) v'\<rbrakk>
    \<Longrightarrow> scorres (wordarray_length v) (App (AFun ''wordarray_length'' ts) (Var 0)) [v'] \<xi>p"
  by (tactic \<open>wa_length_tac @{context}\<close>)

lemma scorres_wordarray_length_u32:
  "\<lbrakk>valRel \<xi>p (v:: 32 word WordArray) v'\<rbrakk>
    \<Longrightarrow> scorres (wordarray_length v) (App (AFun ''wordarray_length'' ts) (Var 0)) [v'] \<xi>p"
  by (tactic \<open>wa_length_tac @{context}\<close>)

lemma scorres_wordarray_length_u64:
  "\<lbrakk>valRel \<xi>p (v:: 64 word WordArray) v'\<rbrakk>
    \<Longrightarrow> scorres (wordarray_length v) (App (AFun ''wordarray_length'' ts) (Var 0)) [v'] \<xi>p"
  by (tactic \<open>wa_length_tac @{context}\<close>)
*)

subsection "wordarray_get"
text
  "@{term wordarray_get} is similar to the @{term nth} function for lists, except is does not cause
   and error when the index requested is out of bounds. Instead it returns the value @{term 0}. One
   issue with this behaviour is that it that we cannot define a generic @{term valRel} relation for
   word arrays as word arrays of other types may not have a sensible @{term 0} value.

   Below is a proof tactic to prove @{term scorres} for wordarray_get. The proof is
   slightly more tricky than @{term wordarray_length}, but it essentially can be proven using
   the simplifier to unfold the @{term valRel} definitions and by applying the @{term v_sem}
   introduction rules where necessary."
ML \<open>
fun wa_get_tac ctxt =
let
  fun clarsimp_add thms = Clasimp.clarsimp_tac (add_simps thms ctxt);
  fun clarsimp_split thm i = Clasimp.clarsimp_tac (Splitter.add_split thm ctxt) i
  val base_simpset = @{thms scorres_def valRel_records wordarray_get' valRel_WordArray_simps};
in
  clarsimp_add base_simpset 1
  THEN clarsimp_split @{thm if_split_asm} 1
  THEN ALLGOALS (fn a =>
    rtac @{thm conjI} a
    THEN ALLGOALS (fn i => clarsimp_add [] i
      THEN etac @{thm v_sem_appE} i
      THEN etac @{thm v_sem_afunE} i
      THEN etac @{thm v_sem_varE} i
      THEN clarsimp_add @{thms val_wa_get_def ucast_id} i)
    THEN TRYALL (fn i => rtac @{thm FalseE} i
      THEN etac @{thm v_sem_afunE} i
      THEN clarsimp_add [] i))
end;
\<close>

\<comment>\<open> @{term valRel} does not exist for @{typ "('a :: len8) word"} so we can't make a generalised
   lemma like we did for @{term wordarray_length}. \<close>

lemma scorres_wordarray_get_u8:
  "\<lbrakk>i < length \<gamma>;  \<xi>p' ''wordarray_get'' =  val_wa_get;
    valRel \<xi>p' (v:: (8 word WordArray, 32 word) T0) (\<gamma> ! i)\<rbrakk>
    \<Longrightarrow> scorres (wordarray_get v) (App (AFun ''wordarray_get'' ts ls) (Var i)) \<gamma> \<xi>p'"
  by (tactic \<open>wa_get_tac @{context}\<close>)

lemma scorres_wordarray_get_u16:
  "\<lbrakk>i < length \<gamma>;  \<xi>p' ''wordarray_get'' =  val_wa_get;
    valRel \<xi>p' (v:: (16 word WordArray, 32 word) T0) (\<gamma> ! i)\<rbrakk>
    \<Longrightarrow> scorres (wordarray_get v) (App (AFun ''wordarray_get'' ts ls) (Var i)) \<gamma> \<xi>p'"
  by (tactic \<open>wa_get_tac @{context}\<close>)

lemma scorres_wordarray_get_u32:
  "\<lbrakk>i < length \<gamma>;  \<xi>p' ''wordarray_get'' =  val_wa_get;
    valRel \<xi>p' (v:: (32 word WordArray, 32 word) T0) (\<gamma> ! i)\<rbrakk>
    \<Longrightarrow> scorres (wordarray_get v) (App (AFun ''wordarray_get'' ts ls) (Var i)) \<gamma> \<xi>p'"
  by (tactic \<open>wa_get_tac @{context}\<close>)

lemma scorres_wordarray_get_u64:
  "\<lbrakk>i < length \<gamma>; \<xi>p' ''wordarray_get'' =  val_wa_get;
    valRel \<xi>p' (v:: (64 word WordArray, 32 word) T0) (\<gamma> ! i)\<rbrakk>
    \<Longrightarrow> scorres (wordarray_get v) (App (AFun ''wordarray_get'' ts ls) (Var i)) \<gamma> \<xi>p'"
  by (tactic \<open>wa_get_tac @{context}\<close>)

subsection "wordarray_put2"

text
  "@{term wordarray_put2} has the same behaviour as @{term list_update}."

lemma related_lists_update_nth_eq:
  "\<lbrakk>length ys = length xs; j < length xs; \<forall>i < length xs. xs ! i = f (ys ! i)\<rbrakk>
    \<Longrightarrow> xs[i := f v] ! j = f (ys[i := v] ! j)"
  apply (erule_tac x = j in allE)
  apply (case_tac " i = j"; clarsimp)
  done

text
  "Below is a proof tactic to prove @{term scorres} for wordarray_put2. The proof tactic was
   slightly more tricky than @{term wordarray_get} to create. However, the core part is the same as
   the proof @{thm scorres_wordarray_get_u8}, and the only major difference is the addition of the
   helper lemma @{thm related_lists_update_nth_eq}."

ML \<open>
fun inst_param_tac param_nms var_nms thm tac ({context, params, ...} : Subgoal.focus) =
let
  fun mk_inst a b = ((b, 0), (snd o hd o (filter (fn v => fst v = a))) params)
  val insts = map2 mk_inst param_nms var_nms
  val inst_thm = Drule.infer_instantiate context insts thm
in
  tac context [inst_thm] 1
end
\<close>

ML \<open>
fun wa_put2_tac ctxt =
let
  fun clarsimp_add thms = Clasimp.clarsimp_tac (add_simps thms ctxt);
  fun clarsimp_split thm i = Clasimp.clarsimp_tac (Splitter.add_split thm ctxt) i
  val base_simpset = @{thms scorres_def valRel_records wordarray_put2' valRel_WordArray_simps};
  val helper_thm = @{thm related_lists_update_nth_eq}
in
  clarsimp_add base_simpset 1
  THEN clarsimp_split @{thm if_split_asm} 1
  THEN ALLGOALS (fn a =>
    etac @{thm v_sem_appE} a
    THEN etac @{thm v_sem_afunE} a
    THEN etac @{thm v_sem_varE} a
    THEN clarsimp_add @{thms val_wa_put2_def ucast_id} a
    THEN Subgoal.FOCUS_PARAMS (inst_param_tac ["i"] ["j"] helper_thm resolve_tac) ctxt a
    THEN ALLGOALS (fn i => asm_full_simp_tac ctxt i)
    THEN etac @{thm v_sem_afunE} a
    THEN rtac @{thm FalseE} a
    THEN clarsimp_add [] a)
end;
\<close>

lemma scorres_wordarray_put2_u8:
  "\<lbrakk>k < length \<gamma>;  \<xi>p' ''wordarray_put2'' =  val_wa_put2;
    valRel \<xi>p' (v:: (8 word WordArray, 32 word, 8 word) WordArrayPutP) (\<gamma> ! k)\<rbrakk>
    \<Longrightarrow> scorres (wordarray_put2 v) (App (AFun ''wordarray_put2'' ts ls) (Var k)) \<gamma> \<xi>p'"
  by (tactic \<open> wa_put2_tac @{context}\<close>)

lemma scorres_wordarray_put2_u16:
  "\<lbrakk>k < length \<gamma>;  \<xi>p' ''wordarray_put2'' =  val_wa_put2;
    valRel \<xi>p' (v:: (16 word WordArray, 32 word, 16 word) WordArrayPutP) (\<gamma> ! k)\<rbrakk>
    \<Longrightarrow> scorres (wordarray_put2 v) (App (AFun ''wordarray_put2'' ts ls) (Var k)) \<gamma> \<xi>p'"
  by (tactic \<open> wa_put2_tac @{context}\<close>)

lemma scorres_wordarray_put2_u32:
  "\<lbrakk>k < length \<gamma>;  \<xi>p' ''wordarray_put2'' =  val_wa_put2;
    valRel \<xi>p' (v:: (32 word WordArray, 32 word, 32 word) WordArrayPutP) (\<gamma> ! k)\<rbrakk>
    \<Longrightarrow> scorres (wordarray_put2 v) (App (AFun ''wordarray_put2'' ts ls) (Var k)) \<gamma> \<xi>p'"
  by (tactic \<open> wa_put2_tac @{context}\<close>)

lemma scorres_wordarray_put2_u64:
  "\<lbrakk>k < length \<gamma>;  \<xi>p' ''wordarray_put2'' =  val_wa_put2;
    valRel \<xi>p' (v:: (64 word WordArray, 32 word, 64 word) WordArrayPutP) (\<gamma> ! k)\<rbrakk>
    \<Longrightarrow> scorres (wordarray_put2 v) (App (AFun ''wordarray_put2'' ts ls) (Var k)) \<gamma> \<xi>p'"
  by (tactic \<open> wa_put2_tac @{context}\<close>)

subsection "wordarray_fold_no_break"

text
  "@{term wordarray_fold_no_break} is very similar to the list @{term fold} function. It differs
   from the traditional @{term fold} function as it can be applied to only a specified range of
   a list. It also takes an addition observer argument which remains unchanged throughout the
   @{term fold} operation and can be used throughout the @{term fold} operation. This can easily be
   emulated with the traditional @{term fold} function."

lemma map_forall:
  "\<lbrakk>length xs = length ys; \<forall>i<length xs. xs ! i = f(ys ! i)\<rbrakk> \<Longrightarrow> xs = map f ys"
  apply (induct xs arbitrary: ys; clarsimp)
  apply (drule_tac x = "tl ys" in meta_spec; clarsimp)
  apply (drule meta_mp)
   apply linarith
  apply (drule meta_mp)
   apply clarsimp
   apply (erule_tac x = "Suc i" in allE)
   apply clarsimp
   apply (simp add: tl_drop_1)
  apply clarsimp
  by (metis list.sel(3) list_exhaust_size_gt0 list_to_map_more nth_Cons_0 zero_less_Suc)

lemma take_1_drop:
  "i < length xs \<Longrightarrow> List.take (Suc 0) (List.drop i xs) = [xs ! i]"
  apply (induct xs arbitrary: i)
   apply (simp add: take_Suc_conv_app_nth)
  by (simp add: drop_Suc_nth)

lemma take_drop_Suc:
  "i < l \<and> i < length xs \<Longrightarrow>
    List.take (l - i) (List.drop i xs) = (xs ! i) # List.take (l - Suc i) (List.drop (Suc i) xs)"
  apply clarsimp
  by (metis Cons_nth_drop_Suc Suc_diff_Suc take_Suc_Cons)

lemma take_drop_Suc_app:
  "\<lbrakk>i < Suc l; Suc l \<le> length xs\<rbrakk> \<Longrightarrow>
    List.take (Suc l - i) (List.drop i xs) = List.take (l - i) (List.drop i xs) @ [xs ! l]"
  apply (induct i)
   apply (simp add: take_Suc_conv_app_nth)
  apply clarsimp
  apply (subst Suc_diff_Suc[symmetric])
   apply arith
  apply (subst take_hd_drop[symmetric])
   apply simp
  apply simp
  using Suc_le_lessD hd_drop_conv_nth by blast

abbreviation "upd_rec_field rec i v \<equiv> (case rec of VRecord fs \<Rightarrow> VRecord (fs[i := v]))"

text
  \<open> We cannot generalise this unless you can prove that
    @{term "\<forall>a b. valRel \<xi>\<^sub>i (a :: 'a) b \<longleftrightarrow> valRel \<xi>\<^sub>j a b"}
    which is generally not true for functions.\<close>
lemma scorres_wordarray_fold_no_break_u32:
  "\<lbrakk>i < length \<gamma>; \<xi>p1' ''wordarray_fold_no_break'' = val_wa_foldnbp \<xi>p';
    valRel \<xi>p' \<lparr>WordArrayMapNoBreakP.arr\<^sub>f = (arr:: 32 word WordArray), frm\<^sub>f = (frm::32 word), to\<^sub>f = to,
      f\<^sub>f = f, acc\<^sub>f = (acc :: 'b), obsv\<^sub>f = obsv\<rparr> (\<gamma> ! i);
    \<forall>x x'. valRel \<xi>p' (x :: 'b) x' \<longleftrightarrow> valRel \<xi>p1' x x'\<rbrakk>
    \<Longrightarrow> scorres
    (wordarray_fold_no_break \<lparr>WordArrayMapNoBreakP.arr\<^sub>f = arr, frm\<^sub>f = frm, to\<^sub>f = to, f\<^sub>f = f,
        acc\<^sub>f = acc, obsv\<^sub>f = obsv\<rparr>) (App (AFun ''wordarray_fold_no_break'' ts ls) (Var i)) \<gamma> \<xi>p1'"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_appE; erule v_sem_afunE; clarsimp)
  apply (erule v_sem_varE; clarsimp)
  apply (clarsimp simp: val_wa_foldnbp_def)
  apply (clarsimp simp: wordarray_fold_no_break' valRel_records valRel_WordArray_simps)
  apply (induct to arbitrary: i \<gamma>)
   apply clarsimp
   apply (erule val_wa_foldnb_bod.elims; clarsimp split: if_split_asm)
  apply clarsimp
  apply (drule unatSuc; clarsimp)
  apply (rename_tac to r xs func acca obsva i \<gamma>)
  apply (case_tac "length xs < Suc (unat to)")
   apply (drule val_wa_foldnb_bod_back_step'; simp?)
   apply (drule_tac x = r in meta_spec)
   apply (drule_tac x = xs in meta_spec)
   apply (drule_tac x = func in meta_spec)
   apply (drule_tac x = acca in meta_spec)
   apply (drule_tac x = obsva in meta_spec)
   apply (drule_tac x = i in meta_spec)
   apply (drule_tac x = "\<gamma>[i := upd_rec_field (\<gamma> ! i) 2 (VPrim (LU32 to))]" in meta_spec)
   apply clarsimp
  apply (case_tac "unat frm \<ge> Suc (unat to)")
   apply clarsimp
   apply (erule val_wa_foldnb_bod.elims; clarsimp)
  apply (drule val_wa_foldnb_bod_back_step; clarsimp)
  apply (rename_tac r')
  apply (drule_tac x = r' in meta_spec)
  (*apply (drule_tac x = t in meta_spec)*)
  apply (drule_tac x = xs in meta_spec)
  apply (drule_tac x = func in meta_spec)
  apply (drule_tac x = acca in meta_spec)
  apply (drule_tac x = obsva in meta_spec)
  apply clarsimp
  apply (drule_tac x = i in meta_spec)
  apply (drule_tac x = "\<gamma>[i := upd_rec_field (\<gamma> ! i) 2 (VPrim (LU32 to))]" in meta_spec)
  apply clarsimp
  apply (subst take_drop_Suc_app; simp?)
(*   apply (clarsimp split: if_split_asm)*)
  apply (clarsimp simp: ucast_id)
  apply (case_tac func; clarsimp)
   apply (erule_tac x = "\<lparr>ElemAO.elem\<^sub>f = arr ! unat to,
    acc\<^sub>f = fold (\<lambda>a b. f \<lparr>ElemAO.elem\<^sub>f = a, acc\<^sub>f = b, obsv\<^sub>f = obsv\<rparr>)
      (take (unat to - unat frm) (List.drop (unat frm) arr)) acc, obsv\<^sub>f = obsv\<rparr>" in allE)
   apply (erule_tac x = "VRecord [xs ! unat to, r', obsva]" in allE)
   apply clarsimp
   apply (erule v_sem_appE; clarsimp)
   apply (erule v_sem_varE; clarsimp)
(*   apply (erule impE)
  apply (clarsimp split: if_split_asm; erule_tac x = "unat to" in allE; clarsimp)*)
  apply (erule_tac x = "\<lparr>ElemAO.elem\<^sub>f = arr ! unat to,
    acc\<^sub>f = fold (\<lambda>a b. f \<lparr>ElemAO.elem\<^sub>f = a, acc\<^sub>f = b, obsv\<^sub>f = obsv\<rparr>)
      (take (unat to - unat frm) (List.drop (unat frm) arr)) acc, obsv\<^sub>f = obsv\<rparr>" in allE)
  apply (erule_tac x = "VRecord [xs ! unat to, r', obsva]" in allE)
  apply clarsimp
  apply (erule v_sem_appE; erule v_sem_afunE; clarsimp)
  apply (erule v_sem_varE; clarsimp)
  done

lemma min_word_0:
  "min x (0 :: ('a :: len8 word)) = 0"
  by simp

lemma max_word_0:
  "max x (0 :: ('a :: len8 word)) = x"
  apply (unfold max_def)
  by simp

lemma myslice_nth_last:
  "\<lbrakk>frm < Suc to; Suc to \<le> length xs; length xs' = to - frm\<rbrakk>
    \<Longrightarrow> ((List.take frm xs) @ xs' @ x # (List.drop (Suc to) xs)) ! to = x"
  apply (cut_tac xs = "(List.take frm xs)" and
      ys = " xs' @ x # (List.drop (Suc to) xs)" and
      n = "to - frm" in nth_append_length_plus)
  apply simp
  apply (cut_tac xs = xs' and
      ys = "x # List.drop (Suc to) xs" and
      n = 0 in nth_append_length_plus)
  apply simp
  done

lemma scorres_wordarray_map_no_break_u32:
  "\<lbrakk>i < length \<gamma>; \<xi>p1' ''wordarray_map_no_break'' = val_wa_mapAccumnbp \<xi>p';
    valRel \<xi>p' \<lparr>WordArrayMapNoBreakP.arr\<^sub>f = (arr:: 32 word WordArray), frm\<^sub>f = (frm::32 word), to\<^sub>f = to,
      f\<^sub>f = f, acc\<^sub>f = (acc :: 'b), obsv\<^sub>f = obsv\<rparr> (\<gamma> ! i); \<forall>x x'. valRel \<xi>p' (x :: 'b) x' \<longleftrightarrow> valRel \<xi>p1' x x'\<rbrakk>
    \<Longrightarrow> scorres
    (wordarray_map_no_break \<lparr>WordArrayMapNoBreakP.arr\<^sub>f = arr, frm\<^sub>f = frm, to\<^sub>f = to, f\<^sub>f = f,
        acc\<^sub>f = acc, obsv\<^sub>f = obsv\<rparr>) (App (AFun ''wordarray_map_no_break'' ts ls) (Var i)) \<gamma> \<xi>p1'"
  apply (clarsimp simp: scorres_def)
  apply (erule v_sem_appE; erule v_sem_afunE; clarsimp)
  apply (erule v_sem_varE; clarsimp)
  apply (clarsimp simp: val_wa_mapAccumnbp_def)
  apply (clarsimp simp: wordarray_map_no_break' valRel_records valRel_WordArray_simps)
  apply (induct to arbitrary: i \<gamma>)
  apply clarsimp
   apply (erule val_wa_mapAccumnb_bod.elims; clarsimp split: if_split_asm simp: ucast_id)
  apply clarsimp
  apply (drule unatSuc; clarsimp)
  apply (rename_tac to r xs func acca obsva i \<gamma>)
  apply (case_tac "length xs < Suc (unat to)")
   apply (drule val_wa_mapAccumnb_bod_back_step'; simp?)
   apply (clarsimp simp: ucast_id)
   apply (drule_tac x = r in meta_spec)
   apply (drule_tac x = xs in meta_spec)
   apply (drule_tac x = func in meta_spec)
   apply (drule_tac x = acca in meta_spec)
   apply (drule_tac x = obsva in meta_spec)
   apply (drule_tac x = i in meta_spec)
   apply (drule_tac x = "\<gamma>[i := upd_rec_field (\<gamma> ! i) 2 (VPrim (LU32 to))]" in meta_spec)
   apply clarsimp
   apply (clarsimp split: if_split_asm prod.splits simp: word_less_nat_alt word_le_nat_alt)
  apply (case_tac "unat frm \<ge> Suc (unat to)")
   apply clarsimp
   apply (erule val_wa_mapAccumnb_bod.elims)
   apply (clarsimp split: if_split_asm simp: ucast_id word_less_nat_alt word_le_nat_alt)
  apply (frule val_wa_mapAccumnb_bod_preservation'; clarsimp)
  apply (rename_tac rxs racc)
  apply (drule val_wa_mapAccumnb_bod_back_step; clarsimp simp: ucast_id)
  apply (rename_tac racc')
  apply (drule_tac x = "VRecord [VAbstract (VWA (TPrim (Num U32))
    (rxs[unat to := VPrim (LU32 (arr ! unat to))])), racc']" in meta_spec)
  apply clarsimp
  apply (drule_tac x = xs in meta_spec)
  apply (drule_tac x = func in meta_spec)
  apply (drule_tac x = acca in meta_spec)
  apply (drule_tac x = obsva in meta_spec)
  apply clarsimp
  apply (drule_tac x = i in meta_spec)
  apply (drule_tac x = "\<gamma>[i := upd_rec_field (\<gamma> ! i) 2 (VPrim (LU32 to))]" in meta_spec)
  apply clarsimp
  apply (subst take_drop_Suc_app; simp?)+
  apply (clarsimp simp: mapAccum_step)
  apply (clarsimp split: prod.splits if_splits simp: word_less_nat_alt word_le_nat_alt)
  apply (rename_tac rxs' racc')
  apply (cut_tac acc = acc and
      xs = "(take (unat to - unat frm) (List.drop (unat frm) arr))" and
      f = "(\<lambda>a b. (T0.p1\<^sub>f (f \<lparr>ElemAO.elem\<^sub>f = a, acc\<^sub>f = b, obsv\<^sub>f = obsv\<rparr>),
                 T0.p2\<^sub>f (f \<lparr>ElemAO.elem\<^sub>f = a, acc\<^sub>f = b, obsv\<^sub>f = obsv\<rparr>)))" in mapAccum_length)
  apply (case_tac func; clarsimp)
   apply (rename_tac racc'a rxs' racc' fn ts ls)
   apply (erule_tac x = "\<lparr>ElemAO.elem\<^sub>f = arr ! unat to, acc\<^sub>f = racc', obsv\<^sub>f = obsv\<rparr>" in allE)
   apply (erule_tac x = "VRecord [VPrim (LU32 (arr ! unat to)), racc'a, obsva]" in allE)
   apply clarsimp
   apply (erule v_sem_appE; clarsimp)
   apply (erule v_sem_varE; clarsimp)
   apply (erule_tac x = " VRecord [rxs ! unat to, racc]" in allE; clarsimp)
   apply (rename_tac j)
   apply (erule_tac x = j in allE; clarsimp)
   apply (erule_tac x = j in allE; clarsimp)
   apply (case_tac "j = unat to"; clarsimp simp: myslice_nth_last nth_append)
  apply (rename_tac racc'a rxs' racc' fn ts ls)
  apply (erule_tac x = "\<lparr>ElemAO.elem\<^sub>f = arr ! unat to, acc\<^sub>f = racc', obsv\<^sub>f = obsv\<rparr>" in allE)
  apply (erule_tac x = "VRecord [VPrim (LU32 (arr ! unat to)), racc'a, obsva]" in allE)
  apply clarsimp
  apply (erule v_sem_appE; erule v_sem_afunE; clarsimp)
  apply (erule v_sem_varE; clarsimp)
  apply (rotate_tac -2)
  apply (erule_tac x = " VRecord [rxs ! unat to, racc]" in allE; clarsimp)
  apply (rename_tac j)
  apply (erule_tac x = j in allE; clarsimp)
  apply (erule_tac x = j in allE; clarsimp)
  apply (case_tac "j = unat to"; clarsimp simp: myslice_nth_last nth_append)
  done

end (* of context *)

end


(*
    Title:      Examples_Gauss_Jordan_Abstract.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

header{*Examples of computations over abstract matrices*}

theory Examples_Gauss_Jordan_Abstract
imports
  Determinants2
  Inverse
  System_Of_Equations
  Code_Bit
  "~~/src/HOL/Library/Code_Target_Numeral"
begin
subsection{*Transforming a list of lists to an abstract matrix*}

text{*Definitions to transform a matrix to a list of list and vice versa*}
definition vec_to_list :: "'a^'n::{finite, enum} => 'a list"
  where "vec_to_list A = map (op $ A) (enum_class.enum::'n list)"

definition matrix_to_list_of_list :: "'a^'n::{finite, enum}^'m::{finite, enum} => 'a list list"
  where "matrix_to_list_of_list A = map (vec_to_list) (map (op $ A) (enum_class.enum::'m list))"

text{*This definition should be equivalent to @{text "vector_def"} (in suitable types)*}
definition list_to_vec :: "'a list => 'a^'n::{finite, enum, mod_type}"
  where "list_to_vec xs = vec_lambda (% i. xs ! (to_nat i))"

lemma [code abstract]: "vec_nth (list_to_vec xs) = (%i. xs ! (to_nat i))"
  unfolding list_to_vec_def by fastforce

definition list_of_list_to_matrix :: "'a list list => 'a^'n::{finite, enum, mod_type}^'m::{finite, enum, mod_type}"
  where "list_of_list_to_matrix xs = vec_lambda (%i. list_to_vec (xs ! (to_nat i)))"

lemma [code abstract]: "vec_nth (list_of_list_to_matrix xs) = (%i. list_to_vec (xs ! (to_nat i)))"
  unfolding list_of_list_to_matrix_def by auto

subsection{*Examples*}

text{*The following three lemmas are presented in both this file and in the
@{text "Examples_Gauss_Jordan_IArrays"} one. They allow a more convenient printing of rational and
real numbers after evaluation. They have already been added to the repository version of Isabelle,
so after Isabelle2014 they should be removed from here. *}

lemma [code_post]:
  "int_of_integer (- 1) = - 1"
 by simp

lemma [code_abbrev]:
 "(of_rat (- 1) :: real) = - 1"
  by simp

lemma [code_post]:
 "(of_rat (- (1 / numeral k)) :: real) = - 1 / numeral k"
 "(of_rat (- (numeral k / numeral l)) :: real) = - numeral k / numeral l"
 by (simp_all add: of_rat_divide of_rat_minus)

subsubsection{*Ranks and dimensions*}
text{*Examples on computing ranks, dimensions of row space, null space and col space and the Gauss Jordan algorithm*}

value "matrix_to_list_of_list (Gauss_Jordan (list_of_list_to_matrix ([[1,0,0,0,0,0],[0,1,0,0,0,0],[0,0,0,0,0,0],[0,0,0,0,8,2]])::real^6^4))"
value "matrix_to_list_of_list (Gauss_Jordan (list_of_list_to_matrix ([[1,-2,1,-3,0],[3,-6,2,-7,0]])::rat^5^2))"
value "matrix_to_list_of_list (Gauss_Jordan (list_of_list_to_matrix ([[1,0,0,1,1],[1,0,1,1,1]])::bit^5^2))"
value "(reduced_row_echelon_form_upt_k (list_of_list_to_matrix ([[1,0,8],[0,1,9],[0,0,0]])::real^3^3)) 3"
value "matrix_to_list_of_list (Gauss_Jordan (list_of_list_to_matrix [[Complex 1 1,Complex 1 (- 1), Complex 0 0],[Complex 2 (- 1),Complex 1 3, Complex 7 3]]::complex^3^2))"
value "DIM(real^5)"
value "vec.dimension (TYPE(bit)) (TYPE(5))"
value "vec.dimension (TYPE(real)) (TYPE(2))"
value "complex_over_reals.dimension"
(*value "vector_space_over_itself.dimension (TYPE(real))"*)
value "DIM(real^5^4)"
value "row_rank (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4)"
value "vec.dim (row_space (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4))"
value "col_rank (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4)"
value "vec.dim (col_space (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4))"
value "rank (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4)"
value "vec.dim (null_space (list_of_list_to_matrix [[1,0,0,7,5],[1,0,4,8,-1],[1,0,0,9,8],[1,2,3,6,5]]::real^5^4))"
value "rank (list_of_list_to_matrix [[Complex 1 1,Complex 1 (- 1), Complex 0 0],[Complex 2 (- 1),Complex 1 3, Complex 7 3]]::complex^3^2)"

subsubsection{*Inverse of a matrix*}
text{*Examples on computing the inverse of matrices*}

value "let A=(list_of_list_to_matrix [[1,1,2,4,5,9,8],[3,0,8,4,5,0,8],[3,2,0,4,5,9,8], [3,2,8,0,5,9,8] ,[3,2,8,4,0,9,8] ,[3,2,8,4,5,0,8], [3,2,8,4,5,9,0]]::real^7^7)
                    in matrix_to_list_of_list (P_Gauss_Jordan A)"
value "let A=(list_of_list_to_matrix [[1,1,2,4,5,9,8],[3,0,8,4,5,0,8],[3,2,0,4,5,9,8], [3,2,8,0,5,9,8] ,[3,2,8,4,0,9,8] ,[3,2,8,4,5,0,8], [3,2,8,4,5,9,0]]::real^7^7) in
              matrix_to_list_of_list (A ** (P_Gauss_Jordan A))"
value "let A=(list_of_list_to_matrix [[1,1,2,4,5,9,8],[3,0,8,4,5,0,8],[3,2,0,4,5,9,8], [3,2,8,0,5,9,8] ,[3,2,8,4,0,9,8] ,[3,2,8,4,5,0,8], [3,2,8,4,5,9,0]]::real^7^7)
                    in (inverse_matrix A)"
value "let A=(list_of_list_to_matrix [[1,1,2,4,5,9,8],[3,0,8,4,5,0,8],[3,2,0,4,5,9,8], [3,2,8,0,5,9,8] ,[3,2,8,4,0,9,8] ,[3,2,8,4,5,0,8], [3,2,8,4,5,9,0]]::real^7^7)
                    in matrix_to_list_of_list (the (inverse_matrix A))"
value "let A=(list_of_list_to_matrix [[1,1,1,1,1,1,1],[2,2,2,2,2,2,2],[3,2,0,4,5,9,8], [3,2,8,0,5,9,8] ,[3,2,8,4,0,9,8] ,[3,2,8,4,5,0,8], [3,2,8,4,5,9,0]]::real^7^7)
                    in (inverse_matrix A)"
value "let A=(list_of_list_to_matrix [[Complex 1 1,Complex 1 (- 1), Complex 0 0],[Complex 1 1,Complex 1 (- 1), Complex 8 0],[Complex 2 (- 1),Complex 1 3, Complex 7 3]]::complex^3^3)
                    in matrix_to_list_of_list (the (inverse_matrix A))"

subsubsection{*Determinant of a matrix*}
text{*Examples on computing determinants of matrices*}

value "(let A = list_of_list_to_matrix[[1,2,7,8,9],[3,4,12,10,7],[-5,4,8,7,4],[0,1,2,4,8],[9,8,7,13,11]]::real^5^5 in det A)"
value "det (list_of_list_to_matrix ([[1,0,0],[0,1,0],[0,0,1]])::real^3^3)"
value "det (list_of_list_to_matrix ([[1,8,9,1,47],[7,2,2,5,9],[3,2,7,7,4],[9,8,7,5,1],[1,2,6,4,5]])::rat^5^5)"

subsubsection{*Bases of the fundamental subspaces*}
text{*Examples on computing basis for null space, row space, column space and left null space*}
(*Null_space basis:*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
  in vec_to_list` (basis_null_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_null_space A)"
(*Row_space basis*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
    in vec_to_list` (basis_row_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_row_space A)"
(*Col_space basis*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
    in vec_to_list` (basis_col_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_col_space A)"
(*Left_null_space basis*)
value "let A = (list_of_list_to_matrix ([[1,3,-2,0,2,0],[2,6,-5,-2,4,-3],[0,0,5,10,0,15],[2,6,0,8,4,18]])::real^6^4)
    in vec_to_list` (basis_left_null_space A)"
value "let A = (list_of_list_to_matrix ([[3,4,0,7],[1,-5,2,-2],[-1,4,0,3],[1,-1,2,2]])::real^4^4)
  in vec_to_list` (basis_left_null_space A)"

subsubsection{*Consistency and inconsistency*}
text{*Examples on checking the consistency/inconsistency of a system of equations*}
value "independent_and_consistent (list_of_list_to_matrix ([[1,0,0],[0,1,0],[0,0,1],[0,0,0],[0,0,0]])::real^3^5) (list_to_vec([2,3,4,0,0])::real^5)"
value "consistent (list_of_list_to_matrix ([[1,0,0],[0,1,0],[0,0,1],[0,0,0],[0,0,0]])::real^3^5) (list_to_vec([2,3,4,0,0])::real^5)"
value "inconsistent (list_of_list_to_matrix ([[1,0,0],[0,1,0],[3,0,1],[0,7,0],[0,0,9]])::real^3^5) (list_to_vec([2,0,4,0,0])::real^5)"
value "dependent_and_consistent (list_of_list_to_matrix ([[1,0,0],[0,1,0]])::real^3^2) (list_to_vec([3,4])::real^2)"
value "independent_and_consistent (mat 1::real^3^3) (list_to_vec([3,4,5])::real^3)"

subsubsection{*Solving systems of linear equations*}

text{*Examples on solving linear systems.*}

definition print_result_solve
  where "print_result_solve A = (if A = None then None else Some (vec_to_list (fst (the A)), vec_to_list` (snd (the A))))"

value "let A = (list_of_list_to_matrix [[4,5,8],[9,8,7],[4,6,1]]::real^3^3);
                  b=(list_to_vec [4,5,8]::real^3)
                  in (print_result_solve (solve A b))"

value "let A = (list_of_list_to_matrix [[0,0,0],[0,0,0],[0,0,1]]::real^3^3);
                  b=(list_to_vec [4,5,0]::real^3)
                  in (print_result_solve (solve A b))"

value "let A = (list_of_list_to_matrix [[3,2,5,2,7],[6,4,7,4,5],[3,2,-1,2,-11],[6,4,1,4,-13]]::real^5^4);
                  b=(list_to_vec [0,0,0,0]::real^4)
                  in (print_result_solve (solve A b))"

value "let A = (list_of_list_to_matrix [[1,2,1],[-2,-3,-1],[2,4,2]]::real^3^3);
                  b=(list_to_vec [-2,1,-4]::real^3)
                  in (print_result_solve (solve A b))"

value "let A = (list_of_list_to_matrix [[1,1,-4,10],[3,-2,-2,6]]::real^4^2);
                  b=(list_to_vec [24,15]::real^2)
                  in (print_result_solve (solve A b))"

end


(*  Title:       Properties of Lambda-Free KBO on the Lambda Encoding
    Author:      Jasmin Blanchette <j.c.blanchette at vu.nl>, 2019
    Maintainer:  Jasmin Blanchette <j.c.blanchette at vu.nl>
*)

section \<open>Properties of Lambda-Free KBO on the Lambda Encoding\<close>

theory Lambda_Encoding_KBO
imports Lambda_Free_RPOs.Lambda_Encoding Lambda_Free_KBO_Basic
begin

text \<open>
This theory explores the properties of the \<open>\<lambda>\<close>-free KBO on the proposed encoding of \<open>\<lambda>\<close>-expressions.
\<close>

locale kbo_lambda_encoding = kbo_basic _ _ _ _ "\<lambda>_ :: 'v. UNIV :: 's set" + lambda_encoding lam
  for lam :: 's +
  assumes
    gt_db_db: "j > i \<Longrightarrow> db j >\<^sub>s db i" and
    wt_db_db: "wt_sym (db j) = wt_sym (db i)"
begin

notation gt (infix ">\<^sub>t" 50)
notation gt_hd (infix ">\<^sub>h\<^sub>d" 50)

abbreviation ge :: "('s, 'v) tm \<Rightarrow> ('s, 'v) tm \<Rightarrow> bool" (infix "\<ge>\<^sub>t" 50) where
  "t \<ge>\<^sub>t s \<equiv> t >\<^sub>t s \<or> t = s"

lemma wary_raw_db_subst: "wary_subst (raw_db_subst i x)"
  unfolding wary_subst_def by (simp add: arity_def)

lemma wt_subst_db: "wt (subst_db i x s) = wt (subst (raw_db_subst j x) s)"
  by (induct s arbitrary: i j)
    (clarsimp simp: raw_db_subst_def wt_db_db split: hd.splits,
      metis lambda_encoding.subst_db.simps(2) subst.simps(2) wt.simps(2))

lemma subst_db_Suc_ge: "subst_db (Suc i) x s \<ge>\<^sub>t subst_db i x s"
proof (induct s arbitrary: i)
  case (Hd x)
  then show ?case
    by (auto intro: gt_diff simp: wt_db_db gt_db_db gt_sym_imp_hd)
next
  case (App s1 s2)
  show ?case
    by (simp, safe)
      (metis (full_types) App.hyps(1) App.hyps(2) gt_compat_arg gt_compat_fun gt_trans)+
qed

lemma gt_subst_db: "t >\<^sub>t s \<Longrightarrow> subst_db i x t >\<^sub>t subst_db i x s"
proof (simp only: atomize_imp,
    rule measure_induct_rule[of "\<lambda>(t, s, i). {#size t, size s#}"
        "\<lambda>(t, s, i). t >\<^sub>t s \<longrightarrow> subst_db i x t >\<^sub>t subst_db i x s" "(t, s, i)",
      simplified prod.case],
    simp only: split_paired_all prod.case atomize_imp[symmetric] atomize_all[symmetric])
  fix t s :: "('s, 'v) tm" and i :: nat
  assume
    ih: "\<And>ta sa i. {#size ta, size sa#} < {#size t, size s#} \<Longrightarrow> ta >\<^sub>t sa \<Longrightarrow>
      subst_db i x ta >\<^sub>t subst_db i x sa" and
    t_gt_s: "t >\<^sub>t s"

  let ?\<rho> = "subst_db i x"

  show "?\<rho> t >\<^sub>t ?\<rho> s"
  proof (cases "wt (?\<rho> t) = wt (?\<rho> s)")
    case wt_\<rho>t_ne_\<rho>s: False

    have vars_s: "vars_mset t \<supseteq># vars_mset s"
      using gt.cases t_gt_s by blast
    hence vars_\<rho>s: "vars_mset (?\<rho> t) \<supseteq># vars_mset (?\<rho> s)"
      by (simp add: var_mset_subst_db_subseteq)

    have wt_t_ge_s: "wt t \<ge> wt s"
      by (metis dual_order.strict_implies_order eq_imp_le gt.cases t_gt_s)

    have "wt (?\<rho> t) > wt (?\<rho> s)"
      using wt_\<rho>t_ne_\<rho>s unfolding wt_subst_db
      by (metis (full_types) gt.simps gt_subst t_gt_s wary_raw_db_subst wt_subst_db)
    thus ?thesis
      by (rule gt_wt[OF vars_\<rho>s])
  next
    case wt_\<rho>t_eq_\<rho>s: True
    show ?thesis
      using t_gt_s
    proof cases
      case gt_wt
      hence False
        using wt_\<rho>t_eq_\<rho>s
        by (metis add_less_le_mono kbo_std.extra_wt_subseteq nat_less_le wary_raw_db_subst wt_subst
            wt_subst_db)
      thus ?thesis
        by sat
    next
      case _: gt_diff
      note vars_s = this(1) and hd_t_gt_hd_s = this(3)
      have vars_\<rho>s: "vars_mset (?\<rho> t) \<supseteq># vars_mset (?\<rho> s)"
        by (simp add: var_mset_subst_db_subseteq vars_s)
      term gt_hd
      have "head (?\<rho> t) >\<^sub>h\<^sub>d head (?\<rho> s)"
        by (smt Set.set_insert gt_hd_def hd_t_gt_hd_s head_subst_db insert_subset wary_raw_db_subst
            wary_subst_ground_heads)
      thus ?thesis
        by (rule gt_diff[OF vars_\<rho>s wt_\<rho>t_eq_\<rho>s])
    next
      case _: gt_same
      note vars_s = this(1) and hd_s_eq_hd_t = this(3) and extf = this(4)

      have vars_\<rho>s: "vars_mset (?\<rho> t) \<supseteq># vars_mset (?\<rho> s)"
        by (simp add: var_mset_subst_db_subseteq vars_s)
      have hd_\<rho>t: "head (?\<rho> t) = head (?\<rho> s)"
        by (simp add: hd_s_eq_hd_t head_subst_db)

      {
        fix f
        assume f_in_grs: "f \<in> ground_heads (head (?\<rho> s))"

        let ?\<rho>a = "subst_db (if head s = Sym lam then i + 1 else i) x"
        let ?S = "set (args t) \<union> set (args s)"

        have extf_args_s_t: "extf f (>\<^sub>t) (args t) (args s)"
          using extf f_in_grs hd_s_eq_hd_t head_subst_db wary_raw_db_subst wary_subst_ground_heads
          by (metis (no_types, lifting) insert_subset mk_disjoint_insert)
        have "extf f (>\<^sub>t) (map ?\<rho>a (args t)) (map ?\<rho>a (args s))"
        proof (rule extf_map[of ?S, OF _ _ _ _ _ _ extf_args_s_t])
          show "\<forall>x \<in> ?S. \<not> ?\<rho>a x >\<^sub>t ?\<rho>a x"
            using gt_irrefl by blast
        next
          show "\<forall>z \<in> ?S. \<forall>y \<in> ?S. \<forall>x \<in> ?S. ?\<rho>a z >\<^sub>t ?\<rho>a y \<longrightarrow> ?\<rho>a y >\<^sub>t ?\<rho>a x \<longrightarrow> ?\<rho>a z >\<^sub>t ?\<rho>a x"
            using gt_trans by blast
        next
          have sz_a: "\<forall>ta \<in> ?S. \<forall>sa \<in> ?S. {#size ta, size sa#} < {#size t, size s#}"
            by (fastforce intro: Max_lt_imp_lt_mset dest: size_in_args)
          show "\<forall>y \<in> ?S. \<forall>x \<in> ?S. y >\<^sub>t x \<longrightarrow> ?\<rho>a y >\<^sub>t ?\<rho>a x"
            using ih sz_a by blast
        qed auto
        hence "extf f (>\<^sub>t) (args (?\<rho> t)) (args (?\<rho> s))"
          by (simp add: args_subst_db hd_s_eq_hd_t)
      }
      hence "\<forall>f \<in> ground_heads (head (?\<rho> s)). extf f (>\<^sub>t) (args (?\<rho> t)) (args (?\<rho> s))"
        by blast
      thus ?thesis
        by (rule gt_same[OF vars_\<rho>s wt_\<rho>t_eq_\<rho>s hd_\<rho>t])
    qed
  qed
qed

end

end


(*  Title:      Containers/Card_Datatype_Ex.thy
    Author:     Andreas Lochbihler, ETH Zurich *)

theory Card_Datatype_Ex imports
  Card_Datatype
begin

subsection {* Examples *}

subsubsection {* Finite types *}

datatype ('a, 'b) foo = Foo 'a | Bar 'a 'b | FooBar 'a 'b "'a + 'b" | Stop

lemma inj_foo [simp]:
  "inj Foo"
  "inj Bar" "inj (Bar x)"
  "inj FooBar" "inj (FooBar x)" "inj (FooBar x y)"
by(simp_all add: inj_on_def fun_eq_iff)

context includes card_datatype begin

lemma UNIV_foo:
  "(UNIV :: ('a, 'b) foo set) =
  rangeC {Foo} \<union>
  rangeC (rangeC {Bar}) \<union>
  rangeC (rangeC (rangeC {FooBar})) \<union>
  rangeC {\<lambda>_::unit. Stop}"
apply(rule UNIV_eq_I)
apply(case_tac x)
apply(simp_all)
done

lemma finite_UNIV_foo:
  "finite (UNIV :: ('a, 'b) foo set) \<longleftrightarrow> finite (UNIV :: 'a set) \<and> finite (UNIV :: 'b set)"
by(simp add: UNIV_foo)

definition card_foo :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where "card_foo a b = (if a = 0 \<or> b = 0 then 0 else a + a * b + a * b * card_sum a b + 1)"

lemma CARD_foo [card_simps]:
  "CARD(('a, 'b) foo) = card_foo CARD('a) CARD('b)"
by(simp add: card_foo_def UNIV_foo Let_def card_simps)

end

datatype ('a, 'b) bar
  = Bar1
  | Bar2 "'a \<Rightarrow> 'b"
  | Bar3 "('a, 'b) foo" "'a \<Rightarrow> char \<Rightarrow> 'b \<Rightarrow> 'a" "('a \<times> 'b) option"
  | Bar4 char 'a bool

lemma inj_bar [simp]:
  "inj Bar2"
  "inj Bar3"
  "inj (Bar3 x)"
  "inj (Bar3 x y)"
  "inj Bar4"
  "inj (Bar4 z)"
  "inj (Bar4 z u)"
by(simp_all add: inj_on_def fun_eq_iff)

context includes card_datatype begin

lemma UNIV_bar:
  "(UNIV :: ('a, 'b) bar set) =
  rangeC {\<lambda>_::unit. Bar1} \<union>
  rangeC {Bar2} \<union>
  rangeC (rangeC (rangeC {Bar3})) \<union>
  rangeC (rangeC (rangeC {Bar4}))"
apply(rule UNIV_eq_I)
apply(case_tac x)
apply(simp_all)
done

lemma finite_UNIV_bar:
  "finite (UNIV :: ('a, 'b) bar set) \<longleftrightarrow> finite (UNIV :: 'a set) \<and> finite (UNIV :: 'b set)"
by(auto simp add: UNIV_bar finite_UNIV_fun finite_prod finite_UNIV_foo)

definition card_bar :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "card_bar a b =
  (if a = 0 \<or> b = 0 then 0
   else 1 + card_fun a b + card_foo a b * card_fun a (card_fun CARD(char) (card_fun b a)) * card_option (card_prod a b) + CARD(char) * a * CARD(bool))"

lemma CARD_bar [card_simps]:
  "CARD(('a, 'b) bar) = card_bar CARD('a) CARD('b)"
by(simp add: UNIV_bar card_bar_def finite_UNIV_bar finite_UNIV_foo finite_prod finite_UNIV_fun card_simps del: card_prod)

end

subsection {* Infinite types *}

datatype 'a tree = Leaf | Node 'a "'a tree" "'a tree"

lemma inj_expr [simp]:
  "inj Node"
  "inj (Node a)"
  "inj (Node a l)"
by(simp_all add: inj_on_def fun_eq_iff)

context includes card_datatype begin

lemma finite_UNIV_tree: "finite (UNIV :: 'a tree set) \<longleftrightarrow> False"
proof -
  have "rangeIt Leaf (Node (undefined :: 'a) Leaf) \<subseteq> UNIV" by simp
  from finite_subset[OF this] show ?thesis by auto
qed

definition card_tree :: "nat \<Rightarrow> nat"
where "card_tree _ = 0"

lemma CARD_tree [card_simps]:
  "CARD('a tree) = card_tree CARD('a)"
by(simp add: card_tree_def finite_UNIV_tree)

end

end