subsection \<open>Heap Memory Implementations\<close>

theory Memory_Heap
  imports State_Heap DP_CRelVH Pair_Memory "HOL-Eisbach.Eisbach" "../Index"
begin

text \<open>Move\<close>
abbreviation "result_of c h \<equiv> fst (the (execute c h))"
abbreviation "heap_of   c h \<equiv> snd (the (execute c h))"

lemma map_emptyI:
  "m \<subseteq>\<^sub>m Map.empty" if "\<And> x. m x = None"
  using that unfolding map_le_def by auto

lemma result_of_return[simp]:
  "result_of (Heap_Monad.return x) h = x"
  by (simp add: execute_simps)

lemma get_result_of_lookup:
  "result_of (!r) heap = x" if "Ref.get heap r = x"
  using that by (auto simp: execute_simps)

context
  fixes size :: nat
    and to_index :: "('k2 :: heap) \<Rightarrow> nat"
begin

definition
  "mem_empty = (Array.new size (None :: ('v :: heap) option))"

lemma success_empty[intro]:
  "success mem_empty heap"
  unfolding mem_empty_def by (auto intro: success_intros)

lemma length_mem_empty:
  "Array.length
    (heap_of (mem_empty:: (('b :: heap) option array) Heap) h)
    (result_of (mem_empty :: ('b option array) Heap) h) = size"
  unfolding mem_empty_def by (auto simp: execute_simps Array.length_alloc)

lemma nth_mem_empty:
  "result_of
    (Array.nth (result_of (mem_empty :: ('b option array) Heap) h) i)
    (heap_of (mem_empty :: (('b :: heap) option array) Heap) h) = None" if "i < size"
  apply (subst execute_nth(1))
  apply (simp add: length_mem_empty that)
  apply (simp add: execute_simps mem_empty_def Array.get_alloc that)
  done

context
  fixes mem :: "('v :: heap) option array"
begin

definition
  "mem_lookup k = (let i = to_index k in
    if i < size then Array.nth mem i else return None
  )"

definition
  "mem_update k v = (let i = to_index k in
    if i < size then (Array.upd i (Some v) mem \<bind> (\<lambda> _. return ()))
    else return ()
  )
  "

context assumes injective: "injective size to_index"
begin

interpretation heap_correct "\<lambda>heap. Array.length heap mem = size" mem_update mem_lookup
  apply standard
  subgoal lookup_inv
    unfolding State_Heap.lift_p_def mem_lookup_def by (simp add: Let_def execute_simps)
  subgoal update_inv
    unfolding State_Heap.lift_p_def mem_update_def by (simp add: Let_def execute_simps)
  subgoal for k heap
    unfolding heap_mem_defs.map_of_heap_def map_le_def mem_lookup_def
    by (auto simp: execute_simps Let_def split: if_split_asm)
  subgoal for heap k
    unfolding heap_mem_defs.map_of_heap_def map_le_def mem_lookup_def mem_update_def
    apply (auto simp: execute_simps Let_def length_def split: if_split_asm)
    apply (subst (asm) nth_list_update_neq)
    using injective[unfolded injective_def] apply auto
    done
  done

lemmas mem_heap_correct = heap_correct_axioms

context
  assumes [simp]: "mem = result_of mem_empty Heap.empty"
begin

interpretation heap_correct_empty
  "\<lambda>heap. Array.length heap mem = size" mem_update mem_lookup
  "heap_of (mem_empty :: 'v option array Heap) Heap.empty"
  apply standard
  subgoal
    apply (rule map_emptyI)
    unfolding map_of_heap_def mem_lookup_def by (auto simp: Let_def nth_mem_empty)
  subgoal
    by (simp add: length_mem_empty)
  done

lemmas array_heap_emptyI = heap_correct_empty_axioms

context
  fixes dp :: "'k2 \<Rightarrow> 'v"
begin

interpretation dp_consistency_heap_empty
  "\<lambda>heap. Array.length heap mem = size" mem_update mem_lookup dp
  "heap_of (mem_empty :: 'v option array Heap) Heap.empty"
  by standard

lemmas array_consistentI = dp_consistency_heap_empty_axioms

end

end (* Empty Memory *)

end (* Injectivity *)

end (* Fixed array *)

lemma execute_bind_success':
  assumes "success f h" "execute (f \<bind> g) h = Some (y, h'')"
  obtains x h' where "execute f h = Some (x, h')" "execute (g x) h' = Some (y, h'')"
  using assms by (auto simp: execute_simps elim: successE)

lemma success_bind_I:
  assumes "success f h"
    and "\<And> x h'. execute f h = Some (x, h') \<Longrightarrow> success (g x) h'"
  shows "success (f \<bind> g) h"
  by (rule successE[OF assms(1)]) (auto elim: assms(2) intro: success_bind_executeI)

definition
  "alloc_pair a b \<equiv> do {
    r1 \<leftarrow> ref a;
    r2 \<leftarrow> ref b;
    return (r1, r2)
  }"

lemma alloc_pair_alloc:
  "Ref.get heap' r1 = a" "Ref.get heap' r2 = b"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
  using that unfolding alloc_pair_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
     (metis Ref.get_alloc fst_conv get_alloc_neq next_present present_alloc_neq snd_conv)+

lemma alloc_pairD1:
  "r =!= r1 \<and> r =!= r2 \<and> Ref.present heap' r"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')" "Ref.present heap r"
  using that unfolding alloc_pair_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
     (metis next_fresh noteq_I Ref.present_alloc snd_conv)+

lemma alloc_pairD2:
  "r1 =!= r2 \<and> Ref.present heap' r2 \<and> Ref.present heap' r1"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
  using that unfolding alloc_pair_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
     (metis next_fresh next_present noteq_I Ref.present_alloc snd_conv)+

lemma alloc_pairD3:
  "Array.present heap' r"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')" "Array.present heap r"
  using that unfolding alloc_pair_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
     (metis array_present_alloc snd_conv)

lemma alloc_pairD4:
  "Ref.get heap' r = x"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
     "Ref.get heap r = x" "Ref.present heap r"
  using that unfolding alloc_pair_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
     (metis Ref.not_present_alloc Ref.present_alloc get_alloc_neq noteq_I snd_conv)

lemma alloc_pair_array_get:
  "Array.get heap' r = x"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')" "Array.get heap r = x"
  using that unfolding alloc_pair_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
 (metis array_get_alloc snd_conv)

lemma alloc_pair_array_length:
  "Array.length heap' r = Array.length heap r"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
  using that unfolding alloc_pair_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF success_refI])
     (metis Ref.length_alloc snd_conv)

lemma alloc_pair_nth:
  "result_of (Array.nth r i) heap' = result_of (Array.nth r i) heap"
  if "execute (alloc_pair a b) heap = Some ((r1, r2), heap')"
  using alloc_pair_array_get[OF that(1) HOL.refl, of r] alloc_pair_array_length[OF that(1), of r]
  by (cases "(\<lambda>h. i < Array.length h r) heap"; simp add: execute_simps Array.nth_def)

lemma succes_alloc_pair[intro]:
  "success (alloc_pair a b) heap"
  unfolding alloc_pair_def by (auto intro: success_intros success_bind_I)

definition
  "init_state_inner k1 k2 m1 m2 \<equiv>  do {
    (k_ref1, k_ref2) \<leftarrow> alloc_pair k1 k2;
    (m_ref1, m_ref2) \<leftarrow> alloc_pair m1 m2;
    return (k_ref1, k_ref2, m_ref1, m_ref2)
  }
  "

lemma init_state_inner_alloc:
  assumes
    "execute (init_state_inner k1 k2 m1 m2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "Ref.get heap' k_ref1 = k1" "Ref.get heap' k_ref2 = k2"
    "Ref.get heap' m_ref1 = m1" "Ref.get heap' m_ref2 = m2"
  using assms unfolding init_state_inner_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF succes_alloc_pair])
     (auto intro: alloc_pair_alloc dest: alloc_pairD2 elim: alloc_pairD4)

lemma init_state_inner_distinct:
  assumes
    "execute (init_state_inner k1 k2 m1 m2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "m_ref1 =!= m_ref2 \<and> m_ref1 =!= k_ref1 \<and> m_ref1 =!= k_ref2 \<and> m_ref2 =!= k_ref1
   \<and> m_ref2 =!= k_ref2 \<and> k_ref1 =!= k_ref2"
  using assms unfolding init_state_inner_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF succes_alloc_pair])
     (blast dest: alloc_pairD1 alloc_pairD2 intro: noteq_sym)+

lemma init_state_inner_present:
  assumes
    "execute (init_state_inner k1 k2 m1 m2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "Ref.present heap' k_ref1" "Ref.present heap' k_ref2"
    "Ref.present heap' m_ref1" "Ref.present heap' m_ref2"
  using assms unfolding init_state_inner_def
  by (auto simp: execute_simps elim!: execute_bind_success'[OF succes_alloc_pair])
     (blast dest: alloc_pairD1 alloc_pairD2)+

lemma inite_state_inner_present':
  assumes
    "execute (init_state_inner k1 k2 m1 m2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
    "Array.present heap a"
  shows
    "Array.present heap' a"
    using assms unfolding init_state_inner_def
    by (auto simp: execute_simps elim!: execute_bind_success'[OF succes_alloc_pair] alloc_pairD3)

lemma succes_init_state_inner[intro]:
  "success (init_state_inner k1 k2 m1 m2) heap"
  unfolding init_state_inner_def by (auto 4 3 intro: success_intros success_bind_I)

lemma init_state_inner_nth:
  "result_of (Array.nth r i) heap' = result_of (Array.nth r i) heap"
  if "execute (init_state_inner k1 k2 m1 m2) heap = Some ((r1, r2), heap')"
  using that unfolding init_state_inner_def
  by (auto simp: execute_simps alloc_pair_nth elim!: execute_bind_success'[OF succes_alloc_pair])

definition
  "init_state k1 k2 \<equiv> do {
    m1 \<leftarrow> mem_empty;
    m2 \<leftarrow> mem_empty;
    init_state_inner k1 k2 m1 m2
  }"

definition
  "inv_distinct k_ref1 k_ref2 m_ref1 m_ref2 \<equiv>
     m_ref1 =!= m_ref2 \<and> m_ref1 =!= k_ref1 \<and> m_ref1 =!= k_ref2 \<and> m_ref2 =!= k_ref1
   \<and> m_ref2 =!= k_ref2 \<and> k_ref1 =!= k_ref2
  "

lemma init_state_distinct:
  assumes
    "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "inv_distinct k_ref1 k_ref2 m_ref1 m_ref2"
  using assms unfolding init_state_def inv_distinct_def
  by (elim execute_bind_success'[OF success_empty] init_state_inner_distinct)

lemma init_state_present:
  assumes
    "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "Ref.present heap' k_ref1" "Ref.present heap' k_ref2"
    "Ref.present heap' m_ref1" "Ref.present heap' m_ref2"
  using assms unfolding init_state_def
  by (auto
        simp: execute_simps elim!: execute_bind_success'[OF success_empty]
        dest: init_state_inner_present
     )

lemma empty_present:
  "Array.present h' x" if "execute mem_empty heap = Some (x, h')"
  using that unfolding mem_empty_def
  by (auto simp: execute_simps) (metis Array.present_alloc fst_conv snd_conv)

lemma empty_present':
  "Array.present h' a" if "execute mem_empty heap = Some (x, h')" "Array.present heap a"
  using that unfolding mem_empty_def
  by (auto simp: execute_simps Array.present_def Array.alloc_def Array.set_def Let_def)

lemma init_state_present2:
  assumes
    "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "Array.present heap' (Ref.get heap' m_ref1)" "Array.present heap' (Ref.get heap' m_ref2)"
  using assms unfolding init_state_def
  by (auto 4 3
        simp: execute_simps init_state_inner_alloc elim!: execute_bind_success'[OF success_empty]
        dest: inite_state_inner_present' empty_present empty_present'
     )

lemma init_state_neq:
  assumes
    "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "Ref.get heap' m_ref1 =!!= Ref.get heap' m_ref2"
  using assms unfolding init_state_def
  by (auto 4 3
        simp: execute_simps init_state_inner_alloc elim!: execute_bind_success'[OF success_empty]
        dest: inite_state_inner_present' empty_present empty_present'
     )
    (metis empty_present execute_new fst_conv mem_empty_def option.inject present_alloc_noteq)

lemma present_alloc_get:
  "Array.get heap' a = Array.get heap a"
  if "Array.alloc xs heap = (a', heap')" "Array.present heap a"
  using that by (auto simp: Array.alloc_def Array.present_def Array.get_def Let_def Array.set_def)

lemma init_state_length:
  assumes
    "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows
    "Array.length heap' (Ref.get heap' m_ref1) = size"
    "Array.length heap' (Ref.get heap' m_ref2) = size"
  using assms unfolding init_state_def
  apply (auto
        simp: execute_simps init_state_inner_alloc elim!: execute_bind_success'[OF success_empty]
        dest: inite_state_inner_present' empty_present empty_present'
     )
   apply (auto
      simp: execute_simps init_state_inner_def alloc_pair_def mem_empty_def Array.length_def
      elim!: execute_bind_success'[OF success_refI]
     )
  apply (metis
      Array.alloc_def Array.get_set_eq Array.present_alloc array_get_alloc fst_conv length_replicate
      present_alloc_get snd_conv
     )+
  done

context
  fixes key1 :: "'k \<Rightarrow> ('k1 :: heap)" and key2 :: "'k \<Rightarrow> 'k2"
    and m_ref1 m_ref2 :: "('v :: heap) option array ref"
    and k_ref1 k_ref2 :: "('k1 :: heap) ref"
begin

text \<open>We assume that look-ups happen on the older row, so this is biased towards the second entry.\<close>
definition
  "lookup_pair k = do {
    let k' = key1 k;
    k2 \<leftarrow> !k_ref2;
    if k' = k2 then
      do {
        m2 \<leftarrow> !m_ref2;
        mem_lookup m2 (key2 k)
      }
    else
      do {
      k1 \<leftarrow> !k_ref1;
      if k' = k1 then
        do {
          m1 \<leftarrow> !m_ref1;
          mem_lookup m1 (key2 k)
        }
      else
        return None
    }
  }
   "

text \<open>We assume that updates happen on the newer row, so this is biased towards the first entry.\<close>
definition
  "update_pair k v = do {
    let k' = key1 k;
      k1 \<leftarrow> !k_ref1;
      if k' = k1 then do {
        m \<leftarrow> !m_ref1;
        mem_update m (key2 k) v
      }
      else do {
        k2 \<leftarrow> !k_ref2;
        if k' = k2 then do {
          m \<leftarrow> !m_ref2;
          mem_update m (key2 k) v
        }
        else do {
          do {
            k1 \<leftarrow> !k_ref1;
            m \<leftarrow> mem_empty;
            m1 \<leftarrow> !m_ref1;
            k_ref2 := k1;
            k_ref1 := k';
            m_ref2 := m1;
            m_ref1 := m
          }
        ;
        m \<leftarrow> !m_ref1;
        mem_update m (key2 k) v
      }
    }
   }
   "

definition
  "inv_pair_weak heap = (
    let
      m1 = Ref.get heap m_ref1;
      m2 = Ref.get heap m_ref2
    in Array.length heap m1 = size \<and> Array.length heap m2 = size
      \<and> Ref.present heap k_ref1 \<and> Ref.present heap k_ref2
      \<and> Ref.present heap m_ref1 \<and> Ref.present heap m_ref2
      \<and> Array.present heap m1 \<and> Array.present heap m2
      \<and> m1 =!!= m2
  )"

