section \<open>Heap Implementation On Lists\<close>
theory IICF_Abs_Heap
imports
  "HOL-Library.Multiset"
  "../../../Sepref"
  "List-Index.List_Index"
  "../../Intf/IICF_List"
  "../../Intf/IICF_Prio_Bag"
begin

text \<open>
  We define Min-Heaps, which implement multisets of prioritized values.
  The operations are:
    empty heap, emptiness check, insert an element,
    remove a minimum priority element.\<close>

  subsection \<open>Basic Definitions\<close>

  type_synonym 'a heap = "'a list"

  locale heapstruct =
    fixes prio :: "'a \<Rightarrow> 'b::linorder"
  begin
    definition valid :: "'a heap \<Rightarrow> nat \<Rightarrow> bool"
      where "valid h i \<equiv> i>0 \<and> i\<le>length h"

    abbreviation \<alpha> :: "'a heap \<Rightarrow> 'a multiset" where "\<alpha> \<equiv> mset"

    lemma valid_empty[simp]: "\<not>valid [] i" by (auto simp: valid_def)
    lemma valid0[simp]: "\<not>valid h 0" by (auto simp: valid_def)
    lemma valid_glen[simp]: "i>length h \<Longrightarrow> \<not>valid h i" by (auto simp: valid_def)

    lemma valid_len[simp]: "h\<noteq>[] \<Longrightarrow> valid h (length h)" by (auto simp: valid_def)

    lemma validI: "0<i \<Longrightarrow> i\<le>length h \<Longrightarrow> valid h i"
      by (auto simp: valid_def)

    definition val_of :: "'a heap \<Rightarrow> nat \<Rightarrow> 'a" where "val_of l i \<equiv> l!(i-1)"
    abbreviation prio_of :: "'a heap \<Rightarrow> nat \<Rightarrow> 'b" where
      "prio_of l i \<equiv> prio (val_of l i)"

    subsubsection \<open>Navigating the tree\<close>

    definition parent :: "nat \<Rightarrow> nat" where "parent i \<equiv> i div 2"
    definition left :: "nat \<Rightarrow> nat" where "left i \<equiv> 2*i"
    definition right :: "nat \<Rightarrow> nat" where "right i \<equiv> 2*i + 1"

    abbreviation "has_parent h i \<equiv> valid h (parent i)"
    abbreviation "has_left h i \<equiv> valid h (left i)"
    abbreviation "has_right h i \<equiv> valid h (right i)"

    abbreviation "vparent h i == val_of h (parent i)"
    abbreviation "vleft h i == val_of h (left i)"
    abbreviation "vright h i == val_of h (right i)"

    abbreviation "pparent h i == prio_of h (parent i)"
    abbreviation "pleft h i == prio_of h (left i)"
    abbreviation "pright h i == prio_of h (right i)"

    lemma parent_left_id[simp]: "parent (left i) = i"
      unfolding parent_def left_def
      by auto

    lemma parent_right_id[simp]: "parent (right i) = i"
      unfolding parent_def right_def
      by auto

    lemma child_of_parentD:
      "has_parent l i \<Longrightarrow> left (parent i) = i \<or> right (parent i) = i"
      unfolding parent_def left_def right_def valid_def
      by auto

    lemma rc_imp_lc: "\<lbrakk>valid h i; has_right h i\<rbrakk> \<Longrightarrow> has_left h i"
      by (auto simp: valid_def left_def right_def)

    lemma plr_corner_cases[simp]:
      assumes "0<i"
      shows
      "i\<noteq>parent i"
      "i\<noteq>left i"
      "i\<noteq>right i"
      "parent i \<noteq> i"
      "left i \<noteq> i"
      "right i \<noteq> i"
      using assms
      by (auto simp: parent_def left_def right_def)

    lemma i_eq_parent_conv[simp]: "i=parent i \<longleftrightarrow> i=0"
      by (auto simp: parent_def)

    subsubsection \<open>Heap Property\<close>
    text \<open>The heap property states, that every node's priority is greater
      or equal to its parent's priority \<close>
    definition heap_invar :: "'a heap \<Rightarrow> bool"
      where "heap_invar l
      \<equiv> \<forall>i. valid l i \<longrightarrow> has_parent l i \<longrightarrow> pparent l i \<le> prio_of l i"

    definition "heap_rel1 \<equiv> br \<alpha> heap_invar"

    lemma heap_invar_empty[simp]: "heap_invar []"
      by (auto simp: heap_invar_def)

    function heap_induction_scheme :: "nat \<Rightarrow> unit" where
      "heap_induction_scheme i = (
        if i>1 then heap_induction_scheme (parent i) else ())"
      by pat_completeness auto

    termination
      apply (relation "less_than")
      apply (auto simp: parent_def)
      done

    lemma
      heap_parent_le: "\<lbrakk>heap_invar l; valid l i; has_parent l i\<rbrakk>
        \<Longrightarrow> pparent l i \<le> prio_of l i"
      unfolding heap_invar_def
      by auto

    lemma heap_min_prop:
      assumes H: "heap_invar h"
      assumes V: "valid h i"
      shows "prio_of h (Suc 0) \<le> prio_of h i"
    proof (cases "i>1")
      case False with V show ?thesis
        by (auto simp: valid_def intro: Suc_lessI)
    next
      case True
      from V have "i\<le>length h" "valid h (Suc 0)" by (auto simp: valid_def)
      with True show ?thesis
        apply (induction i rule: heap_induction_scheme.induct)
        apply (rename_tac i)
        apply (case_tac "parent i = Suc 0")
        apply (rule order_trans[rotated])
        apply (rule heap_parent_le[OF H])
        apply (auto simp: valid_def) [3]

        apply (rule order_trans)
        apply (rprems)
        apply (auto simp: parent_def) [4]
        apply (rule heap_parent_le[OF H])
        apply (auto simp: valid_def parent_def)
        done
    qed

    text \<open> Obviously, the heap property can also be stated in terms of children,
      i.e., each node's priority is smaller or equal to it's children's priority.\<close>

    definition "children_ge h p i \<equiv>
      (has_left h i \<longrightarrow> p \<le> pleft h i)
    \<and> (has_right h i \<longrightarrow> p \<le> pright h i)"

    definition "heap_invar' h \<equiv> \<forall>i. valid h i \<longrightarrow> children_ge h (prio_of h i) i"

    lemma heap_eq_heap':
      shows "heap_invar h \<longleftrightarrow> heap_invar' h"
      unfolding heap_invar_def
      unfolding heap_invar'_def children_ge_def
      apply rule
      apply auto []
      apply clarsimp
      apply (frule child_of_parentD)
      apply auto []
      done

    subsection \<open>Basic Operations\<close>
    text \<open>The basic operations are the only operations that directly
      modify the underlying data structure.\<close>
    subsubsection \<open>Val-Of\<close>
    abbreviation (input) "val_of_pre l i \<equiv> valid l i"
    definition val_of_op :: "'a heap \<Rightarrow> nat \<Rightarrow> 'a nres"
      where "val_of_op l i \<equiv> ASSERT (i>0) \<then> mop_list_get l (i-1)"
    lemma val_of_correct[refine_vcg]:
      "val_of_pre l i \<Longrightarrow> val_of_op l i \<le> SPEC (\<lambda>r. r = val_of l i)"
      unfolding val_of_op_def val_of_def valid_def
      by refine_vcg auto

    abbreviation (input) "prio_of_pre \<equiv> val_of_pre"
    definition "prio_of_op l i \<equiv> do {v \<leftarrow> val_of_op l i; RETURN (prio v)}"
    lemma prio_of_op_correct[refine_vcg]:
      "prio_of_pre l i \<Longrightarrow> prio_of_op l i \<le> SPEC (\<lambda>r. r = prio_of l i)"
      unfolding prio_of_op_def
      apply refine_vcg by simp

    subsubsection \<open>Update\<close>
    abbreviation "update_pre h i v \<equiv> valid h i"
    definition update :: "'a heap \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a heap"
      where "update h i v \<equiv> h[i - 1 := v]"
    definition update_op :: "'a heap \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a heap nres"
      where "update_op h i v \<equiv> ASSERT (i>0) \<then> mop_list_set h (i-1) v"
    lemma update_correct[refine_vcg]:
      "update_pre h i v \<Longrightarrow> update_op h i v \<le> SPEC(\<lambda>r. r = update h i v)"
      unfolding update_op_def update_def valid_def by refine_vcg auto

    lemma update_valid[simp]: "valid (update h i v) j \<longleftrightarrow> valid h j"
      by (auto simp: update_def valid_def)

    lemma val_of_update[simp]: "\<lbrakk>update_pre h i v; valid h j\<rbrakk> \<Longrightarrow> val_of (update h i v) j = (
      if i=j then v else val_of h j)"
      unfolding update_def val_of_def
      by (auto simp: nth_list_update valid_def)

    lemma length_update[simp]: "length (update l i v) = length l"
      by (auto simp: update_def)

    subsubsection \<open>Exchange\<close>
    text \<open> Exchange two elements \<close>

    definition exch :: "'a heap \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a heap" where
      "exch l i j \<equiv> swap l (i - 1) (j - 1)"
    abbreviation "exch_pre l i j \<equiv> valid l i \<and> valid l j"

    definition exch_op :: "'a list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list nres"
    where "exch_op l i j \<equiv> do {
      ASSERT (i>0 \<and> j>0);
      l \<leftarrow> mop_list_swap l (i - 1) (j - 1);
      RETURN l
    }"

    lemma exch_op_alt: "exch_op l i j = do {
      vi \<leftarrow> val_of_op l i;
      vj \<leftarrow> val_of_op l j;
      l \<leftarrow> update_op l i vj;
      l \<leftarrow> update_op l j vi;
      RETURN l }"
      by (auto simp: exch_op_def swap_def val_of_op_def update_op_def
        pw_eq_iff refine_pw_simps)

    lemma exch_op_correct[refine_vcg]:
      "exch_pre l i j \<Longrightarrow> exch_op l i j \<le> SPEC (\<lambda>r. r = exch l i j)"
      unfolding exch_op_def
      apply refine_vcg
      apply (auto simp: exch_def valid_def)
      done

    lemma valid_exch[simp]: "valid (exch l i j) k = valid l k"
      unfolding exch_def by (auto simp: valid_def)

    lemma val_of_exch[simp]: "\<lbrakk>valid l i; valid l j; valid l k\<rbrakk> \<Longrightarrow>
      val_of (exch l i j) k = (
        if k=i then val_of l j
        else if k=j then val_of l i
        else val_of l k
      )"
      unfolding exch_def val_of_def valid_def
      by (auto)

    lemma exch_eq[simp]: "exch h i i = h"
      by (auto simp: exch_def)

    lemma \<alpha>_exch[simp]: "\<lbrakk>valid l i; valid l j\<rbrakk>
      \<Longrightarrow> \<alpha> (exch l i j) = \<alpha> l"
      unfolding exch_def valid_def
      by (auto)

    lemma length_exch[simp]: "length (exch l i j) = length l"
      by (auto simp: exch_def)

    subsubsection \<open>Butlast\<close>
    text \<open>Remove last element\<close>

    abbreviation "butlast_pre l \<equiv> l\<noteq>[]"
    definition butlast_op :: "'a heap \<Rightarrow> 'a heap nres"
      where "butlast_op l \<equiv> mop_list_butlast l"
    lemma butlast_op_correct[refine_vcg]:
      "butlast_pre l \<Longrightarrow> butlast_op l \<le> SPEC (\<lambda>r. r = butlast l)"
      unfolding butlast_op_def by (refine_vcg; auto)

    lemma valid_butlast_conv[simp]: "valid (butlast h) i \<longleftrightarrow> valid h i \<and> i < length h"
      by (auto simp: valid_def)

    lemma valid_butlast: "valid (butlast h) i \<Longrightarrow> valid h i"
      by (cases h rule: rev_cases) (auto simp: valid_def)

    lemma val_of_butlast[simp]: "\<lbrakk>valid h i; i<length h\<rbrakk>
      \<Longrightarrow> val_of (butlast h) i = val_of h i"
      by (auto simp: valid_def val_of_def nth_butlast)

    lemma val_of_butlast'[simp]:
      "valid (butlast h) i \<Longrightarrow> val_of (butlast h) i = val_of h i"
      by (cases h rule: rev_cases) (auto simp: valid_def val_of_def nth_append)

    lemma \<alpha>_butlast[simp]: "\<lbrakk> length h \<noteq> 0 \<rbrakk>
      \<Longrightarrow> \<alpha> (butlast h) = \<alpha> h - {# val_of h (length h)#}"
      apply (cases h rule: rev_cases)
      apply (auto simp: val_of_def)
      done

    lemma heap_invar_butlast[simp]: "heap_invar h \<Longrightarrow> heap_invar (butlast h)"
      apply (cases "h = []")
      apply simp
      apply (auto simp: heap_invar_def dest: valid_butlast)
      done

    subsubsection \<open>Append\<close>
    definition append_op :: "'a heap \<Rightarrow> 'a \<Rightarrow> 'a heap nres"
      where "append_op l v \<equiv> mop_list_append l v"
    lemma append_op_correct[refine_vcg]:
      "append_op l v \<le> SPEC (\<lambda>r. r = l@[v])"
      unfolding append_op_def by (refine_vcg; auto)

    lemma valid_append[simp]: "valid (l@[v]) i \<longleftrightarrow> valid l i \<or> i = length l + 1"
      by (auto simp: valid_def)

    lemma val_of_append[simp]: "valid (l@[v]) i \<Longrightarrow>
      val_of (l@[v]) i = (if valid l i then val_of l i else v)"
      unfolding valid_def val_of_def by (auto simp: nth_append)

    lemma \<alpha>_append[simp]: "\<alpha> (l@[v]) = \<alpha> l + {#v#}"
      by (auto simp: )

    subsection \<open>Auxiliary operations\<close>
    text \<open>The auxiliary operations do not have a corresponding abstract operation, but
      are to restore the heap property after modification.\<close>
    subsubsection \<open>Swim\<close>

    text \<open>This invariant expresses that the heap has a single defect,
      which can be repaired by swimming up\<close>
    definition swim_invar :: "'a heap \<Rightarrow> nat \<Rightarrow> bool"
      where "swim_invar h i \<equiv>
        valid h i
      \<and> (\<forall>j. valid h j \<and> has_parent h j \<and> j\<noteq>i \<longrightarrow> pparent h j \<le> prio_of h j)
      \<and> (has_parent h i \<longrightarrow>
        (\<forall>j. valid h j \<and> has_parent h j \<and> parent j = i
          \<longrightarrow> pparent h i \<le> prio_of h j))"

    text \<open>Move up an element that is too small, until it fits\<close>
    definition swim_op :: "'a heap \<Rightarrow> nat \<Rightarrow> 'a heap nres" where
      "swim_op h i \<equiv> do {
        RECT (\<lambda>swim (h,i). do {
          ASSERT (valid h i \<and> swim_invar h i);
          if has_parent h i then do {
            ppi \<leftarrow> prio_of_op h (parent i);
            pi \<leftarrow> prio_of_op h i;
            if (\<not>ppi \<le> pi) then do {
              h \<leftarrow> exch_op h i (parent i);
              swim (h, parent i)
            } else
              RETURN h
          } else
            RETURN h
        }) (h,i)
      }"

    lemma swim_invar_valid: "swim_invar h i \<Longrightarrow> valid h i"
      unfolding swim_invar_def by simp

    lemma swim_invar_exit1: "\<not>has_parent h i \<Longrightarrow> swim_invar h i \<Longrightarrow> heap_invar h"
      unfolding heap_invar_def swim_invar_def by auto

    lemma swim_invar_exit2: "pparent h i \<le> prio_of h i \<Longrightarrow> swim_invar h i \<Longrightarrow> heap_invar h"
      unfolding heap_invar_def swim_invar_def by auto

    lemma swim_invar_pres:
      assumes HPI: "has_parent h i"
      assumes VIOLATED: "pparent h i > prio_of h i"
      and INV: "swim_invar h i"
      defines "h' \<equiv> exch h i (parent i)"
      shows "swim_invar h' (parent i)"
      unfolding swim_invar_def
      apply safe
      apply (simp add: h'_def HPI)

      using HPI VIOLATED INV
      unfolding swim_invar_def h'_def
      apply auto []

      using HPI VIOLATED INV
      unfolding swim_invar_def h'_def
      apply auto
      by (metis order_trans)

    lemma swim_invar_decr:
      assumes INV: "heap_invar h"
      assumes V: "valid h i"
      assumes DECR: "prio v \<le> prio_of h i"
      shows "swim_invar (update h i v) i"
      using INV V DECR
      apply (auto simp: swim_invar_def heap_invar_def intro: dual_order.trans)
      done

    lemma swim_op_correct[refine_vcg]:
    "\<lbrakk>swim_invar h i\<rbrakk> \<Longrightarrow>
      swim_op h i \<le> SPEC (\<lambda>h'. \<alpha> h' = \<alpha> h \<and> heap_invar h' \<and> length h' = length h)"
      unfolding swim_op_def
      using [[goals_limit = 1]]
      apply (refine_vcg  RECT_rule[where
          pre="\<lambda>(hh,i).
            swim_invar hh i
          \<and> \<alpha> hh = \<alpha> h
          \<and> length hh = length h" and
          V = "inv_image less_than snd"
          ])
      apply (auto) []
      apply (auto) []
      apply (auto) []
      apply (auto) []
      apply (auto simp: swim_invar_valid) []
      apply (auto) []
      apply (auto) []
      apply (auto) []

      apply rprems
        apply (auto simp: swim_invar_pres) []
        apply (auto simp: parent_def valid_def) []

      apply (auto) []
      apply (auto simp: swim_invar_exit2) []
      apply (auto) []
      apply (auto) []
      apply (auto simp: swim_invar_exit1) []
      apply (auto) []
      done

    subsubsection \<open>Sink\<close>
    text \<open>Move down an element that is too big, until it fits in\<close>

    definition sink_op :: "'a heap \<Rightarrow> nat \<Rightarrow> 'a heap nres" where
      "sink_op h i \<equiv> do {
        RECT (\<lambda>sink (h,i). do {
          ASSERT (valid h i);
          if has_right h i then do {
            ASSERT (has_left h i);
            lp \<leftarrow> prio_of_op h (left i);
            rp \<leftarrow> prio_of_op h (right i);
            p \<leftarrow> prio_of_op h i;
            if (lp < p \<and> rp \<ge> lp) then do {
              h \<leftarrow> exch_op h i (left i);
              sink (h,left i)
            } else if (rp<lp \<and> rp < p) then do {
              h \<leftarrow> exch_op h i (right i);
              sink (h,right i)
            } else
              RETURN h
          } else if (has_left h i) then do {
            lp \<leftarrow> prio_of_op h (left i);
            p \<leftarrow> prio_of_op h i;
            if (lp < p) then do {
              h \<leftarrow> exch_op h i (left i);
              sink (h,left i)
            } else
              RETURN h

          } else
            RETURN h
        }) (h,i)
      }"

    text \<open>This invariant expresses that the heap has a single defect,
      which can be repaired by sinking\<close>
    definition "sink_invar l i \<equiv>
      valid l i
    \<and> (\<forall>j. valid l j \<and> j\<noteq>i \<longrightarrow> children_ge l (prio_of l j) j)
    \<and> (has_parent l i \<longrightarrow> children_ge l (pparent l i) i)"

    lemma sink_invar_valid: "sink_invar l i \<Longrightarrow> valid l i"
      unfolding sink_invar_def by auto

    lemma sink_invar_exit: "\<lbrakk>sink_invar l i; children_ge l (prio_of l i) i\<rbrakk>
      \<Longrightarrow> heap_invar' l"
      unfolding heap_invar'_def sink_invar_def
      by auto

    lemma sink_aux1: "\<not> (2*i \<le> length h) \<Longrightarrow> \<not>has_left h i \<and> \<not>has_right h i"
      unfolding valid_def left_def right_def by auto

    lemma sink_invar_pres1:
      assumes "sink_invar h i"
      assumes "has_left h i" "has_right h i"
      assumes "prio_of h i \<ge> pleft h i"
      assumes "pleft h i \<ge> pright h i"
      shows "sink_invar (exch h i (right i)) (right i)"
      using assms
      unfolding sink_invar_def
      apply auto
      apply (auto simp: children_ge_def)
      done

    lemma sink_invar_pres2:
      assumes "sink_invar h i"
      assumes "has_left h i" "has_right h i"
      assumes "prio_of h i \<ge> pleft h i"
      assumes "pleft h i \<le> pright h i"
      shows "sink_invar (exch h i (left i)) (left i)"
      using assms
      unfolding sink_invar_def
      apply auto
      apply (auto simp: children_ge_def)
      done

    lemma sink_invar_pres3:
      assumes "sink_invar h i"
      assumes "has_left h i" "has_right h i"
      assumes "prio_of h i \<ge> pright h i"
      assumes "pleft h i \<le> pright h i"
      shows "sink_invar (exch h i (left i)) (left i)"
      using assms
      unfolding sink_invar_def
      apply auto
      apply (auto simp: children_ge_def)
      done

    lemma sink_invar_pres4:
      assumes "sink_invar h i"
      assumes "has_left h i" "has_right h i"
      assumes "prio_of h i \<ge> pright h i"
      assumes "pleft h i \<ge> pright h i"
      shows "sink_invar (exch h i (right i)) (right i)"
      using assms
      unfolding sink_invar_def
      apply auto
      apply (auto simp: children_ge_def)
      done

    lemma sink_invar_pres5:
      assumes "sink_invar h i"
      assumes "has_left h i" "\<not>has_right h i"
      assumes "prio_of h i \<ge> pleft h i"
      shows "sink_invar (exch h i (left i)) (left i)"
      using assms
      unfolding sink_invar_def
      apply auto
      apply (auto simp: children_ge_def)
      done

    lemmas sink_invar_pres =
      sink_invar_pres1
      sink_invar_pres2
      sink_invar_pres3
      sink_invar_pres4
      sink_invar_pres5

    lemma sink_invar_incr:
      assumes INV: "heap_invar h"
      assumes V: "valid h i"
      assumes INCR: "prio v \<ge> prio_of h i"
      shows "sink_invar (update h i v) i"
      using INV V INCR
      apply (auto simp: sink_invar_def)
      apply (auto simp: children_ge_def heap_invar_def) []
      apply (auto simp: children_ge_def heap_invar_def intro: order_trans) []
      apply (frule spec[where x="left i"])
      apply auto []
      apply (frule spec[where x="right i"])
      apply auto []
      done

    lemma sink_op_correct[refine_vcg]:
    "\<lbrakk>sink_invar h i\<rbrakk> \<Longrightarrow>
      sink_op h i \<le> SPEC (\<lambda>h'. \<alpha> h' = \<alpha> h \<and> heap_invar h' \<and> length h' = length h)"
      unfolding sink_op_def heap_eq_heap'
      using [[goals_limit = 1]]

      apply (refine_vcg  RECT_rule[where
          pre="\<lambda>(hh,i). sink_invar hh i \<and> \<alpha> hh = \<alpha> h \<and> length hh = length h" and
          V = "measure (\<lambda>(l,i). length l - i)"
          ])

      apply (auto) []
      apply (auto) []
      apply (auto) []
      apply (auto) []
      apply (auto simp: sink_invar_valid) []
      apply (auto simp: valid_def left_def right_def) []

      apply rprems
        apply (auto intro: sink_invar_pres) []
        apply (auto simp: valid_def left_def right_def) []

      apply rprems
        apply (auto intro: sink_invar_pres) []
        apply (auto simp: valid_def left_def right_def) []

      apply (auto) []

      apply clarsimp
      apply (rule sink_invar_exit, assumption) []
      apply (auto simp: children_ge_def) []

      apply (auto) []

      apply rprems
        apply (auto intro: sink_invar_pres) []
        apply (auto simp: valid_def left_def right_def) []

      apply (auto) []

      apply clarsimp
      apply (rule sink_invar_exit, assumption) []
      apply (auto simp: children_ge_def) []

      apply (auto) []

      apply (auto) []

      apply clarsimp
      apply (rule sink_invar_exit, assumption) []
      apply (auto simp: children_ge_def) []

      apply (auto) []
      done

    lemma sink_op_swim_rule:
      "swim_invar h i \<Longrightarrow> sink_op h i \<le> SPEC (\<lambda>h'. h'=h)"
      apply (frule swim_invar_valid)
      unfolding sink_op_def
      apply (subst RECT_unfold, refine_mono)
      apply (fold sink_op_def)
      apply refine_vcg
      apply (simp_all)
      apply (auto simp add: valid_def left_def right_def dest: swim_invar_valid) []
      apply (auto simp: swim_invar_def) []
      apply (auto simp: swim_invar_def) []
      apply (auto simp: swim_invar_def) []
      apply (auto simp: swim_invar_def) []
      apply (auto simp: swim_invar_def) []
      apply (auto simp: swim_invar_def) []
      done

    definition sink_op_opt
      \<comment> \<open>Sink operation as presented in Sedgewick et al. Algs4 reference implementation\<close>
    where
      "sink_op_opt h k \<equiv> RECT (\<lambda>D (h,k). do {
        ASSERT (k>0 \<and> k\<le>length h);
        let len = length h;
        if (2*k \<le> len) then do {
          let j = 2*k;
          pj \<leftarrow> prio_of_op h j;

          j \<leftarrow> (
            if j<len then do {
              psj \<leftarrow> prio_of_op h (Suc j);
              if pj>psj then RETURN (j+1) else RETURN j
            } else RETURN j);

          pj \<leftarrow> prio_of_op h j;
          pk \<leftarrow> prio_of_op h k;
          if (pk > pj) then do {
            h \<leftarrow> exch_op h k j;
            D (h,j)
          } else
            RETURN h
        } else RETURN h
      }) (h,k)"

    lemma sink_op_opt_eq: "sink_op_opt h k = sink_op h k"
      unfolding sink_op_opt_def sink_op_def
      apply (fo_rule arg_cong fun_cong)+
      apply (intro ext)
      unfolding sink_op_def[symmetric]
      apply (simp cong: if_cong split del: if_split add: Let_def)

      apply (auto simp: valid_def left_def right_def prio_of_op_def val_of_op_def
        val_of_def less_imp_diff_less ASSERT_same_eq_conv nz_le_conv_less) []
      done

    subsubsection \<open>Repair\<close>
    text \<open>Repair a local defect in the heap. This can be done
      by swimming and sinking. Note that, depending on the defect, only one
      of the operations will change the heap.
      Moreover, note that we do not need repair to implement the heap operations.
      However, it is required for heapmaps. \<close>

    definition "repair_op h i \<equiv> do {
      h \<leftarrow> sink_op h i;
      h \<leftarrow> swim_op h i;
      RETURN h
    }"

    lemma update_sink_swim_cases:
      assumes "heap_invar h"
      assumes "valid h i"
      obtains "swim_invar (update h i v) i" | "sink_invar (update h i v) i"
      apply (cases rule: linear[of "prio v" "prio_of h i", THEN disjE])
      apply (blast dest: swim_invar_decr[OF assms])
      apply (blast dest: sink_invar_incr[OF assms])
      done

    lemma heap_invar_imp_swim_invar: "\<lbrakk>heap_invar h; valid h i\<rbrakk> \<Longrightarrow> swim_invar h i"
      unfolding heap_invar_def swim_invar_def
      by (auto intro: order_trans)

    lemma repair_correct[refine_vcg]:
      assumes "heap_invar h" and "valid h i"
      shows "repair_op (update h i v) i \<le> SPEC (\<lambda>h'.
        heap_invar h' \<and> \<alpha> h' = \<alpha> (update h i v) \<and> length h' = length h)"
      apply (rule update_sink_swim_cases[of h i v, OF assms])
      unfolding repair_op_def
      apply (refine_vcg sink_op_swim_rule)
      apply auto [4]
      apply (refine_vcg)
      using assms(2)
      apply (auto intro: heap_invar_imp_swim_invar simp: valid_def) []
      apply auto [3]
      done

    subsection \<open>Operations\<close>

    (*
    subsubsection \<open>Length\<close>
    definition length_op :: "'a heap \<Rightarrow> nat nres" where "length_op \<equiv> lst_op_length"

    lemma [refine_vcg]: "length_op l \<le> SPEC (\<lambda>r. r = length l)"
      unfolding length_op_def
      by refine_vcg
    *)

    subsubsection \<open>Empty\<close>
    abbreviation (input) empty :: "'a heap" \<comment> \<open>The empty heap\<close>
      where "empty \<equiv> []"
    definition empty_op :: "'a heap nres"
      where "empty_op \<equiv> mop_list_empty"
    lemma empty_op_correct[refine_vcg]:
      "empty_op \<le> SPEC (\<lambda>r. \<alpha> r = {#} \<and> heap_invar r)"
      unfolding empty_op_def apply refine_vcg by auto

    subsubsection \<open>Emptiness check\<close>
    definition is_empty_op :: "'a heap \<Rightarrow> bool nres" \<comment> \<open>Check for emptiness\<close>
      where "is_empty_op h \<equiv> do {ASSERT (heap_invar h); let l=length h; RETURN (l=0)}"
    lemma is_empty_op_correct[refine_vcg]:
      "heap_invar h \<Longrightarrow> is_empty_op h \<le> SPEC (\<lambda>r. r\<longleftrightarrow>\<alpha> h = {#})"
      unfolding is_empty_op_def
      apply refine_vcg by auto

    subsubsection \<open>Insert\<close>
    definition insert_op :: "'a \<Rightarrow> 'a heap \<Rightarrow> 'a heap nres" \<comment> \<open>Insert element\<close>
      where "insert_op v h \<equiv> do {
        ASSERT (heap_invar h);
        h \<leftarrow> append_op h v;
        let l = length h;
        h \<leftarrow> swim_op h l;
        RETURN h
      }"

    lemma swim_invar_insert: "heap_invar l \<Longrightarrow> swim_invar (l@[x]) (Suc (length l))"
      unfolding swim_invar_def heap_invar_def valid_def parent_def val_of_def
      by (fastforce simp: nth_append)

    lemma
      "(insert_op,RETURN oo op_mset_insert) \<in> Id \<rightarrow> heap_rel1 \<rightarrow> \<langle>heap_rel1\<rangle>nres_rel"
      unfolding insert_op_def[abs_def] heap_rel1_def o_def
      by refine_vcg (auto simp: swim_invar_insert in_br_conv)

    lemma insert_op_correct:
      "heap_invar h \<Longrightarrow> insert_op v h \<le> SPEC (\<lambda>h'. heap_invar h' \<and> \<alpha> h' = \<alpha> h + {#v#})"
      unfolding insert_op_def
      by (refine_vcg) (auto simp: swim_invar_insert)
    lemmas [refine_vcg] = insert_op_correct

    subsubsection \<open>Pop minimum element\<close>

    definition pop_min_op :: "'a heap \<Rightarrow> ('a \<times> 'a heap) nres" where
      "pop_min_op h \<equiv> do {
        ASSERT (heap_invar h);
        ASSERT (valid h 1);
        m \<leftarrow> val_of_op h 1;
        let l = length h;
        h \<leftarrow> exch_op h 1 l;
        h \<leftarrow> butlast_op h;

        if (l\<noteq>1) then do {
          h \<leftarrow> sink_op h 1;
          RETURN (m,h)
        } else RETURN (m,h)
      }"

    lemma left_not_one[simp]: "left j \<noteq> Suc 0"
      by (auto simp: left_def)

    lemma right_one_conv[simp]: "right j = Suc 0 \<longleftrightarrow> j=0"
      by (auto simp: right_def)

    lemma parent_one_conv[simp]: "parent (Suc 0) = 0"
      by (auto simp: parent_def)

    lemma sink_invar_init:
      assumes I: "heap_invar h"
      assumes NE: "length h > 1"
      shows "sink_invar (butlast (exch h (Suc 0) (length h))) (Suc 0)"
    proof -
      from NE have V: "valid h (Suc 0)" "valid h (length h)"
        apply -
        apply (auto simp: valid_def neq_Nil_conv) []
        by (cases h) (auto simp: valid_def)

      show ?thesis using I
        unfolding heap_eq_heap' heap_invar'_def sink_invar_def
        apply (intro impI conjI allI)
        using NE apply (auto simp: V valid_butlast_conv) []
        apply (auto simp add: children_ge_def V NE valid_butlast_conv) []
        apply (auto simp add: children_ge_def V NE valid_butlast_conv) []
        done
    qed

    lemma in_set_conv_val: "v \<in> set h \<longleftrightarrow> (\<exists>i. valid h i \<and> v = val_of h i)"
      apply (rule iffI)
      apply (clarsimp simp add: valid_def val_of_def in_set_conv_nth)
      apply (rule_tac x="Suc i" in exI; auto)
      apply (clarsimp simp add: valid_def val_of_def in_set_conv_nth)
      apply (rule_tac x="i - Suc 0" in exI; auto)
      done

    lemma pop_min_op_correct:
      assumes "heap_invar h" "\<alpha> h \<noteq> {#}"
      shows "pop_min_op h \<le> SPEC (\<lambda>(v,h'). heap_invar h' \<and>
        v \<in># \<alpha> h \<and> \<alpha> h' = \<alpha> h - {#v#} \<and> (\<forall>v'\<in>set_mset (\<alpha> h). prio v \<le> prio v'))"
    proof -
      note [simp del] = length_greater_0_conv
      note LG = length_greater_0_conv[symmetric]

      from assms show ?thesis
        unfolding pop_min_op_def
        apply refine_vcg
        apply (simp_all add: sink_invar_init LG)
        apply (auto simp: valid_def) []
        apply (cases h; auto simp: val_of_def) [] (* FIXME: Looking below val_of! *)
        apply (auto simp: in_set_conv_val simp: heap_min_prop) []
        apply auto []
        apply (cases h; auto simp: val_of_def) [] (* FIXME: Looking below val_of! *)
        apply auto []
        apply (cases h; auto simp: val_of_def) [] (* FIXME: Looking below val_of! *)
        done
    qed

    lemmas [refine_vcg] = pop_min_op_correct

    subsubsection \<open>Peek minimum element\<close>

    definition peek_min_op :: "'a heap \<Rightarrow> 'a nres" where
      "peek_min_op h \<equiv> do {
        ASSERT (heap_invar h);
        ASSERT (valid h 1);
        val_of_op h 1
      }"

    lemma peek_min_op_correct:
      assumes "heap_invar h" "\<alpha> h \<noteq> {#}"
      shows "peek_min_op h \<le> SPEC (\<lambda>v.
        v \<in># \<alpha> h \<and> (\<forall>v'\<in>set_mset (\<alpha> h). prio v \<le> prio v'))"
      unfolding peek_min_op_def
      apply refine_vcg
      using assms
      apply clarsimp_all
      apply (auto simp: valid_def) []
      apply (cases h; auto simp: val_of_def) [] (* FIXME: Looking below val_of! *)
      apply (auto simp: in_set_conv_val simp: heap_min_prop) []
      done

    lemmas peek_min_op_correct'[refine_vcg] = peek_min_op_correct

    subsection \<open>Operations as Relator-Style Refinement\<close>

    lemma empty_op_refine: "(empty_op,RETURN op_mset_empty)\<in>\<langle>heap_rel1\<rangle>nres_rel"
      apply (rule nres_relI)
      apply (rule order_trans)
      apply (rule empty_op_correct)
      apply (auto simp: heap_rel1_def br_def pw_le_iff refine_pw_simps)
      done

    lemma is_empty_op_refine: "(is_empty_op,RETURN o op_mset_is_empty) \<in> heap_rel1 \<rightarrow> \<langle>bool_rel\<rangle>nres_rel"
      apply (intro nres_relI fun_relI; simp)
      apply refine_vcg
      apply (auto simp: heap_rel1_def br_def)
      done

    lemma insert_op_refine: "(insert_op,RETURN oo op_mset_insert) \<in> Id \<rightarrow> heap_rel1 \<rightarrow> \<langle>heap_rel1\<rangle>nres_rel"
      apply (intro nres_relI fun_relI; simp)
      apply (refine_vcg RETURN_as_SPEC_refine)
      apply (auto simp: heap_rel1_def br_def pw_le_iff refine_pw_simps)
      done

    lemma pop_min_op_refine:
      "(pop_min_op, PR_CONST (mop_prio_pop_min prio)) \<in> heap_rel1 \<rightarrow> \<langle>Id \<times>\<^sub>r heap_rel1\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding mop_prio_pop_min_def PR_CONST_def
      apply (refine_vcg SPEC_refine)
      apply (auto simp: heap_rel1_def br_def)
      done

    lemma peek_min_op_refine:
      "(peek_min_op, PR_CONST (mop_prio_peek_min prio)) \<in> heap_rel1 \<rightarrow> \<langle>Id\<rangle>nres_rel"
      apply (intro fun_relI nres_relI)
      unfolding mop_prio_peek_min_def PR_CONST_def
      apply (refine_vcg RES_refine)
      apply (auto simp: heap_rel1_def br_def)
      done

  end

