(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory Memcpy
imports
  "../../../c-parser/CTranslation"
  "../../AutoCorres"
begin

abbreviation "ADDR_MAX \<equiv> UWORD_MAX TYPE(addr_bitsize)"

(* Helper for noticing when you accidentally haven't constrained an of_nat *)
abbreviation "of_nat_addr \<equiv> of_nat::(nat \<Rightarrow> addr)"

lemma byte_ptr_guarded:
    "ptr_val (x::8 word ptr) \<noteq> 0 \<Longrightarrow> c_guard x"
  unfolding c_guard_def c_null_guard_def ptr_aligned_def
  by (clarsimp simp: intvl_Suc)

(* FIXME: MOVE *)
lemma ptr_add_coerce: "ptr_val (((ptr_coerce x)::('a::{c_type}) ptr) +\<^sub>p a) = (ptr_val x) + (of_int a * of_nat (size_of TYPE('a)))"
  apply (case_tac x)
  apply (clarsimp simp: CTypesDefs.ptr_add_def)
  done

(* FIXME: MOVE *)
(* Casting a valid pointer to char* and incrementing it by a value less than
 * the size of the underlying type does not give us NULL.
 *)
lemma ptr_contained:"\<lbrakk> c_guard (x::('a::c_type) ptr); size_of TYPE('a) = sz;
                       0 \<le> i; i < int sz; (y::8 word ptr) = ptr_coerce x\<rbrakk> \<Longrightarrow> c_guard (y +\<^sub>p i)"
  apply (rule byte_ptr_guarded)
  unfolding c_guard_def c_null_guard_def ptr_add_def
  apply simp
  apply (clarsimp simp: CTypesDefs.ptr_add_def intvl_def)
  apply (erule allE [where x="nat i"])
  apply (clarsimp simp: nat_less_iff of_nat_nat)
  done

install_C_file "memcpy.c"

(* FIXME: MOVE *)
lemma squash_auxupd_id[polish]:
  "modify (t_hrs_'_update (hrs_htd_update id)) = skip"
  by (monad_eq simp: skip_def id_def hrs_htd_update_def)

autocorres [no_heap_abs=memcpy memcpy_int] "memcpy.c"

(* Dereference a pointer *)
abbreviation "deref s x \<equiv> h_val (hrs_mem (t_hrs_' s)) x"

(* char* cast *)
abbreviation "byte_cast x \<equiv> ((ptr_coerce x)::8 word ptr)"

context memcpy begin

lemma memcpy_char:
  "\<lbrace> \<lambda>s. c_guard (x::8 word ptr) \<and>
         c_guard (y::8 word ptr) \<and>
         unat sz = size_of TYPE(8 word) \<and>
         P (deref s x) \<and>
         x \<noteq> y\<rbrace>
      memcpy' (ptr_coerce y) (ptr_coerce x) sz
   \<lbrace>\<lambda> _ s. P (deref s y) \<rbrace>!"
  (* Evaluate sz *)
  apply clarsimp

  unfolding memcpy'_def
  apply (clarsimp simp:skip_def)
  apply wp

  (* Unroll the loop twice *)
  apply (subst whileLoop_unroll, wp)
     apply (subst whileLoop_unroll, wp)

  (* The remaining loop is never encountered *)
       apply (rule validNF_false_pre)
      apply wp+

  (* Finally we're left with the single assignment *)
  apply (clarsimp simp:hrs_mem_update h_val_heap_update)
  apply unat_arith
 done

lemma of_nat_prop_exp: "n < 32 \<Longrightarrow> of_nat (2 ^ n) = 2 ^ (of_nat n)"
  by clarsimp

lemma memcpy_word:
  "\<lbrace> \<lambda>s. c_guard (x::32 word ptr) \<and>
         c_guard (y::32 word ptr) \<and>
         unat sz = size_of TYPE(32 word) \<and>
         P (deref s x) \<and>
         x \<noteq> y \<rbrace>
      memcpy' (ptr_coerce y) (ptr_coerce x) sz
   \<lbrace> \<lambda>_ s. P (deref s y) \<rbrace>!"
  apply clarsimp
  unfolding memcpy'_def apply (clarsimp simp:skip_def)
  apply (rule validNF_assume_pre)
  apply (subgoal_tac "{ptr_val x ..+ unat sz} \<inter> {ptr_val y ..+ unat sz} = {}")
   apply (subst whileLoop_add_inv [where
     I="\<lambda>i s.  unat i \<le> unat sz \<and>
                (\<forall>a < i. deref s (byte_cast x +\<^sub>p uint a) = deref s (byte_cast y +\<^sub>p uint a)) \<and>
                P (deref s x)" and
     M="\<lambda>(i, s). unat sz - unat i"])
   apply (wp validNF_whileLoop_inv_measure_twosteps)
      apply clarsimp
      apply (rule conjI, unat_arith)
      apply (rule conjI, clarsimp)
       apply (case_tac "a = i")
        apply (clarsimp)
        apply (erule_tac x=i in allE)
        apply (clarsimp simp:hrs_mem_update h_val_heap_update)
        apply (subst h_val_heap_same)
            apply (rule ptr_retyp_h_t_valid)
            apply simp
           apply (rule ptr_retyp_disjoint)
            apply (rule ptr_retyp_h_t_valid)
            apply simp
           apply (clarsimp simp:ptr_add_def intvl_def CTypesDefs.ptr_add_def)
          apply simp
         apply (clarsimp simp: CTypesDefs.ptr_add_def field_of_t_simple)
         apply (drule field_of_t_simple)
         apply clarsimp
        apply simp
       apply (subgoal_tac "a < i")
        apply (clarsimp simp:hrs_mem_update)
        apply (subst h_val_heap_update_disjoint)

         (* The current goal should be obvious to unat_arith, but for some reason isn't *)
         apply (clarsimp simp:ptr_add_def intvl_def disjoint_iff_not_equal)
         apply (erule_tac x="ptr_val x + a" in allE, clarsimp)
         apply (erule impE)
          apply (rule_tac x="unat a" in exI, clarsimp)
          apply unat_arith

         apply (erule_tac x="ptr_val y + i" and
                          P="\<lambda>ya. (\<exists>k. ya = ptr_val y + of_nat k \<and> k < 4) \<longrightarrow> ptr_val y + i \<noteq> ya" in allE, clarsimp)
         apply (erule_tac x="unat i" in allE, clarsimp)
          apply unat_arith
         apply (clarsimp simp:CTypesDefs.ptr_add_def)
        apply (subst h_val_heap_update_disjoint)
         (* Similar goal to the previous irritation, but this time Isabelle decides to play ball *)
         apply (clarsimp simp:ptr_add_def intvl_def ptr_val_def disjoint_iff_not_equal)
        apply (clarsimp simp:CTypesDefs.ptr_add_def)
       apply (clarsimp simp:CTypesDefs.ptr_add_def)
      apply unat_arith

      apply (rule conjI)
       apply (subst hrs_mem_update)+
       apply (subst h_val_heap_update_disjoint)
        apply (clarsimp simp: disjoint_iff_not_equal)
        apply (clarsimp simp:CTypesDefs.ptr_add_def intvl_def)
        apply (erule_tac x="ptr_val x + of_nat k" in allE)
        apply (erule impE)
         apply (rule_tac x="k" in exI)
         apply simp
        apply (erule_tac x="ptr_val y + i" and
                         P="\<lambda>ya. (\<exists>k. ya = ptr_val y + of_nat k \<and> k < 4) \<longrightarrow> ptr_val x + of_nat k \<noteq> ya" in allE)
        apply (erule impE)
         apply (rule_tac x="unat i" in exI)
         apply simp
         apply unat_arith
        apply simp
       apply simp

      (* Yet more tedium that unat_arith doesn't like *)
      apply (rule conjI)
       apply (rule byte_ptr_guarded,
              clarsimp simp:CTypesDefs.ptr_add_def c_guard_def c_null_guard_def intvl_def,
              (erule_tac x="unat i" in allE)+,
              clarsimp,
              unat_arith)+

     apply wp
     apply unat_arith
    apply clarsimp
    apply (subgoal_tac "deref sa x = deref sa y")
     apply clarsimp
    apply (clarsimp simp: h_val_def)[1]
    apply (rule arg_cong[where f=from_bytes])
    apply (subst numeral_eqs(3))+
    apply simp
    apply (rule_tac x=0 in allE, assumption, erule impE, unat_arith)
    apply (rule_tac x=1 in allE, assumption, erule impE, unat_arith)
    apply (rule_tac x=2 in allE, assumption, erule impE, unat_arith)
    apply (rule_tac x=3 in allE, assumption, erule impE, unat_arith)
    apply (simp add:CTypesDefs.ptr_add_def)
    apply (simp add: add.commute from_bytes_eq)
   apply clarsimp
  apply (clarsimp simp:intvl_def disjoint_iff_not_equal)
  apply (drule_tac x=x and y=y and j="of_nat k" and i="of_nat ka" and n=2 in neq_imp_bytes_disjoint)
        apply assumption
       apply (case_tac "k = 0", clarsimp) (* insert "k > 0" *)
       apply (clarsimp simp:unat_of_nat_len)
      apply (case_tac "ka = 0", clarsimp)
      apply (clarsimp simp:unat_of_nat_len)
     apply assumption
    apply clarsimp+
  done

text {* The bytes at the pointer @{term p} are @{term bs}. *}
definition
  bytes_at :: "'a globals_scheme \<Rightarrow> 'b::c_type ptr \<Rightarrow> word8 list \<Rightarrow> bool"
where
  "bytes_at s p bs \<equiv> length bs = 0 \<or>
                      (length bs \<le> ADDR_MAX \<and> (\<forall>i \<in> {0..(length bs - 1)}. deref s (byte_cast p +\<^sub>p (of_nat i)) = bs ! i))"

lemma bytes_at_none[simp]: "bytes_at s p []"
  by (clarsimp simp:bytes_at_def)

text {* The bytes of typed pointer @{term p} are @{term bs}. *}
definition
  bytes_of :: "'a globals_scheme \<Rightarrow> 'b::c_type ptr \<Rightarrow> word8 list \<Rightarrow> bool"
where
  "bytes_of s p bs \<equiv> length bs = size_of TYPE('b) \<and> bytes_at s p bs"

text {* The bytes at a char pointer are just it dereferenced. *}
lemma bytes_of_char[simp]: "bytes_of s (p::8word ptr) bs = (length bs = 1 \<and> deref s p = hd bs)"
  apply (clarsimp simp:bytes_of_def bytes_at_def)
  apply (rule iffI)
   apply clarsimp
   apply (erule disjE)
    apply clarsimp+
   apply (rule hd_conv_nth[symmetric])
   apply clarsimp+
  apply (subgoal_tac "hd bs = bs ! 0")
   apply simp
  apply (rule hd_conv_nth)
  apply clarsimp
  done

text {* A pointer does not wrap around memory. *}
definition
  no_wrap :: "'a::c_type ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "no_wrap p sz \<equiv> 0 \<notin> {ptr_val p ..+ sz}"

text {* Two pointers do not overlap. *}
definition
  no_overlap :: "'a::c_type ptr \<Rightarrow> 'b::c_type ptr \<Rightarrow> nat \<Rightarrow> bool"
where
  "no_overlap p q sz \<equiv> {ptr_val p ..+ sz} \<inter> {ptr_val q ..+ sz} = {}"

lemma no_overlap_sym: "no_overlap x y = no_overlap y x"
  apply (rule ext)
  apply (clarsimp simp:no_overlap_def)
  by blast

(* FIXME: MOVE *)
lemma h_val_not_id:
  fixes x :: "'a::mem_type ptr"
    and y :: "'b::mem_type ptr"
  shows "{ptr_val x..+size_of TYPE('a)} \<inter> {ptr_val y..+size_of TYPE('b)} = {}
     \<Longrightarrow> h_val (hrs_mem (hrs_mem_update (heap_update x v) s)) y = h_val (hrs_mem s) y"
  apply (subst hrs_mem_heap_update[symmetric])
  apply (subst h_val_heap_update_disjoint)
   apply blast
  apply clarsimp
  done

definition
  update_bytes :: "'a globals_scheme \<Rightarrow> 'b::mem_type ptr \<Rightarrow> word8 list \<Rightarrow> 'a globals_scheme"
where
  "update_bytes s p bs \<equiv> s\<lparr>t_hrs_' := hrs_mem_update (heap_update_list (ptr_val p) bs) (t_hrs_' s)\<rparr>"

lemma the_horse_says_neigh: "(s\<lparr>t_hrs_' := x\<rparr> = s\<lparr>t_hrs_' := y\<rparr>) = (x = y)"
 by (metis (erased, lifting) globals.cases_scheme globals.select_convs(1) globals.update_convs(1))

lemma upto_singleton[simp]:"[x..x] = [x]"
  by (simp add: upto_rec1)

lemma update_bytes_ignore_ptr_coerce[simp]: "update_bytes s (ptr_coerce p) = update_bytes s p"
  by (clarsimp simp:update_bytes_def intro!:ext)

lemma hrs_mem_update_commute:
  "f \<circ> g = g \<circ> f \<Longrightarrow> hrs_mem_update f (hrs_mem_update g s) = hrs_mem_update g (hrs_mem_update f s)"
  by (metis (no_types, lifting) comp_eq_elim hrs_htd_def hrs_htd_mem_update hrs_mem_def hrs_mem_f prod.collapse)

lemma hrs_mem_update_collapse:
  "hrs_mem_update f (hrs_mem_update g s) = hrs_mem_update (f \<circ> g) s"
  by (metis comp_eq_dest_lhs hrs_htd_def hrs_htd_mem_update hrs_mem_def hrs_mem_f prod.collapse)

lemma update_bytes_reorder:
  "{ptr_val p..+length cs} \<inter> {ptr_val q..+length bs} = {} \<Longrightarrow>
      update_bytes (update_bytes s q bs) p cs = update_bytes (update_bytes s p cs) q bs"
  apply (clarsimp simp:update_bytes_def)
  apply (subst the_horse_says_neigh)
  apply (subst hrs_mem_update_commute)
   apply (clarsimp intro!:ext)
   apply (subst heap_update_list_commute)
    apply clarsimp+
  done

lemma lt_step_down: "\<lbrakk>(x::nat) < y; x = y - 1 \<longrightarrow> P; x < y - 1 \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by force

(* XXX: This proof makes me sad. *)
lemma under_uint_imp_no_overflow: "x < ADDR_MAX \<Longrightarrow> ((of_nat x)::addr) + 1 \<noteq> 0"
  apply (induct x)
   apply (clarsimp simp:UWORD_MAX_def)+
  apply unat_arith
  apply (clarsimp simp:UWORD_MAX_def)
  apply (cut_tac y=x and z="(of_nat (ADDR_MAX - 1))::addr" in le_unat_uoi)
   apply (clarsimp simp:UWORD_MAX_def)+
  done

lemma heap_update_list_append3:
  "1 + length ys < 2 ^ word_bits \<Longrightarrow>
    heap_update_list s (y # ys) hp = heap_update_list s [y] (heap_update_list (s + 1) ys hp)"
  apply clarsimp
  apply (subst heap_update_list_append2[where xs="[y]", simplified])
   apply clarsimp+
  done

lemma hrs_mem_update_cong': "f = g \<Longrightarrow> hrs_mem_update f s = hrs_mem_update g s"
  by presburger

lemma update_bytes_append: "length bs \<le> ADDR_MAX \<Longrightarrow>
  update_bytes s p (b # bs) = update_bytes (update_bytes s p [b]) (byte_cast p +\<^sub>p 1) bs"
  apply (clarsimp simp:update_bytes_def)
  apply (subst the_horse_says_neigh)
  apply (subst hrs_mem_update_commute)
   apply (rule ext)+
   apply simp
   apply (case_tac "xa = ptr_val p")
    apply (clarsimp simp:fun_upd_def)
    apply (subst heap_update_nmem_same)
     apply (clarsimp simp:intvl_def ptr_add_def)
     apply (subgoal_tac "k < ADDR_MAX")
      prefer 2
      apply unat_arith
     apply (drule under_uint_imp_no_overflow)
     apply unat_arith
    apply clarsimp
   apply (subst heap_update_list_update)
    apply simp
   apply (clarsimp simp:fun_upd_def)
  apply (subst hrs_mem_update_collapse)
  apply (rule hrs_mem_update_cong')
  apply (clarsimp simp:ptr_add_def)
  apply (rule ext)
  apply (cut_tac xs="[b]" and ys=bs and s="ptr_val p" and hp=x in heap_update_list_append)
  apply (clarsimp simp:fun_upd_def intro!:ext)
  apply (rule conjI)
   apply clarsimp
   apply (subst heap_update_nmem_same)
    apply (clarsimp simp:ptr_add_def intvl_def)
    apply (subgoal_tac "k < ADDR_MAX")
     prefer 2
     apply unat_arith
    apply (drule under_uint_imp_no_overflow)
    apply unat_arith
   apply clarsimp
  apply clarsimp
  apply (case_tac "xa \<in> {ptr_val p + 1..+length bs}")
  apply (subst heap_update_mem_same_point)
    apply simp
   apply (subgoal_tac "addr_card = ADDR_MAX + 1")
    apply clarsimp
   apply (clarsimp simp:addr_card UWORD_MAX_def)
  apply (subst heap_update_mem_same_point)
    apply simp
   apply (subgoal_tac "addr_card = ADDR_MAX + 1")
    apply clarsimp
   apply (clarsimp simp:addr_card UWORD_MAX_def)
  apply clarsimp
  apply (subst heap_update_nmem_same)
   apply clarsimp
  apply (subst heap_update_nmem_same)
   apply clarsimp+
  done

lemma update_bytes_postpend: "length bs = x + 1 \<Longrightarrow>
  update_bytes s p bs = update_bytes (update_bytes s p (take x bs)) (byte_cast p +\<^sub>p (of_nat x)) [bs ! x]"
  apply (clarsimp simp:update_bytes_def)
  apply (subst the_horse_says_neigh)
  apply (clarsimp simp:ptr_add_def)
  apply (subst heap_update_list_concat_fold_hrs_mem)
   apply clarsimp+
  by (metis append_eq_conv_conj append_self_conv hd_drop_conv_nth2 lessI take_hd_drop)

lemma h_val_not_id_general:
  fixes y :: "'a::mem_type ptr"
  shows "\<forall>i \<in> {0..+size_of TYPE('a)}. \<forall>g. f g (ptr_val y + i) = g (ptr_val y + i)
     \<Longrightarrow> h_val (hrs_mem (hrs_mem_update f s)) y = h_val (hrs_mem s) y"
  apply (subst hrs_mem_update)
  apply (clarsimp simp:h_val_def)
  apply (subgoal_tac "heap_list (f (hrs_mem s)) (size_of TYPE('a)) (ptr_val y) =
                      heap_list (hrs_mem s) (size_of TYPE('a)) (ptr_val y)")
   apply clarsimp
  apply (cut_tac h="f (hrs_mem s)" and p="ptr_val y" and n="size_of TYPE('a)"
                 and h'="hrs_mem s" in heap_list_h_eq2)
   apply (erule_tac x="x - ptr_val y" in  ballE)
    apply clarsimp
   apply (clarsimp simp:intvl_def)+
  done

lemma h_val_not_id_list:
  fixes y :: "'a::mem_type ptr"
  shows "{x..+length vs} \<inter> {ptr_val y..+size_of TYPE('a)} = {}
     \<Longrightarrow> h_val (hrs_mem (hrs_mem_update (heap_update_list x vs) s)) y = h_val (hrs_mem s) y"
  apply (subst h_val_not_id_general)
   apply clarsimp
   apply (metis (erased, hide_lams) disjoint_iff_not_equal heap_update_nmem_same intvlD intvlI
          monoid_add_class.add.left_neutral)
  apply clarsimp
  done

lemma h_val_id_update_bytes:
  fixes q :: "'a::mem_type ptr"
  shows "{ptr_val q..+size_of TYPE('a)} \<inter> {ptr_val p..+length bs} = {}
          \<Longrightarrow> deref (update_bytes s p bs) q = deref s q"
  apply (clarsimp simp:update_bytes_def)
  apply (subst h_val_not_id_list)
   apply blast
  by simp

lemma bytes_at_len: "bytes_at s p bs \<Longrightarrow> length bs \<le> ADDR_MAX"
  by (clarsimp simp:bytes_at_def, fastforce)

(* Another sad proof. *)
lemma le_uint_max_imp_id: "x \<le> ADDR_MAX \<Longrightarrow> unat ((of_nat x)::addr) = x"
  apply (induct x)
   apply (clarsimp simp: UWORD_MAX_def)+
  apply unat_arith
  apply clarsimp
  done

lemma update_bytes_id: "update_bytes s p [] = s"
  apply (clarsimp simp:update_bytes_def)
  apply (subst heap_update_list_base')
  by (simp add: hrs_mem_update_id3)

lemma a_horse_by_any_other_name: "t_hrs_'_update f s = s\<lparr>t_hrs_' := f (t_hrs_' s)\<rparr>"
  by auto

lemma heap_update_list_singleton: "heap_update_list p [x] = heap_update (Ptr p) x"
  apply (rule ext)
  by (metis heap_update_def ptr_val.simps to_bytes_word8)

lemma update_bytes_eq: "\<lbrakk>s = s'; p = p'; bs = bs'\<rbrakk> \<Longrightarrow> update_bytes s p bs = update_bytes s' p' bs'"
  by clarsimp

text {*
  Memcpy does what it says on the box.
*}
lemma memcpy_wp':
  fixes src :: "'a::mem_type ptr"
    and dst :: "'b::mem_type ptr"
  shows "\<forall>s0 bs.
  \<lbrace>\<lambda>s. s = s0 \<and> c_guard src \<and> c_guard dst \<and> sz = of_nat (length bs) \<and> bytes_at s src bs \<and>
       no_wrap src (unat sz) \<and> no_wrap dst (unat sz) \<and> no_overlap src dst (unat sz)\<rbrace>
    memcpy' (ptr_coerce dst) (ptr_coerce src) sz
  \<lbrace>\<lambda>r s. r = ptr_coerce dst \<and> bytes_at s dst bs \<and> s = update_bytes s0 dst bs\<rbrace>!"
  apply (rule allI)+
  apply (rule validNF_assume_pre)
  unfolding memcpy'_def
  apply clarsimp
  apply (subst whileLoop_add_inv[where
    I="\<lambda>i s. unat i \<le> unat sz \<and>
             bytes_at s dst (take (unat i) bs) \<and>
             bytes_at s src bs \<and>
             s = update_bytes s0 dst (take (unat i) bs)" and
    M="\<lambda>(i, s). unat sz - unat i"])
  apply wp
    apply clarsimp
    apply (rule conjI)
     apply unat_arith
    apply (rule conjI)
     apply (simp add:bytes_at_def)
     apply (case_tac "bs = []")
      apply (rule disjI1)
      apply clarsimp
     apply (rule disjI2)
     apply clarsimp
     apply (rule conjI)
      apply unat_arith
     apply clarsimp
     apply (case_tac "unat i = ia")
      apply clarsimp
      apply (subgoal_tac "int (unat i) = uint i")
       prefer 2
       apply (subst uint_nat)
       apply simp
      apply simp
      apply (subst h_val_id)
      apply (subst h_val_id_update_bytes)
       apply (clarsimp simp:no_overlap_def ptr_add_def)
       apply (subgoal_tac "{ptr_val src + i..+Suc 0} \<subseteq> {ptr_val src..+unat (of_nat_addr (length bs))}")
        prefer 2
        apply (clarsimp simp:intvl_def)
        apply (rule_tac x="unat i" in exI)
        apply unat_arith
       apply (subgoal_tac "{ptr_val dst..+unat i} \<subseteq> {ptr_val dst..+unat (of_nat_addr (length bs))}")
        prefer 2
        apply (clarsimp simp:intvl_def)
        apply (rule exI, rule conjI, rule refl)
        apply (simp add: unat_of_nat)
       apply blast
      apply (erule_tac x="unat i" and P="\<lambda>x. deref s0 (byte_cast src +\<^sub>p int x) = bs ! x" in ballE)
       apply clarsimp
       apply (subst nth_take)
        apply unat_arith
       apply simp
      apply (erule disjE)
       apply clarsimp+
     apply (erule disjE)
      apply (subgoal_tac "length bs \<noteq> 0")
       prefer 2
       apply clarsimp
      apply (case_tac "unat i = 0")
       apply unat_arith
      apply linarith
     apply (subst h_val_not_id)
      apply (clarsimp simp:ptr_add_def intvl_def)
      (* Isabelle, why do you have to make it so hard? *)
      apply (erule_tac P="unat (of_nat ia) = ia" in notE)
      apply (cut_tac y=ia and z="(of_nat ADDR_MAX)::addr" in le_unat_uoi)
       apply (subgoal_tac "unat ((of_nat ADDR_MAX)::addr) = ADDR_MAX")
        prefer 2
        apply (simp add: unat_of_nat)
       apply (simp add: unat_of_nat)
      apply clarsimp
     apply clarsimp
     apply (erule_tac x=ia and A="{0..min (length bs) (unat i) - Suc 0}" in ballE)
      apply clarsimp
      apply (subst nth_take, unat_arith)+
      apply simp
     apply clarsimp
     apply unat_arith
    apply (rule conjI)
     apply (clarsimp simp:bytes_at_def)
     apply (subst h_val_not_id)
      apply (clarsimp simp:no_overlap_def)
      apply (subgoal_tac "ptr_val (byte_cast dst +\<^sub>p uint i) \<in> {ptr_val dst..+unat (of_nat (length bs))}")
       prefer 2
       apply (clarsimp simp:ptr_add_def intvl_def)
       apply (rule_tac x="unat i" in exI)
       apply clarsimp
       apply unat_arith
      (* More or less symmetric subgoal *)
      apply (subgoal_tac "ptr_val (byte_cast src +\<^sub>p int ia) \<in> {ptr_val src..+unat ((of_nat (length bs))::addr)}")
       prefer 2
       apply (clarsimp simp:ptr_add_def intvl_def)
       apply (rule_tac x=ia in exI)
       apply clarsimp
       apply (subgoal_tac "unat ((of_nat (length bs))::addr) = length bs")
        apply clarsimp
        apply arith
       apply (cut_tac y="length bs" and z="(of_nat ADDR_MAX)::addr" in le_unat_uoi)
        apply (simp add: unat_of_nat)
       apply arith
      apply (clarsimp simp:intvl_def ptr_add_def)
      apply blast
     apply clarsimp
    apply (rule conjI)
     apply (subst h_val_id_update_bytes)
      apply (clarsimp simp:no_overlap_def ptr_add_def)
      apply (subgoal_tac "{ptr_val src + i..+Suc 0} \<subseteq> {ptr_val src..+unat (of_nat_addr (length bs))}")
       prefer 2
       apply (clarsimp simp:intvl_def)
       apply (rule_tac x="unat i" in exI)
       apply unat_arith
      apply (subgoal_tac "{ptr_val dst..+min (length bs) (unat i)} \<subseteq> {ptr_val dst..+unat (of_nat_addr (length bs))}")
       prefer 2
       apply (clarsimp simp:intvl_def)
       apply (rule_tac x=ka in exI)
       apply unat_arith
      apply blast
     apply (subgoal_tac "deref s0 (byte_cast src +\<^sub>p uint i) = bs ! (unat i)")
      apply clarsimp
      apply (subgoal_tac "update_bytes s0 dst (take (unat (i + 1)) bs) =
                          update_bytes (update_bytes s0 dst (take (unat i) bs)) (byte_cast dst +\<^sub>p uint i) [bs ! unat i]")
       apply clarsimp
       apply (subgoal_tac
               "\<forall>s'. t_hrs_'_update (hrs_mem_update (heap_update (byte_cast dst +\<^sub>p uint i) (bs ! unat i))) s' =
                     update_bytes s' (byte_cast dst +\<^sub>p uint i) [bs ! unat i]")
        apply fast
       apply (clarsimp simp:update_bytes_def)
       apply (subst a_horse_by_any_other_name)
       apply (subst the_horse_says_neigh)
       apply (clarsimp simp:ptr_add_def)
       apply (subst heap_update_list_singleton)
       apply simp
      apply (cut_tac s=s0 and p=dst and bs="take (unat (i + 1)) bs" and x="unat i"
                     in update_bytes_postpend)
       apply (subgoal_tac "unat (i + 1) \<le> length bs")
        apply clarsimp
        apply unat_arith
       apply (subgoal_tac "unat i < length bs")
        apply unat_arith
       apply (rule unat_less_helper)
       apply simp
      apply clarsimp
      apply (rule update_bytes_eq)
        apply (subgoal_tac "min (unat i) (unat (i + 1)) = unat i")
         apply clarsimp
        apply clarsimp
        apply unat_arith
       apply (clarsimp simp:ptr_add_def)
      apply clarsimp
      apply (rule nth_take)
      apply unat_arith
     apply (clarsimp simp:bytes_at_def)
     apply (erule disjE)
      apply clarsimp
     apply clarsimp
     apply (erule_tac x="unat i" in ballE)
      apply (subst (asm) uint_nat[symmetric])
      apply simp
     apply clarsimp
     apply (subgoal_tac "unat i < length bs")
      prefer 2
      apply (rule unat_less_helper)
      apply simp
     apply unat_arith
    apply (rule conjI)
     apply unat_arith
    apply (rule conjI)
     apply (rule byte_ptr_guarded)
     apply (clarsimp simp:no_wrap_def intvl_def ptr_add_def)
     apply (erule_tac x="unat i" in allE)
     apply clarsimp
    apply (rule byte_ptr_guarded)
    apply (clarsimp simp:no_wrap_def intvl_def ptr_add_def)
    apply (erule_tac x="unat i" and
                     P="\<lambda>x. ptr_val dst + ((of_nat x)::addr) = 0 \<longrightarrow> \<not> x < unat ((of_nat_addr (length bs))::addr)"
                    in allE)
    apply clarsimp
   apply clarsimp
   apply (rule conjI)
    apply (subgoal_tac "unat i = length bs")
     apply clarsimp
    apply (case_tac "length bs = 0")
     apply clarsimp
    apply (subgoal_tac "length bs \<le> ADDR_MAX")
     prefer 2
     apply (clarsimp simp:bytes_at_def)
    (* XXX: We keep introducing this subgoal; we should do it once and for all up top. *)
    apply (subgoal_tac "unat ((of_nat (length bs))::addr) = length bs")
     prefer 2
     apply (cut_tac y="length bs" and z="(of_nat ADDR_MAX)::addr" in le_unat_uoi)
      apply (clarsimp simp:UWORD_MAX_def)
     apply clarsimp+
    apply unat_arith
   (* insert a bunch a tedium... *)
   apply (subgoal_tac "unat i = length bs")
    prefer 2
    apply (drule bytes_at_len)
    apply (subgoal_tac "unat (of_nat_addr (length bs)) = length bs")
     prefer 2
     apply (rule le_uint_max_imp_id)
     apply simp
    apply unat_arith
   apply clarsimp
  apply (simp add:update_bytes_id)
  done

lemma validNF_make_schematic_post':
  "(\<forall>s0 x. \<lbrace> \<lambda>s. P s0 x s \<rbrace> f \<lbrace> \<lambda>rv s. Q s0 x rv s \<rbrace>!) \<Longrightarrow>
   \<lbrace> \<lambda>s. \<exists>s0 x. P s0 x s \<and> (\<forall>rv s'. Q s0 x rv s' \<longrightarrow> Q' rv s') \<rbrace> f \<lbrace> Q'\<rbrace>!"
  by (auto simp add: valid_def validNF_def no_fail_def split: prod.splits)

lemmas memcpy_wp = memcpy_wp'[THEN validNF_make_schematic_post', simplified]

lemma h_val_not_id_update_bytes:
  fixes q :: "'a::mem_type ptr"
  shows "\<lbrakk>ptr_val p = ptr_val q; length bs = size_of TYPE('a)\<rbrakk> \<Longrightarrow>
            deref (update_bytes s p bs) q = from_bytes bs"
  apply (clarsimp simp:update_bytes_def h_val_def)
  apply (subst hrs_mem_update)
  apply (cut_tac p="ptr_val q" and v=bs and h="hrs_mem (t_hrs_' s)" in heap_list_update)
   apply clarsimp
   apply (metis less_imp_le max_size)
  by clarsimp

text {*
  Test that we can use memcpy in a compositional proof. The following proof can be done much more
  pleasantly, but we're just trying to check that the memcpy WP lemma is usable.
  TODO: This relies on disabling heap abstraction for the calling function as well. We should be
  able to phrase an exec_concrete WP lemma over memcpy that lets us prove properties about
  heap-abstracted callers. This will need AutoCorres support to connect is_valid_* with
  c_guard/no_overlap/no_wrap.
*}

definition
  memcpy_int_spec :: "sword32 ptr \<Rightarrow> sword32 ptr \<Rightarrow> bool"
where
  "memcpy_int_spec dst src \<equiv>
    \<forall>x. \<lbrace>\<lambda>s. deref s src = x \<and>
             {ptr_val src..+4} \<inter> {ptr_val dst..+4} = {} \<and>
             c_guard src \<and> c_guard dst \<and>
             no_wrap src 4 \<and> no_wrap dst 4\<rbrace>
          memcpy_int' dst src
        \<lbrace>\<lambda>_ s. deref s dst = x\<rbrace>!"

lemma memcpy_int_wp'[unfolded memcpy_int_spec_def]: "memcpy_int_spec dst src"
  unfolding memcpy_int_spec_def
  apply (rule allI)
  unfolding memcpy_int'_def
  apply (wp memcpy_wp)
  apply clarsimp
  apply (rule_tac x="[deref s (byte_cast src),
                      deref s (byte_cast src +\<^sub>p 1),
                      deref s (byte_cast src +\<^sub>p 2),
                      deref s (byte_cast src +\<^sub>p 3)]" in exI)
  apply (clarsimp simp:bytes_at_def no_overlap_def UINT_MAX_def)
  apply (rule conjI)
   apply clarsimp
   apply (case_tac "i = 0", clarsimp)
   apply (case_tac "i = 1", clarsimp)
   apply (case_tac "i = 2", clarsimp)
   apply (case_tac "i = 3", clarsimp)
   apply clarsimp
  apply clarsimp
  apply (subst h_val_not_id_update_bytes)
    apply clarsimp+
  apply (clarsimp simp:h_val_def)
  apply (subgoal_tac "heap_list (hrs_mem (t_hrs_' s)) 4 (ptr_val src) =
                      deref s (byte_cast src) # (heap_list (hrs_mem (t_hrs_' s)) 3 (ptr_val src + 1))")
   prefer 2
   apply (clarsimp simp:h_val_def)
   apply (metis Suc_numeral from_bytes_eq heap_list_rec semiring_norm(2) semiring_norm(8))
  apply (subgoal_tac "heap_list (hrs_mem (t_hrs_' s)) 3 (ptr_val src + 1) =
                      deref s (byte_cast src +\<^sub>p 1) # (heap_list (hrs_mem (t_hrs_' s)) 2 (ptr_val src + 2))")
   prefer 2
   apply (clarsimp simp:h_val_def ptr_add_def)
   apply (cut_tac h="hrs_mem (t_hrs_' s)" and p="ptr_val src + 1" and n=2 in heap_list_rec)
   apply clarsimp
   apply (simp add: add.commute from_bytes_eq)
  apply clarsimp
  apply (subgoal_tac "heap_list (hrs_mem (t_hrs_' s)) 2 (ptr_val src + 2) =
                      deref s (byte_cast src +\<^sub>p 2) # (heap_list (hrs_mem (t_hrs_' s)) 1 (ptr_val src + 3))")
   prefer 2
   apply (cut_tac h="hrs_mem (t_hrs_' s)" and p="ptr_val src + 2" and n=3 in heap_list_rec)
   apply (clarsimp simp:h_val_def ptr_add_def from_bytes_eq)
   apply (metis (no_types, hide_lams) Suc_eq_plus1 heap_list_base heap_list_rec is_num_normalize(1)
                monoid_add_class.add.left_neutral one_add_one one_plus_numeral semiring_norm(3))
  apply (clarsimp simp:h_val_def ptr_add_def from_bytes_eq)
  done

text {* memcpying a typed variable is equivalent to assignment. *}
lemma memcpy_type_wp':
  fixes dst :: "'a::mem_type ptr"
    and src :: "'a::mem_type ptr"
  shows "\<forall>s0 bs.
   \<lbrace>\<lambda>s. s = s0 \<and> c_guard dst \<and> c_guard src \<and> sz = of_nat (size_of TYPE('a)) \<and>
        no_overlap dst src (unat sz) \<and> no_wrap dst (unat sz) \<and> no_wrap src (unat sz) \<and>
        bytes_of s src bs\<rbrace>
     memcpy' (ptr_coerce dst) (ptr_coerce src) sz
   \<lbrace>\<lambda>r s. r = ptr_coerce dst \<and> bytes_of s dst bs \<and> s = update_bytes s0 dst bs\<rbrace>!"
  apply (rule allI)+
  apply (wp memcpy_wp)
  apply clarsimp
  apply (rule_tac x=bs in exI)
  apply clarsimp
  apply (subst no_overlap_sym)
  apply (clarsimp simp:bytes_of_def)
  done

lemmas memcpy_type_wp = memcpy_type_wp'[THEN validNF_make_schematic_post', simplified]

text {* Confirm that we can also prove memcpy_int using the previous generic lemma. *}
lemma memcpy_int_wp''[unfolded memcpy_int_spec_def]: "memcpy_int_spec dst src"
  unfolding memcpy_int_spec_def memcpy_int'_def
  apply (rule allI)
  apply (wp memcpy_type_wp)
  (* Remainder mostly clagged from the original proof above. *)
  apply clarsimp
  apply (rule conjI, clarsimp simp:no_overlap_def, blast)
  apply (rule_tac x="[deref s (byte_cast src),
                      deref s (byte_cast src +\<^sub>p 1),
                      deref s (byte_cast src +\<^sub>p 2),
                      deref s (byte_cast src +\<^sub>p 3)]" in exI)
  apply (rule conjI)
   apply (clarsimp simp:bytes_of_def bytes_at_def UINT_MAX_def)
   apply (case_tac "i = 0", clarsimp)
   apply (case_tac "i = 1", clarsimp)
   apply (case_tac "i = 2", clarsimp)
   apply (case_tac "i = 3", clarsimp)
   apply clarsimp
  apply clarsimp
  apply (subst h_val_not_id_update_bytes, clarsimp+)
  apply (clarsimp simp:h_val_def)
  apply (subgoal_tac "heap_list (hrs_mem (t_hrs_' s)) 4 (ptr_val src) =
                      deref s (byte_cast src) # (heap_list (hrs_mem (t_hrs_' s)) 3 (ptr_val src + 1))")
   prefer 2
   apply (clarsimp simp:h_val_def from_bytes_eq)
   apply (subst heap_list_rec[symmetric])
   apply simp
  apply (subgoal_tac "heap_list (hrs_mem (t_hrs_' s)) 3 (ptr_val src + 1) =
                      deref s (byte_cast src +\<^sub>p 1) # (heap_list (hrs_mem (t_hrs_' s)) 2 (ptr_val src + 2))")
   prefer 2
   apply (clarsimp simp:h_val_def ptr_add_def)
   apply (cut_tac h="hrs_mem (t_hrs_' s)" and p="ptr_val src + 1" and n=2 in heap_list_rec)
   apply (clarsimp simp: from_bytes_eq)
   apply (metis add.commute)
  apply clarsimp
  apply (subgoal_tac "heap_list (hrs_mem (t_hrs_' s)) 2 (ptr_val src + 2) =
                      deref s (byte_cast src +\<^sub>p 2) # (heap_list (hrs_mem (t_hrs_' s)) 1 (ptr_val src + 3))")
   prefer 2
   apply (cut_tac h="hrs_mem (t_hrs_' s)" and p="ptr_val src + 2" and n=3 in heap_list_rec)
   apply (clarsimp simp:h_val_def ptr_add_def from_bytes_eq)
   apply (metis (no_types, hide_lams) Suc_eq_plus1 heap_list_base heap_list_rec is_num_normalize(1)
                monoid_add_class.add.left_neutral one_add_one one_plus_numeral semiring_norm(3))
  apply (clarsimp simp:h_val_def ptr_add_def from_bytes_eq)
  done

lemma bytes_of_imp_at[simp]: "bytes_of s x bs \<Longrightarrow> bytes_at s x bs"
  by (clarsimp simp:bytes_of_def bytes_at_def)

lemma bytes_at_imp_of:
  fixes x :: "'a::mem_type ptr"
  shows "\<lbrakk>bytes_at s x bs; length bs = size_of TYPE('a)\<rbrakk> \<Longrightarrow> bytes_of s x bs"
  by (clarsimp simp:bytes_of_def bytes_at_def)

text {*
  Memcpying from a source to a destination via an intermediary does what it should. This is close to
  the desirable property we want for CAmkES systems; i.e. that copying into your IPC buffer on one
  side and then out on the other gives you back what you put in. Note that the type of the
  intermediate pointer is irrelevant and we don't need to assume that the source and final
  destination do not overlap.
*}
lemma memcpy_seq:
  fixes x :: "'a::mem_type ptr"
    and y :: "'b::mem_type ptr"
    and z :: "'a::mem_type ptr"
  shows "\<forall>s0 bs.
   \<lbrace>\<lambda>s. s = s0 \<and> sz = of_nat (size_of TYPE('a)) \<and>
        c_guard x \<and> c_guard y \<and> c_guard z \<and>
        no_wrap x (unat sz) \<and> no_wrap y (unat sz) \<and> no_wrap z (unat sz) \<and>
        no_overlap x y (unat sz) \<and> no_overlap y z (unat sz) \<and>
        bytes_of s x bs\<rbrace>
    do memcpy' (ptr_coerce y) (ptr_coerce x) sz;
       memcpy' (ptr_coerce z) (ptr_coerce y) sz
    od
   \<lbrace>\<lambda>r s. r = ptr_coerce z \<and> bytes_of s z bs\<rbrace>!"
  apply (rule allI)+
  apply (wp memcpy_wp)
  apply clarsimp
  apply (rule_tac x=bs in exI)
  apply clarsimp
  apply (rule conjI, clarsimp simp:bytes_of_def)
  apply clarsimp
  apply (rule_tac x=bs in exI)
  apply (rule conjI, clarsimp simp:bytes_of_def)
  apply clarsimp
  apply (rule bytes_at_imp_of)
   apply (clarsimp simp:bytes_of_def)+
  done

lemma update_ti_eq:
  fixes x :: "'a::mem_type"
    and y :: 'a
  shows "\<lbrakk>length bs = size_of TYPE('a); bs = bs'\<rbrakk>
          \<Longrightarrow> update_ti_t (typ_info_t TYPE('a)) bs x = update_ti_t (typ_info_t TYPE('a)) bs' y"
  by (clarsimp simp:upd)

lemma from_bytes_cong: "x = y \<Longrightarrow> from_bytes x = from_bytes y"
  by simp

declare from_bytes_eq [simp]

text {*
  If you dereference a pointer, the value you get is the same as the underlying bytes backing that
  memory.
*}
lemma val_eq_bytes:
  fixes x :: "'a::mem_type ptr"
  shows "deref s x = from_bytes (map (\<lambda>off. deref s (byte_cast x +\<^sub>p of_nat off)) [0..<size_of TYPE('a)])"
  apply (clarsimp simp:h_val_def ptr_add_def)
  apply (rule from_bytes_cong)
  apply (rule nth_equalityI)
   apply clarsimp+
  apply (subst heap_list_nth)
   apply clarsimp+
  done

lemma extract_list_elem: "i < n \<Longrightarrow> f i = (map f [0..<n]) ! i"
  apply (induct i)
   apply clarsimp+
  done

lemma update_deref:
  fixes x :: "'a::mem_type ptr"
  shows "size_of TYPE('a) = length bs \<Longrightarrow> deref (update_bytes s x bs) x = from_bytes bs"
  apply (clarsimp simp:update_bytes_def)
  apply (subst hrs_mem_update)
  apply (clarsimp simp:h_val_def)
  apply (subst heap_list_update)
   apply (metis less_imp_le max_size)
  apply clarsimp
  done

text {*
  The memcpy_int proof can now be completed more elegantly. Note that the body of this proof is more
  generic than the previous attempts and doesn't involve manually reasoning about each byte.
*}
lemma memcpy_int_wp'''[unfolded memcpy_int_spec_def]: "memcpy_int_spec dst src"
  unfolding memcpy_int_spec_def memcpy_int'_def
  apply (rule allI)
  apply (wp memcpy_type_wp)
  apply clarsimp
  apply (rule conjI, clarsimp simp:no_overlap_def, blast)
  apply (rule_tac x="map (\<lambda>i. deref s (byte_cast src +\<^sub>p of_nat i)) [0..<size_of TYPE(32sword)]" in exI)
  apply (rule conjI)
   apply (clarsimp simp:bytes_of_def bytes_at_def UINT_MAX_def)+
  apply (subst update_deref)
   apply clarsimp
  apply (cut_tac s=s and x=src in val_eq_bytes)
  apply clarsimp
  done

lemma bytes_at_heap_list:
  fixes x :: "'a::mem_type ptr"
  shows "\<lbrakk>n \<le> ADDR_MAX; no_wrap x n\<rbrakk>
          \<Longrightarrow> bytes_at s x (heap_list (hrs_mem (t_hrs_' s)) n (ptr_val x))"
  apply (clarsimp simp:bytes_at_def ptr_add_def h_val_def)
  apply (subst heap_list_nth)
   apply unat_arith
  apply clarsimp
  done

text {*
  A collection of useful type-generic implications for moving from the abstract heap to the concrete
  heap.
*}
definition
  is_valid_imp_c_guard :: "(lifted_globals \<Rightarrow> 'b::mem_type ptr \<Rightarrow> bool) \<Rightarrow> bool"
where
  "is_valid_imp_c_guard is_valid \<equiv> \<forall>s p. is_valid (lift_global_heap s) p \<longrightarrow> c_guard p"
definition
  is_valid_imp_no_null :: "(lifted_globals \<Rightarrow> 'b::mem_type ptr \<Rightarrow> bool) \<Rightarrow> bool"
where
  "is_valid_imp_no_null is_valid \<equiv>
     \<forall>s p. is_valid (lift_global_heap s) p \<longrightarrow> 0 \<notin> {ptr_val p..of_nat (size_of TYPE('b))}"
definition
  is_valid_imp_no_wrap :: "(lifted_globals \<Rightarrow> 'b::mem_type ptr \<Rightarrow> bool) \<Rightarrow> bool"
where
  "is_valid_imp_no_wrap is_valid \<equiv>
     \<forall>s p. is_valid (lift_global_heap s) p \<longrightarrow> no_wrap p (size_of TYPE('b))"
definition
  is_valid_imp_no_overlap :: "(lifted_globals \<Rightarrow> 'b::mem_type ptr \<Rightarrow> bool) \<Rightarrow> bool"
where
  "is_valid_imp_no_overlap is_valid \<equiv>
     \<forall>s p q. is_valid (lift_global_heap s) p \<and> is_valid (lift_global_heap s) q \<and> p \<noteq> q
               \<longrightarrow> no_overlap p q (size_of TYPE('b))"
definition
  is_valid_imp_heap_ptr_valid :: "(lifted_globals \<Rightarrow> 'b::mem_type ptr \<Rightarrow> bool) \<Rightarrow> bool"
where
  "is_valid_imp_heap_ptr_valid is_valid \<equiv>
     \<forall>s p. is_valid (lift_global_heap s) p \<longrightarrow> heap_ptr_valid (hrs_htd (t_hrs_' s)) p"

text {* We can easily discharge these for a given type. *}
lemma is_valid_w32_imp_c_guard[unfolded is_valid_imp_c_guard_def, simplified]:
    "is_valid_imp_c_guard is_valid_w32"
  unfolding is_valid_imp_c_guard_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  apply (rule simple_lift_c_guard, force)
  done

lemma is_valid_w32_imp_no_null[unfolded is_valid_imp_no_null_def, simplified]:
    "is_valid_imp_no_null is_valid_w32"
  unfolding is_valid_imp_no_null_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  apply (drule simple_lift_c_guard)
  apply (clarsimp simp:c_guard_def c_null_guard_def intvl_def)
  by force

lemma is_valid_w32_imp_no_wrap[unfolded is_valid_imp_no_wrap_def, simplified]:
    "is_valid_imp_no_wrap is_valid_w32"
  unfolding is_valid_imp_no_wrap_def no_wrap_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  apply (drule simple_lift_c_guard)
  apply (clarsimp simp:c_guard_def c_null_guard_def intvl_def)
  done

lemma is_valid_w32_imp_no_overlap[unfolded is_valid_imp_no_overlap_def, simplified]:
    "is_valid_imp_no_overlap is_valid_w32"
  unfolding is_valid_imp_no_overlap_def no_wrap_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)+
  apply clarsimp
  apply (drule simple_lift_heap_ptr_valid)+
  apply (clarsimp simp:no_overlap_def)
  apply (cut_tac p=p and q=q and d="hrs_htd (t_hrs_' s)" in heap_ptr_valid_neq_disjoint)
     apply clarsimp+
  done

lemma is_valid_w32_imp_heap_ptr_valid[unfolded is_valid_imp_heap_ptr_valid_def, simplified]:
    "is_valid_imp_heap_ptr_valid is_valid_w32"
  unfolding is_valid_imp_heap_ptr_valid_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  by (rule simple_lift_heap_ptr_valid, force)

text {*
  With that support in place, we can now prove a heap-abstracted call to memcpy of a type in a
  reasonably generic way. Note that we leverage the relationship between
  is_valid_*/lift_global_heap/simple_lift to transfer assumptions across the boundary between the
  abstract and concrete heaps.
*}
lemma
  fixes dst :: "32word ptr"
    and src :: "32word ptr"
  shows "\<forall>s0 x.
   \<lbrace>\<lambda>s. s = s0 \<and> is_valid_w32 s dst \<and> is_valid_w32 s src \<and> sz = of_nat (size_of TYPE(32word)) \<and>
        heap_w32 s src = x \<and> dst \<noteq> src\<rbrace>
     exec_concrete lift_global_heap (memcpy' (ptr_coerce dst) (ptr_coerce src) sz)
   \<lbrace>\<lambda>r s. r = ptr_coerce dst \<and> heap_w32 s dst = x\<rbrace>!"
  apply (rule allI)+
  apply (wp memcpy_wp)
  apply (clarsimp simp:is_valid_w32_imp_c_guard
                       is_valid_w32_imp_no_wrap
                       is_valid_w32_imp_no_overlap)
  apply (rule_tac x="map (\<lambda>i. deref s (byte_cast src +\<^sub>p of_nat i)) [0..<size_of TYPE(32word)]" in exI)
  apply clarsimp
  apply (rule conjI)
   apply (clarsimp simp:bytes_at_def UINT_MAX_def)
  apply clarsimp
  apply (subst lifted_globals_ext_simps(3))+
  apply (clarsimp simp:simple_lift_def is_valid_w32_imp_heap_ptr_valid)
  apply (rule conjI)
   apply clarsimp
   apply (subst update_deref)
    apply clarsimp+
   apply (cut_tac s=s and x=src in val_eq_bytes)
   apply clarsimp
  apply (clarsimp simp:update_bytes_def is_valid_w32_imp_heap_ptr_valid)
  done

text {*
  Let's do the same instantiation for a structure. Note that the proof text for the following lemmas
  is identical to the word 32 instantiation above. These could be straightforwardly abstracted into
  a locale which could be automatically interpreted with the use of generated proofs.
*}
lemma is_valid_my_structure_imp_c_guard[unfolded is_valid_imp_c_guard_def, simplified]:
    "is_valid_imp_c_guard is_valid_my_structure_C"
  unfolding is_valid_imp_c_guard_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  apply (rule simple_lift_c_guard, force)
  done

lemma is_valid_my_structure_imp_no_null[unfolded is_valid_imp_no_null_def, simplified]:
    "is_valid_imp_no_null is_valid_my_structure_C"
  unfolding is_valid_imp_no_null_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  apply (drule simple_lift_c_guard)
  apply (clarsimp simp:c_guard_def c_null_guard_def intvl_def)
  by force

lemma is_valid_my_structure_imp_no_wrap[unfolded is_valid_imp_no_wrap_def, simplified]:
    "is_valid_imp_no_wrap is_valid_my_structure_C"
  unfolding is_valid_imp_no_wrap_def no_wrap_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  apply (drule simple_lift_c_guard)
  apply (clarsimp simp:c_guard_def c_null_guard_def intvl_def)
  done

lemma is_valid_my_structure_imp_no_overlap[unfolded is_valid_imp_no_overlap_def, simplified]:
    "is_valid_imp_no_overlap is_valid_my_structure_C"
  unfolding is_valid_imp_no_overlap_def no_wrap_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)+
  apply clarsimp
  apply (drule simple_lift_heap_ptr_valid)+
  apply (clarsimp simp:no_overlap_def)
  apply (cut_tac p=p and q=q and d="hrs_htd (t_hrs_' s)" in heap_ptr_valid_neq_disjoint)
     apply clarsimp+
  done

lemma is_valid_my_structure_imp_heap_ptr_valid[unfolded is_valid_imp_heap_ptr_valid_def, simplified]:
    "is_valid_imp_heap_ptr_valid is_valid_my_structure_C"
  unfolding is_valid_imp_heap_ptr_valid_def
  apply clarsimp
  apply (subst (asm) lifted_globals_ext_simps)
  apply clarsimp
  by (rule simple_lift_heap_ptr_valid, force)

text {*
  Again, we can now trivially transfer Hoare triple properties.
*}
lemma
  fixes dst :: "my_structure_C ptr"
    and src :: "my_structure_C ptr"
  shows "\<forall>s0 x.
   \<lbrace>\<lambda>s. s = s0 \<and> is_valid_my_structure_C s dst \<and> is_valid_my_structure_C s src \<and>
        heap_my_structure_C s src = x \<and> dst \<noteq> src\<rbrace>
     memcpy_struct' dst src
   \<lbrace>\<lambda>r s. r = dst \<and> heap_my_structure_C s dst = x\<rbrace>!"
  apply (rule allI)+
  unfolding memcpy_struct'_def
  apply (wp memcpy_wp)
  apply (clarsimp simp:is_valid_my_structure_imp_c_guard)
  apply (rule_tac x="map (\<lambda>i. deref s (byte_cast src +\<^sub>p of_nat i)) [0..<size_of TYPE(my_structure_C)]" in exI)
  apply (clarsimp simp:is_valid_my_structure_imp_no_wrap is_valid_my_structure_imp_no_overlap)
  apply (rule conjI)
   apply (clarsimp simp:bytes_at_def UINT_MAX_def)
  apply clarsimp
  apply (subst lifted_globals_ext_simps)+
  apply (clarsimp simp:simple_lift_def is_valid_my_structure_imp_heap_ptr_valid)
  apply (rule conjI)
   apply clarsimp
   apply (subst update_deref)
    apply clarsimp
   apply (cut_tac s=s and x=src in val_eq_bytes)
   apply clarsimp
  apply (clarsimp simp:update_bytes_def is_valid_my_structure_imp_heap_ptr_valid)
  done

end

end


(*  Title:      HOL/Auth/n_mutualExSimp_lemma_inv__4_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_mutualExSimp Protocol Case Study*}

theory n_mutualExSimp_lemma_inv__4_on_rules imports n_mutualExSimp_lemma_on_inv__4
begin
section{*All lemmas on causal relation between inv__4*}
lemma lemma_inv__4_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv4. p__Inv4\<le>N\<and>f=inv__4  p__Inv4)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i. i\<le>N\<and>r=n_Crit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Exit  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_Idle  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Crit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_CritVsinv__4) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Exit  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_ExitVsinv__4) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_Idle  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_IdleVsinv__4) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


theory Lifter_idem
 imports  "../Mergeable/Mergeable_Instances" "../Mergeable/Mergeable_Oalist" "../Mergeable/Mergeable_Roalist" "../Mergeable/Mono"
begin

(* When we lift syntaxes we reverse the function arrow *)
type_synonym ('a, 'b) syn_lifting = "('b \<Rightarrow> 'a)"

(*
datatype ('syn, 'a, 'b) lifting =
  LMake  (LUpd : "('syn \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b)")
         (LOut : "('syn \<Rightarrow> 'b \<Rightarrow> 'a)")
         (LBase : "('syn \<Rightarrow> 'b)")
*)

(*
"mappable" typeclass?
*)

(* need a generic way to talk about things over which LMap makes sense.

*)

datatype ('syn, 'a, 'b, 'f) lifting =
  LMake  (LUpd_Idem : "('syn \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b)")
         (LPost : "('syn \<Rightarrow> 'b \<Rightarrow> 'b)")
         (LOut : "('syn \<Rightarrow> 'b \<Rightarrow> 'a)")
         (LBase : "('syn \<Rightarrow> 'b)")
         (LFD : "'f \<Rightarrow> 'syn \<Rightarrow> 'a \<Rightarrow> 'a")

type_synonym ('syn, 'a, 'b) lifting' =
  "('syn, 'a, 'b, 'syn \<Rightarrow> 'a \<Rightarrow> 'a) lifting"

definition LUpd ::
  "('syn, 'a, 'b, 'f) lifting \<Rightarrow> 'syn \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b" where
"LUpd l s a b =
  LPost l s (LUpd_Idem l s a b)"

definition LMap_Idem ::
  "('x, 'a, 'b, 'f) lifting \<Rightarrow> 'f \<Rightarrow> ('x \<Rightarrow> 'b \<Rightarrow> 'b)" where
"LMap_Idem l f s b =
  LUpd_Idem l s (LFD l f s (LOut l s b)) b"

definition LMap ::
  "('x, 'a, 'b, 'f) lifting \<Rightarrow> 'f \<Rightarrow> ('x \<Rightarrow> 'b \<Rightarrow> 'b)" where
"LMap l f s b =
  LUpd l s (LFD l f s (LOut l s b)) b"

definition LNew :: "('syn, 'a, 'b, 'f) lifting \<Rightarrow> 'syn \<Rightarrow> 'a \<Rightarrow> 'b"  where
"LNew l s a = LUpd l s a (LBase l s)"

(* TODO: make sure this is a good idea. *)
declare LNew_def [simp]
declare LMap_def [simp]
declare LMap_Idem_def [simp]
declare LUpd_def [simp]

type_synonym ('syn, 'b) valid_set =
"'syn \<Rightarrow> 'b set"

(* liftings can have several kinds of validity properties, only some of
   which depend on others.
*)

(* TODO: for inference purposes we are probably going to
 * still have to use something like our current formulation. *)

class Okay =
  fixes ok_S :: "('a) set"

instantiation md_triv :: (_) Okay
begin
definition triv_ok_S : "(ok_S :: 'a md_triv set) = UNIV"
instance proof
qed
end

instantiation md_prio :: (Okay) Okay
begin
definition prio_ok_S : "(ok_S :: 'a md_prio set) = ({x . \<exists> px vx . x = mdp vx px \<and> px \<in> ok_S})"
instance proof qed
end

instantiation option :: (Okay) Okay
begin
definition option_ok_S : "(ok_S :: 'a option set) = (Some ` ok_S)"
instance proof qed
end

instantiation prod :: (Okay, Okay) Okay
begin
definition prod_ok_S : "(ok_S :: ('a * 'b) set) = { x :: 'a * 'b . \<exists> a' b' . x = (a', b') \<and> a' \<in> ok_S \<and> b' \<in> ok_S}"
instance proof qed
end

instantiation oalist :: (linorder, Okay) Okay
begin

definition oalist_ok_S :
  "(ok_S :: ('a, 'b) oalist set) = { x  :: ('a, 'b) oalist . oalist_all_val (\<lambda> y . y \<in> ok_S) x }"
instance proof qed
end

instantiation unit :: Okay
begin
definition unit_ok_S :
  "(ok_S :: unit set) = UNIV"
instance proof qed
end

locale lifting_valid_weak =
  fixes l :: "('syn, 'a, 'b :: Pord_Weak, 'f) lifting"
  fixes S :: "('syn, 'b) valid_set"
  assumes put_get : "\<And> s a b . LOut l s (LUpd_Idem l s a b) = a"
  assumes post_nop : "\<And> s b . LOut l s (LPost l s b) = LOut l s b"
  assumes put_S : "\<And> s a b . LUpd_Idem l s a b \<in> S s"
  assumes post_S : "\<And> s b . b \<in> S s \<Longrightarrow> LPost l s b \<in> S s"
  assumes post_geq : "\<And> s b . b <[ LPost l s b"
  assumes get_put_weak : "\<And> s b . b \<in> S s \<Longrightarrow> b = LUpd_Idem l s (LOut l s b) b"

locale lifting_putonly =
  fixes l :: "('syn, 'a, 'b :: Pord_Weak, 'f) lifting"
  fixes S :: "('syn, 'b) valid_set"
  assumes put_S : "\<And> s a b . LUpd l s a b \<in> S s"

(* TODO reexamine this *)
locale lifting_presonly =
  fixes l :: "('syn, 'a, 'b :: Pord_Weak, 'f) lifting"
  fixes S :: "('syn, 'b) valid_set"
  assumes pres :
    "\<And> v V supr f s .
         v \<in> V \<Longrightarrow>
         V \<subseteq> S s \<Longrightarrow>
         is_sup V supr \<Longrightarrow> supr \<in> S s \<Longrightarrow> is_sup (LMap_Idem l f s ` V) (LMap_Idem l f s supr)"
  assumes pres_post :
    "\<And> v V supr s .
      v \<in> V \<Longrightarrow>
      V \<subseteq> S s \<Longrightarrow>
      is_sup V supr \<Longrightarrow>
      supr \<in> S s \<Longrightarrow>
      is_sup (LPost l s ` V) (LPost l s supr)"

(* reduced version of lifting-valid, for use with
 * improper merges (when using merge_l as a tool for combining
 * semantics) *)
locale lifting_valid_presonly =
  lifting_putonly + lifting_presonly

locale lifting_valid = lifting_valid_weak +
  assumes put_put : "\<And> s a1 a2 b . LUpd_Idem l s a1 (LUpd_Idem l s a2 b) = LUpd_Idem l s a1 b"

locale lifting_valid_weak_base = lifting_valid_weak +
  assumes base : "\<And> s . LBase l s = \<bottom>"

locale lifting_valid_base = lifting_valid + lifting_valid_weak_base

locale lifting_valid_weak_ok = lifting_valid_weak +
  assumes ok_S_valid : "\<And> s . ok_S \<subseteq> S s"
  assumes ok_S_put : "\<And> s a b . b \<in> ok_S \<Longrightarrow> LUpd_Idem l s a b \<in> ok_S"
  assumes ok_S_post : "\<And> s b . b \<in> ok_S \<Longrightarrow> LPost l s b \<in> ok_S"

locale lifting_valid_ok = lifting_valid + lifting_valid_weak_ok

locale lifting_valid_weak_base_ok = lifting_valid_weak_ok + lifting_valid_weak_base

locale lifting_valid_base_ok = lifting_valid_ok + lifting_valid_base

locale lifting_valid_weak_pres = lifting_valid_weak +
  lifting_presonly
(*
sublocale lifting_valid_weak_pres \<subseteq> lifting_valid_presonly
proof
  show "\<And>s a b. LUpd l s a b \<in> S s"
    using put_S by auto
next
  show "\<And>v V supr f s.
       v \<in> V \<Longrightarrow>
       V \<subseteq> S s \<Longrightarrow>
       is_sup V supr \<Longrightarrow>
       supr \<in> S s \<Longrightarrow>
       is_sup (LMap l f s ` V)
        (LMap l f s supr)"
    using pres
    by auto
qed
*)

locale lifting_valid_pres = lifting_valid + lifting_valid_weak_pres

locale lifting_valid_weak_base_pres = lifting_valid_weak_pres + lifting_valid_weak_base +
  assumes bot_bad : "\<And> s . \<bottom> \<notin> S s"

locale lifting_valid_base_pres = lifting_valid_pres + lifting_valid_weak_base_pres

locale lifting_valid_weak_ok_pres = lifting_valid_weak_pres + lifting_valid_weak_ok

locale lifting_valid_ok_pres = lifting_valid_pres + lifting_valid_ok

locale lifting_valid_weak_base_ok_pres =
  lifting_valid_weak_base_pres + lifting_valid_weak_base_ok

(* generally we are assuming we won't be using ok and pres separately.
 * we could if we wanted to though. *)
locale lifting_valid_base_ok_pres =
  lifting_valid_base_pres + lifting_valid_base_ok

(* orthogonality, used to define merge correctness *)
(*
these were originally pord_weak, but this was
(i think) insufficient to prove fst_l_ortho;
the strengthening to pord shouldn't be an issue though.
*)
locale l_ortho' =
  fixes l1 :: "('a, 'b1, 'c :: Pord, 'f1) lifting"
  fixes S1 :: "'a \<Rightarrow> 'c set"
  fixes l2 :: "('a, 'b2, 'c :: Pord, 'f2) lifting"
  fixes S2 :: "'a \<Rightarrow> 'c set"

(* need set membership constraints. *)
locale l_ortho =
  l_ortho' +

  assumes eq_base : "\<And> s . LBase l1 s = LBase l2 s"
  assumes compat_idem : "\<And> s a1 a2 b1 b2 supr .
    is_sup {b1, b2} supr \<Longrightarrow>
    has_sup {LUpd_Idem l1 s a1 b1, LUpd_Idem l2 s a2 b2}"

  assumes compat_post : "\<And> b1 b2 s supr . is_sup {b1, b2} supr \<Longrightarrow> has_sup {LPost l1 s b1, LPost l2 s b2}"

  assumes compat_idem_S : "\<And> s a1 a2 b1 b2 supr0 supr .
      is_sup {b1, b2} supr0 \<Longrightarrow>
      is_sup {LUpd_Idem l1 s a1 b1, LUpd_Idem l2 s a2 b2} supr \<Longrightarrow>
                        supr \<in> (S1 s \<inter> S2 s)"

  assumes compat_post_S : "\<And> s b1 b2 supr0 supr .
        is_sup {b1, b2} supr0 \<Longrightarrow>
        supr0 \<in> S1 s \<Longrightarrow>
        supr0 \<in> S2 s \<Longrightarrow>
        is_sup {LPost l1 s b1, LPost l2 s b2} supr \<Longrightarrow>
        supr \<in> (S1 s \<inter> S2 s)"

  assumes compat_idem_get1 :
      "\<And> s a1 a2 b1 b2 supr0 supr .
         is_sup {b1, b2} supr0 \<Longrightarrow>
         is_sup {LUpd_Idem l1 s a1 b1, LUpd_Idem l2 s a2 b2} supr \<Longrightarrow>
                        LOut l1 s supr = a1"

    assumes compat_idem_get2 : "\<And> s a1 a2 b1 b2 supr0 supr .
         is_sup {b1, b2} supr0 \<Longrightarrow>
          is_sup {LUpd_Idem l1 s a1 b1, LUpd_Idem l2 s a2 b2} supr \<Longrightarrow>
                        LOut l2 s supr = a2"

  assumes compat_post_get1 : "\<And> s b1 b2 supr0 supr .
     is_sup {b1, b2} supr0 \<Longrightarrow>
     is_sup {LPost l1 s b1, LPost l2 s b2} supr \<Longrightarrow>
      LOut l1 s supr = LOut l1 s supr0"

  assumes compat_post_get2 : "\<And> s b1 b2 supr0 supr .
    is_sup {b1, b2} supr0 \<Longrightarrow>
    is_sup {LPost l1 s b1, LPost l2 s b2} supr \<Longrightarrow>
        LOut l2 s supr = LOut l2 s supr0"

  assumes put1_S2 : "\<And> s a b . b \<in> S2 s \<Longrightarrow> LUpd_Idem l1 s a b \<in> S2 s"
  assumes put2_S1 : "\<And> s a b . b \<in> S1 s \<Longrightarrow> LUpd_Idem l2 s a b \<in> S1 s"

(* TODO: this feels weird*)
locale l_ortho_strong = l_ortho +
  assumes compat_put_put :
    "\<And> s x1 x2 y1 y2 b1 b2 supr0 supr1 supr2 supr3.
      is_sup {b1, b2} supr0 \<Longrightarrow>
      is_sup {LUpd_Idem l1 s y1 b1, LUpd_Idem l2 s y2 b2} supr1 \<Longrightarrow>
      is_sup {LUpd_Idem l1 s x1 supr1, LUpd_Idem l2 s x2 supr1} supr2 \<Longrightarrow>
      is_sup {LUpd_Idem l1 s x1 b1, LUpd_Idem l2 s x2 b2} supr3 \<Longrightarrow>
      supr2 = supr3"

lemma (in l_ortho) compat :
  fixes s a1 a2 b1 b2 supr
  assumes Supr : "is_sup {b1, b2} supr"
  shows "has_sup {LUpd l1 s a1 b1, LUpd l2 s a2 b2}"
proof-

  obtain supr' where Supr' : "is_sup {LUpd_Idem l1 s a1 b1, LUpd_Idem l2 s a2 b2} supr'"
    using compat_idem[OF Supr]
    by(fastforce simp add: has_sup_def)

  show "has_sup {LUpd l1 s a1 b1, LUpd l2 s a2 b2}"
    using compat_post[OF Supr']
    unfolding LUpd_def
    by(auto)
qed

lemma (in l_ortho) compat_get1 :
  fixes s a1 a2 b1 b2 supr0 supr
  assumes Supr0 : "is_sup {b1, b2} supr0"
  assumes Supr : "is_sup {LUpd l1 s a1 b1, LUpd l2 s a2 b2} supr"
  shows "LOut l1 s supr = a1"
proof-

  obtain supr' where Supr' : "is_sup {LUpd_Idem l1 s a1 b1, LUpd_Idem l2 s a2 b2} supr'"
    using compat_idem[OF Supr0]
    by(fastforce simp add: has_sup_def)

  have "LOut l1 s supr' = a1"
    using compat_idem_get1[OF Supr0 Supr']
    by auto

  then show "LOut l1 s supr = a1"
    using compat_post_get1[OF Supr'] Supr
    unfolding LUpd_def
    by(auto simp add: LUpd_def)
qed

lemma (in l_ortho) compat_get2 :
  fixes s a1 a2 b1 b2 supr0 supr
  assumes Supr0 : "is_sup {b1, b2} supr0"
  assumes Supr : "is_sup {LUpd l1 s a1 b1, LUpd l2 s a2 b2} supr"
  shows "LOut l2 s supr = a2"
proof-

  obtain supr' where Supr' : "is_sup {LUpd_Idem l1 s a1 b1, LUpd_Idem l2 s a2 b2} supr'"
    using compat_idem[OF Supr0]
    by(fastforce simp add: has_sup_def)

  have "LOut l2 s supr' = a2"
    using compat_idem_get2[OF Supr0 Supr']
    by auto

  then show "LOut l2 s supr = a2"
    using compat_post_get2[OF Supr'] Supr
    unfolding LUpd_def
    by(auto simp add: LUpd_def)
qed

lemma (in l_ortho) compat_S :
  fixes s a1 a2 b1 b2 supr0 supr
  assumes Supr0 : "is_sup {b1, b2} supr0"
  assumes Supr : "is_sup {LUpd l1 s a1 b1, LUpd l2 s a2 b2} supr"
  shows "supr \<in> S1 s \<inter> S2 s"
proof-
   obtain supr' where Supr' : "is_sup {LUpd_Idem l1 s a1 b1, LUpd_Idem l2 s a2 b2} supr'"
     using compat_idem[OF Supr0]
     by(fastforce simp add: has_sup_def)

  have Supr'_in : "supr' \<in> S1 s" "supr' \<in> S2 s"
    using compat_idem_S[OF Supr0 Supr']
    by auto

  obtain supr'2 where Supr'2 : "is_sup {LPost l1 s (LUpd_Idem l1 s a1 b1), LPost l2 s (LUpd_Idem l2 s a2 b2)} supr'2"
    using compat_post[OF Supr']
    by(fastforce simp add: has_sup_def)

  have Supr'2_supr : "supr'2 = supr"
    using is_sup_unique[OF Supr[unfolded LUpd_def] Supr'2]
    by simp

  show "supr \<in> S1 s \<inter> S2 s"
    using compat_post_S[OF Supr' Supr'_in(1) Supr'_in(2) Supr'2]
    unfolding Supr'2_supr
    by auto
qed

locale l_ortho_base' =
  fixes l1 :: "('a, 'b1, 'c :: Pord_Weakb, 'f1) lifting"
  fixes l2 :: "('a, 'b2, 'c, 'f2) lifting"

locale l_ortho_base = l_ortho + l_ortho_base' +
  assumes compat_bases : "\<And> s . is_sup {LBase l1 s, LBase l2 s} \<bottom>"

locale l_ortho_ok' =
  fixes l1 :: "('a, 'b1, 'c :: {Pord_Weakb, Okay}, 'f1) lifting"
  fixes l2 :: "('a, 'b2, 'c, 'f2) lifting"

locale l_ortho_ok = l_ortho + l_ortho_ok' +
  assumes compat_idem_ok :
    "\<And> s a1 a2 b supr . b \<in> ok_S \<Longrightarrow>
    is_sup {LUpd_Idem l1 s a1 b, LUpd_Idem l2 s a2 b} supr \<Longrightarrow> supr \<in> ok_S"
  assumes compat_post_ok :
    "\<And> s b supr . b \<in> ok_S \<Longrightarrow>
    is_sup {LPost l1 s b, LPost l2 s b} supr \<Longrightarrow> supr \<in> ok_S"

(* lift_map_s is LMap plus a syntax translation *)
definition lift_map_s ::
  "('b1 \<Rightarrow> 'a1) \<Rightarrow>
   ('a1, 'a2, 'b2 :: Pord, 'f) lifting \<Rightarrow>
   'f \<Rightarrow>
   ('b1 \<Rightarrow> 'b2 \<Rightarrow> 'b2)" where
"lift_map_s l' l sem syn st =
  LMap l sem (l' syn) st"

(* commutativity of l_ortho *)
sublocale l_ortho \<subseteq> comm :
  l_ortho l2 S2 l1 S1
proof

  fix s
  show "LBase l2 s = LBase l1 s"
    using eq_base by auto
next

  fix s a1 a2 b1 b2 supr

  have Comm : "{LUpd_Idem l2 s a1 b1, LUpd_Idem l1 s a2 b2} =
               {LUpd_Idem l1 s a2 b2, LUpd_Idem l2 s a1 b1}"
    by auto

  have Comm' : "{b1, b2} = {b2, b1}"
    by auto

  assume "is_sup {b1, b2} supr"
  then have "has_sup {b2, b1}" unfolding Comm' by auto

  then show "has_sup
        {LUpd_Idem l2 s a1 b1,
         LUpd_Idem l1 s a2 b2}"
    using compat_idem[of b2 b1 s a2 a1]
    unfolding Comm
    by auto

next
  fix s
  fix b1 b2 :: 'c

  have Comm : "{LPost l2 s b1, LPost l1 s b2} = {LPost l1 s b2, LPost l2 s b1}"
    by auto

  have Comm' : "{b1, b2} = {b2, b1}"
    by auto

  assume Sup : "has_sup {b1, b2}"

  then show "has_sup {LPost l2 s b1, LPost l1 s b2}"
    using compat_post[OF Sup[unfolded Comm']] unfolding Comm
    by auto
next
  fix b s a1 a2
  fix b1 b2 supr :: 'c

  have Comm' : "{b1, b2} = {b2, b1}"
    by auto

  have Comm: "{LUpd_Idem l2 s a1 b1, LUpd_Idem l1 s a2 b2} = {LUpd_Idem l1 s a2 b2, LUpd_Idem l2 s a1 b1}"
    by auto

  assume Sup_b : "has_sup {b1, b2}"
  assume Sup : "is_sup {LUpd_Idem l2 s a1 b1, LUpd_Idem l1 s a2 b2} supr"

  then show "supr \<in> S2 s \<inter> S1 s"
    using compat_S[OF Sup_b[unfolded Comm'] Sup[unfolded Comm]]
    by auto

next

  fix s a b

  show "b \<in> S1 s \<Longrightarrow>
       LUpd_Idem l2 s a b \<in> S1 s"
    using put2_S1[of b s a]
    by auto
next

  fix s a b

  show "b \<in> S2 s \<Longrightarrow>
       LUpd_Idem l1 s a b \<in> S2 s"
    using put1_S2[of b s a]
    by auto
qed

sublocale l_ortho_base \<subseteq> comm :
  l_ortho_base l2 S2 l1 S1
proof
  fix s

  have Comm : "{LBase l2 s, LBase l1 s} = {LBase l1 s, LBase l2 s}"
    by auto

  show "is_sup {LBase l2 s, LBase l1 s} \<bottom>"
    using compat_bases unfolding Comm
    by auto
qed

sublocale l_ortho_ok \<subseteq> comm :
  l_ortho_ok l2 S2 l1 S1
proof
  fix s a1 a2 b supr

  assume Sup : "is_sup {LUpd l2 s a1 b, LUpd l1 s a2 b} supr"

  assume Bok : "b \<in> ok_S"

  have Comm : "{LUpd l2 s a1 b, LUpd l1 s a2 b} =
               {LUpd l1 s a2 b, LUpd l2 s a1 b}"
    by auto

  show "supr \<in> ok_S"
    using compat_ok[OF Bok Sup[unfolded Comm]]
    by auto
qed
(*
lemma (in l_ortho) compat'_comm :
  shows "LUpd l1 s a1 (LUpd l2 s a2 b) = LUpd l2 s a2 (LUpd l1 s a1 b)"
  using is_sup_unique[OF compat'1 compat'2]
  by auto
*)
end


theory EinChannel

imports bundle.SB automaton.dAutomaton_causal

begin
text \<open>You need to set THIS directory as Session-Directory. NOT the root-directory of the repository\<close>

lemma cempty_empty[simp]: "cEmpty = {c3}"
  apply(auto simp add: cEmpty_def)
  apply(insert ctype.elims,auto)
  by (metis channel.exhaust ctype.simps(1) ctype.simps(2) ctype.simps(4) ctype.simps(5) ctype.simps(6)
      empty_not_UNIV image_is_empty  sup_eq_bot_iff)

typedef singleChan = "{c1}"
  by blast

lemma "Abs_singleChan c1 = undefined"
  oops
text \<open>Macht nicht wirklich sinn, aber da wir nur den einen Channel haben...
  Normalerweise erstellt der Nutzer hier seine eigenen channels zuerst\<close>
instantiation singleChan::chan
begin
definition "Rep = Rep_singleChan"

  instance
    apply(intro_classes)
     apply(auto simp add: Rep_singleChan_def)
    by (meson Rep_singleChan_inject injI)

end

section\<open>Datatype Konstruktor\<close>

(* FYI: the old approach from v2 to create the datatype is not really reusable,
  because:
      lift_definition elem_raw_i :: "int \<Rightarrow> ndaExampleMessage sbElem" is
  Thats an old "single-channel" setter...
  One has to replace the "ndaExampleMessage" with a "chan"... but which?
  There can only be ONE channel in the replacement! ! !
  But what if the channel-datatype of the component has 2 or more channels?
*)

text \<open>Motivation: I HATE freemarker and other templates.
  And the workflow sucks. The generator people have no idea about isabelle,
  feature-request take FOREVER and then it might not work in every case\<close>

text\<open>Goal: Move the heavy-stuff from the Generator to Isabelle.
  Pretty much every proof should be done in Isabelle, the generator
  can still create datatypes, functions and so on\<close>

text\<open>Implementation: Is using Locales... \<close>

text \<open>\<open>'a\<close> should be interpreted as a tuple. The goal of this local is to create a
  bijective mapping from \<open>'a\<close> to \<open>'cs\<close>.
  The user can freely choose \<open>'a\<close>, hence he will not use the datatype \<open>M\<close>.
  for example \<open>'a = (nat \<times> bool)\<close> which maps to a bundle with one bool-channel and one nat-channel\<close>
locale sbeGen =
  fixes lConstructor::"'a::countable \<Rightarrow> 'cs::{chan, finite} \<Rightarrow> M"
  assumes c_well: "\<And>a. \<not>chIsEmpty TYPE ('cs) \<Longrightarrow> sbElem_well (Some (lConstructor a))"
      and c_inj: "\<not>chIsEmpty TYPE ('cs) \<Longrightarrow> inj lConstructor"
      and c_surj: "\<And>sbe. \<not>chIsEmpty TYPE ('cs) \<Longrightarrow> sbElem_well (Some sbe) \<Longrightarrow> sbe\<in>range lConstructor" (* Schöner? *)
      and c_empty: "\<And>a b::'a. chIsEmpty TYPE ('cs) \<Longrightarrow> a=b"
begin

lift_definition setter::"'a \<Rightarrow> 'cs\<^sup>\<surd>" is
  "if(chIsEmpty TYPE ('cs)) then (\<lambda>_. None) else Some o lConstructor"
  using c_well sbtypeempty_sbewell by auto

definition getter::"'cs\<^sup>\<surd> \<Rightarrow> 'a" where
"getter sbe = (case (Rep_sbElem sbe) of None \<Rightarrow> (SOME x. True) |
      Some f \<Rightarrow> (inv lConstructor) f)" (* geht was anderes als "SOME x"? *)

lemma get_set[simp]: "getter (setter a) = a"
  unfolding getter_def
  by (simp add: setter.rep_eq c_inj c_empty)

lemma set_inj: "inj setter"
  by (metis get_set injI)

lemma set_surj: "surj setter"
  unfolding setter_def
  apply(cases "\<not>(chIsEmpty(TYPE('cs)))")
proof(simp add: surj_def,auto)
  fix y::"'cs\<^sup>\<surd>"
  assume chnEmpty:"\<not> chIsEmpty TYPE('cs)"
  obtain f where f_def:"Rep_sbElem y=(Some f)"
    using chnEmpty sbtypenotempty_fex by auto
  then obtain x where x_def:"f = lConstructor x"
    by (metis c_inj c_surj f_the_inv_into_f sbelemwell2fwell chnEmpty)
  then show "\<exists>x::'a. y = Abs_sbElem (Some (lConstructor x))"
    by (metis Rep_sbElem_inverse f_def)
qed

lemma set_bij: "bij setter"
  by (metis bijI inj_onI sbeGen.get_set sbeGen_axioms set_surj)

lemma get_inv_set: "getter = (inv setter)"
  by (metis get_set set_surj surj_imp_inv_eq)

lemma set_get[simp]: "setter (getter sbe) = sbe"
  apply(simp add: get_inv_set)
  by (meson bij_inv_eq_iff set_bij)

lemma "getter A = getter B \<Longrightarrow> A = B"
  by (metis set_get)

fixrec setterSB::"'a stream \<rightarrow> 'cs\<^sup>\<Omega>" where
"setterSB\<cdot>((up\<cdot>l)&&ls) = (setter (undiscr l)) \<bullet>\<^sup>\<surd> (setterSB\<cdot>ls)"

lemma settersb_unfold:"setterSB\<cdot>(\<up>a \<bullet> s) = (setter a) \<bullet>\<^sup>\<surd> setterSB\<cdot>s"
  unfolding setterSB_def
  apply(subst fix_eq)
  apply simp
  apply(subgoal_tac "\<exists>l. \<up>a \<bullet> s = (up\<cdot>l)&&s")
  apply auto
  apply (metis (no_types, lifting) lshd_updis stream.sel_rews(4) undiscr_Discr up_inject)
  by (metis lscons_conv)

lemma settersb_emptyfix:"chIsEmpty (TYPE ('cs)) \<Longrightarrow> setterSB\<cdot>s = \<bottom>"
  by simp

lemma settersb_epsbot:"setterSB\<cdot>\<epsilon> = \<bottom>"
  apply(simp add: setterSB_def)
  apply(subst fix_eq)
  by auto

(* TODO : Dokumentireen! *)
definition getterSB::"'cs\<^sup>\<Omega> \<rightarrow> 'a stream" where
"getterSB \<equiv> fix\<cdot>(\<Lambda> h. sb_case\<cdot>(\<lambda>sbe. \<Lambda> sb. updis (getter sbe) && h\<cdot>sb))"

lemma gettersb_unfold:"getterSB\<cdot>(sbe \<bullet>\<^sup>\<surd> sb) = \<up>(getter sbe) \<bullet> getterSB\<cdot>sb"
  unfolding getterSB_def
  apply(subst fix_eq)
  apply simp
  by (simp add: lscons_conv)

lemma gettersb_emptyfix:"chIsEmpty (TYPE ('cs)) \<Longrightarrow> getterSB\<cdot>sb = \<up>(getter (Abs_sbElem None)) \<bullet> getterSB\<cdot>sb"
  by (metis(full_types) gettersb_unfold sbtypeepmpty_sbbot)

lemma gettersb_realboteps:"\<not>(chIsEmpty (TYPE ('cs))) \<Longrightarrow> getterSB\<cdot>\<bottom> = \<epsilon>"
  unfolding getterSB_def
  apply(subst fix_eq)
  by (simp add: sb_cases_bot)
(* TODO: lemma über setterSB und getterSB *)

lemma assumes "chIsEmpty (TYPE ('cs))"
  shows "\<exists>a. (getterSB\<cdot>sb) = (sinftimes(\<up>(a)))"
  apply(insert assms,subst gettersb_emptyfix,simp)
  using gettersb_emptyfix s2sinftimes by auto

 (* TODO; warning entfernen. abbreviation-prioritäten für \<infinity>?*)

lemma "sbLen (setterSB\<cdot>s) = #s"
  oops(* gilt nicht für chIsEmpty *)

lemma "a \<sqsubseteq> getterSB\<cdot>(setterSB\<cdot>a)"
  apply(induction a rule: ind)
  apply(auto)
  apply (simp add: gettersb_unfold settersb_unfold)
  by (simp add: monofun_cfun_arg)

lemma getset_eq:"\<not>chIsEmpty (TYPE ('cs)) \<Longrightarrow> getterSB\<cdot>(setterSB\<cdot>a) = a"
  apply(induction a rule: ind)
  apply(auto)
  apply (simp add: gettersb_realboteps settersb_epsbot)
  by (simp add: gettersb_unfold settersb_unfold)

lemma "setterSB\<cdot>(getterSB\<cdot>sb) \<sqsubseteq> sb"
  apply(induction sb)
  apply auto
  apply(cases "chIsEmpty(TYPE('cs))")
  apply (metis (full_types)minimal sbtypeepmpty_sbbot)
  apply(simp add: sbIsLeast_def)
  oops

lemma setget_eq:"(\<forall>c. #(sb \<^enum> c) = k) \<Longrightarrow>setterSB\<cdot>(getterSB\<cdot>sb) = sb"
  apply(induction sb arbitrary: k)
  apply auto
  apply(rule adm_imp)
     apply auto
  apply(rule admI)
  defer
  apply(case_tac "chIsEmpty (TYPE ('cs))")
  apply (metis (full_types)sbtypeepmpty_sbbot)
    apply(simp add: sbIsLeast_def)
  apply(subgoal_tac "k = 0",auto)
     apply (metis gettersb_realboteps sb_eqI sbgetch_bot settersb_epsbot)
    defer
    apply(subst gettersb_unfold)
    apply(subst settersb_unfold,simp)
  apply(subgoal_tac "\<And>c. #(sb \<^enum> c) \<le> #(sbe \<bullet>\<^sup>\<surd> sb  \<^enum>  c)",auto)
  oops  (* Nur für gleichlange ströme *)
end

locale sscanlGen =
  fixes da::"('state::countable, 'in::{chan, finite}, 'out::{chan,finite}, 'initOut::chan) dAutomaton_weak"
  and fin::"'a::countable \<Rightarrow> 'in \<Rightarrow> M"
  and fout::"'b::countable \<Rightarrow> 'out \<Rightarrow> M"
  assumes sbegenfin:"sbeGen fin"
      and sbegenfout:"sbeGen fout"
begin

abbreviation "sscanlTransition \<equiv> (\<lambda> s a.
  let (nextState, nextOut) = dawTransition da s (sbeGen.setter fin a) in
     (nextState, sbeGen.getter fout nextOut)
)"

lemma daut2sscanl:"dawStateSem da state\<cdot>(input::'in\<^sup>\<Omega>) =
       sbeGen.setterSB fout\<cdot>(sscanlAsnd sscanlTransition state\<cdot>(sbeGen.getterSB fin\<cdot>input))"
  sorry

lemma daut2sscnalinit:"range(Rep::'out \<Rightarrow> channel) = range(Rep::'initOut\<Rightarrow> channel) \<Longrightarrow> dawSem da\<cdot>input =
  sbeConvert(dawInitOut da) \<bullet>\<^sup>\<surd> dawStateSem da state\<cdot>(input::'in\<^sup>\<Omega>)"
  sorry

(* TODO: initiale ausgabe ... "sscanlA" kann nichts partielles ausgben.
  dh alles oder nichts. Das kann man durch den typ abfangen!
    * weak = "chIstEmpty" als assumption (oder besser, dafür eine klasse anlegen)
    * strong = gleicher typ wie ausgabe
*)

end

locale smapGen =
 fixes da::"('state::countable, 'in::{chan, finite}, 'out::{chan,finite}, 'initOut::chan) dAutomaton_weak"
  and fin::"'a::countable \<Rightarrow> 'in \<Rightarrow> M"
  and fout::"'b::countable \<Rightarrow> 'out \<Rightarrow> M"
  assumes scscanlgenf:"sscanlGen fin fout"
  and singlestate:"is_singleton(UNIV::'state set)"
begin

abbreviation "smapTransition \<equiv> (\<lambda>a.
  let nextOut = snd(dawTransition da (dawInitState da) (sbeGen.setter fin a)) in
     sbeGen.getter fout nextOut)"

lemma daut2smap:"dawStateSem da state\<cdot>(input::'in\<^sup>\<Omega>) =
       sbeGen.setterSB fout\<cdot>(smap smapTransition\<cdot>(sbeGen.getterSB fin\<cdot>input))"
  sorry

end

sublocale  smapGen \<subseteq> sscanlGen
  by (simp add: scscanlgenf)

locale sumChanSB = (* TODO: anpassen wie oben, z.B. reihenfolge argumente *)
  fixes lConstructor::" 'a::pcpo \<Rightarrow> 'cs::chan  \<Rightarrow> M stream"
  assumes c_type: "\<And>a c. sValues (lConstructor a c) \<subseteq> ctype (Rep c)"
    and c_inj: "inj lConstructor"
    and c_surj: "\<And>f. sb_well f \<Longrightarrow> f\<in>range lConstructor" (* Schöner? *)
begin

lift_definition setter::"'a \<Rightarrow> ('cs::chan)\<^sup>\<Omega>"is"lConstructor"
  by (simp add: c_type sb_well_def)

definition getter::"'cs\<^sup>\<Omega> \<Rightarrow> 'a" where
"getter= (inv lConstructor) o  Rep_sb"

lemma get_set[simp]: "getter (setter a) = a"
  unfolding getter_def
  by (simp add: setter.rep_eq c_inj)

lemma set_inj: "inj setter"
  by (metis get_set injI)

lemma set_surj: "surj setter"
  unfolding setter_def
proof(simp add: surj_def,auto)
  fix y::"'cs\<^sup>\<Omega>"
 obtain f where f_def:"Rep_sb y=f"
   by simp
 then obtain x where x_def:"f = lConstructor x"
    by (metis c_inj c_surj f_the_inv_into_f sbwell2fwell)
  then show "\<exists>x::'a. y = Abs_sb (lConstructor x)"
    by (metis Rep_sb_inverse f_def)
qed

lemma set_bij: "bij setter"
  using bij_betw_def set_inj set_surj by auto

lemma get_inv_set: "getter = (inv setter)"
  by (metis get_set set_surj surj_imp_inv_eq)

lemma set_get[simp]: "setter (getter sbe) = sbe"
  apply(simp add: get_inv_set)
  by (meson bij_inv_eq_iff set_bij)

lemma "getter A = getter B \<Longrightarrow> A = B"
  by (metis set_get)

end

section \<open>Beispiel\<close>

typedef mymy = "{c1, c2}"
  by blast

definition "mymyC1 = Abs_mymy c1"
definition "mymyC2 = Abs_mymy c2"

(* Fuck Yeah, pattern matching! *)
(* TODO: is it possible to put everything in a "bundle"?
    eg. bundleName.c1 = mymyC1
        bundleName.setter = dudu.setter"
*)
free_constructors mymy for "mymyC1"  | "mymyC2"
   apply auto
  unfolding mymyC1_def mymyC2_def
  apply (metis Rep_mymy Rep_mymy_inverse empty_iff insert_iff)
  by (meson channel.distinct(1) insertI1 insertI2 type_definition.Abs_inject type_definition_mymy)

lemma mymy_rep_range [simp]:"range Rep_mymy = {c1, c2}"
  using type_definition.Rep_range type_definition_mymy by blast

instantiation mymy::chan
begin
definition "Rep = Rep_mymy" (* TODO: abbreviation oÄ, ich will nicht immer "Rep_mymy_def" anwenden *)

instance
  apply(intro_classes)
  unfolding Rep_mymy_def apply simp
  by (meson Rep_mymy_inject injI)
end

lemma myc1_rep [simp]: "Rep (mymyC1) = c1"
  unfolding Rep_mymy_def mymyC1_def
  by (simp add: Abs_mymy_inverse)

lemma myc2_rep [simp]: "Rep (mymyC2) = c2"
  unfolding Rep_mymy_def mymyC2_def
  by (simp add: Abs_mymy_inverse)

(* :/ Schöner? *)
fun orderChan::"('nat::type \<Rightarrow> 'a::type) \<Rightarrow> ('bool::type \<Rightarrow> 'a) \<Rightarrow>('nat\<times>'bool) \<Rightarrow> mymy \<Rightarrow> 'a" where
"orderChan Cc1 Cc2 (port_c1, port_c2) mymyC1 = Cc1 port_c1" |
"orderChan Cc1 Cc2 (port_c1, port_c2) mymyC2 = Cc2 port_c2"

abbreviation "buildSBE \<equiv> orderChan \<N> \<B>"

lemma build_ctype: "buildSBE a c \<in> ctype (Rep c)"
  by(cases c; cases a; simp)

lemma build_inj: "inj buildSBE"
  apply(rule injI)
  apply(case_tac x; case_tac y; simp)
  by (metis M.inject orderChan.simps)

lemma build_range: "range (\<lambda>a. buildSBE a c) = ctype (Rep c)"
  apply(cases c)
  by(auto simp add: image_iff)

lemma build_surj: assumes "sbElem_well (Some sbe)"
  shows "sbe \<in> range buildSBE"
proof -
  have ctypewell:"\<And>c. sbe c\<in> ctype (Rep c)"
    using assms by auto
  hence "\<And>c. sbe c \<in> range (\<lambda>a. buildSBE a c)"
    by (simp add: build_range)
  hence "\<exists>prod. sbe = buildSBE prod"
    apply(subst fun_eq_iff,auto) (*TODO: shorter proof*)
  proof -
    { fix mm :: "nat \<Rightarrow> bool \<Rightarrow> mymy"
      obtain bb :: bool where
        ff1: "(\<not> bb) = (\<forall>x2. \<B> x2 \<noteq> sbe mymyC2)"
        by moura
      then have ff2: bb
        by (metis ctype.simps(2) ctypewell myc2_rep rangeE)
      obtain bba :: bool where
        ff3: "(\<not> bba) = (\<forall>x1. \<N> x1 \<noteq> sbe mymyC1)"
        by moura
      then have bba
        by (metis ctype.simps(1) ctypewell myc1_rep rangeE)
      then have "\<exists>n b. sbe (mm n b) = buildSBE (n, b) (mm n b)"
        using ff3 ff2 ff1 by (metis (full_types) mymy.exhaust orderChan.simps(1) orderChan.simps(2)) }
    then show "\<exists>n b. \<forall>m. sbe m = buildSBE (n, b) m"
      by metis
  qed
  thus ?thesis
    by auto
qed

instance mymy::finite
  sorry

interpretation dudu: sbeGen "buildSBE" (*WTF Nitpick ? ? ?*)
  apply(unfold_locales)
  apply (simp add: build_ctype)
  apply (simp add: build_inj)
  using build_surj sorry

term "dudu.setter"

term "curry dudu.setter"  (* If you prefer the "old way" *)

lemma "dudu.getter (dudu.setter (1,True)) = (1,True)"
  by simp

(*buildSB interpretation*)

abbreviation "buildSB \<equiv> orderChan (Rep_cfun (smap \<N>)) (Rep_cfun (smap \<B>))"

lemma buildSB_ctype: "sValues(buildSB a c) \<subseteq> ctype (Rep c)"
  by(cases c; cases a; simp add: sValues_def)

lemma buildSB_inj: "inj buildSB"
  apply(rule injI)
  apply(case_tac x; case_tac y; simp)
  apply(auto)
  sorry

lemma buildSB_range: "(\<Union>a. sValues (buildSB a c)) = ctype (Rep c)"
  apply(cases c)
  apply auto
  apply (metis (no_types, lifting) in_mono sValues_def smap_sdom_range)
  apply(rule_tac x="\<up>xa" in exI)
  apply(simp add: sValues_def)
  apply (metis (mono_tags) ctype.simps(2) image_iff range_eqI sValues_def smap_sdom)
  apply(rule_tac x="\<up>xa" in exI)
  by(simp add: sValues_def)

lemma buildSB_surj: assumes "sb_well f"
  shows "f \<in> range buildSB"
proof -
  have ctypewell:"\<And>c. sValues (f c) \<subseteq> ctype (Rep c)"
    using assms sb_well_def by blast
  hence "\<And>c. sValues(f c) \<subseteq> range (\<lambda>a. buildSBE a c)"
    by (simp add: build_range)
  hence "\<exists>prod. f = buildSB prod"
    apply(subst fun_eq_iff,auto,simp add: sValues_def) (*TODO: shorter proof*)
    sorry
  thus ?thesis
    by auto
qed

interpretation duda: sumChanSB "buildSB"
  apply(unfold_locales)
  apply (simp add: buildSB_ctype)
  apply (simp add: buildSB_inj)
  by (simp add: buildSB_surj)

term "duda.setter"
term "duda.getter"

end


theory Pair_Automaton
  imports Tree_Automata_Complement GTT_Compose
begin

subsection \<open>Pair automaton and anchored GTTs\<close>

definition pair_at_lang :: "('q, 'f) gtt \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> 'f gterm rel" where
  "pair_at_lang \<G> Q = {(s, t) | s t p q. q |\<in>| gta_der (fst \<G>) s \<and> p |\<in>| gta_der (snd \<G>) t \<and> (q, p) |\<in>| Q}"

lemma pair_at_lang_restr_states:
  "pair_at_lang \<G> Q = pair_at_lang \<G> (Q |\<inter>| (\<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)))"
  by (auto simp: pair_at_lang_def gta_der_def) (meson gterm_ta_der_states)

lemma pair_at_langE:
  assumes "(s, t) \<in> pair_at_lang \<G> Q"
  obtains q p where "(q, p) |\<in>| Q" and "q |\<in>| gta_der (fst \<G>) s" and "p |\<in>| gta_der (snd \<G>) t"
  using assms by (auto simp: pair_at_lang_def)

lemma pair_at_langI:
  assumes "q |\<in>| gta_der (fst \<G>) s" "p |\<in>| gta_der (snd \<G>) t" "(q, p) |\<in>| Q"
  shows "(s, t) \<in> pair_at_lang \<G> Q"
  using assms by (auto simp: pair_at_lang_def)

lemma pair_at_lang_fun_states:
  assumes "finj_on f (\<Q> (fst \<G>))" and "finj_on g (\<Q> (snd \<G>))"
    and "Q |\<subseteq>| \<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)"
  shows "pair_at_lang \<G> Q = pair_at_lang (map_prod (fmap_states_ta f) (fmap_states_ta g) \<G>) (map_prod f g |`| Q)"
    (is "?LS = ?RS")
proof
  {fix s t assume "(s, t) \<in> ?LS"
    then have "(s, t) \<in> ?RS" using ta_der_fmap_states_ta_mono[of f "fst \<G>" s]
      using ta_der_fmap_states_ta_mono[of g "snd \<G>" t]
      by (force simp: gta_der_def map_prod_def image_iff  elim!: pair_at_langE split: prod.split intro!: pair_at_langI)}
  then show "?LS \<subseteq> ?RS" by auto
next
  {fix s t assume "(s, t) \<in> ?RS"
    then obtain p q where rs: "p |\<in>| ta_der (fst \<G>) (term_of_gterm s)" "f p |\<in>| ta_der (fmap_states_ta f (fst \<G>)) (term_of_gterm s)" and
      ts: "q |\<in>| ta_der (snd \<G>) (term_of_gterm t)" "g q |\<in>| ta_der (fmap_states_ta g (snd \<G>)) (term_of_gterm t)" and
      st: "(f p, g q) |\<in>| (map_prod f g |`| Q)" using assms ta_der_fmap_states_inv[of f "fst \<G>" _ s]
      using ta_der_fmap_states_inv[of g "snd \<G>" _ t]
      by (auto simp: gta_der_def adapt_vars_term_of_gterm elim!: pair_at_langE)
         (metis (no_types, opaque_lifting) fimageE fmap_prod_fimageI ta_der_fmap_states_conv)
    then have "p |\<in>| \<Q> (fst \<G>)" "q |\<in>| \<Q> (snd \<G>)" by auto
    then have "(p, q) |\<in>| Q" using assms st unfolding fimage_iff fBex_def
      by (auto dest!: fsubsetD simp: finj_on_eq_iff)
    then have "(s, t) \<in> ?LS" using st rs(1) ts(1) by (auto simp: gta_der_def intro!: pair_at_langI)}
  then show "?RS \<subseteq> ?LS" by auto
qed

lemma converse_pair_at_lang:
  "(pair_at_lang \<G> Q)\<inverse> = pair_at_lang (prod.swap \<G>) (Q|\<inverse>|)"
  by (auto simp: pair_at_lang_def)

lemma pair_at_agtt:
  "agtt_lang \<G> = pair_at_lang \<G> (fId_on (gtt_interface \<G>))"
  by (auto simp: agtt_lang_def gtt_interface_def pair_at_lang_def gtt_states_def gta_der_def fId_on_iff)

definition \<Delta>_eps_pair where
  "\<Delta>_eps_pair \<G>\<^sub>1 Q\<^sub>1 \<G>\<^sub>2 Q\<^sub>2 \<equiv>  Q\<^sub>1 |O| \<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2) |O| Q\<^sub>2"

lemma pair_comp_sound1:
  assumes "(s, t) \<in> pair_at_lang \<G>\<^sub>1 Q\<^sub>1"
    and "(t, u) \<in> pair_at_lang \<G>\<^sub>2 Q\<^sub>2"
  shows "(s, u) \<in> pair_at_lang (fst \<G>\<^sub>1, snd \<G>\<^sub>2) (\<Delta>_eps_pair \<G>\<^sub>1 Q\<^sub>1 \<G>\<^sub>2 Q\<^sub>2)"
proof -
  from pair_at_langE assms obtain p q  q' r where
    wit: "(p, q) |\<in>| Q\<^sub>1" "p |\<in>| gta_der (fst \<G>\<^sub>1) s" "q |\<in>| gta_der (snd \<G>\<^sub>1) t"
    "(q', r) |\<in>| Q\<^sub>2" "q' |\<in>| gta_der (fst \<G>\<^sub>2) t" "r |\<in>| gta_der (snd \<G>\<^sub>2) u"
      by metis
  from wit(3, 5) have "(q, q') |\<in>| \<Delta>\<^sub>\<epsilon> (snd \<G>\<^sub>1) (fst \<G>\<^sub>2)"
    by (auto simp: \<Delta>\<^sub>\<epsilon>_def' gta_der_def intro!: exI[of _ "term_of_gterm t"])
  then have "(p, r) |\<in>| \<Delta>_eps_pair \<G>\<^sub>1 Q\<^sub>1 \<G>\<^sub>2 Q\<^sub>2" using wit(1, 4)
    by (auto simp: \<Delta>_eps_pair_def)
  then show ?thesis using wit(2, 6) unfolding pair_at_lang_def
    by auto
qed

lemma pair_comp_sound2:
  assumes "(s, u) \<in>  pair_at_lang (fst \<G>\<^sub>1, snd \<G>\<^sub>2) (\<Delta>_eps_pair \<G>\<^sub>1 Q\<^sub>1 \<G>\<^sub>2 Q\<^sub>2)"
  shows "\<exists> t. (s, t) \<in> pair_at_lang \<G>\<^sub>1 Q\<^sub>1 \<and> (t, u) \<in> pair_at_lang \<G>\<^sub>2 Q\<^sub>2"
  using assms unfolding pair_at_lang_def \<Delta>_eps_pair_def
  by (auto simp: \<Delta>\<^sub>\<epsilon>_def' gta_der_def) (metis gterm_of_term_inv)

lemma pair_comp_sound:
  "pair_at_lang \<G>\<^sub>1 Q\<^sub>1 O pair_at_lang \<G>\<^sub>2 Q\<^sub>2 = pair_at_lang (fst \<G>\<^sub>1, snd \<G>\<^sub>2) (\<Delta>_eps_pair \<G>\<^sub>1 Q\<^sub>1 \<G>\<^sub>2 Q\<^sub>2)"
  by (auto simp: pair_comp_sound1 pair_comp_sound2 relcomp.simps)

inductive_set \<Delta>_Atrans_set :: "('q \<times> 'q) fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) set" for Q \<A> \<B> where
  base [simp]: "(p, q) |\<in>| Q \<Longrightarrow> (p, q) \<in> \<Delta>_Atrans_set Q \<A> \<B>"
| step [intro]: "(p, q) \<in> \<Delta>_Atrans_set Q \<A> \<B> \<Longrightarrow> (q, r) |\<in>| \<Delta>\<^sub>\<epsilon> \<B> \<A> \<Longrightarrow>
     (r, v) \<in> \<Delta>_Atrans_set Q \<A> \<B> \<Longrightarrow> (p, v) \<in> \<Delta>_Atrans_set Q \<A> \<B>"

lemma \<Delta>_Atrans_set_states:
  "(p, q) \<in> \<Delta>_Atrans_set Q \<A> \<B> \<Longrightarrow> (p, q) \<in> fset ((fst |`| Q |\<union>| \<Q> \<A>) |\<times>| (snd |`| Q |\<union>| \<Q> \<B>))"
  by (induct rule: \<Delta>_Atrans_set.induct) (auto simp: fimage_iff fBex_def simp flip: fmember_iff_member_fset)

lemma finite_\<Delta>_Atrans_set: "finite (\<Delta>_Atrans_set Q \<A> \<B>)"
proof -
  have "\<Delta>_Atrans_set Q \<A> \<B> \<subseteq> fset ((fst |`| Q |\<union>| \<Q> \<A>) |\<times>| (snd |`| Q |\<union>| \<Q> \<B>))"
    using \<Delta>_Atrans_set_states by auto
  from finite_subset[OF this] show ?thesis by simp
qed

context
includes fset.lifting
begin
lift_definition \<Delta>_Atrans ::  "('q \<times> 'q) fset \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q, 'f) ta \<Rightarrow> ('q \<times> 'q) fset" is \<Delta>_Atrans_set
  by (simp add: finite_\<Delta>_Atrans_set)

lemmas \<Delta>_Atrans_base [simp] = \<Delta>_Atrans_set.base [Transfer.transferred]
lemmas \<Delta>_Atrans_step [intro] = \<Delta>_Atrans_set.step [Transfer.transferred]
lemmas \<Delta>_Atrans_cases = \<Delta>_Atrans_set.cases[Transfer.transferred]
lemmas \<Delta>_Atrans_induct [consumes 1, case_names base step] = \<Delta>_Atrans_set.induct[Transfer.transferred]
end

abbreviation "\<Delta>_Atrans_gtt \<G> Q \<equiv> \<Delta>_Atrans Q (fst \<G>) (snd \<G>)"

lemma pair_trancl_sound1:
  assumes "(s, t) \<in> (pair_at_lang \<G> Q)\<^sup>+"
  shows "\<exists> q p. p |\<in>| gta_der (fst \<G>) s \<and> q |\<in>| gta_der (snd \<G>) t \<and> (p, q) |\<in>| \<Delta>_Atrans_gtt \<G> Q"
  using assms
proof (induct)
  case (step t v)
  obtain p q r r' where reach_t: "r |\<in>| gta_der (fst \<G>) t" "q |\<in>| gta_der (snd \<G>) t" and
    reach: "p |\<in>| gta_der (fst \<G>) s" "r' |\<in>| gta_der (snd \<G>) v" and
    st: "(p, q) |\<in>| \<Delta>_Atrans_gtt \<G> Q"  "(r, r') |\<in>| Q" using step(2, 3)
    by (auto simp: pair_at_lang_def)
  from reach_t have "(q, r) |\<in>| \<Delta>\<^sub>\<epsilon> (snd \<G>) (fst \<G>)"
    by (auto simp: \<Delta>\<^sub>\<epsilon>_def' gta_der_def intro: ground_term_of_gterm)
  then have "(p, r') |\<in>| \<Delta>_Atrans_gtt \<G> Q" using st by auto
  then show ?case using reach reach_t
    by (auto simp: pair_at_lang_def gta_der_def \<Delta>\<^sub>\<epsilon>_def' intro: ground_term_of_gterm)
qed (auto simp: pair_at_lang_def intro: \<Delta>_Atrans_base)

lemma pair_trancl_sound2:
  assumes "(p, q) |\<in>| \<Delta>_Atrans_gtt \<G> Q"
    and "p |\<in>| gta_der (fst \<G>) s" "q |\<in>| gta_der (snd \<G>) t"
  shows "(s, t) \<in> (pair_at_lang \<G> Q)\<^sup>+" using assms
proof (induct arbitrary: s t rule:\<Delta>_Atrans_induct)
  case (step p q r v)
  from step(2)[OF step(6)] step(5)[OF _ step(7)] step(3)
  show ?case by (auto simp: gta_der_def \<Delta>\<^sub>\<epsilon>_def' intro!: ground_term_of_gterm)
      (metis gterm_of_term_inv trancl_trans)
qed (auto simp: pair_at_lang_def)

lemma pair_trancl_sound:
  "(pair_at_lang \<G> Q)\<^sup>+ = pair_at_lang \<G> (\<Delta>_Atrans_gtt \<G> Q)"
  by (auto simp: pair_trancl_sound2 dest: pair_trancl_sound1 elim: pair_at_langE intro: pair_at_langI)

abbreviation "fst_pair_cl \<A> Q \<equiv> TA (rules \<A>) (eps \<A> |\<union>| (fId_on (\<Q> \<A>) |O| Q))"
definition pair_at_to_agtt :: "('q, 'f) gtt \<Rightarrow> ('q \<times> 'q) fset \<Rightarrow> ('q, 'f) gtt" where
  "pair_at_to_agtt \<G> Q = (fst_pair_cl (fst \<G>) Q , TA (rules (snd \<G>)) (eps (snd \<G>)))"

lemma fst_pair_cl_eps:
  assumes "(p, q) |\<in>| (eps (fst_pair_cl \<A> Q))|\<^sup>+|"
    and "\<Q> \<A> |\<inter>| snd |`| Q = {||}"
  shows "(p, q) |\<in>| (eps \<A>)|\<^sup>+| \<or> (\<exists> r. (p = r \<or> (p, r) |\<in>| (eps \<A>)|\<^sup>+|) \<and> (r, q) |\<in>| Q)" using assms
proof (induct rule: ftrancl_induct)
  case (Step p q r)
  then have y: "q |\<in>| \<Q> \<A>" by (auto simp add: eps_trancl_statesD eps_statesD)
  have [simp]: "(p, q) |\<in>| Q \<Longrightarrow> q |\<in>| snd |`| Q" for p q by (auto simp: fimage_iff) force
  then show ?case using Step y
    by auto (simp add: ftrancl_into_trancl)
qed auto

lemma fst_pair_cl_res_aux:
  assumes "\<Q> \<A> |\<inter>| snd |`| Q = {||}"
    and "q |\<in>| ta_der (fst_pair_cl \<A> Q) (term_of_gterm t)"
  shows "\<exists> p. p |\<in>| ta_der \<A> (term_of_gterm t) \<and> (q |\<notin>| \<Q> \<A> \<longrightarrow> (p, q) |\<in>| Q) \<and> (q |\<in>| \<Q> \<A> \<longrightarrow> p = q)" using assms
proof (induct t arbitrary: q)
  case (GFun f ts)
  then obtain qs q' where rule: "TA_rule f qs q' |\<in>| rules \<A>" "length qs = length ts" and
    eps: "q' = q \<or> (q', q) |\<in>| (eps (fst_pair_cl \<A> Q))|\<^sup>+|" and
    reach: "\<forall> i < length ts. qs ! i |\<in>| ta_der (fst_pair_cl \<A> Q) (term_of_gterm (ts ! i))"
    by auto
  {fix i assume ass: "i < length ts" then have st: "qs ! i |\<in>| \<Q> \<A>" using rule
      by (auto simp: rule_statesD)
    then have "qs ! i |\<notin>| snd |`| Q" using GFun(2) by auto
    then have "qs ! i |\<in>| ta_der \<A> (term_of_gterm (ts ! i))" using reach st ass
      using fst_pair_cl_eps[OF _ GFun(2)] GFun(1)[OF nth_mem[OF ass] GFun(2), of "qs ! i"]
      by blast} note IH = this
  show ?case
  proof (cases "q' = q")
    case True
    then show ?thesis using rule reach IH
      by (auto dest: rule_statesD intro!: exI[of _ q'] exI[of _ qs])
  next
    case False note nt_eq = this
    then have eps: "(q', q) |\<in>| (eps (fst_pair_cl \<A> Q))|\<^sup>+|" using eps by simp
    from fst_pair_cl_eps[OF this assms(1)] show ?thesis
      using False rule IH
    proof (cases "q |\<notin>| \<Q> \<A>")
      case True
      from fst_pair_cl_eps[OF eps assms(1)] obtain r where
         "q' = r \<or> (q', r) |\<in>| (eps \<A>)|\<^sup>+|" "(r, q) |\<in>| Q" using True
        by (auto simp: eps_trancl_statesD)
      then show ?thesis using nt_eq rule IH True
        by (auto simp: fimage_iff eps_trancl_statesD)
    next
      case False
      from fst_pair_cl_eps[OF eps assms(1)] False assms(1)
      have "(q', q) |\<in>| (eps \<A>)|\<^sup>+|"
        by (auto simp: fimage_iff) (metis fempty_iff fimage_eqI finterI snd_conv)+
      then show ?thesis using IH rule
        by (intro exI[of _ q]) (auto simp: eps_trancl_statesD)
    qed
  qed
qed

lemma restr_distjoing:
  assumes "Q |\<subseteq>| \<Q> \<A> |\<times>| \<Q> \<BB>"
    and "\<Q> \<A> |\<inter>| \<Q> \<BB> = {||}"
  shows "\<Q> \<A> |\<inter>| snd |`| Q = {||}"
  using assms by auto

lemma pair_at_agtt_conv:
  assumes "Q |\<subseteq>| \<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)" and "\<Q> (fst \<G>) |\<inter>| \<Q> (snd \<G>) = {||}"
  shows "pair_at_lang \<G> Q = agtt_lang (pair_at_to_agtt \<G> Q)" (is "?LS = ?RS")
proof
  let ?TA = "fst_pair_cl (fst \<G>) Q"
  {fix s t assume ls: "(s, t) \<in> ?LS"
    then obtain q p where w: "(q, p) |\<in>| Q" "q |\<in>| gta_der (fst \<G>) s" "p |\<in>| gta_der (snd \<G>) t"
      by (auto elim: pair_at_langE)
    from w(2) have "q |\<in>| gta_der ?TA s" "q |\<in>| \<Q> (fst \<G>)"
      using ta_der_mono'[of "fst \<G>" ?TA "term_of_gterm s"]
      by (auto simp add: fin_mono ta_subset_def gta_der_def in_mono)
    then have "(s, t) \<in> ?RS" using w(1, 3)
      by (auto simp: pair_at_to_agtt_def agtt_lang_def gta_der_def ta_der_eps intro!: exI[of _ p])
         (metis fId_onI frelcompI funionI2 ta.sel(2) ta_der_eps)}
  then show "?LS \<subseteq> ?RS" by auto
next
  {fix s t assume ls: "(s, t) \<in> ?RS"
    then obtain q where w: "q |\<in>| ta_der (fst_pair_cl (fst \<G>) Q) (term_of_gterm s)"
      "q |\<in>| ta_der (snd \<G>) (term_of_gterm t)"
      by (auto simp: agtt_lang_def pair_at_to_agtt_def gta_der_def)
    from w(2) have "q |\<in>| \<Q> (snd \<G>)" "q |\<notin>| \<Q> (fst \<G>)" using assms(2)
      by auto
    from fst_pair_cl_res_aux[OF restr_distjoing[OF assms] w(1)] this w(2)
    have "(s, t) \<in> ?LS" by (auto simp: agtt_lang_def pair_at_to_agtt_def gta_der_def intro: pair_at_langI)}
  then show "?RS \<subseteq> ?LS" by auto
qed

definition pair_at_to_agtt' where
  "pair_at_to_agtt' \<G> Q = (let \<A> = fmap_states_ta Inl (fst \<G>) in
    let \<B> = fmap_states_ta Inr (snd \<G>) in
    let Q' = Q |\<inter>| (\<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)) in
    pair_at_to_agtt (\<A>, \<B>) (map_prod Inl Inr |`| Q'))"

lemma pair_at_agtt_cost:
  "pair_at_lang \<G> Q = agtt_lang (pair_at_to_agtt' \<G> Q)"
proof -
  let ?G = "(fmap_states_ta CInl (fst \<G>), fmap_states_ta CInr (snd \<G>))"
  let ?Q = "(Q |\<inter>| (\<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)))"
  let ?Q' = "map_prod CInl CInr |`| ?Q"
  have *: "pair_at_lang \<G> Q = pair_at_lang \<G> ?Q"
    using pair_at_lang_restr_states by blast
  have "pair_at_lang \<G> ?Q = pair_at_lang (map_prod (fmap_states_ta CInl) (fmap_states_ta CInr) \<G>) (map_prod CInl CInr |`| ?Q)"
    by (intro pair_at_lang_fun_states[where ?\<G> = \<G> and ?Q = ?Q and ?f = CInl and ?g = CInr])
       (auto simp: finj_CInl_CInr)
  then have **:"pair_at_lang \<G> ?Q = pair_at_lang ?G ?Q'" by (simp add: map_prod_simp')
  have "pair_at_lang ?G ?Q' = agtt_lang (pair_at_to_agtt ?G ?Q')"
    by (intro pair_at_agtt_conv[where ?\<G> = ?G]) auto
  then show ?thesis unfolding * ** pair_at_to_agtt'_def Let_def
    by simp
qed

lemma \<Delta>_Atrans_states_stable:
  assumes "Q |\<subseteq>| \<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)"
  shows "\<Delta>_Atrans_gtt \<G> Q |\<subseteq>| \<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)"
proof
  fix s assume ass: "s |\<in>| \<Delta>_Atrans_gtt \<G> Q"
  then obtain t u where s: "s = (t, u)" by (cases s) blast
  show "s |\<in>| \<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)" using ass assms unfolding s
    by (induct rule: \<Delta>_Atrans_induct) auto
qed

lemma \<Delta>_Atrans_map_prod:
  assumes "finj_on f (\<Q> (fst \<G>))" and "finj_on g (\<Q> (snd \<G>))"
    and "Q |\<subseteq>| \<Q> (fst \<G>) |\<times>| \<Q> (snd \<G>)"
  shows "map_prod f g |`| (\<Delta>_Atrans_gtt \<G> Q) = \<Delta>_Atrans_gtt (map_prod (fmap_states_ta f) (fmap_states_ta g) \<G>) (map_prod f g |`| Q)"
    (is "?LS = ?RS")
proof -
  {fix p q assume "(p, q) |\<in>| \<Delta>_Atrans_gtt \<G> Q"
    then have "(f p, g q) |\<in>| ?RS" using assms
    proof (induct rule: \<Delta>_Atrans_induct)
      case (step p q r v)
      from step(3, 6, 7) have "(g q, f r) |\<in>| \<Delta>\<^sub>\<epsilon> (fmap_states_ta g (snd \<G>)) (fmap_states_ta f (fst \<G>))"
        by (auto simp: \<Delta>\<^sub>\<epsilon>_def' intro!: ground_term_of_gterm)
           (metis ground_term_of_gterm ground_term_to_gtermD ta_der_to_fmap_states_der)
      then show ?case using step by auto
    qed (auto simp add: fmap_prod_fimageI)}
  moreover
  {fix p q assume "(p, q) |\<in>| ?RS"
    then have "(p, q) |\<in>| ?LS" using assms
    proof (induct rule: \<Delta>_Atrans_induct)
      case (step p q r v)
      let ?f = "the_finv_into (\<Q> (fst \<G>)) f" let ?g = "the_finv_into (\<Q> (snd \<G>)) g"
      have sub: "\<Delta>\<^sub>\<epsilon> (snd \<G>) (fst \<G>) |\<subseteq>| \<Q> (snd \<G>) |\<times>| \<Q> (fst \<G>)"
        using \<Delta>\<^sub>\<epsilon>_statesD(1, 2) by fastforce
      have s_e: "(?f p, ?g q) |\<in>| \<Delta>_Atrans_gtt \<G> Q" "(?f r, ?g v) |\<in>| \<Delta>_Atrans_gtt \<G> Q"
        using step assms(1, 2) fsubsetD[OF \<Delta>_Atrans_states_stable[OF assms(3)]]
        using finj_on_eq_iff[OF assms(1)] finj_on_eq_iff
        using the_finv_into_f_f[OF assms(1)] the_finv_into_f_f[OF assms(2)]
        by auto
      from step(3) have "(?g q, ?f r) |\<in>| \<Delta>\<^sub>\<epsilon> (snd \<G>) (fst \<G>)"
        using step(6-) sub
        using ta_der_fmap_states_conv[OF assms(1)] ta_der_fmap_states_conv[OF assms(2)]
        using the_finv_into_f_f[OF assms(1)] the_finv_into_f_f[OF assms(2)]
        by (auto simp: \<Delta>\<^sub>\<epsilon>_fmember fimage_iff fBex_def)
           (metis ground_term_of_gterm ground_term_to_gtermD ta_der_fmap_states_inv)
      then have "(q, r) |\<in>| map_prod g f |`| \<Delta>\<^sub>\<epsilon> (snd \<G>) (fst \<G>)" using step
        using the_finv_into_f_f[OF assms(1)] the_finv_into_f_f[OF assms(2)] sub
        by auto (smt \<Delta>\<^sub>\<epsilon>_statesD(1, 2) f_the_finv_into_f fmap_prod_fimageI fmap_states)
      then show ?case using s_e assms(1, 2) s_e
        using fsubsetD[OF sub]
        using fsubsetD[OF \<Delta>_Atrans_states_stable[OF assms(3)]]
        using \<Delta>_Atrans_step[of "?f p" "?g q" Q "fst \<G>" "snd \<G>" "?f r" "?g v"]
        using the_finv_into_f_f[OF assms(1)] the_finv_into_f_f[OF assms(2)]
        by  (auto simp: fimage_iff fBex_def)
            (smt Pair_inject prod_fun_fimageE step.hyps(2) step.hyps(5) step.prems(3))
    qed auto}
  ultimately show ?thesis by auto
qed

\<comment> \<open>Section: Pair Automaton is closed under Determinization\<close>

definition Q_pow where
  "Q_pow Q \<S>\<^sub>1 \<S>\<^sub>2 =
    {|(Wrapp X, Wrapp Y) | X Y p q. X |\<in>| fPow \<S>\<^sub>1 \<and> Y |\<in>| fPow \<S>\<^sub>2 \<and> p |\<in>| X \<and> q |\<in>| Y \<and> (p, q) |\<in>| Q|}"

lemma Q_pow_fmember:
  "(X, Y) |\<in>| Q_pow Q \<S>\<^sub>1 \<S>\<^sub>2 \<longleftrightarrow> (\<exists> p q. ex X |\<in>| fPow \<S>\<^sub>1 \<and> ex Y |\<in>| fPow \<S>\<^sub>2 \<and> p |\<in>| ex X \<and> q |\<in>| ex Y \<and> (p, q) |\<in>| Q)"
proof -
  let ?S = "{(Wrapp X, Wrapp Y) | X Y p q. X |\<in>| fPow \<S>\<^sub>1 \<and> Y |\<in>| fPow \<S>\<^sub>2 \<and> p |\<in>| X \<and> q |\<in>| Y \<and> (p, q) |\<in>| Q}"
  have "?S \<subseteq> map_prod Wrapp Wrapp ` fset (fPow \<S>\<^sub>1 |\<times>| fPow \<S>\<^sub>2)" by (auto simp flip: fmember_iff_member_fset)
  from finite_subset[OF this] show ?thesis unfolding Q_pow_def
    apply auto apply blast
    by (meson FSet_Lex_Wrapper.exhaust_sel)
qed

lemma pair_automaton_det_lang_sound_complete:
  "pair_at_lang \<G> Q = pair_at_lang (map_both ps_ta \<G>) (Q_pow Q (\<Q> (fst \<G>)) (\<Q> (snd \<G>)))" (is "?LS = ?RS")
proof -
  {fix s t assume "(s, t) \<in> ?LS"
    then obtain  p q where
      res : "p |\<in>| ta_der (fst \<G>) (term_of_gterm s)"
      "q |\<in>| ta_der (snd \<G>) (term_of_gterm t)" "(p, q) |\<in>| Q"
      by (auto simp: pair_at_lang_def gta_der_def)
    from ps_rules_complete[OF this(1)] ps_rules_complete[OF this(2)] this(3)
    have "(s, t) \<in> ?RS" using fPow_iff ps_ta_states'
      by (auto simp: pair_at_lang_def gta_der_def Q_pow_fmember)
         force}
  moreover
  {fix s t assume "(s, t) \<in> ?RS" then have "(s, t) \<in> ?LS"
      using ps_rules_sound
      by (auto simp: pair_at_lang_def gta_der_def ps_ta_def Let_def Q_pow_fmember) blast}
  ultimately show ?thesis by auto
qed

lemma pair_automaton_complement_sound_complete:
  assumes "partially_completely_defined_on \<A> \<F>" and "partially_completely_defined_on \<B> \<F>"
    and "ta_det \<A>" and "ta_det \<B>"
  shows "pair_at_lang (\<A>, \<B>) (\<Q> \<A> |\<times>| \<Q> \<B> |-| Q) = gterms (fset \<F>) \<times> gterms (fset \<F>) - pair_at_lang (\<A>, \<B>) Q"
  using assms unfolding partially_completely_defined_on_def pair_at_lang_def
  apply (auto simp: gta_der_def)
  apply (metis ta_detE)
  apply fastforce
  done

end