(* TODO: Remove? *)
definition
  "inv_pair heap \<equiv> inv_pair_weak heap \<and> inv_distinct k_ref1 k_ref2 m_ref1 m_ref2"

lemma init_state_inv:
  assumes
    "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
  shows "inv_pair_weak heap'"
  using assms unfolding inv_pair_weak_def Let_def
  by (auto intro:
      init_state_present init_state_present2 init_state_neq init_state_length
      init_state_distinct
     )

lemma inv_pair_lengthD1:
  "Array.length heap (Ref.get heap m_ref1) = size" if "inv_pair_weak heap"
  using that unfolding inv_pair_weak_def by (auto simp: Let_def)

lemma inv_pair_lengthD2:
  "Array.length heap (Ref.get heap m_ref2) = size" if "inv_pair_weak heap"
  using that unfolding inv_pair_weak_def by (auto simp: Let_def)

lemma inv_pair_presentD:
  "Array.present heap (Ref.get heap m_ref1)" "Array.present heap (Ref.get heap m_ref2)"
  if "inv_pair_weak heap"
  using that unfolding inv_pair_weak_def by (auto simp: Let_def)

lemma inv_pair_presentD2:
  "Ref.present heap m_ref1" "Ref.present heap m_ref2"
  "Ref.present heap k_ref1" "Ref.present heap k_ref2"
  if "inv_pair_weak heap"
  using that unfolding inv_pair_weak_def by (auto simp: Let_def)

lemma inv_pair_not_eqD:
  "Ref.get heap m_ref1 =!!= Ref.get heap m_ref2" if "inv_pair_weak heap"
  using that unfolding inv_pair_weak_def by (auto simp: Let_def)

definition "lookup1 k \<equiv> state_of (do {m \<leftarrow> !m_ref1; mem_lookup m k})"

definition "lookup2 k \<equiv> state_of (do {m \<leftarrow> !m_ref2; mem_lookup m k})"

definition "update1 k v \<equiv> state_of (do {m \<leftarrow> !m_ref1; mem_update m k v})"

definition "update2 k v \<equiv> state_of (do {m \<leftarrow> !m_ref2; mem_update m k v})"

definition "move12 k \<equiv> state_of (do {
    k1 \<leftarrow> !k_ref1;
    m \<leftarrow> mem_empty;
    m1 \<leftarrow> !m_ref1;
    k_ref2 := k1;
    k_ref1 := k;
    m_ref2 := m1;
    m_ref1 := m
  })
  "

definition "get_k1 \<equiv> state_of (!k_ref1)"

definition "get_k2 \<equiv> state_of (!k_ref2)"

lemma run_state_state_of[simp]:
  "State_Monad.run_state (state_of p) m = the (execute p m)"
  unfolding state_of_def by simp

context assumes injective: "injective size to_index"
begin

context
  assumes inv_distinct: "inv_distinct k_ref1 k_ref2 m_ref1 m_ref2"
begin

lemma disjoint[simp]:
  "m_ref1 =!= m_ref2" "m_ref1 =!= k_ref1" "m_ref1 =!= k_ref2"
  "m_ref2 =!= k_ref1" "m_ref2 =!= k_ref2"
  "k_ref1 =!= k_ref2"
  using inv_distinct unfolding inv_distinct_def by auto

lemmas [simp] = disjoint[THEN noteq_sym]

lemma [simp]:
  "Ref.get (snd (Array.alloc xs heap)) r = Ref.get heap r" if "Ref.present heap r"
  using that unfolding Array.alloc_def Ref.present_def
  by (simp add: Let_def Ref.get_def Array.set_def)

lemma alloc_present':
  "Ref.present (snd (Array.alloc xs heap)) r" if "Ref.present heap r"
  using that unfolding Ref.present_def Array.alloc_def by (simp add: Let_def Array.set_def)

lemma length_get_upd[simp]:
  "length (Array.get (Array.update a i x heap) r) = length (Array.get heap r)"
  unfolding Array.get_def Array.update_def Array.set_def by simp

method solve1 =
  (frule inv_pair_lengthD1, frule inv_pair_lengthD2, frule inv_pair_not_eqD)?,
  auto split: if_split_asm dest: Array.noteq_sym