end


(*<*)
theory ChisholmExampleProp
  imports TheoryCombination
begin

declare [[smt_solver=cvc4]]
declare [[smt_oracle]]
nitpick_params[user_axioms=true, show_all, expect=genuine, format = 2]
(*>*)

(****Chisholm Example (Propositional)****)
consts go::m tell::m
consts C::c
axiomatization where
 D1: "\<lfloor>\<^bold>O\<langle>go\<rangle>\<rfloor>" and (*It ought to be that Jones goes to assist his neighbour*)
 D2: "\<lfloor>\<^bold>O\<langle>tell|go\<rangle>\<rfloor>" and (*It ought to be that if Jones goes, then he tells them he is coming*)
 D3: "\<lfloor>\<^bold>O\<langle>\<^bold>\<not>tell|\<^bold>\<not>go\<rangle>\<rfloor>" and (*If Jones doesn't go, then he ought not tell them he is coming*)
 D4: "\<lfloor>\<^bold>\<not>(go)\<rfloor>\<^sub>C"  (*Jones doesn't go (locally valid statement)*)

lemma True nitpick [satisfy] oops

abbreviation "violated \<phi> \<equiv> \<^bold>O\<^sub>i(\<phi>) \<^bold>\<and> \<^bold>\<not>\<phi>"

lemma "(\<lfloor>\<^bold>\<box>\<^sub>a\<^bold>\<not>(go)\<rfloor>\<^sub>C \<and> \<lfloor>\<^bold>\<diamond>\<^sub>p(go \<^bold>\<and> tell)\<rfloor>\<^sub>C \<and> \<lfloor>\<^bold>\<diamond>\<^sub>p(go \<^bold>\<and> \<^bold>\<not>tell)\<rfloor>\<^sub>C \<and> \<lfloor>\<^bold>\<not>tell\<rfloor>\<^sub>C \<and> \<lfloor>\<^bold>\<diamond>\<^sub>atell\<rfloor>\<^sub>C \<and>  \<lfloor>\<^bold>\<diamond>\<^sub>a(\<^bold>\<not>tell)\<rfloor>\<^sub>C)
       \<longrightarrow> (\<lfloor>violated go\<rfloor>\<^sub>C \<and> \<lfloor>\<^bold>O\<^sub>a(\<^bold>\<not>tell)\<rfloor>\<^sub>C)"
  using sem_4a sem_4b sem_5e D1 D3 D4 sem_5b by smt


(*  Title:      HOL/Quotient_Examples/Lift_FSet.thy
    Author:     Brian Huffman, TU Munich
*)

section \<open>Lifting and transfer with a finite set type\<close>

theory Lift_FSet
imports MainRLT
begin

subsection \<open>Equivalence relation and quotient type definition\<close>

definition list_eq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where [simp]: "list_eq xs ys \<longleftrightarrow> set xs = set ys"

lemma reflp_list_eq: "reflp list_eq"
  unfolding reflp_def by simp

lemma symp_list_eq: "symp list_eq"
  unfolding symp_def by simp

lemma transp_list_eq: "transp list_eq"
  unfolding transp_def by simp

lemma equivp_list_eq: "equivp list_eq"
  by (intro equivpI reflp_list_eq symp_list_eq transp_list_eq)

context includes lifting_syntax
begin

lemma list_eq_transfer [transfer_rule]:
  assumes [transfer_rule]: "bi_unique A"
  shows "(list_all2 A ===> list_all2 A ===> (=)) list_eq list_eq"
  unfolding list_eq_def [abs_def] by transfer_prover

quotient_type 'a fset = "'a list" / "list_eq" parametric list_eq_transfer
  by (rule equivp_list_eq)

subsection \<open>Lifted constant definitions\<close>

lift_definition fnil :: "'a fset" ("{||}") is "[]" parametric list.ctr_transfer(1) .

lift_definition fcons :: "'a \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is Cons parametric list.ctr_transfer(2)
  by simp

lift_definition fappend :: "'a fset \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is append parametric append_transfer
  by simp

lift_definition fmap :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a fset \<Rightarrow> 'b fset" is map parametric list.map_transfer
  by simp

lift_definition ffilter :: "('a \<Rightarrow> bool) \<Rightarrow> 'a fset \<Rightarrow> 'a fset" is filter parametric filter_transfer
  by simp

lift_definition fset :: "'a fset \<Rightarrow> 'a set" is set parametric list.set_transfer
  by simp

text \<open>Constants with nested types (like concat) yield a more
  complicated proof obligation.\<close>

lemma list_all2_cr_fset:
  "list_all2 cr_fset xs ys \<longleftrightarrow> map abs_fset xs = ys"
  unfolding cr_fset_def
  apply safe
  apply (erule list_all2_induct, simp, simp)
  apply (simp add: list_all2_map2 List.list_all2_refl)
  done

lemma abs_fset_eq_iff: "abs_fset xs = abs_fset ys \<longleftrightarrow> list_eq xs ys"
  using Quotient_rel [OF Quotient_fset] by simp

lift_definition fconcat :: "'a fset fset \<Rightarrow> 'a fset" is concat parametric concat_transfer
proof (simp only: fset.pcr_cr_eq)
  fix xss yss :: "'a list list"
  assume "(list_all2 cr_fset OO list_eq OO (list_all2 cr_fset)\<inverse>\<inverse>) xss yss"
  then obtain uss vss where
    "list_all2 cr_fset xss uss" and "list_eq uss vss" and
    "list_all2 cr_fset yss vss" by clarsimp
  hence "list_eq (map abs_fset xss) (map abs_fset yss)"
    unfolding list_all2_cr_fset by simp
  thus "list_eq (concat xss) (concat yss)"
    apply (simp add: set_eq_iff image_def)
    apply safe
    apply (rename_tac xs, drule_tac x="abs_fset xs" in spec)
    apply (drule iffD1, fast, clarsimp simp add: abs_fset_eq_iff, fast)
    apply (rename_tac xs, drule_tac x="abs_fset xs" in spec)
    apply (drule iffD2, fast, clarsimp simp add: abs_fset_eq_iff, fast)
    done
qed

lemma member_transfer:
  assumes [transfer_rule]: "bi_unique A"
  shows "(A ===> list_all2 A ===> (=)) (\<lambda>x xs. x \<in> set xs) (\<lambda>x xs. x \<in> set xs)"
by transfer_prover

end

syntax
  "_insert_fset"     :: "args => 'a fset"  ("{|(_)|}")

translations
  "{|x, xs|}" == "CONST fcons x {|xs|}"
  "{|x|}"     == "CONST fcons x {||}"

lift_definition fmember :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<in>|" 50) is "\<lambda>x xs. x \<in> set xs"
   parametric member_transfer by simp

abbreviation notin_fset :: "'a \<Rightarrow> 'a fset \<Rightarrow> bool" (infix "|\<notin>|" 50) where
  "x |\<notin>| S \<equiv> \<not> (x |\<in>| S)"

lemma fmember_fmap[simp]: "a |\<in>| fmap f X = (\<exists>b. b |\<in>| X \<and> a = f b)"
  by transfer auto

text \<open>We can export code:\<close>

export_code fnil fcons fappend fmap ffilter fset fmember in SML file_prefix fset

subsection \<open>Using transfer with type \<open>fset\<close>\<close>

text \<open>The correspondence relation \<open>cr_fset\<close> can only relate
  \<open>list\<close> and \<open>fset\<close> types with the same element type.
  To relate nested types like \<open>'a list list\<close> and
  \<open>'a fset fset\<close>, we define a parameterized version of the
  correspondence relation, \<open>pcr_fset\<close>.\<close>

thm pcr_fset_def

subsection \<open>Transfer examples\<close>

text \<open>The \<open>transfer\<close> method replaces equality on \<open>fset\<close> with the \<open>list_eq\<close> relation on lists, which is
  logically equivalent.\<close>

lemma "fmap f (fmap g xs) = fmap (f \<circ> g) xs"
  apply transfer
  apply simp
  done

text \<open>The \<open>transfer'\<close> variant can replace equality on \<open>fset\<close> with equality on \<open>list\<close>, which is logically stronger
  but sometimes more convenient.\<close>

lemma "fmap f (fmap g xs) = fmap (f \<circ> g) xs"
  using map_map [Transfer.transferred] .

lemma "ffilter p (fmap f xs) = fmap f (ffilter (p \<circ> f) xs)"
  using filter_map [Transfer.transferred] .

lemma "ffilter p (ffilter q xs) = ffilter (\<lambda>x. q x \<and> p x) xs"
  using filter_filter [Transfer.transferred] .

lemma "fset (fcons x xs) = insert x (fset xs)"
  using list.set(2) [Transfer.transferred] .

lemma "fset (fappend xs ys) = fset xs \<union> fset ys"
  using set_append [Transfer.transferred] .

lemma "fset (fconcat xss) = (\<Union>xs\<in>fset xss. fset xs)"
  using set_concat [Transfer.transferred] .

lemma "\<forall>x\<in>fset xs. f x = g x \<Longrightarrow> fmap f xs = fmap g xs"
  apply transfer
  apply (simp cong: map_cong del: set_map)
  done

lemma "fnil = fconcat xss \<longleftrightarrow> (\<forall>xs\<in>fset xss. xs = fnil)"
  apply transfer
  apply simp
  done

lemma "fconcat (fmap (\<lambda>x. fcons x fnil) xs) = xs"
  apply transfer
  apply simp
  done

lemma concat_map_concat: "concat (map concat xsss) = concat (concat xsss)"
  by (induct xsss, simp_all)

lemma "fconcat (fmap fconcat xss) = fconcat (fconcat xss)"
  using concat_map_concat [Transfer.transferred] .

end


theory FO
  imports Main
begin

abbreviation "sorted_distinct xs \<equiv> sorted xs \<and> distinct xs"

datatype 'a fo_term = Const 'a | Var nat

type_synonym 'a val = "nat \<Rightarrow> 'a"

fun list_fo_term :: "'a fo_term \<Rightarrow> 'a list" where
  "list_fo_term (Const c) = [c]"
| "list_fo_term _ = []"

fun fv_fo_term_list :: "'a fo_term \<Rightarrow> nat list" where
  "fv_fo_term_list (Var n) = [n]"
| "fv_fo_term_list _ = []"

fun fv_fo_term_set :: "'a fo_term \<Rightarrow> nat set" where
  "fv_fo_term_set (Var n) = {n}"
| "fv_fo_term_set _ = {}"

definition fv_fo_terms_set :: "('a fo_term) list \<Rightarrow> nat set" where
  "fv_fo_terms_set ts = \<Union>(set (map fv_fo_term_set ts))"

fun fv_fo_terms_list_rec :: "('a fo_term) list \<Rightarrow> nat list" where
  "fv_fo_terms_list_rec [] = []"
| "fv_fo_terms_list_rec (t # ts) = fv_fo_term_list t @ fv_fo_terms_list_rec ts"

definition fv_fo_terms_list :: "('a fo_term) list \<Rightarrow> nat list" where
  "fv_fo_terms_list ts = remdups_adj (sort (fv_fo_terms_list_rec ts))"

fun eval_term :: "'a val \<Rightarrow> 'a fo_term \<Rightarrow> 'a" (infix "\<cdot>" 60) where
  "eval_term \<sigma> (Const c) = c"
| "eval_term \<sigma> (Var n) = \<sigma> n"

definition eval_terms :: "'a val \<Rightarrow> ('a fo_term) list \<Rightarrow> 'a list" (infix "\<odot>" 60) where
  "eval_terms \<sigma> ts = map (eval_term \<sigma>) ts"

lemma finite_set_fo_term: "finite (set_fo_term t)"
  by (cases t) auto

lemma list_fo_term_set: "set (list_fo_term t) = set_fo_term t"
  by (cases t) auto

lemma finite_fv_fo_term_set: "finite (fv_fo_term_set t)"
  by (cases t) auto

lemma fv_fo_term_setD: "n \<in> fv_fo_term_set t \<Longrightarrow> t = Var n"
  by (cases t) auto

lemma fv_fo_term_set_list: "set (fv_fo_term_list t) = fv_fo_term_set t"
  by (cases t) auto

lemma sorted_distinct_fv_fo_term_list: "sorted_distinct (fv_fo_term_list t)"
  by (cases t) auto

lemma fv_fo_term_set_cong: "fv_fo_term_set t = fv_fo_term_set (map_fo_term f t)"
  by (cases t) auto

lemma fv_fo_terms_setI: "Var m \<in> set ts \<Longrightarrow> m \<in> fv_fo_terms_set ts"
  by (induction ts) (auto simp: fv_fo_terms_set_def)

lemma fv_fo_terms_setD: "m \<in> fv_fo_terms_set ts \<Longrightarrow> Var m \<in> set ts"
  by (induction ts) (auto simp: fv_fo_terms_set_def dest: fv_fo_term_setD)

lemma finite_fv_fo_terms_set: "finite (fv_fo_terms_set ts)"
  by (auto simp: fv_fo_terms_set_def finite_fv_fo_term_set)

lemma fv_fo_terms_set_list: "set (fv_fo_terms_list ts) = fv_fo_terms_set ts"
  using fv_fo_term_set_list
  unfolding fv_fo_terms_list_def
  by (induction ts rule: fv_fo_terms_list_rec.induct)
     (auto simp: fv_fo_terms_set_def set_insort_key)

lemma distinct_remdups_adj_sort: "sorted xs \<Longrightarrow> distinct (remdups_adj xs)"
  by (induction xs rule: induct_list012) auto

lemma sorted_distinct_fv_fo_terms_list: "sorted_distinct (fv_fo_terms_list ts)"
  unfolding fv_fo_terms_list_def
  by (induction ts rule: fv_fo_terms_list_rec.induct)
     (auto simp add: sorted_insort intro: distinct_remdups_adj_sort)

lemma fv_fo_terms_set_cong: "fv_fo_terms_set ts = fv_fo_terms_set (map (map_fo_term f) ts)"
  using fv_fo_term_set_cong
  by (induction ts) (fastforce simp: fv_fo_terms_set_def)+

lemma eval_term_cong: "(\<And>n. n \<in> fv_fo_term_set t \<Longrightarrow> \<sigma> n = \<sigma>' n) \<Longrightarrow>
  eval_term \<sigma> t = eval_term \<sigma>' t"
  by (cases t) auto

lemma eval_terms_fv_fo_terms_set: "\<sigma> \<odot> ts = \<sigma>' \<odot> ts \<Longrightarrow> n \<in> fv_fo_terms_set ts \<Longrightarrow> \<sigma> n = \<sigma>' n"
proof (induction ts)
  case (Cons t ts)
  then show ?case
    by (cases t) (auto simp: eval_terms_def fv_fo_terms_set_def)
qed (auto simp: eval_terms_def fv_fo_terms_set_def)

lemma eval_terms_cong: "(\<And>n. n \<in> fv_fo_terms_set ts \<Longrightarrow> \<sigma> n = \<sigma>' n) \<Longrightarrow>
  eval_terms \<sigma> ts = eval_terms \<sigma>' ts"
  by (auto simp: eval_terms_def fv_fo_terms_set_def intro: eval_term_cong)

datatype ('a, 'b) fo_fmla =
  Pred 'b "('a fo_term) list"
| Bool bool
| Eqa "'a fo_term" "'a fo_term"
| Neg "('a, 'b) fo_fmla"
| Conj "('a, 'b) fo_fmla" "('a, 'b) fo_fmla"
| Disj "('a, 'b) fo_fmla" "('a, 'b) fo_fmla"
| Exists nat "('a, 'b) fo_fmla"
| Forall nat "('a, 'b) fo_fmla"

fun fv_fo_fmla_list_rec :: "('a, 'b) fo_fmla \<Rightarrow> nat list" where
  "fv_fo_fmla_list_rec (Pred _ ts) = fv_fo_terms_list ts"
| "fv_fo_fmla_list_rec (Bool b) = []"
| "fv_fo_fmla_list_rec (Eqa t t') = fv_fo_term_list t @ fv_fo_term_list t'"
| "fv_fo_fmla_list_rec (Neg \<phi>) = fv_fo_fmla_list_rec \<phi>"
| "fv_fo_fmla_list_rec (Conj \<phi> \<psi>) = fv_fo_fmla_list_rec \<phi> @ fv_fo_fmla_list_rec \<psi>"
| "fv_fo_fmla_list_rec (Disj \<phi> \<psi>) = fv_fo_fmla_list_rec \<phi> @ fv_fo_fmla_list_rec \<psi>"
| "fv_fo_fmla_list_rec (Exists n \<phi>) = filter (\<lambda>m. n \<noteq> m) (fv_fo_fmla_list_rec \<phi>)"
| "fv_fo_fmla_list_rec (Forall n \<phi>) = filter (\<lambda>m. n \<noteq> m) (fv_fo_fmla_list_rec \<phi>)"

definition fv_fo_fmla_list :: "('a, 'b) fo_fmla \<Rightarrow> nat list" where
  "fv_fo_fmla_list \<phi> = remdups_adj (sort (fv_fo_fmla_list_rec \<phi>))"

fun fv_fo_fmla :: "('a, 'b) fo_fmla \<Rightarrow> nat set" where
  "fv_fo_fmla (Pred _ ts) = fv_fo_terms_set ts"
| "fv_fo_fmla (Bool b) = {}"
| "fv_fo_fmla (Eqa t t') = fv_fo_term_set t \<union> fv_fo_term_set t'"
| "fv_fo_fmla (Neg \<phi>) = fv_fo_fmla \<phi>"
| "fv_fo_fmla (Conj \<phi> \<psi>) = fv_fo_fmla \<phi> \<union> fv_fo_fmla \<psi>"
| "fv_fo_fmla (Disj \<phi> \<psi>) = fv_fo_fmla \<phi> \<union> fv_fo_fmla \<psi>"
| "fv_fo_fmla (Exists n \<phi>) = fv_fo_fmla \<phi> - {n}"
| "fv_fo_fmla (Forall n \<phi>) = fv_fo_fmla \<phi> - {n}"

lemma finite_fv_fo_fmla: "finite (fv_fo_fmla \<phi>)"
  by (induction \<phi> rule: fv_fo_fmla.induct)
     (auto simp: finite_fv_fo_term_set finite_fv_fo_terms_set)

lemma fv_fo_fmla_list_set: "set (fv_fo_fmla_list \<phi>) = fv_fo_fmla \<phi>"
  unfolding fv_fo_fmla_list_def
  by (induction \<phi> rule: fv_fo_fmla.induct) (auto simp: fv_fo_terms_set_list fv_fo_term_set_list)

lemma sorted_distinct_fv_list: "sorted_distinct (fv_fo_fmla_list \<phi>)"
  by (auto simp: fv_fo_fmla_list_def intro: distinct_remdups_adj_sort)

lemma length_fv_fo_fmla_list: "length (fv_fo_fmla_list \<phi>) = card (fv_fo_fmla \<phi>)"
  using fv_fo_fmla_list_set[of \<phi>] sorted_distinct_fv_list[of \<phi>]
    distinct_card[of "fv_fo_fmla_list \<phi>"]
  by auto

lemma fv_fo_fmla_list_eq: "fv_fo_fmla \<phi> = fv_fo_fmla \<psi> \<Longrightarrow> fv_fo_fmla_list \<phi> = fv_fo_fmla_list \<psi>"
  using fv_fo_fmla_list_set sorted_distinct_fv_list
  by (metis sorted_distinct_set_unique)

lemma fv_fo_fmla_list_Conj: "fv_fo_fmla_list (Conj \<phi> \<psi>) = fv_fo_fmla_list (Conj \<psi> \<phi>)"
  using fv_fo_fmla_list_eq[of "Conj \<phi> \<psi>" "Conj \<psi> \<phi>"]
  by auto

type_synonym 'a table = "('a list) set"