interpretation pair: pair_mem lookup1 lookup2 update1 update2 move12 get_k1 get_k2 inv_pair_weak
  supply [simp] =
    mem_empty_def state_mem_defs.map_of_def map_le_def
    move12_def update1_def update2_def lookup1_def lookup2_def get_k1_def get_k2_def
    mem_update_def mem_lookup_def
    execute_bind_success[OF success_newI] execute_simps Let_def Array.get_alloc length_def
    inv_pair_presentD inv_pair_presentD2
    Memory_Heap.lookup1_def Memory_Heap.lookup2_def Memory_Heap.mem_lookup_def
  apply standard
                      apply (solve1; fail)+
  subgoal
    apply (rule lift_pI)
    unfolding inv_pair_weak_def
    apply (auto simp:
        intro: alloc_present alloc_present'
        elim: present_alloc_noteq[THEN Array.noteq_sym]
        )
    done
                     apply (rule lift_pI, unfold inv_pair_weak_def, auto split: if_split_asm; fail)+
                 apply (solve1; fail)+
  subgoal
    using injective[unfolded injective_def] by - (solve1, subst (asm) nth_list_update_neq, auto)
  subgoal
    using injective[unfolded injective_def] by - (solve1, subst (asm) nth_list_update_neq, auto)
   apply (solve1; fail)+
  done

lemmas mem_correct_pair = pair.mem_correct_pair

definition
  "mem_lookup1 k = do {m \<leftarrow> !m_ref1; mem_lookup m k}"

definition
  "mem_lookup2 k = do {m \<leftarrow> !m_ref2; mem_lookup m k}"

definition "get_k1' \<equiv> !k_ref1"

definition "get_k2' \<equiv> !k_ref2"

definition "update1' k v \<equiv> do {m \<leftarrow> !m_ref1; mem_update m k v}"

definition "update2' k v \<equiv> do {m \<leftarrow> !m_ref2; mem_update m k v}"

definition "move12' k \<equiv> do {
    k1 \<leftarrow> !k_ref1;
    m \<leftarrow> mem_empty;
    m1 \<leftarrow> !m_ref1;
    k_ref2 := k1;
    k_ref1 := k;
    m_ref2 := m1;
    m_ref1 := m
  }"

interpretation heap_mem_defs inv_pair_weak lookup_pair update_pair .

lemma rel_state_ofI:
  "rel_state (=) (state_of m) m" if
  "\<forall> heap. inv_pair_weak heap \<longrightarrow> success m heap"
  "lift_p inv_pair_weak m"
  using that unfolding rel_state_def
  by (auto split: option.split intro: lift_p_P'' simp: success_def)

lemma inv_pair_iff:
  "inv_pair_weak = inv_pair"
  unfolding inv_pair_def using inv_distinct by simp

lemma lift_p_inv_pairI:
  "State_Heap.lift_p inv_pair m" if "State_Heap.lift_p inv_pair_weak m"
  using that unfolding inv_pair_iff by simp

lemma lift_p_success:
  "State_Heap.lift_p inv_pair_weak m"
  if "DP_CRelVS.lift_p inv_pair_weak (state_of m)" "\<forall> heap. inv_pair_weak heap \<longrightarrow> success m heap"
  using that
  unfolding lift_p_def DP_CRelVS.lift_p_def
  by (auto simp: success_def split: option.split)

lemma rel_state_ofI2:
  "rel_state (=) (state_of m) m" if
  "\<forall> heap. inv_pair_weak heap \<longrightarrow> success m heap"
  "DP_CRelVS.lift_p inv_pair_weak (state_of m)"
  using that by (blast intro: rel_state_ofI lift_p_success)

context
  includes lifting_syntax
begin

lemma [transfer_rule]:
  "((=) ===> rel_state (rel_option (=))) lookup1 mem_lookup1"
  unfolding lookup1_def mem_lookup1_def
  apply (intro rel_funI)
  apply (simp add: option.rel_eq)
  apply (rule rel_state_ofI2)
  subgoal
    by (auto 4 4
        simp: mem_lookup_def inv_pair_lengthD1 execute_simps Let_def
        intro: success_bind_executeI success_returnI Array.success_nthI
       )
  subgoal
    using pair.lookup_inv(1) unfolding lookup1_def .
  done

lemma [transfer_rule]:
  "((=) ===> rel_state (rel_option (=))) lookup2 mem_lookup2"
  unfolding lookup2_def mem_lookup2_def
  apply (intro rel_funI)
  apply (simp add: option.rel_eq)
  apply (rule rel_state_ofI2)
  subgoal
    by (auto 4 3
        simp: mem_lookup_def inv_pair_lengthD2 execute_simps Let_def
        intro: success_intros intro!: success_bind_I
       )
  subgoal
    using pair.lookup_inv(2) unfolding lookup2_def .
  done

lemma [transfer_rule]:
  "rel_state (=) get_k1 get_k1'"
  unfolding get_k1_def get_k1'_def
  apply (rule rel_state_ofI2)
  subgoal
    by (auto intro: success_lookupI)
  subgoal
    unfolding get_k1_def[symmetric] by (auto dest: pair.get_state(1) intro: lift_pI)
  done

lemma [transfer_rule]:
  "rel_state (=) get_k2 get_k2'"
  unfolding get_k2_def get_k2'_def
  apply (rule rel_state_ofI2)
  subgoal
    by (auto intro: success_lookupI)
  subgoal
    unfolding get_k2_def[symmetric] by (auto dest: pair.get_state(2) intro: lift_pI)
  done

lemma [transfer_rule]:
  "((=) ===> (=) ===> rel_state (=)) update1 update1'"
  unfolding update1_def update1'_def
  apply (intro rel_funI)
  apply simp
  apply (rule rel_state_ofI2)
  subgoal
    by (auto 4 3
        simp: mem_update_def inv_pair_lengthD1 execute_simps Let_def
        intro: success_intros intro!: success_bind_I
       )
  subgoal
    using pair.update_inv(1) unfolding update1_def .
  done

lemma [transfer_rule]:
  "((=) ===> (=) ===> rel_state (=)) update2 update2'"
  unfolding update2_def update2'_def
  apply (intro rel_funI)
  apply simp
  apply (rule rel_state_ofI2)
  subgoal
    by (auto 4 3
        simp: mem_update_def inv_pair_lengthD2 execute_simps Let_def
        intro: success_intros intro!: success_bind_I
       )
  subgoal
    using pair.update_inv(2) unfolding update2_def .
  done

lemma [transfer_rule]:
  "((=) ===> rel_state (rel_option (=))) lookup1 mem_lookup1"
  unfolding lookup1_def mem_lookup1_def
  apply (intro rel_funI)
  apply (simp add: option.rel_eq)
  apply (rule rel_state_ofI2)
  subgoal
    by (auto 4 3
        simp: mem_lookup_def inv_pair_lengthD1 execute_simps Let_def
        intro: success_intros intro!: success_bind_I
       )
  subgoal
    using pair.lookup_inv(1) unfolding lookup1_def .
  done

lemma rel_state_lookup:
  "((=) ===> rel_state (=)) pair.lookup_pair lookup_pair"
  unfolding pair.lookup_pair_def lookup_pair_def
  unfolding
    mem_lookup1_def[symmetric] mem_lookup2_def[symmetric]
    get_k2_def[symmetric] get_k2'_def[symmetric]
    get_k1_def[symmetric] get_k1'_def[symmetric]
  by transfer_prover

lemma rel_state_update:
  "((=) ===> (=) ===> rel_state (=)) pair.update_pair update_pair"
  unfolding pair.update_pair_def update_pair_def
  unfolding move12'_def[symmetric]
  unfolding
    update1'_def[symmetric] update2'_def[symmetric]
    get_k2_def[symmetric] get_k2'_def[symmetric]
    get_k1_def[symmetric] get_k1'_def[symmetric]
  by transfer_prover

interpretation mem: heap_mem_defs pair.inv_pair lookup_pair update_pair .

lemma inv_pairD:
  "inv_pair_weak heap" if "pair.inv_pair heap"
  using that unfolding pair.inv_pair_def by (auto simp: Let_def)