type_synonym ('t, 'b) fo_intp = "'b \<times> nat \<Rightarrow> 't"

fun wf_fo_intp :: "('a, 'b) fo_fmla \<Rightarrow> ('a table, 'b) fo_intp \<Rightarrow> bool" where
  "wf_fo_intp (Pred r ts) I \<longleftrightarrow> finite (I (r, length ts))"
| "wf_fo_intp (Bool b) I \<longleftrightarrow> True"
| "wf_fo_intp (Eqa t t') I \<longleftrightarrow> True"
| "wf_fo_intp (Neg \<phi>) I \<longleftrightarrow> wf_fo_intp \<phi> I"
| "wf_fo_intp (Conj \<phi> \<psi>) I \<longleftrightarrow> wf_fo_intp \<phi> I \<and> wf_fo_intp \<psi> I"
| "wf_fo_intp (Disj \<phi> \<psi>) I \<longleftrightarrow> wf_fo_intp \<phi> I \<and> wf_fo_intp \<psi> I"
| "wf_fo_intp (Exists n \<phi>) I \<longleftrightarrow> wf_fo_intp \<phi> I"
| "wf_fo_intp (Forall n \<phi>) I \<longleftrightarrow> wf_fo_intp \<phi> I"

fun sat :: "('a, 'b) fo_fmla \<Rightarrow> ('a table, 'b) fo_intp \<Rightarrow> 'a val \<Rightarrow> bool" where
  "sat (Pred r ts) I \<sigma> \<longleftrightarrow> \<sigma> \<odot> ts \<in> I (r, length ts)"
| "sat (Bool b) I \<sigma> \<longleftrightarrow> b"
| "sat (Eqa t t') I \<sigma> \<longleftrightarrow> \<sigma> \<cdot> t = \<sigma> \<cdot> t'"
| "sat (Neg \<phi>) I \<sigma> \<longleftrightarrow> \<not>sat \<phi> I \<sigma>"
| "sat (Conj \<phi> \<psi>) I \<sigma> \<longleftrightarrow> sat \<phi> I \<sigma> \<and> sat \<psi> I \<sigma>"
| "sat (Disj \<phi> \<psi>) I \<sigma> \<longleftrightarrow> sat \<phi> I \<sigma> \<or> sat \<psi> I \<sigma>"
| "sat (Exists n \<phi>) I \<sigma> \<longleftrightarrow> (\<exists>x. sat \<phi> I (\<sigma>(n := x)))"
| "sat (Forall n \<phi>) I \<sigma> \<longleftrightarrow> (\<forall>x. sat \<phi> I (\<sigma>(n := x)))"

lemma sat_fv_cong: "(\<And>n. n \<in> fv_fo_fmla \<phi> \<Longrightarrow> \<sigma> n = \<sigma>' n) \<Longrightarrow>
  sat \<phi> I \<sigma> \<longleftrightarrow> sat \<phi> I \<sigma>'"