lemma mem_rel_state_ofI:
  "mem.rel_state (=) m' m" if
  "rel_state (=) m' m"
  "\<And> heap. pair.inv_pair heap \<Longrightarrow>
    (case State_Monad.run_state m' heap of (_, heap) \<Rightarrow> inv_pair_weak heap \<longrightarrow> pair.inv_pair heap)"
proof -
  show ?thesis
    apply (rule mem.rel_state_intro)
    subgoal for heap v heap'
      by (auto elim: rel_state_elim[OF that(1)] dest!: inv_pairD)
    subgoal premises prems for heap v heap'
    proof -
      from prems that(1) have "inv_pair_weak heap'"
        by (fastforce elim: rel_state_elim dest: inv_pairD)
      with prems show ?thesis
        by (auto dest: that(2))
    qed
    done
qed

lemma mem_rel_state_ofI':
  "mem.rel_state (=) m' m" if
  "rel_state (=) m' m"
  "DP_CRelVS.lift_p pair.inv_pair m'"
  using that by (auto elim: DP_CRelVS.lift_p_P intro: mem_rel_state_ofI)

context
  assumes keys: "\<forall>k k'. key1 k = key1 k' \<and> key2 k = key2 k' \<longrightarrow> k = k'"
begin

interpretation mem_correct pair.lookup_pair pair.update_pair pair.inv_pair
  by (rule mem_correct_pair[OF keys])

lemma rel_state_lookup':
  "((=) ===> mem.rel_state (=)) pair.lookup_pair lookup_pair"
  apply (intro rel_funI)
  apply simp
  apply (rule mem_rel_state_ofI')
  subgoal for x y
    using rel_state_lookup by (rule rel_funD) (rule HOL.refl)
  by (rule lookup_inv)

lemma rel_state_update':
  "((=) ===> (=) ===> mem.rel_state (=)) pair.update_pair update_pair"
  apply (intro rel_funI)
  apply simp
  apply (rule mem_rel_state_ofI')
  subgoal for x y a b
    using rel_state_update by (blast dest: rel_funD)
  by (rule update_inv)

interpretation heap_correct pair.inv_pair update_pair lookup_pair
  by (rule mem.mem_correct_heap_correct[OF _ rel_state_lookup' rel_state_update']) standard

lemmas heap_correct_pairI = heap_correct_axioms

(* TODO: Generalize *)
lemma mem_rel_state_resultD:
  "result_of m heap = fst (run_state m' heap)" if "mem.rel_state (=) m' m" "pair.inv_pair heap"
  by (metis (mono_tags, lifting) mem.rel_state_elim option.sel that)

lemma map_of_heap_eq:
  "mem.map_of_heap heap = pair.pair.map_of heap" if "pair.inv_pair heap"
  unfolding mem.map_of_heap_def pair.pair.map_of_def
  using that by (simp add: mem_rel_state_resultD[OF rel_state_lookup'[THEN rel_funD]])

context
  fixes k1 k2 heap heap'
  assumes init: "execute (init_state k1 k2) heap = Some ((k_ref1, k_ref2, m_ref1, m_ref2), heap')"
begin

lemma init_state_empty1:
  "pair.mem1.map_of heap' k = None"
  using init
  unfolding pair.mem1.map_of_def lookup1_def mem_lookup_def init_state_def
  by (auto
        simp: init_state_inner_nth init_state_inner_alloc(3) execute_simps Let_def
        elim!: execute_bind_success'[OF success_empty])
     (metis
        Array.present_alloc Memory_Heap.length_mem_empty execute_new execute_nth(1) fst_conv
        length_def mem_empty_def nth_mem_empty option.sel present_alloc_get snd_conv
     )

lemma init_state_empty2:
  "pair.mem2.map_of heap' k = None"
  using init
  unfolding pair.mem2.map_of_def lookup2_def mem_lookup_def init_state_def
  by (auto
        simp: execute_simps init_state_inner_nth init_state_inner_alloc(4) Let_def
        elim!: execute_bind_success'[OF success_empty]
     )
     (metis fst_conv nth_mem_empty option.sel snd_conv)

lemma
  shows init_state_k1: "result_of (!k_ref1) heap' = k1"
    and init_state_k2: "result_of (!k_ref2) heap' = k2"
  using init init_state_inner_alloc
  by (auto simp: execute_simps init_state_def elim!: execute_bind_success'[OF success_empty])

context
  assumes neq: "k1 \<noteq> k2"
begin

lemma init_state_inv':
  "pair.inv_pair heap'"
  unfolding pair.inv_pair_def
  apply (auto simp: Let_def)
  subgoal
    using init_state_empty1 by simp
  subgoal
    using init_state_empty2 by simp
  subgoal
    using neq init by (simp add: get_k1_def get_k2_def init_state_k1 init_state_k2)
  subgoal
    by (rule init_state_inv[OF init])
  done

lemma init_state_empty:
  "pair.pair.map_of heap' \<subseteq>\<^sub>m Map.empty"
  using neq by (intro pair.emptyI init_state_inv' map_emptyI init_state_empty1 init_state_empty2)

interpretation heap_correct_empty pair.inv_pair update_pair lookup_pair heap'
  apply (rule heap_correct_empty.intro)
   apply (rule heap_correct_pairI)
  apply standard
  subgoal
    by (subst map_of_heap_eq; intro init_state_inv' init_state_empty)
  subgoal
    by (rule init_state_inv')
  done

lemmas heap_correct_empty_pairI = heap_correct_empty_axioms

context
  fixes dp :: "'k \<Rightarrow> 'v"
begin

interpretation dp_consistency_heap_empty
  pair.inv_pair update_pair lookup_pair dp heap'
  by standard

lemmas consistent_empty_pairI = dp_consistency_heap_empty_axioms

end (* DP *)

end (* Unequal Keys *)

end (* Init State *)

end (* Keys injective *)

end (* Lifting Syntax *)

end (* Disjoint *)

end (* Injectivity *)

end (* Refs *)

end (* Key functions & Size *)

end (* Theory *)


(* Title:     Xml
   Author:    Christian Sternagel
   Author:    René Thiemann
*)

section \<open>XML Transformers for Extracting Data from XML Nodes\<close>

theory Xmlt
imports
  Xml
  Certification_Monads.Strict_Sum
  HOL.Rat
begin

type_synonym
  tag = string

text \<open>The type of transformers on xml nodes.\<close>
type_synonym
  'a xmlt = "xml \<Rightarrow> string +\<^sub>\<bottom> 'a"

definition map :: "(xml \<Rightarrow> ('e +\<^sub>\<bottom> 'a)) \<Rightarrow> xml list \<Rightarrow> 'e +\<^sub>\<bottom> 'a list"
where
  [code_unfold]: "map = map_sum_bot"

lemma map_mono [partial_function_mono]:
  fixes C :: "xml \<Rightarrow> ('b \<Rightarrow> ('e +\<^sub>\<bottom> 'c)) \<Rightarrow> 'e +\<^sub>\<bottom> 'd"
  assumes C: "\<And>y. y \<in> set B \<Longrightarrow> mono_sum_bot (C y)"
  shows "mono_sum_bot (\<lambda>f. map (\<lambda>y. C y f) B)"
  unfolding map_def by (auto intro: partial_function_mono C)

hide_const (open) map

fun "text" :: "tag \<Rightarrow> string xmlt"
where
  "text tag (XML n atts [XML_text t]) =
    (if n = tag \<and> atts = [] then return t
    else error (concat
      [''could not extract text for '', tag,'' from '', ''\<newline>'', show (XML n atts [XML_text t])]))"
| "text tag xml = error (concat [''could not extract text for '', tag,'' from '', ''\<newline>'', show xml])"
hide_const (open) "text"

definition bool_of_string :: "string \<Rightarrow> string +\<^sub>\<bottom> bool"
where
  "bool_of_string s =
    (if s = ''true'' then return True
    else if s = ''false'' then return False
    else error (''cannot convert '' @ s @ '' into Boolean''))"

fun bool :: "tag \<Rightarrow> bool xmlt"
where
  "bool tag node = Xmlt.text tag node \<bind> bool_of_string"
hide_const (open) bool

definition fail :: "tag \<Rightarrow> 'a xmlt"
where
  "fail tag xml =
    error (concat
      [''could not transform the following xml element (expected '', tag, '')'', ''\<newline>'', show xml])"
hide_const (open) fail

definition guard :: "(xml \<Rightarrow> bool) \<Rightarrow> 'a xmlt \<Rightarrow> 'a xmlt \<Rightarrow> 'a xmlt"
where
  "guard p p1 p2 x = (if p x then p1 x else p2 x)"
hide_const (open) guard

lemma guard_mono [partial_function_mono]:
  assumes p1: "\<And>y. mono_sum_bot (p1 y)"
    and p2: "\<And>y. mono_sum_bot (p2 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.guard p (\<lambda>y. p1 y g) (\<lambda>y. p2 y g) x)"
  by (cases x) (auto intro!: partial_function_mono p1 p2 simp: Xmlt.guard_def)

fun leaf :: "tag \<Rightarrow> 'a \<Rightarrow> 'a xmlt"
where
  "leaf tag x (XML name atts cs) =
    (if name = tag \<and> atts = [] \<and> cs = [] then return x
    else Xmlt.fail tag (XML name atts cs))" |
  "leaf tag x xml = Xmlt.fail tag xml"
hide_const (open) leaf

fun list1element :: "'a list \<Rightarrow> 'a option"
where
  "list1element [x] = Some x" |
  "list1element _ = None"

fun singleton :: "tag \<Rightarrow> 'a xmlt \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b xmlt"
where
  "singleton tag p1 f xml =
    (case xml of
      XML name atts cs \<Rightarrow>
      (if name = tag \<and> atts = [] then
        (case list1element cs of
          Some (cs1) \<Rightarrow> p1 cs1 \<bind> return \<circ> f
        | None \<Rightarrow> Xmlt.fail tag xml)
      else Xmlt.fail tag xml)
    | _ \<Rightarrow> Xmlt.fail tag xml)"
hide_const (open) singleton

lemma singleton_mono [partial_function_mono]:
  assumes p: "\<And>y. mono_sum_bot (p1 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.singleton t (\<lambda>y. p1 y g) f x)"
    by (cases x, cases "list1element (Xml.children x)") (auto intro!: partial_function_mono p)

fun list2elements :: "'a list \<Rightarrow> ('a \<times> 'a) option"
where
  "list2elements [x, y] = Some (x, y)" |
  "list2elements _ = None"

fun pair :: "tag \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'c xmlt"
where
  "pair tag p1 p2 f xml =
    (case xml of
      XML name atts cs \<Rightarrow>
      (if name = tag \<and> atts = [] then
        (case list2elements cs of
          Some (cs1, cs2) \<Rightarrow>
          do {
            a \<leftarrow> p1 cs1;
            b \<leftarrow> p2 cs2;
            return (f a b)
          }
        | None \<Rightarrow> Xmlt.fail tag xml)
      else Xmlt.fail tag xml)
    | _ \<Rightarrow> Xmlt.fail tag xml)"
hide_const (open) pair

lemma pair_mono [partial_function_mono]:
  assumes "\<And>y. mono_sum_bot (p1 y)"
    and "\<And>y. mono_sum_bot (p2 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.pair t (\<lambda>y. p1 y g) (\<lambda> y. p2 y g) f x)"
  using assms
  by (cases x, cases "list2elements (Xml.children x)") (auto intro!: partial_function_mono)

fun list3elements :: "'a list \<Rightarrow> ('a \<times> 'a \<times> 'a) option"
where
  "list3elements [x, y, z] = Some (x, y, z)" |
  "list3elements _ = None"

fun triple :: "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> 'd xmlt"
where
  "triple tag p1 p2 p3 f xml = (case xml of XML name atts cs \<Rightarrow>
    (if name = tag \<and> atts = [] then
      (case list3elements cs of
        Some (cs1, cs2, cs3) \<Rightarrow>
        do {
          a \<leftarrow> p1 cs1;
          b \<leftarrow> p2 cs2;
          c \<leftarrow> p3 cs3;
          return (f a b c)
        }
      | None \<Rightarrow> Xmlt.fail tag xml)
    else Xmlt.fail tag xml)
  | _ \<Rightarrow> Xmlt.fail tag xml)"

lemma triple_mono [partial_function_mono]:
  assumes "\<And>y. mono_sum_bot (p1 y)"
    and "\<And>y. mono_sum_bot (p2 y)"
    and "\<And>y. mono_sum_bot (p3 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.triple t (\<lambda>y. p1 y g) (\<lambda> y. p2 y g) (\<lambda> y. p3 y g) f x)"
  using assms
  by (cases x, cases "list3elements (Xml.children x)", auto intro!: partial_function_mono)

fun list4elements :: "'a list \<Rightarrow> ('a \<times> 'a \<times> 'a \<times> 'a) option"
where
  "list4elements [x, y, z, u] = Some (x, y, z, u)" |
  "list4elements _ = None"

fun
  tuple4 ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> 'd xmlt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e) \<Rightarrow> 'e xmlt"
where
  "tuple4 tag p1 p2 p3 p4 f xml =
    (case xml of
      XML name atts cs \<Rightarrow>
        (if name = tag \<and> atts = [] then
          (case list4elements cs of
            Some (cs1, cs2, cs3, cs4) \<Rightarrow>
            do {
              a \<leftarrow> p1 cs1;
              b \<leftarrow> p2 cs2;
              c \<leftarrow> p3 cs3;
              d \<leftarrow> p4 cs4;
              return (f a b c d)
            }
          | None \<Rightarrow> Xmlt.fail tag xml)
        else Xmlt.fail tag xml)
   | _ \<Rightarrow> Xmlt.fail tag xml)"

lemma tuple4_mono [partial_function_mono]:
  assumes "\<And>y. mono_sum_bot (p1 y)"
    and "\<And>y. mono_sum_bot (p2 y)"
    and "\<And>y. mono_sum_bot (p3 y)"
    and"\<And>y. mono_sum_bot (p4 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.tuple4 t (\<lambda>y. p1 y g) (\<lambda> y. p2 y g) (\<lambda> y. p3 y g) (\<lambda> y. p4 y g) f x)"
  using assms
  by (cases x, cases "list4elements (Xml.children x)") (auto intro!: partial_function_mono)

fun list5elements :: "'a list \<Rightarrow> ('a \<times> 'a \<times> 'a \<times> 'a \<times> 'a) option"
where
  "list5elements [x, y, z, u, v] = Some (x, y, z, u, v)" |
  "list5elements _ = None"

fun
  tuple5 ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> 'd xmlt \<Rightarrow> 'e xmlt \<Rightarrow>
      ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e \<Rightarrow> 'f) \<Rightarrow> 'f xmlt"
where
  "tuple5 tag p1 p2 p3 p4 p5 f xml =
    (case xml of
      XML name atts cs \<Rightarrow>
        (if name = tag \<and> atts = [] then
          (case list5elements cs of
            Some (cs1,cs2,cs3,cs4,cs5) \<Rightarrow>
            do {
              a \<leftarrow> p1 cs1;
              b \<leftarrow> p2 cs2;
              c \<leftarrow> p3 cs3;
              d \<leftarrow> p4 cs4;
              e \<leftarrow> p5 cs5;
              return (f a b c d e)
            }
          | None \<Rightarrow> Xmlt.fail tag xml)
        else Xmlt.fail tag xml)
    | _ \<Rightarrow> Xmlt.fail tag xml)"

lemma tuple5_mono [partial_function_mono]:
  assumes "\<And>y. mono_sum_bot (p1 y)"
    and "\<And>y. mono_sum_bot (p2 y)"
    and "\<And>y. mono_sum_bot (p3 y)"
    and "\<And>y. mono_sum_bot (p4 y)"
    and "\<And>y. mono_sum_bot (p5 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.tuple5 t (\<lambda>y. p1 y g) (\<lambda> y. p2 y g) (\<lambda> y. p3 y g) (\<lambda> y. p4 y g) (\<lambda> y. p5 y g) f x)"
  using assms
  by (cases x, cases "list5elements (Xml.children x)") (auto intro!: partial_function_mono)

fun list6elements :: "'a list \<Rightarrow> ('a \<times> 'a \<times> 'a \<times> 'a \<times> 'a \<times> 'a) option"
where
  "list6elements [x, y, z, u, v, w] = Some (x, y, z, u, v, w)" |
  "list6elements _ = None"

fun
  tuple6 ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> 'd xmlt \<Rightarrow> 'e xmlt \<Rightarrow> 'f xmlt \<Rightarrow>
      ('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e \<Rightarrow> 'f \<Rightarrow> 'g) \<Rightarrow> 'g xmlt"
where
  "tuple6 tag p1 p2 p3 p4 p5 p6 f xml =
    (case xml of
      XML name atts cs  \<Rightarrow>
        (if name = tag \<and> atts = [] then
          (case list6elements cs of
            Some (cs1,cs2,cs3,cs4,cs5,cs6) \<Rightarrow>
            do {
              a \<leftarrow> p1 cs1;
              b \<leftarrow> p2 cs2;
              c \<leftarrow> p3 cs3;
              d \<leftarrow> p4 cs4;
              e \<leftarrow> p5 cs5;
              ff \<leftarrow> p6 cs6;
              return (f a b c d e ff)
            }
          | None \<Rightarrow> Xmlt.fail tag xml)
        else Xmlt.fail tag xml)
    | _ \<Rightarrow> Xmlt.fail tag xml)"

lemma tuple6_mono [partial_function_mono]:
  assumes "\<And>y. mono_sum_bot (p1 y)"
    and "\<And>y. mono_sum_bot (p2 y)"
    and "\<And>y. mono_sum_bot (p3 y)"
    and "\<And>y. mono_sum_bot (p4 y)"
    and "\<And>y. mono_sum_bot (p5 y)"
    and "\<And>y. mono_sum_bot (p6 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.tuple6 t (\<lambda>y. p1 y g) (\<lambda> y. p2 y g) (\<lambda> y. p3 y g) (\<lambda> y. p4 y g) (\<lambda> y. p5 y g) (\<lambda> y. p6 y g) f x)"
  using assms
  by (cases x, cases "list6elements (Xml.children x)") (auto intro!: partial_function_mono)

fun optional :: "tag \<Rightarrow> 'a xmlt \<Rightarrow> ('a option \<Rightarrow> 'b) \<Rightarrow> 'b xmlt"
where
  "optional tag p1 f (XML name atts cs) =
    (let l = length cs in
    (if name = tag \<and> atts = [] \<and> l \<ge> 0 \<and> l \<le> 1 then do {
      if l = 1 then do {
        x1 \<leftarrow> p1 (cs ! 0);
        return (f (Some x1))
      } else return (f None)
    } else Xmlt.fail tag (XML name atts cs)))" |
  "optional tag p1 f xml = Xmlt.fail tag xml"

lemma optional_mono [partial_function_mono]:
  assumes "\<And>y. mono_sum_bot (p1 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.optional t (\<lambda>y. p1 y g) f x)"
  using assms by (cases x) (auto intro!: partial_function_mono)

fun xml1to2elements :: "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> ('a \<Rightarrow> 'b option \<Rightarrow> 'c) \<Rightarrow> 'c xmlt"
where
  "xml1to2elements tag p1 p2 f (XML name atts cs) = (
     let l = length cs in
     (if name = tag \<and> atts = [] \<and> l \<ge> 1 \<and> l \<le> 2
       then do {
         x1 \<leftarrow> p1 (cs ! 0);
         (if l = 2
           then do {
             x2 \<leftarrow> p2 (cs ! 1);
             return (f x1 (Some x2))
           } else return (f x1 None))
       } else Xmlt.fail tag (XML name atts cs)))" |
  "xml1to2elements tag p1 p2 f xml = Xmlt.fail tag xml"

lemma xml1to2elements_mono[partial_function_mono]:
  assumes p1: "\<And>y. mono_sum_bot (p1 y)"
              "\<And>y. mono_sum_bot (p2 y)"
  shows "mono_sum_bot (\<lambda>g. xml1to2elements t (\<lambda>y. p1 y g) (\<lambda>y. p2 y g) f x)"
  by (cases x, auto intro!: partial_function_mono p1)

text \<open>
  Apply the first transformer to the first child-node, then check the second child-node,
  which is must be a Boolean. If the Boolean is true, then apply the second transformer
  to the last child-node.
\<close>
fun xml2nd_choice :: "tag \<Rightarrow> 'a xmlt \<Rightarrow> tag \<Rightarrow> 'b xmlt \<Rightarrow> ('a \<Rightarrow> 'b option \<Rightarrow> 'c) \<Rightarrow> 'c xmlt"
where
  "xml2nd_choice tag p1 cn p2 f (XML name atts cs) = (
    let l = length cs in
    (if name = tag \<and> atts = [] \<and> l \<ge> 2 then do {
      x1 \<leftarrow> p1 (cs ! 0);
      b \<leftarrow> Xmlt.bool cn (cs ! 1);
      (if b then do {
        x2 \<leftarrow> p2 (cs ! (l - 1));
        return (f x1 (Some x2))
      } else return (f x1 None))
    } else Xmlt.fail tag (XML name atts cs)))" |
  "xml2nd_choice tag p1 cn p2 f xml = Xmlt.fail tag xml"

lemma xml2nd_choice_mono [partial_function_mono]:
  assumes p1: "\<And>y. mono_sum_bot (p1 y)"
              "\<And>y. mono_sum_bot (p2 y)"
  shows "mono_sum_bot (\<lambda>g. xml2nd_choice t (\<lambda>y. p1 y g) h (\<lambda>y. p2 y g) f x)"
  by (cases x, auto intro!: partial_function_mono p1)

fun
  xml2to3elements ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c option \<Rightarrow> 'd) \<Rightarrow> 'd xmlt"
where
  "xml2to3elements tag p1 p2 p3 f (XML name atts cs) = (
     let l = length cs in
     (if name = tag \<and> atts = [] \<and> l \<ge> 2 \<and> l \<le> 3 then do {
       x1 \<leftarrow> p1 (cs ! 0);
       x2 \<leftarrow> p2 (cs ! 1);
       (if l = 3 then do {
         x3 \<leftarrow> p3 (cs ! 2);
         return (f x1 x2 (Some x3))
       } else return (f x1 x2 None))
     } else Xmlt.fail tag (XML name atts cs)))" |
  "xml2to3elements tag p1 p2 p3 f xml = Xmlt.fail tag xml"

lemma xml2to3elements_mono [partial_function_mono]:
  assumes p1: "\<And>y. mono_sum_bot (p1 y)"
              "\<And>y. mono_sum_bot (p2 y)"
              "\<And>y. mono_sum_bot (p3 y)"
  shows "mono_sum_bot (\<lambda>g. xml2to3elements t (\<lambda>y. p1 y g) (\<lambda>y. p2 y g) (\<lambda>y. p3 y g) f x)"
  by (cases x, auto intro!: partial_function_mono p1)

fun
  xml3to4elements ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> 'd xmlt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c option \<Rightarrow> 'd \<Rightarrow> 'e) \<Rightarrow>
      'e xmlt"
where
  "xml3to4elements tag p1 p2 p3 p4 f (XML name atts cs) = (
     let l = length cs in
     (if name = tag \<and> atts = [] \<and> l \<ge> 3 \<and> l \<le> 4 then do {
       x1 \<leftarrow> p1 (cs ! 0);
       x2 \<leftarrow> p2 (cs ! 1);
       (if l = 4 then do {
         x3 \<leftarrow> p3 (cs ! 2);
         x4 \<leftarrow> p4 (cs ! 3);
         return (f x1 x2 (Some x3) x4)
       } else do {
         x4 \<leftarrow> p4 (cs ! 2);
         return (f x1 x2 None x4)
       } )
     } else Xmlt.fail tag (XML name atts cs)))" |
  "xml3to4elements tag p1 p2 p3 p4 f xml = Xmlt.fail tag xml"

lemma xml3to4elements_mono [partial_function_mono]:
  assumes p1: "\<And>y. mono_sum_bot (p1 y)"
              "\<And>y. mono_sum_bot (p2 y)"
              "\<And>y. mono_sum_bot (p3 y)"
              "\<And>y. mono_sum_bot (p4 y)"
  shows "mono_sum_bot (\<lambda>g. xml3to4elements t (\<lambda>y. p1 y g) (\<lambda>y. p2 y g) (\<lambda>y. p3 y g) (\<lambda>y. p4 y g) f x)"
  by (cases x, auto intro!: partial_function_mono p1)

fun many :: "tag \<Rightarrow> 'a xmlt \<Rightarrow> ('a list \<Rightarrow> 'b) \<Rightarrow> 'b xmlt"
where
  "many tag p f (XML name atts cs) =
    (if name = tag \<and> atts = [] then (Xmlt.map p cs \<bind> (return \<circ> f))
    else Xmlt.fail tag (XML name atts cs))" |
  "many tag p f xml = Xmlt.fail tag xml"
hide_const (open) many

lemma many_mono [partial_function_mono]:
  fixes p1 :: "xml \<Rightarrow> ('b \<Rightarrow> (string +\<^sub>\<bottom> 'c)) \<Rightarrow> string +\<^sub>\<bottom> 'd"
  assumes "\<And>y. y \<in> set (Xml.children x) \<Longrightarrow> mono_sum_bot (p1 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.many t (\<lambda>y. p1 y g) f x)"
  using assms by (cases x) (auto intro!: partial_function_mono)

fun many1_gen :: "tag \<Rightarrow> 'a xmlt \<Rightarrow> ('a \<Rightarrow> 'b xmlt) \<Rightarrow> ('a \<Rightarrow> 'b list \<Rightarrow> 'c) \<Rightarrow> 'c xmlt"
where
  "many1_gen tag p1 p2 f (XML name atts cs) =
    (if name = tag \<and> atts = [] \<and> cs \<noteq> [] then
      (case cs of h # t \<Rightarrow> do {
        x \<leftarrow> p1 h;
        xs \<leftarrow> Xmlt.map (p2 x) t;
        return (f x xs)
      })
    else Xmlt.fail tag (XML name atts cs))" |
  "many1_gen tag p1 p2 f xml = Xmlt.fail tag xml"

(* TODO
lemma Xmlt.many1_gen_mono[partial_function_mono]:
  fixes p1 :: "xml \<Rightarrow> ('b \<Rightarrow> 'c sum_bot) \<Rightarrow> 'd sum_bot"
  assumes p1: "\<And>y. mono_sum_bot (p1 y)"
              "\<And>y. mono_sum_bot (p2 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.many1_gen t (\<lambda>y. p1 y g) (\<lambda>y. p2 y g) f x)"
  by (cases x, auto intro!: partial_function_mono p1)
*)

definition many1 :: "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> ('a \<Rightarrow> 'b list \<Rightarrow> 'c) \<Rightarrow> 'c xmlt"
where
  "many1 tag p1 p2 = Xmlt.many1_gen tag p1 (\<lambda>_. p2)"
hide_const (open) many1

lemma many1_mono [partial_function_mono]:
  fixes p1 :: "xml \<Rightarrow> ('b \<Rightarrow> (string +\<^sub>\<bottom> 'c)) \<Rightarrow> string +\<^sub>\<bottom> 'd"
  assumes "\<And>y. mono_sum_bot (p1 y)"
    and "\<And>y. y \<in> set (tl (Xml.children x)) \<Longrightarrow> mono_sum_bot (p2 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.many1 t (\<lambda>y. p1 y g) (\<lambda>y. p2 y g) f x)"
  unfolding Xmlt.many1_def using assms
  by (cases x, cases "Xml.children x") (auto intro!: partial_function_mono)

fun length_ge_2 :: "'a list \<Rightarrow> bool"
where
  "length_ge_2 (_ # _ # _) = True" |
  "length_ge_2 _ = False"

fun many2 :: "tag \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> 'c list \<Rightarrow> 'd) \<Rightarrow> 'd xmlt"
where
  "many2 tag p1 p2 p3 f (XML name atts cs) =
    (if name = tag \<and> atts = [] \<and> length_ge_2 cs then
      (case cs of cs0 # cs1 # t \<Rightarrow> do {
        x \<leftarrow> p1 cs0;
        y \<leftarrow> p2 cs1;
        xs \<leftarrow> Xmlt.map p3 t;
        return (f x y xs)
      })
    else Xmlt.fail tag (XML name atts cs))" |
  "many2 tag p1 p2 p3 f xml = Xmlt.fail tag xml"

lemma many2_mono [partial_function_mono]:
  fixes p1 :: "xml \<Rightarrow> ('b \<Rightarrow> (string +\<^sub>\<bottom> 'c)) \<Rightarrow> string +\<^sub>\<bottom> 'd"
  assumes "\<And>y. mono_sum_bot (p1 y)"
    and "\<And>y. mono_sum_bot (p2 y)"
    and "\<And>y. mono_sum_bot (p3 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.many2 t (\<lambda>y. p1 y g) (\<lambda>y. p2 y g) (\<lambda>y. p3 y g) f x)"
  using assms
  by (cases x, cases "Xml.children x", (auto intro!: partial_function_mono)[1], cases "tl (Xml.children x)", auto intro!: partial_function_mono)

fun
  xml1or2many_elements ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> ('a \<Rightarrow> 'b option \<Rightarrow> 'c list \<Rightarrow> 'd) \<Rightarrow> 'd xmlt"
where
  "xml1or2many_elements tag p1 p2 p3 f (XML name atts cs) =
    (if name = tag \<and> atts = [] \<and> cs \<noteq> [] then
      (case cs of
        cs0 # tt \<Rightarrow>
        do {
          x \<leftarrow> p1 cs0;
          (case tt of
            cs1 # t \<Rightarrow>
            do {
              try do {
                y \<leftarrow> p2 cs1;
                xs \<leftarrow> Xmlt.map p3 t;
                return (f x (Some y) xs)
              } catch (\<lambda> _. do {
                xs \<leftarrow> Xmlt.map p3 tt;
                return (f x None xs)
              })
            }
          | [] \<Rightarrow> return (f x None []))})
     else Xmlt.fail tag (XML name atts cs))" |
  "xml1or2many_elements tag p1 p2 p3 f  xml = Xmlt.fail tag xml"

fun
  xml1many2elements_gen ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> ('a \<Rightarrow> 'b xmlt) \<Rightarrow> 'c xmlt \<Rightarrow> 'd xmlt \<Rightarrow>
      ('a \<Rightarrow> 'b list \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e) \<Rightarrow> 'e xmlt"
where
  "xml1many2elements_gen tag p1 p2 p3 p4 f (XML name atts cs) = (
     let ds = List.rev cs; l = length cs in
     (if name = tag \<and> atts = [] \<and> l \<ge> 3 then do {
       x \<leftarrow> p1 (cs ! 0);
       xs \<leftarrow> Xmlt.map (p2 x) (tl (take (l - 2) cs));
       y \<leftarrow> p3 (ds ! 1);
       z \<leftarrow> p4 (ds ! 0);
       return (f x xs y z)
     } else Xmlt.fail tag (XML name atts cs)))" |
  "xml1many2elements_gen tag p1 p2 p3 p4 f xml = Xmlt.fail tag xml"

lemma xml1many2elements_gen_mono [partial_function_mono]:
  fixes p1 :: "xml \<Rightarrow> ('b \<Rightarrow> (string +\<^sub>\<bottom> 'c)) \<Rightarrow> string +\<^sub>\<bottom> 'd"
  assumes p1: "\<And>y. mono_sum_bot (p1 y)"
              "\<And>y. mono_sum_bot (p3 y)"
              "\<And>y. mono_sum_bot (p4 y)"
  shows "mono_sum_bot (\<lambda>g. xml1many2elements_gen t (\<lambda>y. p1 y g) p2 (\<lambda>y. p3 y g) (\<lambda>y. p4 y g) f x)"
  by (cases x, auto intro!: partial_function_mono p1)

fun
  xml1many2elements ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> 'd xmlt \<Rightarrow> ('a \<Rightarrow> 'b list \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e) \<Rightarrow>
      'e xmlt"
where
  "xml1many2elements tag p1 p2 = xml1many2elements_gen tag p1 (\<lambda>_. p2)"

fun
  xml_many2elements ::
    "string \<Rightarrow> 'a xmlt \<Rightarrow> 'b xmlt \<Rightarrow> 'c xmlt \<Rightarrow> ('a list \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd) \<Rightarrow> 'd xmlt"
where
  "xml_many2elements tag p1 p2 p3 f (XML name atts cs) = (
     let ds = List.rev cs in
     (if name = tag \<and> atts = [] \<and> length_ge_2 cs then do {
       xs \<leftarrow> Xmlt.map p1 (List.rev (tl (tl ds)));
       y \<leftarrow> p2 (ds ! 1);
       z \<leftarrow> p3 (ds ! 0);
       return (f xs y z)
     } else Xmlt.fail tag (XML name atts cs)))" |
  "xml_many2elements tag p1 p2 p3 f xml = Xmlt.fail tag xml"

definition options :: "(string \<times> 'a xmlt) list \<Rightarrow> 'a xmlt"
where
  "options ps x =
    (case map_of ps (Xml.tag x) of
      None \<Rightarrow> error (concat
        [''expected one of: '', concat (map (\<lambda>p. fst p @ '' '') ps), ''\<newline>'', ''but found'', ''\<newline>'', show x])
    | Some p \<Rightarrow> p x)"
hide_const (open) options

lemma options_mono_gen [partial_function_mono]:
  assumes p: "\<And> k p. (k, p) \<in> set ps \<Longrightarrow> mono_sum_bot (p x)"
  shows "mono_sum_bot (\<lambda> g. Xmlt.options (map (\<lambda> (k, p). (k, (\<lambda> y. p y g))) ps) x)"
proof -
  {
    fix g
    have "(map (\<lambda>p. fst p @ '' '') (map (\<lambda>(k, p). (k, \<lambda>y. p y g)) ps)) =
      map (\<lambda>p. fst p @ '' '') ps"
      by (induct ps) (auto)
  } note id = this
  {
    fix z
    have "mono_sum_bot
      (\<lambda>g. case map_of (map (\<lambda>(k, p). (k, \<lambda>y. p y g)) ps) (Xml.tag x) of
        None \<Rightarrow> z
      | Some p \<Rightarrow> p x)"
      using p
    proof (induct ps)
      case Nil
      show ?case by (auto intro: partial_function_mono)
    next
      case (Cons kp ps)
      obtain k p where kp: "kp = (k,p)" by force
      note Cons = Cons[unfolded kp]
      from Cons(2) have monop: "mono_sum_bot (p x)" and mono: "\<And> k p. (k,p) \<in> set ps \<Longrightarrow> mono_sum_bot (p x)" by auto
      show ?case
      proof (cases "Xml.tag x = k")
        case True
        thus ?thesis unfolding kp using monop by auto
      next
        case False
        thus ?thesis using Cons(1) mono unfolding kp by auto
      qed
    qed
  } note main = this
  show ?thesis unfolding Xmlt.options_def
    unfolding id
    by (rule main)
qed

(* instantiate this lemma to have the monotonicity lemmas for lists of variable lengths which
   are then applicable, e.g., for lists of length 3 it would be

mono_sum_bot (p1 x) \<Longrightarrow> mono_sum_bot (p2 x) \<Longrightarrow> mono_sum_bot (p3 x)
\<Longrightarrow> mono_sum_bot (\<lambda>g. Xmlt.options [(k1, \<lambda>y. p1 y g), (k2, \<lambda>y. p2 y g), (k3, \<lambda>y. p3 y g)] x)

*)
local_setup \<open>fn lthy =>
  let
    val N = 30 (* we require monotonicity lemmas for xml-options for lists up to length N *)
    val thy = Proof_Context.theory_of lthy
    val options = @{term "Xmlt.options :: (string \<times> (xml \<Rightarrow> (string +\<^sub>\<bottom> 'd))) list \<Rightarrow> xml \<Rightarrow> string +\<^sub>\<bottom> 'd"}
    val mono_sum_bot = @{term "mono_sum_bot :: (('a \<Rightarrow> ('b +\<^sub>\<bottom> 'c)) \<Rightarrow> string +\<^sub>\<bottom> 'd) \<Rightarrow> bool"}
    val ktyp = @{typ string}
    val x = @{term "x :: xml"}
    val y = @{term "y :: xml"}
    val g = @{term "g :: 'a \<Rightarrow> 'b +\<^sub>\<bottom> 'c"}
    val ptyp = @{typ "xml \<Rightarrow> ('a \<Rightarrow> ('b +\<^sub>\<bottom> 'c)) \<Rightarrow> string +\<^sub>\<bottom> 'd"}
    fun k i = Free ("k" ^ string_of_int i,ktyp)
    fun p i = Free ("p" ^ string_of_int i,ptyp)
    fun prem i = HOLogic.mk_Trueprop (mono_sum_bot $ (p i $ x))
    fun prems n = 1 upto n |> map prem
    fun pair i = HOLogic.mk_prod (k i, lambda y (p i $ y $ g))
    fun pair2 i = HOLogic.mk_prod (k i, p i)
    fun list n = 1 upto n |> map pair |> HOLogic.mk_list @{typ "(string \<times> (xml \<Rightarrow> string +\<^sub>\<bottom> 'd))"}
    fun list2 n = 1 upto n |> map pair2 |> HOLogic.mk_list (HOLogic.mk_prodT (ktyp,ptyp))
    fun concl n = HOLogic.mk_Trueprop (mono_sum_bot $ lambda g (options $ (list n) $ x))
    fun xs n = x :: (1 upto n |> map (fn i => [p i, k i]) |> List.concat)
       |> map (fst o dest_Free)
    fun tac n pc =
      let
        val {prems = prems, context = ctxt} = pc
        val mono_thm = Thm.instantiate'
            (map (SOME o Thm.ctyp_of ctxt) [@{typ 'a},@{typ 'b},@{typ 'c},@{typ 'd}])
            (map (SOME o Thm.cterm_of ctxt) [list2 n,x]) @{thm Xmlt.options_mono_gen}
      in
        Method.insert_tac ctxt (mono_thm :: prems) 1 THEN force_tac ctxt 1
      end
    fun thm n = Goal.prove lthy (xs n) (prems n) (concl n) (tac n)
    val thms = map thm (0 upto N)
  in Local_Theory.note ((@{binding "options_mono_thms"}, []), thms) lthy |> snd end
\<close>

declare Xmlt.options_mono_thms [partial_function_mono]

fun choice :: "string \<Rightarrow> 'a xmlt list \<Rightarrow> 'a xmlt"
where
  "choice e [] x = error (concat [''error in parsing choice for '', e, ''\<newline>'', show x])" |
  "choice e (p # ps) x = (try p x catch (\<lambda>_. choice e ps x))"
hide_const (open) choice

lemma choice_mono_2 [partial_function_mono]:
  assumes p: "mono_sum_bot (p1 x)"
             "mono_sum_bot (p2 x)"
  shows "mono_sum_bot (\<lambda> g. Xmlt.choice e [(\<lambda> y. p1 y g), (\<lambda> y. p2 y g)] x)"
  using p by (auto intro!: partial_function_mono)

lemma choice_mono_3 [partial_function_mono]:
  assumes p: "mono_sum_bot (p1 x)"
             "mono_sum_bot (p2 x)"
             "mono_sum_bot (p3 x)"
  shows "mono_sum_bot (\<lambda> g. Xmlt.choice e [(\<lambda> y. p1 y g), (\<lambda> y. p2 y g), (\<lambda> y. p3 y g)] x)"
  using p by (auto intro!: partial_function_mono)

fun change :: "'a xmlt \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b xmlt"
where
  "change p f x = p x \<bind> return \<circ> f"
hide_const (open) change

lemma change_mono [partial_function_mono]:
  assumes p: "\<And>y. mono_sum_bot (p1 y)"
  shows "mono_sum_bot (\<lambda>g. Xmlt.change (\<lambda>y. p1 y g) f x)"
  by (cases x, insert p, auto intro!: partial_function_mono)

fun int_of_digit :: "char \<Rightarrow> string +\<^sub>\<bottom> int"
where
  "int_of_digit x =
    (if x = CHR ''0'' then return 0
    else if x = CHR ''1'' then return 1
    else if x = CHR ''2'' then return 2
    else if x = CHR ''3'' then return 3
    else if x = CHR ''4'' then return 4
    else if x = CHR ''5'' then return 5
    else if x = CHR ''6'' then return 6
    else if x = CHR ''7'' then return 7
    else if x = CHR ''8'' then return 8
    else if x = CHR ''9'' then return 9
    else error (x # '' is not a digit''))"

fun int_of_string_aux :: "int \<Rightarrow> string \<Rightarrow> string +\<^sub>\<bottom> int"
where
  "int_of_string_aux n [] = return n" |
  "int_of_string_aux n (d # s) = (int_of_digit d \<bind> (\<lambda>m. int_of_string_aux (10 * n + m) s))"

definition int_of_string :: "string \<Rightarrow> string +\<^sub>\<bottom> int"
where
  "int_of_string s =
    (if s = [] then error ''cannot convert empty string into number''
    else if take 1 s = ''-'' then int_of_string_aux 0 (tl s) \<bind> (\<lambda> i. return (0 - i))
    else int_of_string_aux 0 s)"

hide_const int_of_string_aux

fun int :: "tag \<Rightarrow> int xmlt"
where
  "int tag x = (Xmlt.text tag x \<bind> int_of_string)"
hide_const (open) int

fun nat :: "tag \<Rightarrow> nat xmlt"
where
  "nat tag x = do {
    txt \<leftarrow> Xmlt.text tag x;
    i \<leftarrow> int_of_string txt;
    return (Int.nat i)
  }"
hide_const (open) nat

definition rat :: "rat xmlt"
where
  "rat = Xmlt.options [
    (''integer'', Xmlt.change (Xmlt.int ''integer'') of_int),
    (''rational'',
      Xmlt.pair ''rational'' (Xmlt.int ''numerator'') (Xmlt.int ''denominator'')
        (\<lambda> x y. of_int x / of_int y))]"
hide_const (open) rat

end


subsection \<open>Pure pattern matching rule sets\<close>

theory Rewriting_Pterm
imports Rewriting_Pterm_Elim
begin

type_synonym prule = "name \<times> pterm"

primrec prule :: "prule \<Rightarrow> bool" where
"prule (_, rhs) \<longleftrightarrow> wellformed rhs \<and> closed rhs \<and> is_abs rhs"

lemma pruleI[intro!]: "wellformed rhs \<Longrightarrow> closed rhs \<Longrightarrow> is_abs rhs \<Longrightarrow> prule (name, rhs)"
by simp

locale prules = constants C_info "fst |`| rs" for C_info and rs :: "prule fset" +
  assumes all_rules: "fBall rs prule"
  assumes fmap: "is_fmap rs"
  assumes not_shadows: "fBall rs (\<lambda>(_, rhs). \<not> shadows_consts rhs)"
  assumes welldefined_rs: "fBall rs (\<lambda>(_, rhs). welldefined rhs)"

subsubsection \<open>Rewriting\<close>

inductive prewrite :: "prule fset \<Rightarrow> pterm \<Rightarrow> pterm \<Rightarrow> bool" ("_/ \<turnstile>\<^sub>p/ _ \<longrightarrow>/ _" [50,0,50] 50) for rs where
step: "(name, rhs) |\<in>| rs \<Longrightarrow> rs \<turnstile>\<^sub>p Pconst name \<longrightarrow> rhs" |
beta: "c |\<in>| cs \<Longrightarrow> c \<turnstile> t \<rightarrow> t' \<Longrightarrow> rs \<turnstile>\<^sub>p Pabs cs $\<^sub>p t \<longrightarrow> t'" |
"fun": "rs \<turnstile>\<^sub>p t \<longrightarrow> t' \<Longrightarrow> rs \<turnstile>\<^sub>p t $\<^sub>p u \<longrightarrow> t' $\<^sub>p u" |
arg: "rs \<turnstile>\<^sub>p u \<longrightarrow> u' \<Longrightarrow> rs \<turnstile>\<^sub>p t $\<^sub>p u \<longrightarrow> t $\<^sub>p u'"

global_interpretation prewrite: rewriting "prewrite rs" for rs
by standard (auto intro: prewrite.intros simp: app_pterm_def)+

abbreviation prewrite_rt :: "prule fset \<Rightarrow> pterm \<Rightarrow> pterm \<Rightarrow> bool" ("_/ \<turnstile>\<^sub>p/ _ \<longrightarrow>*/ _" [50,0,50] 50) where
"prewrite_rt rs \<equiv> (prewrite rs)\<^sup>*\<^sup>*"

subsubsection \<open>Translation from @{typ irule_set} to @{typ "prule fset"}\<close>

definition finished :: "irule_set \<Rightarrow> bool" where
"finished rs = fBall rs (\<lambda>(_, irs). arity irs = 0)"

definition translate_rhs :: "irules \<Rightarrow> pterm" where
"translate_rhs = snd \<circ> fthe_elem"

definition compile :: "irule_set \<Rightarrow> prule fset" where
"compile = fimage (map_prod id translate_rhs)"

lemma compile_heads: "fst |`| compile rs = fst |`| rs"
unfolding compile_def by simp

subsubsection \<open>Correctness of translation\<close>

lemma arity_zero_shape:
  assumes "arity_compatibles rs" "arity rs = 0" "is_fmap rs" "rs \<noteq> {||}"
  obtains t where "rs = {| ([], t) |}"
proof -
  from assms obtain ppats prhs where "(ppats, prhs) |\<in>| rs"
    by fast

  moreover {
    fix pats rhs
    assume "(pats, rhs) |\<in>| rs"
    with assms have "length pats = 0"
      by (metis arity_compatible_length)
    hence "pats = []"
      by simp
  }
  note all = this

  ultimately have proto: "([], prhs) |\<in>| rs" by auto

  have "fBall rs (\<lambda>(pats, rhs). pats = [] \<and> rhs = prhs)"
    proof safe
      fix pats rhs
      assume cur: "(pats, rhs) |\<in>| rs"
      with all show "pats = []" .
      with cur have "([], rhs) |\<in>| rs" by auto

      with proto show "rhs = prhs"
        using assms by (auto dest: is_fmapD)
    qed
  hence "fBall rs (\<lambda>r. r = ([], prhs))"
    by blast
  with assms have "rs = {| ([], prhs) |}"
    by (simp add: singleton_fset_is)
  thus thesis
    by (rule that)
qed

lemma (in irules) compile_rules:
  assumes "finished rs"
  shows "prules C_info (compile rs)"
proof
  show "is_fmap (compile rs)"
    using fmap
    unfolding compile_def map_prod_def id_apply
    by (rule is_fmap_image)
next
  show "fdisjnt (fst |`| compile rs) C"
    unfolding compile_def
    using disjnt by simp
next
  have
    "fBall (compile rs) prule"
    "fBall (compile rs) (\<lambda>(_, rhs). \<not> shadows_consts rhs)"
    "fBall (compile rs) (\<lambda>(_, rhs). welldefined rhs)"
    proof (safe del: fsubsetI)
      fix name rhs
      assume "(name, rhs) |\<in>| compile rs" (* FIXME clone of compile_correct *)
      then obtain irs where "(name, irs) |\<in>| rs" "rhs = translate_rhs irs"
        unfolding compile_def by force
      hence "is_fmap irs" "irs \<noteq> {||}" "arity irs = 0"
        using assms inner unfolding finished_def by blast+
      moreover have "arity_compatibles irs"
        using \<open>(name, irs) |\<in>| rs\<close> inner by (blast dest: fpairwiseD)
      ultimately obtain u where "irs = {| ([], u) |}"
        by (metis arity_zero_shape)
      hence "rhs = u" and u: "([], u) |\<in>| irs"
        unfolding \<open>rhs = _\<close> translate_rhs_def by simp+
      hence "abs_ish [] u"
        using inner \<open>(name, irs) |\<in>| rs\<close> by blast
      thus "is_abs rhs"
        unfolding abs_ish_def \<open>rhs = u\<close> by simp

      show "wellformed rhs"
        using u \<open>(name, irs) |\<in>| rs\<close> inner unfolding \<open>rhs = u\<close>
        by blast

      have "closed_except u {||}"
        using u inner \<open>(name, irs) |\<in>| rs\<close>
        by (metis (mono_tags, lifting) case_prod_conv fbspec freess_empty)
      thus "closed rhs"
        unfolding \<open>rhs = u\<close> .

      {
        assume "shadows_consts rhs"
        hence "shadows_consts u"
          unfolding compile_def \<open>rhs = u\<close> by simp
        moreover have "\<not> shadows_consts u"
          using inner \<open>([], u) |\<in>| irs\<close> \<open>(name, irs) |\<in>| rs\<close> by blast
        ultimately show False by blast
      }

      have "welldefined u"
        using fbspec[OF inner \<open>(name, irs) |\<in>| rs\<close>, simplified] \<open>([], u) |\<in>| irs\<close>
        by blast
      thus "welldefined rhs"
        unfolding \<open>rhs = u\<close> compile_def
        by simp
    qed
  thus
    "fBall (compile rs) prule"
    "fBall (compile rs) (\<lambda>(_, rhs). \<not> pre_constants.shadows_consts C_info (fst |`| compile rs) rhs)"
    "fBall (compile rs) (\<lambda>(_, rhs). pre_constants.welldefined C_info (fst |`| compile rs) rhs)"
    unfolding compile_heads by auto
next
  show "distinct all_constructors"
    by (fact distinct_ctr)
qed

theorem (in irules) compile_correct:
  assumes "compile rs \<turnstile>\<^sub>p t \<longrightarrow> t'" "finished rs"
  shows "rs \<turnstile>\<^sub>i t \<longrightarrow> t'"
using assms(1) proof induction
  case (step name rhs)
  then obtain irs where "rhs = translate_rhs irs" "(name, irs) |\<in>| rs"
    unfolding compile_def by force
  hence "arity_compatibles irs"
    using inner by (blast dest: fpairwiseD)

  have "is_fmap irs" "irs \<noteq> {||}" "arity irs = 0"
    using assms inner \<open>(name, irs) |\<in>| rs\<close> unfolding finished_def by blast+
  then obtain u where "irs = {| ([], u) |}"
    using \<open>arity_compatibles irs\<close>
    by (metis arity_zero_shape)

  show ?case
    unfolding \<open>rhs = _\<close>
    apply (rule irewrite.step)
      apply fact
    unfolding \<open>irs = _\<close> translate_rhs_def irewrite_step_def
    by (auto simp: const_term_def)
qed (auto intro: irewrite.intros)

theorem (in irules) compile_complete:
  assumes "rs \<turnstile>\<^sub>i t \<longrightarrow> t'" "finished rs"
  shows "compile rs \<turnstile>\<^sub>p t \<longrightarrow> t'"
using assms(1) proof induction
  case (step name irs params rhs t t')
  hence "arity_compatibles irs"
    using inner by (blast dest: fpairwiseD)

  have "is_fmap irs" "irs \<noteq> {||}" "arity irs = 0"
    using assms inner step unfolding finished_def by blast+
  then obtain u where "irs = {| ([], u) |}"
    using \<open>arity_compatibles irs\<close>
    by (metis arity_zero_shape)
  with step have "name, [], u \<turnstile>\<^sub>i t \<rightarrow> t'"
    by simp
  hence "t = Pconst name"
    unfolding irewrite_step_def
    by (cases t) (auto split: if_splits simp: const_term_def)
  hence "t' = u"
    using \<open>name, [], u \<turnstile>\<^sub>i t \<rightarrow> t'\<close>
    unfolding irewrite_step_def
    by (cases t) (auto split: if_splits simp: const_term_def)

  have "(name, t') |\<in>| compile rs"
    unfolding compile_def
    proof
      show "(name, t') = map_prod id translate_rhs (name, irs)"
        using \<open>irs = _\<close> \<open>t' = u\<close>
        by (simp add: split_beta translate_rhs_def)
    qed fact
  thus ?case
    unfolding \<open>t = _\<close>
    by (rule prewrite.step)
qed (auto intro: prewrite.intros)

export_code
  compile finished
  checking Scala

end