proof (induction \<phi> arbitrary: \<sigma> \<sigma>')
  case (Neg \<phi>)
  show ?case
    using Neg(1)[of \<sigma> \<sigma>'] Neg(2)
    by auto
next
  case (Conj \<phi> \<psi>)
  show ?case
    using Conj(1,2)[of \<sigma> \<sigma>'] Conj(3)
    by auto
next
  case (Disj \<phi> \<psi>)
  show ?case
    using Disj(1,2)[of \<sigma> \<sigma>'] Disj(3)
    by auto
next
  case (Exists n \<phi>)
  have "\<And>x. sat \<phi> I (\<sigma>(n := x)) = sat \<phi> I (\<sigma>'(n := x))"
    using Exists(2)
    by (auto intro!: Exists(1))
  then show ?case
    by simp
next
  case (Forall n \<phi>)
  have "\<And>x. sat \<phi> I (\<sigma>(n := x)) = sat \<phi> I (\<sigma>'(n := x))"
    using Forall(2)
    by (auto intro!: Forall(1))
  then show ?case
    by simp
qed (auto cong: eval_terms_cong eval_term_cong)

definition proj_sat :: "('a, 'b) fo_fmla \<Rightarrow> ('a table, 'b) fo_intp \<Rightarrow> 'a table" where
  "proj_sat \<phi> I = (\<lambda>\<sigma>. map \<sigma> (fv_fo_fmla_list \<phi>)) ` {\<sigma>. sat \<phi> I \<sigma>}"

end


(*  Title:       Data refinement of representation of a file
    Authors:     Karen Zee <kkz at mit.edu> and Viktor Kuncak <vkuncak at mit.edu>
    Maintainer:  Karen Zee <kkz at mit.edu>
    License:     LGPL
*)

section "Data refinement of representation of a file"
theory FileRefinement imports Complex_Main CArrays ResizableArrays begin

text \<open>
  We describe a file at
  two levels of abstraction: an abstract file, represented as a resizable array, and
  a concrete file, represented using data blocks.
  We consider the following operations:
\begin{verbatim}
makeAFS     :: AFile
afsRead     :: "AFile => nat \<rightharpoonup> byte"
afsWrite    :: "AFile => nat => byte \<rightharpoonup> AFile"
afsFileSize :: "AFile => nat"
\end{verbatim}
\<close>

typedecl
  \<comment> \<open>unit of file content\<close>
  byte
consts
  \<comment> \<open>value used for padding\<close>
  fillByte :: byte

axiomatization
  blockSize :: nat  \<comment> \<open>in bytes\<close> and
  numBlocks :: nat  \<comment> \<open>total number of blocks in the file system\<close>
where
  nonZeroBlockSize: "blockSize > 0" and
  nonZeroNumBlocks: "numBlocks > 0"

(* ------------------------------------------------------------ *)
subsection \<open>Abstract File\<close>

type_synonym AFile = "byte rArray" \<comment> \<open>abstract file is a resizable array of bytes\<close>

definition makeAF :: AFile
 where  \<comment> \<open>initial file has size 0\<close>
  "makeAF == (0, % index. fillByte)"

definition afSize :: "AFile => nat" where
  \<comment> \<open>file size is the length of the resizable array\<close>
  "afSize afile == fst afile"

definition afRead :: "AFile => nat \<rightharpoonup> byte" where
  \<comment> \<open>reading from a file looks up the byte, reporting @{term None} if the index is out of file bounds\<close>
  "afRead afile byteIndex ==
   if byteIndex < fst afile then Some ((snd afile) byteIndex) else None"

definition afWrite :: "AFile => nat => byte \<rightharpoonup> AFile" where
  \<comment> \<open>writing to a file updates the file content and extends the file if there is enough space\<close>
  "afWrite afile byteIndex value ==
   if byteIndex div blockSize < numBlocks then
     Some (raWrite afile byteIndex value fillByte)
   else None"

(* ------------------------------------------------------------ *)
subsection \<open>Concrete File\<close>

type_synonym Block = "byte cArray" \<comment> \<open>array of @{term blockSize} bytes\<close>

record CFile =
  fileSize      :: nat \<comment> \<open>in bytes\<close>
  nextFreeBlock :: nat \<comment> \<open>next block available for allocation\<close>
  data          :: "Block cArray" \<comment> \<open>array of up to @{term numBlocks} blocks\<close>

definition makeCF :: CFile
 where  \<comment> \<open>initial file has no allocated blocks\<close>
  "makeCF ==
   (| fileSize      = 0,
      nextFreeBlock = 0,
      data          = makeCArray numBlocks (makeCArray blockSize fillByte)
   |)"

definition cfSize :: "CFile => nat" where
  "cfSize cfile == fileSize cfile"

definition cfRead :: "CFile => nat \<rightharpoonup> byte" where
  \<comment> \<open>Looks up correct data block and reads its content,
        if byteIndex is within bounds, else returns None.\<close>
  "cfRead cfile byteIndex ==
   if byteIndex < fileSize cfile then
     (let i = byteIndex div blockSize in
       (let j = byteIndex mod blockSize in
         Some (readCArray (readCArray (data cfile) i) j)))
   else None"

subsubsection \<open>Writing File\<close>

text \<open>We first present some auxiliary operations.\<close>

definition cfWriteNoExtend :: "CFile => nat => byte => CFile" where
  \<comment> \<open>Writing to a file when
        @{term byteIndex} is within bounds.\<close>
  "cfWriteNoExtend cfile byteIndex value ==
   let i = byteIndex div blockSize in
     let j = byteIndex mod blockSize in
       let block = readCArray (data cfile) i in
         cfile(| data :=
                 writeCArray (data cfile) i (writeCArray block j value) |)"

definition cfExtendFile :: "CFile => nat => CFile" where
  \<comment> \<open>Writing to a file when
        @{term byteIndex} is out of bounds.  Involves
        allocating a new block.\<close>
  "cfExtendFile cfile byteIndex ==
     cfile(| fileSize := Suc byteIndex,
             nextFreeBlock := Suc (byteIndex div blockSize) |)"

text \<open>The main file write operation.\<close>

definition cfWrite :: "CFile => nat => byte \<rightharpoonup> CFile" where
  \<comment> \<open>Writes the file at byte location byteIndex, automatically extending
   the file to that byte location if byteIndex is not within bounds.\<close>
  "cfWrite cfile byteIndex value ==
     if byteIndex div blockSize < numBlocks then
       if byteIndex < fileSize cfile then
         Some (cfWriteNoExtend cfile byteIndex value)
       else
         Some (cfWriteNoExtend (cfExtendFile cfile byteIndex) byteIndex value)
     else None"

(* ---------------------------------------------------------------*)
subsection \<open>Reachability Invariants for Concrete File\<close>

definition nextFreeBlockInvariant :: "CFile => bool" where
  "nextFreeBlockInvariant state ==
   (fileSize state + blockSize - 1) div blockSize = nextFreeBlock state"

definition unallocatedBlocksInvariant :: "CFile => bool" where
  \<comment> \<open>This invariant of the implementation is needed to prove
   writeExtendCorrect. It says that any unallocated block contains
   fillByte's.\<close>
  "unallocatedBlocksInvariant state ==
   \<forall>blockNum i .
     ~ blockNum < nextFreeBlock state & blockNum < numBlocks & i < blockSize
     --> data state blockNum i = fillByte"

definition lastBlockInvariant :: "CFile => bool" where
  "lastBlockInvariant state ==
   \<forall>index .
     ~ index < fileSize state & nextFreeBlock state = index div blockSize + 1
     --> data state (index div blockSize) (index mod blockSize) = fillByte"

definition reachabilityInvariant :: "CFile => bool" where
  "reachabilityInvariant cfile ==
      nextFreeBlockInvariant cfile &
      unallocatedBlocksInvariant cfile &
      lastBlockInvariant cfile"

(* ---------------------------------------------------------------*)
subsection \<open>Initial File Satisfies Invariants\<close>

text \<open>We prove each invariant individually and then summarize.\<close>

lemma nextFreeBlockInvariant1:
  "nextFreeBlockInvariant makeCF"
apply (simp add: nextFreeBlockInvariant_def makeCF_def)
apply (simp add: nonZeroBlockSize)
done

lemma unallocatedBlocksInvariant1:
  "unallocatedBlocksInvariant makeCF"
apply (simp add: unallocatedBlocksInvariant_def makeCF_def)
apply (simp add: makeCArray_def)
done

lemma lastBlockInvariant1:
  "lastBlockInvariant makeCF"
by (simp add: lastBlockInvariant_def makeCF_def)

lemma makeCFpreserves: "reachabilityInvariant makeCF"
by (simp add: reachabilityInvariant_def
              nextFreeBlockInvariant1
              unallocatedBlocksInvariant1
              lastBlockInvariant1)

(* ---------------------------------------------------------------*)
subsection \<open>Properties of Concrete File Operations\<close>

lemma cfWriteNoExtendPreservesFileSize:
  "[| index < fileSize cfile1;
      cfWrite cfile1 index value = Some cfile2
   |] ==>
   fileSize cfile2 = fileSize cfile1"
apply (simp add: cfWrite_def)
apply (case_tac "index div blockSize < numBlocks", simp_all)
apply (simp add: cfWriteNoExtend_def Let_def)
apply force
done

lemma cfWriteExtendFileSize:
  "[| ~ index < fileSize cfile1;
      cfWrite cfile1 index value = Some cfile2
   |] ==> fileSize cfile2 = Suc index"
apply (simp add: cfWrite_def)
apply (case_tac "index div blockSize < numBlocks", simp_all)
apply (simp add: cfWriteNoExtend_def cfExtendFile_def Let_def)
apply force
done

lemma fileSizeIncreases:
  "cfWrite cfile1 index value = Some cfile2
   ==> fileSize cfile1 <= fileSize cfile2"
apply (simp add: cfWrite_def)
apply (case_tac "index div blockSize < numBlocks", simp_all)
apply (case_tac "index < fileSize cfile1", simp_all)
apply (simp_all add: cfWriteNoExtend_def cfExtendFile_def Let_def)
apply force
apply force
done

lemma nextFreeBlockIncreases:
  "[| nextFreeBlockInvariant cfile1;
      cfWrite cfile1 index value = Some cfile2
   |] ==> nextFreeBlock cfile1 <= nextFreeBlock cfile2"
apply (simp add: cfWrite_def)
apply (case_tac "index div blockSize < numBlocks", simp_all)
apply (case_tac "index < fileSize cfile1", simp_all)
apply (simp_all add: cfWriteNoExtend_def cfExtendFile_def Let_def)
apply force
apply (simp add: nextFreeBlockInvariant_def)
apply auto
apply hypsubst_thin
apply (subgoal_tac "nextFreeBlock cfile1 =
  (fileSize cfile1 + blockSize - Suc 0) div blockSize", simp_all)
apply (subgoal_tac "Suc (index div blockSize) =
  (index + blockSize) div blockSize", simp)
apply (subgoal_tac "(fileSize cfile1 + blockSize - Suc 0) <=
  (index + blockSize)", simp add: div_le_mono)
apply (subgoal_tac "(fileSize cfile1 + blockSize - Suc 0) <
  (fileSize cfile1 + blockSize)", simp)
apply (simp_all add: nonZeroBlockSize)
done

(* ---------------------------------------------------------------*)
subsection \<open>Concrete File Operations Preserve Invariants\<close>

text \<open>There is only one top-level concrete operation: write, and we
show that it preserves all reachability invariants.\<close>

lemma cfWritePreservesNextFreeBlockInvariant:
   "[| reachabilityInvariant cfile1;
       cfWrite cfile1 byteIndex value = Some cfile2
    |] ==> nextFreeBlockInvariant cfile2"
apply (simp add: reachabilityInvariant_def
                 cfWrite_def
                 nextFreeBlockInvariant_def)
apply (case_tac "byteIndex div blockSize < numBlocks", simp_all)
apply (case_tac "byteIndex < fileSize cfile1", simp_all)
apply (simp_all add: cfWriteNoExtend_def cfExtendFile_def Let_def)
apply auto
apply (simp add: nonZeroBlockSize)
done

lemma modInequalityLemma:
  "(a::nat) ~= b & a mod c = b mod c ==> a div c ~= b div c"
apply auto
apply (insert div_mult_mod_eq [of "a" "c"])
apply (insert div_mult_mod_eq [of "b" "c"])
apply simp
done

lemma mod_round_lt:
  "[| 0 < (c::nat);
      a < b
   |] ==> a div c < (b + c - 1) div c"
apply (subgoal_tac "a <= b - 1")
apply (subgoal_tac "a div c <= (b - 1) div c")
apply (insert div_add_self2 [of c "b - 1"])
apply (simp)
apply (simp add: div_le_mono)
apply (insert less_Suc_eq_le [of a "b - 1"])
apply simp
done

lemma blockNumNELemma:
  "!!blockNum i.
       [| nextFreeBlockInvariant cfile1;
          cfile1
          (| data :=
               writeCArray (data cfile1) (byteIndex div blockSize)
                (writeCArray
                  (readCArray (data cfile1) (byteIndex div blockSize))
                  (byteIndex mod blockSize) value) |) =
          cfile2;
          ~ blockNum < nextFreeBlock cfile2; blockNum < numBlocks;
          i < blockSize; byteIndex div blockSize < numBlocks;
          byteIndex < fileSize cfile1 |]
       ==> blockNum ~= byteIndex div blockSize"
apply (simp add: nextFreeBlockInvariant_def)
apply (subgoal_tac "byteIndex div blockSize < nextFreeBlock cfile1")
apply force
apply (subgoal_tac "nextFreeBlock cfile1 =
  (fileSize cfile1 + blockSize - Suc 0) div blockSize", simp_all)
apply (insert mod_round_lt)
apply force
done

lemma cfWritePreservesUnallocatedBlocksInvariant:
   "[| reachabilityInvariant cfile1;
       cfWrite cfile1 byteIndex value = Some cfile2
    |] ==> unallocatedBlocksInvariant cfile2"
apply (simp add: reachabilityInvariant_def)
apply (subgoal_tac "nextFreeBlock cfile1 <= nextFreeBlock cfile2")
apply (simp add: unallocatedBlocksInvariant_def cfWrite_def)
apply auto
apply (case_tac "byteIndex div blockSize < numBlocks", simp_all)
apply (case_tac "byteIndex < fileSize cfile1", simp_all)
apply (simp_all add: cfWriteNoExtend_def cfExtendFile_def Let_def)
apply (simp_all add: writeCArray_def readCArray_def)
apply (subgoal_tac "blockNum ~= byteIndex div blockSize")
apply force
apply (simp add: blockNumNELemma)
apply (subgoal_tac "~ blockNum < nextFreeBlock cfile1")
apply (subgoal_tac "blockNum ~= byteIndex div blockSize")
apply auto
apply (simp add: nextFreeBlockIncreases)
done

lemma cfWritePreservesLastBlockInvariant:
   "[| reachabilityInvariant cfile1;
       cfWrite cfile1 byteIndex value = Some cfile2 |] ==>
    lastBlockInvariant cfile2"
apply (simp add: reachabilityInvariant_def)
apply (subgoal_tac "nextFreeBlock cfile1 <= nextFreeBlock cfile2")
apply (simp add: cfWrite_def)
apply (simp (no_asm) add: lastBlockInvariant_def)
apply auto
apply (case_tac "byteIndex div blockSize < numBlocks", simp_all)
apply (case_tac "byteIndex < fileSize cfile1", simp_all)
apply (simp_all add: cfWriteNoExtend_def Let_def cfExtendFile_def)
apply (simp_all add: writeCArray_def readCArray_def)
apply (simp add: lastBlockInvariant_def)
apply (subgoal_tac "index ~= byteIndex")
apply (case_tac "index div blockSize ~= byteIndex div blockSize")
apply force
apply (subgoal_tac "index mod blockSize ~= byteIndex mod blockSize")
apply force
apply (insert modInequalityLemma)
apply force
apply force
apply (subgoal_tac "index ~= byteIndex")
apply (case_tac "index div blockSize ~= byteIndex div blockSize", simp_all)
apply force
apply (subgoal_tac "index mod blockSize ~= byteIndex mod blockSize")
apply (case_tac "nextFreeBlock cfile1 = Suc (index div blockSize)")
apply (subgoal_tac "~ index < fileSize cfile1")
apply (simp add: lastBlockInvariant_def)
apply auto
apply (simp add: unallocatedBlocksInvariant_def)
apply (erule_tac x="index div blockSize" in allE)
apply (erule_tac x="index mod blockSize" in allE)
apply (simp add: nonZeroBlockSize)
apply (insert modInequalityLemma)
apply auto
apply (simp add: nextFreeBlockIncreases)
done

text \<open>Final statement that all invariants are preserved.\<close>
lemma cfWritePreserves:
   "[| reachabilityInvariant cfile1;
       cfWrite cfile1 byteIndex value = Some cfile2 |] ==>
    reachabilityInvariant cfile2"
apply (simp (no_asm) add: reachabilityInvariant_def)
apply (simp add: cfWritePreservesNextFreeBlockInvariant)
apply (simp add: cfWritePreservesUnallocatedBlocksInvariant)
apply (simp add: cfWritePreservesLastBlockInvariant)
done

(* ---------------------------------------------------------------*)
subsection \<open>Commuting Diagrams for Simulation Relation\<close>

text \<open>Here we show correctness of file system operations.\<close>

(* ---------------------------------------------------------------*)
subsubsection \<open>Abstraction Function\<close>

definition abstFn :: "CFile => AFile" where
  "abstFn cfile == (fileSize cfile,
                    % index . case cfRead cfile index of
                                None       => fillByte
                              | Some value => value)"

primrec oAbstFn :: "CFile option => AFile option" where
  "oAbstFn None = None"
| "oAbstFn (Some s) = Some (abstFn s)"

(* ---------------------------------------------------------------*)
subsubsection \<open>Creating a File\<close>

lemma makeCFCorrect: "abstFn makeCF = makeAF"
by (simp add: makeCF_def makeAF_def abstFn_def cfRead_def
    split: bool.splits option.splits)

subsubsection \<open>File Size\<close>

lemma fileSizeCorrect:
  "cfSize cfile = afSize (abstFn cfile)"
by (simp add: cfSize_def afSize_def abstFn_def)

subsubsection \<open>Read Operation\<close>

lemma readCorrect:
  "cfRead cfile = afRead (abstFn cfile)"
apply (simp add: abstFn_def)
apply (rule ext)
apply (simp add: cfRead_def afRead_def Let_def)
done

subsubsection \<open>Write Operation\<close>

lemma writeNoExtendCorrect:
  "[| index < fileSize cfile1;
      Some cfile2 = cfWrite cfile1 index value
   |] ==> Some (abstFn cfile2) = afWrite (abstFn cfile1) index value"
apply (simp add: abstFn_def afWrite_def raWrite_def Let_def cfWrite_def)
apply (case_tac "index div blockSize < numBlocks", simp_all)
apply (simp_all add: cfWriteNoExtend_def Let_def)
apply (rule ext)
apply (simp add: cfRead_def writeCArray_def readCArray_def Let_def)
apply (case_tac "indexa < fileSize cfile1", simp_all)
apply (case_tac "indexa = index", simp_all)
apply (case_tac "indexa mod blockSize = index mod blockSize", simp_all)
apply (subgoal_tac "indexa div blockSize ~= index div blockSize", simp_all)
apply (simp_all add: modInequalityLemma)
done

lemma writeFailCorrect:
  "cfWrite cfile1 index value = None ==>
   afWrite (abstFn cfile1) index value = None"
apply (simp add: abstFn_def cfWrite_def afWrite_def)
apply (case_tac "index div blockSize < numBlocks", simp_all)
apply (case_tac "index < fileSize cfile1", simp_all)
done

lemma writeCorrect:
  "reachabilityInvariant cfile1 ==>
   oAbstFn (cfWrite cfile1 index value) = afWrite (abstFn cfile1) index value"
apply (simp add: reachabilityInvariant_def)
apply (case_tac "cfWrite cfile1 index value")
apply (simp add: writeFailCorrect)
apply (simp add: writeSucceedCorrect)
done

end


(* Author: Xingyuan Zhang, Chunhan Wu, Christian Urban *)

theory Myhill
  imports Myhill_2 "../Regular-Sets/Derivatives"
begin

section {* The theorem *}

theorem Myhill_Nerode:
  fixes A::"('a::finite) lang"
  shows "(\<exists>r. A = lang r) \<longleftrightarrow> finite (UNIV // \<approx>A)"
using Myhill_Nerode1 Myhill_Nerode2 by auto

subsection {* Second direction proved using partial derivatives *}

text {*
  An alternaive proof using the notion of partial derivatives for regular
  expressions due to Antimirov \cite{Antimirov95}.
*}

lemma MN_Rel_Derivs:
  shows "x \<approx>A y \<longleftrightarrow> Derivs x A = Derivs y A"
unfolding Derivs_def str_eq_def
by auto

lemma Myhill_Nerode3:
  fixes r::"'a rexp"
  shows "finite (UNIV // \<approx>(lang r))"
proof -
  have "finite (UNIV // =(\<lambda>x. pderivs x r)=)"
  proof -
    have "range (\<lambda>x. pderivs x r) \<subseteq> Pow (pderivs_lang UNIV r)"
      unfolding pderivs_lang_def by auto
    moreover
    have "finite (Pow (pderivs_lang UNIV r))" by (simp add: finite_pderivs_lang)
    ultimately
    have "finite (range (\<lambda>x. pderivs x r))"
      by (simp add: finite_subset)
    then show "finite (UNIV // =(\<lambda>x. pderivs x r)=)"
      by (rule finite_eq_tag_rel)
  qed
  moreover
  have "=(\<lambda>x. pderivs x r)= \<subseteq> \<approx>(lang r)"
    unfolding tag_eq_def
    by (auto simp add: MN_Rel_Derivs Derivs_pderivs)
  moreover
  have "equiv UNIV =(\<lambda>x. pderivs x r)="
  and  "equiv UNIV (\<approx>(lang r))"
    unfolding equiv_def refl_on_def sym_def trans_def
    unfolding tag_eq_def str_eq_def
    by auto
  ultimately show "finite (UNIV // \<approx>(lang r))"
    by (rule refined_partition_finite)
qed

end


(*  Title:      ZF/AC/AC16_lemmas.thy
    Author:     Krzysztof Grabczewski

Lemmas used in the proofs concerning AC16
*)

theory AC16_lemmas
imports AC_Equiv Hartog Cardinal_aux
begin

lemma cons_Diff_eq: "a\<notin>A ==> cons(a,A)-{a}=A"
by fast

lemma nat_1_lepoll_iff: "1\<lesssim>X \<longleftrightarrow> (\<exists>x. x \<in> X)"
apply (unfold lepoll_def)
apply (rule iffI)
apply (fast intro: inj_is_fun [THEN apply_type])
apply (erule exE)
apply (rule_tac x = "\<lambda>a \<in> 1. x" in exI)
apply (fast intro!: lam_injective)
done

lemma eqpoll_1_iff_singleton: "X\<approx>1 \<longleftrightarrow> (\<exists>x. X={x})"
apply (rule iffI)
apply (erule eqpollE)
apply (drule nat_1_lepoll_iff [THEN iffD1])
apply (fast intro!: lepoll_1_is_sing)
apply (fast intro!: singleton_eqpoll_1)
done

lemma cons_eqpoll_succ: "[| x\<approx>n; y\<notin>x |] ==> cons(y,x)\<approx>succ(n)"
apply (unfold succ_def)
apply (fast elim!: cons_eqpoll_cong mem_irrefl)
done

lemma subsets_eqpoll_1_eq: "{Y \<in> Pow(X). Y\<approx>1} = {{x}. x \<in> X}"
apply (rule equalityI)
apply (rule subsetI)
apply (erule CollectE)
apply (drule eqpoll_1_iff_singleton [THEN iffD1])
apply (fast intro!: RepFunI)
apply (rule subsetI)
apply (erule RepFunE)
apply (rule CollectI, fast)
apply (fast intro!: singleton_eqpoll_1)
done

lemma eqpoll_RepFun_sing: "X\<approx>{{x}. x \<in> X}"
apply (unfold eqpoll_def bij_def)
apply (rule_tac x = "\<lambda>x \<in> X. {x}" in exI)
apply (rule IntI)
apply (unfold inj_def surj_def, simp)
apply (fast intro!: lam_type RepFunI intro: singleton_eq_iff [THEN iffD1], simp)
apply (fast intro!: lam_type)
done

lemma subsets_eqpoll_1_eqpoll: "{Y \<in> Pow(X). Y\<approx>1}\<approx>X"
apply (rule subsets_eqpoll_1_eq [THEN ssubst])
apply (rule eqpoll_RepFun_sing [THEN eqpoll_sym])
done

lemma InfCard_Least_in:
     "[| InfCard(x); y \<subseteq> x; y \<approx> succ(z) |] ==> (\<mu> i. i \<in> y) \<in> y"
apply (erule eqpoll_sym [THEN eqpoll_imp_lepoll,
                         THEN succ_lepoll_imp_not_empty, THEN not_emptyE])
apply (fast intro: LeastI
            dest!: InfCard_is_Card [THEN Card_is_Ord]
            elim: Ord_in_Ord)
done

lemma subsets_lepoll_lemma1:
     "[| InfCard(x); n \<in> nat |]
      ==> {y \<in> Pow(x). y\<approx>succ(succ(n))} \<lesssim> x*{y \<in> Pow(x). y\<approx>succ(n)}"
apply (unfold lepoll_def)
apply (rule_tac x = "\<lambda>y \<in> {y \<in> Pow(x) . y\<approx>succ (succ (n))}.
                      <\<mu> i. i \<in> y, y-{\<mu> i. i \<in> y}>" in exI)
apply (rule_tac d = "%z. cons (fst(z), snd(z))" in lam_injective)
 apply (blast intro!: Diff_sing_eqpoll intro: InfCard_Least_in)
apply (simp, blast intro: InfCard_Least_in)
done

lemma set_of_Ord_succ_Union: "(\<forall>y \<in> z. Ord(y)) ==> z \<subseteq> succ(\<Union>(z))"
apply (rule subsetI)
apply (case_tac "\<forall>y \<in> z. y \<subseteq> x", blast )
apply (simp, erule bexE)
apply (rule_tac i=y and j=x in Ord_linear_le)
apply (blast dest: le_imp_subset elim: leE ltE)+
done

lemma subset_not_mem: "j \<subseteq> i ==> i \<notin> j"
by (fast elim!: mem_irrefl)

lemma succ_Union_not_mem:
     "(!!y. y \<in> z ==> Ord(y)) ==> succ(\<Union>(z)) \<notin> z"
apply (rule set_of_Ord_succ_Union [THEN subset_not_mem], blast)
done

lemma Union_cons_eq_succ_Union:
     "\<Union>(cons(succ(\<Union>(z)),z)) = succ(\<Union>(z))"
by fast

lemma Un_Ord_disj: "[| Ord(i); Ord(j) |] ==> i \<union> j = i | i \<union> j = j"
by (fast dest!: le_imp_subset elim: Ord_linear_le)

lemma Union_eq_Un: "x \<in> X ==> \<Union>(X) = x \<union> \<Union>(X-{x})"
by fast

lemma Union_in_lemma [rule_format]:
     "n \<in> nat ==> \<forall>z. (\<forall>y \<in> z. Ord(y)) & z\<approx>n & z\<noteq>0 \<longrightarrow> \<Union>(z) \<in> z"
apply (induct_tac "n")
apply (fast dest!: eqpoll_imp_lepoll [THEN lepoll_0_is_0])
apply (intro allI impI)
apply (erule natE)
apply (fast dest!: eqpoll_1_iff_singleton [THEN iffD1]
            intro!: Union_singleton, clarify)
apply (elim not_emptyE)
apply (erule_tac x = "z-{xb}" in allE)
apply (erule impE)
apply (fast elim!: Diff_sing_eqpoll
                   Diff_sing_eqpoll [THEN eqpoll_succ_imp_not_empty])
apply (subgoal_tac "xb \<union> \<Union>(z - {xb}) \<in> z")
apply (simp add: Union_eq_Un [symmetric])
apply (frule bspec, assumption)
apply (drule bspec)
apply (erule Diff_subset [THEN subsetD])
apply (drule Un_Ord_disj, assumption, auto)
done

lemma Union_in: "[| \<forall>x \<in> z. Ord(x); z\<approx>n; z\<noteq>0; n \<in> nat |] ==> \<Union>(z) \<in> z"
by (blast intro: Union_in_lemma)

lemma succ_Union_in_x:
     "[| InfCard(x); z \<in> Pow(x); z\<approx>n; n \<in> nat |] ==> succ(\<Union>(z)) \<in> x"
apply (rule Limit_has_succ [THEN ltE])
prefer 3 apply assumption
apply (erule InfCard_is_Limit)
apply (case_tac "z=0")
apply (simp, fast intro!: InfCard_is_Limit [THEN Limit_has_0])
apply (rule ltI [OF PowD [THEN subsetD] InfCard_is_Card [THEN Card_is_Ord]], assumption)
apply (blast intro: Union_in
                    InfCard_is_Card [THEN Card_is_Ord, THEN Ord_in_Ord])+
done

lemma succ_lepoll_succ_succ:
     "[| InfCard(x); n \<in> nat |]
      ==> {y \<in> Pow(x). y\<approx>succ(n)} \<lesssim> {y \<in> Pow(x). y\<approx>succ(succ(n))}"
apply (unfold lepoll_def)
apply (rule_tac x = "\<lambda>z \<in> {y\<in>Pow(x). y\<approx>succ(n)}. cons(succ(\<Union>(z)), z)"
       in exI)
apply (rule_tac d = "%z. z-{\<Union>(z) }" in lam_injective)
apply (blast intro!: succ_Union_in_x succ_Union_not_mem
             intro: cons_eqpoll_succ Ord_in_Ord
             dest!: InfCard_is_Card [THEN Card_is_Ord])
apply (simp only: Union_cons_eq_succ_Union)
apply (rule cons_Diff_eq)
apply (fast dest!: InfCard_is_Card [THEN Card_is_Ord]
            elim: Ord_in_Ord
            intro!: succ_Union_not_mem)
done

lemma subsets_eqpoll_X:
     "[| InfCard(X); n \<in> nat |] ==> {Y \<in> Pow(X). Y\<approx>succ(n)} \<approx> X"
apply (induct_tac "n")
apply (rule subsets_eqpoll_1_eqpoll)
apply (rule eqpollI)
apply (rule subsets_lepoll_lemma1 [THEN lepoll_trans], assumption+)
apply (rule eqpoll_trans [THEN eqpoll_imp_lepoll])
 apply (erule eqpoll_refl [THEN prod_eqpoll_cong])
apply (erule InfCard_square_eqpoll)
apply (fast elim: eqpoll_sym [THEN eqpoll_imp_lepoll, THEN lepoll_trans]
            intro!: succ_lepoll_succ_succ)
done

lemma image_vimage_eq:
     "[| f \<in> surj(A,B); y \<subseteq> B |] ==> f``(converse(f)``y) = y"
apply (unfold surj_def)
apply (fast dest: apply_equality2 elim: apply_iff [THEN iffD2])
done

lemma vimage_image_eq: "[| f \<in> inj(A,B); y \<subseteq> A |] ==> converse(f)``(f``y) = y"
by (fast elim!: inj_is_fun [THEN apply_Pair] dest: inj_equality)

lemma subsets_eqpoll:
     "A\<approx>B ==> {Y \<in> Pow(A). Y\<approx>n}\<approx>{Y \<in> Pow(B). Y\<approx>n}"
apply (unfold eqpoll_def)
apply (erule exE)
apply (rule_tac x = "\<lambda>X \<in> {Y \<in> Pow (A) . \<exists>f. f \<in> bij (Y, n) }. f``X" in exI)
apply (rule_tac d = "%Z. converse (f) ``Z" in lam_bijective)
apply (fast intro!: bij_is_inj [THEN restrict_bij, THEN bij_converse_bij,
                                THEN comp_bij]
            elim!: bij_is_fun [THEN fun_is_rel, THEN image_subset])
apply (blast intro!:  bij_is_inj [THEN restrict_bij]
                      comp_bij bij_converse_bij
                      bij_is_fun [THEN fun_is_rel, THEN image_subset])
apply (fast elim!: bij_is_inj [THEN vimage_image_eq])
apply (fast elim!: bij_is_surj [THEN image_vimage_eq])
done

lemma WO2_imp_ex_Card: "WO2 ==> \<exists>a. Card(a) & X\<approx>a"
apply (unfold WO2_def)
apply (drule spec [of _ X])
apply (blast intro: Card_cardinal eqpoll_trans
          well_ord_Memrel [THEN well_ord_cardinal_eqpoll, THEN eqpoll_sym])
done

lemma lepoll_infinite: "[| X\<lesssim>Y; ~Finite(X) |] ==> ~Finite(Y)"
by (blast intro: lepoll_Finite)

lemma infinite_Card_is_InfCard: "[| ~Finite(X); Card(X) |] ==> InfCard(X)"
apply (unfold InfCard_def)
apply (fast elim!: Card_is_Ord [THEN nat_le_infinite_Ord])
done

lemma WO2_infinite_subsets_eqpoll_X: "[| WO2; n \<in> nat; ~Finite(X) |]
        ==> {Y \<in> Pow(X). Y\<approx>succ(n)}\<approx>X"
apply (drule WO2_imp_ex_Card)
apply (elim allE exE conjE)
apply (frule eqpoll_imp_lepoll [THEN lepoll_infinite], assumption)
apply (drule infinite_Card_is_InfCard, assumption)
apply (blast intro: subsets_eqpoll subsets_eqpoll_X eqpoll_sym eqpoll_trans)
done

lemma well_ord_imp_ex_Card: "well_ord(X,R) ==> \<exists>a. Card(a) & X\<approx>a"
by (fast elim!: well_ord_cardinal_eqpoll [THEN eqpoll_sym]
         intro!: Card_cardinal)

lemma well_ord_infinite_subsets_eqpoll_X:
     "[| well_ord(X,R); n \<in> nat; ~Finite(X) |] ==> {Y \<in> Pow(X). Y\<approx>succ(n)}\<approx>X"
apply (drule well_ord_imp_ex_Card)
apply (elim allE exE conjE)
apply (frule eqpoll_imp_lepoll [THEN lepoll_infinite], assumption)
apply (drule infinite_Card_is_InfCard, assumption)
apply (blast intro: subsets_eqpoll subsets_eqpoll_X eqpoll_sym eqpoll_trans)
done

end


(*  Title:      HOL/MicroJava/BV/Product.thy
    Author:     Tobias Nipkow
    Copyright   2000 TUM

Products as semilattices.
*)

section \<open>Products as Semilattices\<close>

theory Product
imports Err
begin

definition le :: "'a ord \<Rightarrow> 'b ord \<Rightarrow> ('a \<times> 'b) ord"
where
  "le r\<^sub>A r\<^sub>B = (\<lambda>(a\<^sub>1,b\<^sub>1) (a\<^sub>2,b\<^sub>2). a\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>A\<^esub> a\<^sub>2 \<and> b\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>B\<^esub> b\<^sub>2)"

definition sup :: "'a ebinop \<Rightarrow> 'b ebinop \<Rightarrow> ('a \<times> 'b) ebinop"
where
  "sup f g = (\<lambda>(a\<^sub>1,b\<^sub>1)(a\<^sub>2,b\<^sub>2). Err.sup Pair (a\<^sub>1 \<squnion>\<^sub>f a\<^sub>2) (b\<^sub>1 \<squnion>\<^sub>g b\<^sub>2))"

definition esl :: "'a esl \<Rightarrow> 'b esl \<Rightarrow> ('a \<times> 'b ) esl"
where
  "esl = (\<lambda>(A,r\<^sub>A,f\<^sub>A) (B,r\<^sub>B,f\<^sub>B). (A \<times> B, le r\<^sub>A r\<^sub>B, sup f\<^sub>A f\<^sub>B))"

abbreviation
  lesubprod :: "'a \<times> 'b \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool"
    ("(_ /\<sqsubseteq>'(_,_') _)" [50, 0, 0, 51] 50) where
  "p \<sqsubseteq>(rA,rB) q == p \<sqsubseteq>\<^bsub>Product.le rA rB\<^esub> q"

(*<*)
notation
  lesubprod  ("(_ /<='(_,_') _)" [50, 0, 0, 51] 50)
(*>*)

lemma unfold_lesub_prod: "x \<sqsubseteq>(r\<^sub>A,r\<^sub>B) y = le r\<^sub>A r\<^sub>B x y"
(*<*) by (simp add: lesub_def) (*>*)

lemma le_prod_Pair_conv [iff]: "((a\<^sub>1,b\<^sub>1) \<sqsubseteq>(r\<^sub>A,r\<^sub>B) (a\<^sub>2,b\<^sub>2)) = (a\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>A\<^esub> a\<^sub>2 & b\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>B\<^esub> b\<^sub>2)"
(*<*) by (simp add: lesub_def le_def) (*>*)

lemma less_prod_Pair_conv:
  "((a\<^sub>1,b\<^sub>1) \<sqsubset>\<^bsub>Product.le r\<^sub>A r\<^sub>B\<^esub> (a\<^sub>2,b\<^sub>2)) =
  (a\<^sub>1 \<sqsubset>\<^bsub>r\<^sub>A\<^esub> a\<^sub>2 & b\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>B\<^esub> b\<^sub>2 | a\<^sub>1 \<sqsubseteq>\<^bsub>r\<^sub>A\<^esub> a\<^sub>2 & b\<^sub>1 \<sqsubset>\<^bsub>r\<^sub>B\<^esub> b\<^sub>2)"
(*<*)
apply (unfold lesssub_def)
apply simp
apply blast
done
(*>*)

lemma order_le_prod [iff]: "order(Product.le r\<^sub>A r\<^sub>B) = (order r\<^sub>A & order r\<^sub>B)"
(*<*)
apply (unfold order_def)
apply simp
apply safe
apply blast+
done
(*>*)

lemma acc_le_prodI [intro!]:
  "\<lbrakk> acc A r\<^sub>A; acc B r\<^sub>B \<rbrakk> \<Longrightarrow> acc (A \<times> B) (Product.le r\<^sub>A r\<^sub>B)"
(*<*)
apply (unfold acc_def)
apply (rule wf_subset)
 apply (erule wf_lex_prod)
 apply assumption
apply (auto simp add: lesssub_def less_prod_Pair_conv lex_prod_def)
done
(*>*)

lemma unfold_plussub_lift2: "e\<^sub>1 \<squnion>\<^bsub>lift2 f\<^esub> e\<^sub>2 = lift2 f e\<^sub>1 e\<^sub>2"
(*<*) by (simp add: plussub_def) (*>*)

lemma plus_eq_Err_conv [simp]:
  assumes "x\<in>A"  "y\<in>A"  "semilat(err A, Err.le r, lift2 f)"
  shows "(x \<squnion>\<^sub>f y = Err) = (\<not>(\<exists>z\<in>A. x \<sqsubseteq>\<^sub>r z \<and> y \<sqsubseteq>\<^sub>r z))"
(*<*)
proof -
  have plus_le_conv2:
    "\<And>r f z. \<lbrakk> z \<in> err A; semilat (err A, r, f); OK x \<in> err A; OK y \<in> err A;
                 OK x \<squnion>\<^sub>f OK y \<sqsubseteq>\<^sub>r z\<rbrakk> \<Longrightarrow> OK x \<sqsubseteq>\<^sub>r z \<and> OK y \<sqsubseteq>\<^sub>r z"
(*<*) by (rule Semilat.plus_le_conv [OF Semilat.intro, THEN iffD1]) (*>*)
  from assms show ?thesis
  apply (rule_tac iffI)
   apply clarify
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule OK_le_err_OK [THEN iffD2])
   apply (drule Semilat.lub[OF Semilat.intro, of _ _ _ "OK x" _ "OK y"])
        apply assumption
       apply assumption
      apply simp
     apply simp
    apply simp
   apply simp
  apply (case_tac "x \<squnion>\<^sub>f y")
   apply assumption
  apply (rename_tac "z")
  apply (subgoal_tac "OK z: err A")
  apply (frule plus_le_conv2)
       apply assumption
      apply simp
      apply blast
     apply simp
    apply (blast dest: Semilat.orderI [OF Semilat.intro] order_refl)
   apply blast
  apply (erule subst)
  apply (unfold semilat_def err_def' closed_def)
  apply simp
  done
qed
(*>*)

lemma err_semilat_Product_esl:
  "\<And>L\<^sub>1 L\<^sub>2. \<lbrakk> err_semilat L\<^sub>1; err_semilat L\<^sub>2 \<rbrakk> \<Longrightarrow> err_semilat(Product.esl L\<^sub>1 L\<^sub>2)"
(*<*)
apply (unfold esl_def Err.sl_def)
apply (simp (no_asm_simp) only: split_tupled_all)
apply simp
apply (simp (no_asm) only: semilat_Def)
apply (simp (no_asm_simp) only: Semilat.closedI [OF Semilat.intro] closed_lift2_sup)
apply (simp (no_asm) only: unfold_lesub_err Err.le_def unfold_plussub_lift2 sup_def)
apply (auto elim: semilat_le_err_OK1 semilat_le_err_OK2
            simp add: lift2_def  split: err.split)
apply (blast dest: Semilat.orderI [OF Semilat.intro])
apply (blast dest: Semilat.orderI [OF Semilat.intro])

apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp

apply (rule OK_le_err_OK [THEN iffD1])
apply (erule subst, subst OK_lift2_OK [symmetric], rule Semilat.lub [OF Semilat.intro])
apply simp
apply simp
apply simp
apply simp
apply simp
apply simp
done
(*>*)

end


(* Author: Tobias Nipkow *)

theory Hoare_Examples imports Hoare begin

text{* Summing up the first @{text x} natural numbers in variable @{text y}. *}

fun sum :: "int \<Rightarrow> int" where
"sum i = (if i \<le> 0 then 0 else sum (i - 1) + i)"

lemma sum_simps[simp]:
  "0 < i \<Longrightarrow> sum i = sum (i - 1) + i"
  "i \<le> 0 \<Longrightarrow> sum i = 0"
by(simp_all)

declare sum.simps[simp del]

abbreviation "wsum ==
  WHILE Less (N 0) (V ''x'')
  DO (''y'' ::= Plus (V ''y'') (V ''x'');;
      ''x'' ::= Plus (V ''x'') (N (- 1)))"

subsubsection{* Proof by Operational Semantics *}

text{* The behaviour of the loop is proved by induction: *}

lemma while_sum:
  "(wsum, s) \<Rightarrow> t \<Longrightarrow> t ''y'' = s ''y'' + sum(s ''x'')"
apply(induction wsum s t rule: big_step_induct)
apply(auto)
done

text{* We were lucky that the proof was automatic, except for the
induction. In general, such proofs will not be so easy. The automation is
partly due to the right inversion rules that we set up as automatic
elimination rules that decompose big-step premises.

Now we prefix the loop with the necessary initialization: *}

lemma sum_via_bigstep:
  assumes "(''y'' ::= N 0;; wsum, s) \<Rightarrow> t"
  shows "t ''y'' = sum (s ''x'')"
proof -
  from assms have "(wsum,s(''y'':=0)) \<Rightarrow> t" by auto
  from while_sum[OF this] show ?thesis by simp
qed

subsubsection{* Proof by Hoare Logic *}

text{* Note that we deal with sequences of commands from right to left,
pulling back the postcondition towards the precondition. *}

lemma "\<Turnstile> {\<lambda>s. s ''x'' = n} ''y'' ::= N 0;; wsum {\<lambda>s. s ''y'' = sum n}"
  apply (rule conseq_pre_rule)
    apply(rule seq_rule)
      apply(rule while_rule [where P = "\<lambda>s. (s ''y'' = sum n - sum(s ''x''))"])
        apply (rule seq_rule)
          apply (rule assign_rule)
          apply (rule assign_rule)

        apply simp (* vc 1: invariant preservation *)
        apply simp (* vc 2: I \<and> \<not>b \<Longrightarrow> Q *)

      apply (rule assign_rule)

    apply simp (* vc 3: Precondition implies generated precondition *)
  done

text{* The proof is intentionally an apply script because it merely composes
the rules of Hoare logic. Of course, in a few places side conditions have to
be proved. But since those proofs are 1-liners, a structured proof is
overkill. In fact, we shall learn later that the application of the Hoare
rules can be automated completely and all that is left for the user is to
provide the loop invariants and prove the side-conditions. *}

end


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

section\<open>Code Cayley Hamilton\<close>

theory Code_Cayley_Hamilton
  imports
  "HOL-Computational_Algebra.Polynomial"
  Cayley_Hamilton_Compatible
  Gauss_Jordan.Code_Matrix
begin

subsection\<open>Code equations for the definitions presented in the Cayley-Hamilton development\<close>

definition "scalar_matrix_mult_row c A i = (\<chi> j. c * (A $ i $ j))"

lemma scalar_matrix_mult_row_code [code abstract]:
  "vec_nth (scalar_matrix_mult_row c A i) =(% j. c * (A $ i $ j))"
  by(simp add: scalar_matrix_mult_row_def fun_eq_iff)

lemma scalar_matrix_mult_code [code abstract]: "vec_nth (c *k A)  = scalar_matrix_mult_row c A"
  unfolding matrix_scalar_mult_def scalar_matrix_mult_row_def[abs_def]
  using vec_lambda_beta by auto

definition "minorM_row A i j k=  vec_lambda (%l. if k = i \<and> l = j then 1 else
  if k = i \<or> l = j then 0 else A$k$l)"

lemma minorM_row_code [code abstract]:
  "vec_nth (minorM_row A i j k) =(%l. if k = i \<and> l = j then 1 else
  if k = i \<or> l = j then 0 else A$k$l)"
  by(simp add: minorM_row_def fun_eq_iff)

lemma minorM_code [code abstract]: "vec_nth (minorM A i j) = minorM_row A i j"
  unfolding minorM_def by transfer (auto simp: vec_eq_iff fun_eq_iff minorM_row_def)

definition "cofactorM_row A i = vec_lambda (\<lambda>j. cofactorM A $ i $ j)"

lemma cofactorM_row_code [code abstract]: "vec_nth (cofactorM_row A i) = cofactor A i"
  by (simp add: fun_eq_iff cofactorM_row_def cofactor_def cofactorM_def)

lemma cofactorM_code [code abstract]: "vec_nth (cofactorM A) = cofactorM_row A"
  by (simp add: fun_eq_iff cofactorM_row_def vec_eq_iff)

lemmas cofactor_def[code_unfold]

definition mat2matofpoly_row
  where "mat2matofpoly_row A i = vec_lambda (\<lambda>j. [: A $ i $ j :])"

lemma mat2matofpoly_row_code [code abstract]:
  "vec_nth (mat2matofpoly_row A i) = (%j. [: A $ i $ j :])"
  unfolding mat2matofpoly_row_def by auto

lemma [code abstract]: "vec_nth (mat2matofpoly k) = mat2matofpoly_row k"
  unfolding mat2matofpoly_def unfolding mat2matofpoly_row_def[abs_def] by auto

primrec matpow :: "'a::semiring_1^'n^'n \<Rightarrow> nat \<Rightarrow> 'a^'n^'n" where
  matpow_0:   "matpow A 0 = mat 1" |
  matpow_Suc: "matpow A (Suc n) = A ** (matpow A n)"

definition evalmat :: "'a::comm_ring_1 poly \<Rightarrow> 'a^'n^'n \<Rightarrow> 'a^'n^'n" where
  "evalmat P A = (\<Sum> i \<in> { n::nat . n \<le> ( degree P ) } . (coeff P i) *k (matpow A i) )"

lemma evalmat_unfold:
  "evalmat P A = (\<Sum>i = 0..degree P. coeff P i *k matpow A i)"
  by (simp add: evalmat_def atMost_def [symmetric] atMost_atLeast0)

lemma evalmat_code[code]:
  "evalmat P A = (\<Sum>i\<leftarrow>[0..int (degree P)]. coeff P (nat i) *k matpow A (nat i))" (is "_ = ?rhs")
proof -
  let ?t = "\<lambda>n. coeff P n *k matpow A n"
  have "(\<Sum>i = 0..degree P. coeff P i *k matpow A i) = (\<Sum>i\<in>{0..int (degree P)}. coeff P (nat i) *k matpow A (nat i))"
    by (rule sum.reindex_cong [of nat])
      (auto simp add: eq_nat_nat_iff image_iff intro: inj_onI, presburger)
(* TODO: why does the proof step above need all of Analysis?? *)
  also have "\<dots> = ?rhs"
    by (simp add: sum_set_upto_conv_sum_list_int [symmetric])
  finally show ?thesis
    by (simp add: evalmat_unfold)
qed

definition coeffM_zero :: "'a poly^'n^'n \<Rightarrow> 'a::zero^'n^'n" where
  "coeffM_zero A = (\<chi> i j. (coeff (A $ i $ j) 0))"

definition "coeffM_zero_row A i = (\<chi> j. (coeff (A $ i $ j) 0))"

definition coeffM :: "'a poly^'n^'n \<Rightarrow> nat \<Rightarrow> 'a::zero^'n^'n" where
  "coeffM A n = (\<chi> i j. coeff (A $ i $ j) n)"

lemma coeffM_zero_row_code [code abstract]:
  "vec_nth (coeffM_zero_row A i) = (% j. (coeff (A $ i $ j) 0))"
  by(simp add: coeffM_zero_row_def fun_eq_iff)

lemma coeffM_zero_code [code abstract]: "vec_nth (coeffM_zero A) = coeffM_zero_row A"
  unfolding coeffM_zero_def coeffM_zero_row_def[abs_def]
  using vec_lambda_beta by auto

definition
  "coeffM_row A n i = (\<chi> j. coeff (A $ i $ j) n)"

lemma coeffM_row_code [code abstract]:
  "vec_nth (coeffM_row A n i) = (% j. coeff (A $ i $ j) n)"
  by(simp add: coeffM_row_def coeffM_def fun_eq_iff)

lemma coeffM_code [code abstract]: "vec_nth (coeffM A n) = coeffM_row A n"
  unfolding coeffM_def coeffM_row_def[abs_def]
  using vec_lambda_beta by auto

end