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 (input) \<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> doN {ASSERT (i>0); 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> doN {ASSERT (i>0); 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 simp: swap_nth)

    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 LTE
  imports
    "HOL-Number_Theory.Number_Theory"
begin

section "Library additions"

lemma cong_sum_mono_neutral_right:
  assumes "finite T"
  assumes "S \<subseteq> T"
  assumes zeros: "\<forall>i \<in> T - S. [g i = 0] (mod n)"
  shows "[sum g T = sum g S] (mod n)"
proof -
  have "[sum g T = (\<Sum>x\<in>T. if x \<in> S then g x else 0)] (mod n)"
    using zeros by (auto intro: cong_sum)
  also have "(\<Sum>x\<in>T. if x \<in> S then g x else 0) = (\<Sum>x\<in>S. if x \<in> S then g x else 0)"
    by (intro sum.mono_neutral_right; fact?; auto)
  also have "... = sum g S"
    by (auto intro: sum.cong)
  finally show ?thesis.
qed

lemma power_odd_inj:
  fixes a b :: "'a::linordered_idom"
  assumes "odd k" and "a^k = b^k"
  shows "a = b"
proof (cases "a \<ge> 0")
  case True
  then have "b \<ge> 0"
    using assms zero_le_odd_power by metis
  moreover from \<open>odd k\<close> have "k > 0" by presburger
  show ?thesis
    by (rule power_eq_imp_eq_base; fact)
next
  case False
  then have "b < 0"
    using assms power_less_zero_eq not_less by metis
  from \<open>a^k = b^k\<close> have "(-a)^k = (-b)^k"
    using \<open>odd k\<close> power_minus_odd by simp
  moreover have "-a \<ge> 0" and "-b \<ge> 0"
    using \<open>\<not> a \<ge> 0\<close> and \<open>b < 0\<close> by auto
  moreover from \<open>odd k\<close> have "k > 0" by presburger
  ultimately have "-a = -b" by (rule power_eq_imp_eq_base)
  then show ?thesis by simp
qed

lemma power_eq_abs:
  fixes a b :: "'a::linordered_idom"
  assumes "a^k = b^k" and "k > 0"
  shows "\<bar>a\<bar> = \<bar>b\<bar>"
proof -
  from \<open>a^k = b^k\<close> have "\<bar>a\<bar>^k = \<bar>b\<bar>^k"
    using power_abs by metis
  show "\<bar>a\<bar> = \<bar>b\<bar>"
    by (rule power_eq_imp_eq_base; fact?; auto)
qed

lemma cong_scale:
  "k \<noteq> 0 \<Longrightarrow> [a = b] (mod c) \<longleftrightarrow> [k*a = k*b] (mod k*c)"
  unfolding cong_def by auto

lemma odd_square_mod_4:
  fixes x :: int
  assumes "odd x"
  shows "[x^2 = 1] (mod 4)"
proof -
  have "x^2 - 1 = (x - 1) * (x + 1)"
    by (simp add: ring_distribs power2_eq_square)
  moreover from \<open>odd x\<close> have "2 dvd x - 1" and "2 dvd x + 1"
    by auto
  ultimately have "4 dvd x^2 - 1"
    by fastforce
  thus ?thesis
    by (simp add: cong_iff_dvd_diff)
qed

section \<open>The \<open>p > 2\<close> case\<close>

context
  fixes x y :: int and p :: nat
  assumes "prime p"
  assumes "p dvd x - y"
  assumes "\<not>p dvd x"   "\<not>p dvd y"
begin

lemma decompose_mod_p:
  "[(\<Sum>i<n. y^(n - Suc i) * x^i) = n*x^(n-1)] (mod p)"
proof -
  {
    fix i
    assume "i < n"
    from \<open>p dvd x - y\<close> have "[x = y] (mod p)"
      by (simp add: cong_iff_dvd_diff)
    hence "[y^(n - Suc i) * x^i = x^(n - Suc i) * x^i] (mod p)"
      by (intro cong_scalar_right cong_pow; rule cong_sym)
    also have "x^(n - Suc i) * x^i = x^(n - 1)"
      using \<open>i < n\<close> by (simp flip: power_add)
    finally have "[y^(n - Suc i) * x^i = x^(n - 1)] (mod p)"
      by auto
  }
  hence "[(\<Sum>i<n. y^(n - Suc i) * x^i) = (\<Sum>i<n. x^(n-1))] (mod p)"
    by (intro cong_sum; auto)
  thus "[(\<Sum>i<n. y^(n - Suc i) * x^i) = n * x^(n-1)] (mod p)"
    by simp
qed

text \<open>Lemma 1:\<close>

lemma multiplicity_diff_pow_coprime:
  assumes "coprime p n"
  shows "multiplicity p (x^n - y^n) = multiplicity p (x - y)"
proof -
  have factor: "x^n - y^n = (\<Sum>i<n. y^(n - Suc i) * x^i) * (x - y)"
    by (simp add: power_diff_sumr2)
  moreover have "\<not> p dvd (\<Sum>i<n. y^(n - Suc i) * x^i)"
  proof
    assume "p dvd (\<Sum>i<n. y^(n - Suc i) * x^i)"
    with decompose_mod_p have "p dvd n * x^(n-1)"
      using cong_dvd_iff by blast
    with \<open>prime p\<close> have "p dvd n \<or> p dvd x^(n-1)"
      by (simp add: prime_dvd_mult_eq_int)
    moreover from \<open>coprime p n\<close> and \<open>prime p\<close> have "\<not>p dvd n"
      using coprime_absorb_right not_prime_unit by auto
    ultimately have "p dvd x^(n-1)"
      by simp
    hence "p dvd x"
      using \<open>prime p\<close> prime_dvd_power_int prime_nat_int_transfer by blast
    with \<open>\<not>p dvd x\<close> show False by simp
  qed
  ultimately show "multiplicity p (x^n - y^n) = multiplicity p (x - y)"
    using \<open>prime p\<close>
    by (auto intro: multiplicity_prime_elem_times_other)
qed

text \<open>The inductive step:\<close>

lemma multiplicity_diff_self_pow:
  assumes "p > 2" and "x \<noteq> y"
  shows "multiplicity p (x^p - y^p) = Suc (multiplicity p (x - y))"
proof -
  have *: "multiplicity p (\<Sum>i<p. y^(p - Suc i) * x^i) = 1"
  proof (rule multiplicity_eqI)
    have "[(\<Sum>t<p. y^(p - Suc t) * x^t) = p * x^(p-1)] (mod p)"
      by (rule decompose_mod_p)
    also have "[p * x^(p-1) = 0] (mod p)"
      by (simp add: cong_mult_self_left)
    finally show "(int p)^1 dvd (\<Sum>i<p. y^(p - Suc i) * x^i)"
      by (simp add: cong_0_iff)

    from \<open>p dvd x - y\<close> obtain k::int where kp: "x = y + k * p"
      by (metis add.commute diff_add_cancel dvd_def mult.commute)

    have "[y^(p - Suc t) * x^t = y^(p-1) + t*k*p*y^(p-2)] (mod p^2)" if "t < p" for t
    proof (cases "t = 0")
      case False
      have "y^(p - Suc t) * x^t = y^(p - Suc t) * (y + k*p)^t"
        unfolding kp..
      also have "... = y^(p - Suc t) * (\<Sum>i\<le>t. (t choose i) * (k*p)^i * y^(t-i))"
        by (simp flip: binomial_ring add: add.commute)
      also have "[... = y^(p - Suc t) * (\<Sum>i\<le>1. (t choose i) * (k*p)^i * y^(t-i))] (mod p^2)"
        \<comment> \<open>discard \<open>i > 1\<close>\<close>
      proof (intro cong_scalar_left cong_sum_mono_neutral_right; rule)
        fix i
        assume "i \<in> {..t} - {..1}"
        then have "i \<ge> 2" by simp
        then obtain i' where "i = i' + 2"
          using add.commute le_Suc_ex by blast
        hence "(k*p)^i = (k*p)^i' * k^2 * p^2"
          by (simp add: ac_simps power2_eq_square)
        hence "[(k*p)^i = 0] (mod p^2)"
          by (simp add: cong_mult_self_right)
        thus "[(t choose i) * (k*p)^i * y^(t-i) = 0] (mod p^2)"
          by (simp add: cong_0_iff)
      qed (use \<open>t \<noteq> 0\<close> in auto)
      also have "(\<Sum>i\<le>1. (t choose i) * (k*p)^i * y^(t-i)) = y^t + t*k*p*y^(t-1)"
        by simp
      also have "y^(p - Suc t) * ... = y^(p-1) + t*k*p*y^(p-2)"
        using \<open>t < p\<close> \<open>t \<noteq> 0\<close> by (auto simp add: algebra_simps numeral_eq_Suc simp flip: power_add)
      finally show ?thesis.
    qed simp

    hence "[(\<Sum>t<p. y^(p - Suc t) * x^t) = (\<Sum>t<p. y^(p-1) + t*k*p*y^(p-2))] (mod p^2)"
      by (auto intro: cong_sum)
    also have "(\<Sum>t<p. y^(p-1) + t*k*p*y^(p-2)) = p*y^(p-1) + (\<Sum>t<p. t) * k*p*y^(p-2)"
      by (simp add: sum.distrib sum_distrib_right)
    also have "(\<Sum>t<p. t) = p*(p - 1) div 2"
      by (simp add: Sum_Ico_nat lessThan_atLeast0)
    finally have "[(\<Sum>t<p. y^(p - Suc t) * x^t) = p*y^(p-1) + (p*(p - 1) div 2) * k*p*y^(p-2)] (mod p^2)".
    moreover have "[(p*(p - 1) div 2) * k*p*y^(p-2) = 0] (mod p^2)"
    proof -
      have "[(p * (p - 1) div 2) * p = 0] (mod p^2)"
      proof -
        from \<open>p > 2\<close> and \<open>prime p\<close> have "odd p"
          using prime_odd_nat by blast
        thus ?thesis
          by (metis (no_types, lifting) cong_0_iff div_mult_swap dvd_times_left_cancel_iff
              dvd_triv_left le_0_eq linorder_not_less mult.commute odd_pos odd_two_times_div_two_nat
              one_add_one power_add power_one_right)
      qed
      hence "[int ((p*(p - 1) div 2) * p)*k*y^(p-2) = 0] (mod p^2)"
        unfolding cong_0_iff using int_dvd_int_iff by fastforce
      thus ?thesis
        by (simp add: ac_simps)
    qed
    ultimately have "[(\<Sum>t<p. y^(p - Suc t) * x^t) = p*y^(p-1)] (mod p^2)"
      by (smt cong_add cong_iff_dvd_diff)
    moreover have "\<not> p^2 dvd p*y^(p-1)"
      using \<open>p > 2\<close> \<open>prime p\<close> \<open>\<not> p dvd y\<close> by (simp add: power2_eq_square prime_dvd_power_int_iff)
    ultimately show "\<not> int p^(Suc 1) dvd (\<Sum>t<p. y^(p - Suc t) * x^t)"
      by (metis (no_types, lifting) Suc_1 of_nat_power cong_dvd_iff)
  qed
  moreover have "multiplicity p (x^p - y^p) = multiplicity p (x - y) + multiplicity p (\<Sum>i<p. y^(p - Suc i) * x^i)"
    apply (unfold power_diff_sumr2, intro prime_elem_multiplicity_mult_distrib)
    using \<open>prime p\<close> \<open>x \<noteq> y\<close> multiplicity_zero * by auto
  ultimately show ?thesis by simp
qed

text \<open>Theorem 1:\<close>

theorem multiplicity_diff_pow:
  assumes "p > 2" and "x \<noteq> y" and "n > 0"
  shows "multiplicity p (x^n - y^n) = multiplicity p (x - y) + multiplicity p n"
proof -
  obtain k where n: "n = p^multiplicity p n * k" and "\<not> p dvd k"
    using \<open>n > 0\<close> \<open>prime p\<close>
    by (metis neq0_conv not_prime_unit multiplicity_decompose')
  have "multiplicity p (x^(p^a * k) - y^(p^a * k)) = multiplicity p (x - y) + a" for a
  proof (induction a)
    case 0
    from \<open>\<not> p dvd k\<close> have "coprime p k"
      using \<open>prime p\<close> by (intro prime_imp_coprime)
    thus ?case
      by (simp add: multiplicity_diff_pow_coprime)
  next
    case (Suc a)
    let ?x' = "x^(p^a*k)" and ?y' = "y^(p^a*k)"
    have "\<not> p dvd ?x'" and "\<not> p dvd ?y'"
      using \<open>\<not> p dvd x\<close>  \<open>\<not> p dvd y\<close> and \<open>prime p\<close>
      by (meson prime_dvd_power prime_nat_int_transfer)+
    moreover have "p dvd ?x' - ?y'"
      using \<open>p dvd x - y\<close> by (simp add: power_diff_sumr2)
    moreover have "?x' \<noteq> ?y'"
    proof
      assume "?x' = ?y'"
      moreover have "0 < p^a * k"
        using \<open>prime p\<close> \<open>n > 0\<close> n
        by (metis gr0I mult_is_0 power_not_zero prime_gt_0_nat)
      ultimately have "\<bar>x\<bar> = \<bar>y\<bar>"
        by (intro power_eq_abs)
      with \<open>x \<noteq> y\<close> have "x = -y"
        using abs_eq_iff by simp
      with \<open>p dvd x - y\<close> have "p dvd 2*x"
        by simp
      with \<open>prime p\<close> have "p dvd 2 \<or> p dvd x"
        by (metis int_dvd_int_iff of_nat_numeral prime_dvd_mult_iff prime_nat_int_transfer)
      with \<open>p > 2\<close> have "p dvd x"
        by auto
      with \<open>\<not> p dvd x\<close> show False..
    qed
    moreover have "p^Suc a * k = p^a * k * p"
      by (simp add: ac_simps)
    ultimately show ?case
      using LTE.multiplicity_diff_self_pow[where x="?x'" and y="?y'", OF \<open>prime p\<close>] \<open>p > 2\<close>
        and Suc.IH
      by (metis add_Suc_right power_mult)
  qed
  with n show ?thesis by metis
qed

end

text \<open>Theorem 2:\<close>

corollary multiplicity_add_pow:
  fixes x y :: int and p n :: nat
  assumes "odd n"
    and "prime p" and "p > 2"
    and "p dvd x + y" and "\<not> p dvd x"  "\<not> p dvd y"
    and "x \<noteq> -y"
  shows "multiplicity p (x^n + y^n) = multiplicity p (x + y) + multiplicity p n"
proof -
  have [simp]: "(-y)^n = -(y^n)"
    using \<open>odd n\<close> by (rule power_minus_odd)
  moreover have "n > 0"
    using \<open>odd n\<close> by presburger
  with assms show ?thesis
    using multiplicity_diff_pow[where x=x and y="-y" and n=n]
    by simp
qed

section \<open>The \<open>p = 2\<close> case\<close>

text \<open>Theorem 3:\<close>

theorem multiplicity_2_diff_pow_4div:
  fixes x y :: int
  assumes "odd x"  "odd y" and "4 dvd x - y" and "n > 0"  "x \<noteq> y"
  shows "multiplicity 2 (x^n - y^n) = multiplicity 2 (x - y) + multiplicity 2 n"
proof -
  have "prime (2::nat)" by simp
  then obtain k where n: "n = 2^multiplicity 2 n * k" and "\<not> 2 dvd k"
    using \<open>n > 0\<close>
    by (metis neq0_conv not_prime_unit multiplicity_decompose')

  have pow2: "multiplicity 2 (x^(2^k) - y^(2^k)) = multiplicity 2 (x - y) + k" for k
  proof (induction k)
    case (Suc k)
    have "x^(2^Suc k) - y^(2^Suc k) = (x^2^k)^2 - (y^2^k)^2"
      by (simp flip: power_mult algebra_simps)
    also have "... = (x^2^k - y^2^k)*(x^2^k + y^2^k)"
      by (simp add: power2_eq_square algebra_simps)
    finally have factor: "x^(2^Suc k) - y^(2^Suc k) = (x^2^k - y^2^k)*(x^2^k + y^2^k)".
    moreover have m_plus: "multiplicity 2 (x^2^k + y^2^k) = 1"
    proof (rule multiplicity_eqI)
      show "2^1 dvd x^2^k + y^2^k"
        using \<open>odd x\<close> and \<open>odd y\<close> by simp

      have "[x^2^k + y^2^k = 2] (mod 4)"
      proof (cases k)
        case 0
        from \<open>odd y\<close> have "[y = 1] (mod 2)"
          using cong_def by fastforce
        hence "[2*y = 2] (mod 4)"
          using cong_scale[where k=2 and b=1 and c=2, simplified] by force
        moreover from \<open>4 dvd x - y\<close> have "[x - y = 0] (mod 4)"
          by (simp add: cong_0_iff)
        ultimately have "[x + y = 2] (mod 4)"
          by (smt cong_add)
        with \<open>k = 0\<close> show ?thesis by simp
      next
        case (Suc k')
        then have "[x^2^k = 1] (mod 4)" and "[y^2^k = 1] (mod 4)"
          using \<open>odd x\<close> \<open>odd y\<close>
          by (auto simp add: power_mult power_Suc2 simp del: power_Suc intro: odd_square_mod_4)
        thus "[x^2^k + y^2^k = 2] (mod 4)"
          by (smt cong_add)
      qed
      thus "\<not> 2^Suc 1 dvd x^2^k + y^2^k"
        by (simp add: cong_dvd_iff)
    qed
    moreover have "x^2^k + y^2^k \<noteq> 0"
      using m_plus multiplicity_zero by auto
    moreover have "x^2^k - y^2^k \<noteq> 0"
    proof
      assume "x^2^k - y^2^k = 0"
      then have "\<bar>x\<bar> = \<bar>y\<bar>"
        by (intro power_eq_abs, simp, simp)
      hence "x = y \<or> x = -y"
        using abs_eq_iff by auto
      with \<open>x \<noteq> y\<close> have "x = -y"
        by simp
      with \<open>4 dvd x - y\<close> have "4 dvd 2*x"
        by simp
      hence "2 dvd x"
        by auto
      with \<open>odd x\<close> show False..
    qed
    ultimately have "multiplicity 2 (x^2^Suc k - y^2^Suc k) =
            multiplicity 2 (x^2^k - y^2^k) + multiplicity 2 (x^2^k + y^2^k)"
      by (unfold factor; intro prime_elem_multiplicity_mult_distrib; auto)
    then show ?case
      using m_plus Suc.IH by simp
  qed simp

  moreover have even_diff: "int 2 dvd x^2^multiplicity 2 n - y^2^multiplicity 2 n"
    using \<open>odd x\<close> and \<open>odd y\<close> by simp
  moreover have odd_parts: "\<not> int 2 dvd x^2^multiplicity 2 n"   "\<not> int 2 dvd y^2^multiplicity 2 n"
    using \<open>odd x\<close> and \<open>odd y\<close> by simp+
  moreover have coprime: "coprime 2 k"
    using \<open>\<not> 2 dvd k\<close> by simp

  show ?thesis
    apply (subst (1) n)
    apply (subst (2) n)
    apply (simp only: power_mult)
    apply (simp only: multiplicity_diff_pow_coprime[OF \<open>prime 2\<close> even_diff odd_parts coprime, simplified])
    by (rule pow2)
qed

text \<open>Theorem 4:\<close>

theorem multiplicity_2_diff_even_pow:
  fixes x y :: int
  assumes "odd x"  "odd y" and "even n" and "n > 0" and "\<bar>x\<bar> \<noteq> \<bar>y\<bar>"
  shows "multiplicity 2 (x^n - y^n) = multiplicity 2 (x - y) + multiplicity 2 (x + y) + multiplicity 2 n - 1"
proof -
  obtain n' where "n = 2*n'"
    using \<open>even n\<close> by auto
  with \<open>n > 0\<close> have "n' > 0" by simp

  moreover have "4 dvd x^2 - y^2"
  proof -
    have "x^2 - y^2 = (x + y) * (x - y)"
      by (simp add: algebra_simps power2_eq_square)
    moreover have "2 dvd x + y" and "2 dvd x - y"
      using \<open>odd x\<close> and \<open>odd y\<close> by auto
    ultimately show "4 dvd x^2 - y^2" by fastforce
  qed

  moreover have "odd (x^2)" and "odd (y^2)"
    using \<open>odd x\<close> \<open>odd y\<close> by auto
  moreover from \<open>\<bar>x\<bar> \<noteq> \<bar>y\<bar>\<close> have "x^2 \<noteq> y^2"
    using diff_0 diff_0_right power2_eq_iff by fastforce

  ultimately have "multiplicity 2 ((x^2)^n' - (y^2)^n') = multiplicity 2 (x^2 - y^2) + multiplicity 2 n'"
    by (intro multiplicity_2_diff_pow_4div)
  also have "multiplicity 2 ((x^2)^n' - (y^2)^n') = multiplicity 2 (x^n - y^n)"
    unfolding \<open>n = 2*n'\<close> by (simp add: power_mult)
  also have "multiplicity 2 (x^2 - y^2) = multiplicity 2 ((x - y) * (x + y))"
    by (simp add: algebra_simps power2_eq_square)
  also have "... = multiplicity 2 (x - y) + multiplicity 2 (x + y)"
    using \<open>\<bar>x\<bar> \<noteq> \<bar>y\<bar>\<close> by (auto intro: prime_elem_multiplicity_mult_distrib)
  also have "multiplicity 2 n = Suc (multiplicity 2 n')"
    unfolding \<open>n = 2*n'\<close> using \<open>n' > 0\<close> by (simp add: multiplicity_times_same)
  ultimately show ?thesis by simp
qed

end


theory Habbouly160503144
imports VDMToolkit VDMSet VDMRecord

begin

text {*  HABBOULY MEHDI 160503144*}

(*=========================================================================================*)
section {* VDM values *}

(* In VDM it would look like:
        SIZE : nat = 3;

   In Isabelle:
        abbreviation name :: "TYPE" where "name \<equiv> EXPR"

--{* abbreviation name :: "TYPE" where "name \<equiv> EXPR" *}
*)

abbreviation
    SIZE :: "VDMNat1"
where
    "SIZE \<equiv> 4"

abbreviation
    BOXN :: "VDMNat1"
where
    "BOXN \<equiv> 2*SIZE + 1"

abbreviation
    DOTN :: "VDMNat1"
where
    "DOTN \<equiv> SIZE * SIZE"

(*=========================================================================================*)
section {* VDM types and their invariants *}

text {* VDM enumerations can be Isabelle data type. For example *}

(*--{* datatype name :: name = VALUE1 | VALUEN *}*)
(*datatype Player = NOUGHT | CROSS*)

print_theorems  (*--"curiosity: Player type has loads of useful facts in Isabelle!"*)

text {* VDM types like pairs can be constructed with @{term type_synonym}.
        VDM type invariants are functions from the type to boolean. Remember
        that you need to define and check type invariants manually in Isabelle!

        As in VDM, you can write pattern matching (let) expressions to simplify models.
        For example, we use a let expression below in the invariant definition for type Pos.
      *}

(*  In VDM it would look like:

      Pos = nat * nat
      inv mk_(x,y) == x <= SIZE and y <= SIZE

      inv_Pos : nat * nat -> bool
      inv_Pos(x,y) == x <= SIZE and y <= SIZE
*)

(*{* type_synonym name = "TYPE_EXPR" *}*)
type_synonym Dot = VDMNat1

(*{* definition name :: "TYPE1 \<Rightarrow> TYPN \<Rightarrow> RES_TYPE" where "name \<equiv> DEF" *}*)
definition
  inv_Dot :: "VDMNat1 \<Rightarrow> bool"
where
  "inv_Dot dot \<equiv>  inv_VDMNat1 dot  \<and> dot \<le> DOTN "

record Move =
  dot1field:: Dot
  dot2field:: Dot

definition
  inv_Move :: "Move \<Rightarrow> bool"
  where
  "inv_Move m \<equiv> (let x=(dot1field m); s=(dot2field m) in
                    inv_Dot x \<and>
                    inv_Dot s \<and>
                    (if (x mod SIZE) = 0 then
                    s = x+SIZE
                    else
                    s = x+SIZE \<or> s = x+1 ))"

record Player =
  boxesfield:: "VDMNat1 VDMSet"
  movelistfield:: "Move VDMSet"

record Box =
  nofield:: VDMNat1
  movesfield:: "Move VDMSet"

definition
  inv_Box :: "Box \<Rightarrow> bool"
  where
  "inv_Box b \<equiv> inv_VDMNat1(nofield b) \<and> vdm_card (movesfield b) \<le> 4 \<and>  (\<forall> x \<in> (movesfield b) . inv_Move(x))"

type_synonym Boxs = "Box VDMSet"

definition
  inv_Boxs :: "Boxs \<Rightarrow> bool"
  where
  "inv_Boxs b \<equiv>  vdm_card (b) \<le> BOXN \<and> (\<forall> x \<in> b . ( inv_Box(x) ))"

datatype result = P1HASWON | P2HASWON | DRAW

abbreviation
    p1 :: "Player"
    where
    "p1 \<equiv> \<lparr> boxesfield = {} , movelistfield = {}\<rparr>"

abbreviation
    p2 :: "Player"
    where
    "p2 \<equiv> \<lparr> boxesfield = {} , movelistfield = {}\<rparr>"

abbreviation
    q :: "VDMNat1 VDMSet"
    where
    "q \<equiv> {1 .. (DOTN-SIZE)}"

abbreviation
    BoxList :: "Boxs"
    where
    "BoxList \<equiv> { \<lparr>nofield = s , movesfield = { \<lparr>dot1field = s, dot2field = s+1\<rparr>,
                                               \<lparr>dot1field = s, dot2field = s+SIZE\<rparr>,
                                               \<lparr>dot1field = s+1, dot2field = s+1+SIZE\<rparr>,
                                               \<lparr>dot1field = s+SIZE, dot2field = s+1+SIZE\<rparr>}\<rparr>
                                               | s . s \<in> q \<and> s mod SIZE \<noteq> 0}"

(*=========================================================================================*)
section {* VDM functions *}

text {* VDM functions can be described using Isabelle @{term definition}
        (e.g. predicates, or basic functions) or @{term fun} (e.g. recursive definitions).
     *}

(*-----------------------------------------------------------------------------------------*)
subsection {* Explicitly defined functions *}

text {* Encode here your explicitly defined VDM functions. Remember that you need to define
        and check type invariants, as well as VDM pre/post conditions manually in Isabelle!

        For every VDM function, you need to define three entities: function itself, and
        its pre and post conditions.

        Precondition definitions go from function parameters to bool, whereas
        postcondition definitions go from function parameters and result to bool.
      *}
(* In VDM these look like:
        myFun: nat * nat -> nat
        myFun(t1,t2) == t1 + t2
          pre t1 > 0 and t2 > 0
          post RESULT >= t1+t2;

        pre_myFun: nat * nat -> bool
        pre_myFun(t1,t2) == t1 > 0 and t2 > 0

        post_myFun: nat * nat * nat -> bool
        post_myFun(t1,t2,RESULT) == RESULT >= t1+t2

    Pre/Pos are optional in VDM explicit functions.
*)

definition
   isMoveFree :: "Move \<Rightarrow> Player \<Rightarrow> Player \<Rightarrow> bool"
   where
   "isMoveFree move pl1 pl2 \<equiv> if (move \<in> movelistfield pl1) \<or> (move \<in> movelistfield pl2) then
False else True"

definition
   isMoveInGame :: " Move \<Rightarrow> Boxs \<Rightarrow> bool "
   where
   "isMoveInGame move boxlist \<equiv> if \<exists> x \<in> boxlist . (move \<in> movesfield x) then
True else False"

definition
  findBoxNum :: "Move \<Rightarrow> Boxs \<Rightarrow> VDMNat1 VDMSet"
  where
  "findBoxNum move bl \<equiv>  {nofield x |x . x \<in> bl \<and> movesfield  x = {move}}"

definition
  pre_findBoxNum :: "Move \<Rightarrow> Boxs \<Rightarrow> bool"
  where
  "pre_findBoxNum move bl \<equiv> inv_Move(move) \<and> inv_Boxs(bl) \<and> isMoveInGame(move)(bl)"

definition
  post_findBoxNum :: "VDMNat1 VDMSet \<Rightarrow> bool"
  where
  "post_findBoxNum boxlist \<equiv> \<forall> x \<in> boxlist . ( x < BOXN+SIZE-1 \<and> (x mod SIZE )\<noteq> 0)"

definition
  removeFromBoxes :: " Move \<Rightarrow> Boxs \<Rightarrow> Boxs "
  where
  "removeFromBoxes m b \<equiv> {\<lparr>nofield = nofield x , movesfield = {y | y . y \<in> (movesfield x) \<and> y \<noteq> m}\<rparr>
                                        | x . x \<in> b} "

definition
  pre_removeFromBoxes :: " Move \<Rightarrow> Boxs \<Rightarrow> bool "
  where
  "pre_removeFromBoxes m b \<equiv> inv_Move (m) \<and> inv_Boxs (b) \<and> isMoveInGame(m)(b)"

definition
  post_removeFromBoxes ::" Move \<Rightarrow> Boxs \<Rightarrow> bool "
  where
  "post_removeFromBoxes m b \<equiv> \<not> isMoveInGame(m)(b) "

definition
  assignBox :: "Move \<Rightarrow> Player \<Rightarrow> Boxs \<Rightarrow> Player "
  where
  "assignBox m p b \<equiv>  \<lparr>boxesfield = boxesfield p \<union> findBoxNum (m)(b),movelistfield = movelistfield p\<rparr>"

definition
  assignMove :: "Move \<Rightarrow> Player \<Rightarrow> Player"
  where
  "assignMove m p \<equiv>    \<lparr>boxesfield = boxesfield p,movelistfield = movelistfield p \<union> {m} \<rparr>"

definition
  switchPlayers :: "bool \<Rightarrow> bool"
  where
  "switchPlayers p1plays \<equiv> if p1plays then False else True"

definition
  isTurnPl1 :: "Move \<Rightarrow> Boxs \<Rightarrow> bool \<Rightarrow> bool"
  where
  "isTurnPl1 m b bo \<equiv> if \<exists> x \<in> b .( (movesfield x) = {m}) then bo
                      else switchPlayers(bo)"

definition
  pre_isTurnPl1 :: "Move \<Rightarrow> Boxs \<Rightarrow> bool \<Rightarrow> bool"
  where
  "pre_isTurnPl1 m b bo \<equiv>  inv_Move (m) \<and> inv_Boxs (b) \<and> (\<exists> x \<in> b .( m \<in> (movesfield x)))"

definition
  tally :: "Player \<Rightarrow> Player \<Rightarrow> result"
  where
  "tally pl1 pl2 \<equiv> if vdm_card (movelistfield pl1) > vdm_card (movelistfield pl2 )then
                       P1HASWON
                    else
                    (if vdm_card (movelistfield pl1) < vdm_card (movelistfield pl2) then
                        P2HASWON
                        else
                        DRAW)"

definition
  pre_tally:: "Player \<Rightarrow> Player \<Rightarrow> bool"
  where
  "pre_tally pl1 pl2 \<equiv> pl1 \<noteq> pl2"
(*
definition
  myFun :: "nat \<Rightarrow> nat \<Rightarrow> nat"
where
  "myFun t1 t2 \<equiv> t1 + t2"

print_theorems (*--"what Isabelle knows about @{term myFun}?"*)

definition
  pre_myFun :: "nat \<Rightarrow> nat \<Rightarrow> bool"
where
  "pre_myFun t1 t2 \<equiv> t1 > 0 \<and> t2 > 0"

definition
  post_myFun :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
where
  "post_myFun t1 t2 RESULT \<equiv> RESULT \<ge> t1+t2"
*)

(*-----------------------------------------------------------------------------------------*)
subsection {* Implicitly defined functions *}

text {* Encode here your implicitly defined VDM functions. Remember that you need to check
        type invariants, as well as VDM pre/post conditions manually in Isabelle!
      *}
(* In VDM these look like:
        myFun(T1 * T2) r: T3
          [pre PRED]
          post PRED;

   Pre is optional; Post is mandatory in VDM implicit functions
*)

(*=========================================================================================*)
section {* VDM state *}

record DBGame =
  P1field :: Player
  P2field :: Player
  p1playsfield :: bool
  BoxListfield :: Boxs

definition
  inv_DBGame_flat :: "Player \<Rightarrow> Player \<Rightarrow> bool \<Rightarrow> Boxs \<Rightarrow> bool"
  where
  "inv_DBGame_flat pl1 pl2 pl1pl b \<equiv> \<forall> x \<in> movelistfield pl1 .
                                     (\<forall> i \<in> movelistfield pl2 .
                                     (i \<noteq> x \<and>
                                     (\<forall> y \<in> b  .
                                     (\<forall> z \<in> movesfield y .
                                     (z \<noteq> i \<and> z \<noteq> x  )))))"

definition
  inv_DBGame :: "DBGame \<Rightarrow> bool "
  where
  "inv_DBGame state \<equiv> inv_DBGame_flat (P1field state)
                                      (P2field state)
                                      (p1playsfield state)
                                      (BoxListfield state)"

definition
  init_DBGame :: "DBGame"
  where
  "init_DBGame \<equiv> \<lparr> P1field = p1, P2field = p2, p1playsfield = True , BoxListfield = BoxList\<rparr>"

definition
  post_init_DBGame :: "bool"
  where
  "post_init_DBGame \<equiv> inv_DBGame (init_DBGame)"

(*=========================================================================================*)
section {* VDM operations (over the state) *}

definition
  pre_chooseMove :: " Move \<Rightarrow> DBGame \<Rightarrow> bool "
  where
  "pre_chooseMove m db \<equiv> inv_Move (m) \<and> inv_DBGame(db) \<and> isMoveInGame(m)(BoxListfield db) \<and>
   (if (\<exists> x \<in> (BoxListfield db) . ((movesfield x ) = {m})) then
(\<exists> x \<in> (BoxListfield db) . ((nofield x) \<in> findBoxNum(m)(BoxListfield db) \<and>
isMoveFree(m)(P1field db)(P2field db) )) else isMoveFree(m)(P1field db)(P2field db))"

definition
  post_chooseMove :: " Move \<Rightarrow> Player \<Rightarrow> Boxs \<Rightarrow> bool "
  where
  "post_chooseMove m p b \<equiv> \<exists> x  \<in> (movelistfield p) .(x = m)"

definition
  chooseMove :: " Move \<Rightarrow> Player \<Rightarrow> DBGame \<Rightarrow> Player "
  where
  "chooseMove m p db \<equiv> if \<exists> x \<in> (BoxListfield db) .( (movesfield x) = {m} )then
                               assignBox(m)(p)(BoxListfield db)
                      else
                               assignMove(m)(p)"

definition
  pre_play_move :: "Move \<Rightarrow> DBGame \<Rightarrow> bool"
  where
  "pre_play_move m DB \<equiv> \<exists> x . (x \<in> BoxListfield DB \<and> m \<in> movesfield x)"

definition
  post_play_move :: "Move \<Rightarrow> DBGame \<Rightarrow> DBGame \<Rightarrow> bool"
  where

  "post_play_move m preDB postDB \<equiv> \<forall> x \<in> BoxListfield postDB . (\<forall> y \<in> movesfield x .(m \<noteq> y  \<and>
                                 BoxListfield postDB \<noteq> BoxListfield preDB \<and>
                                 (P1field preDB \<noteq> P1field postDB \<or>
                                  P2field preDB \<noteq> P2field postDB))) "

definition
  play_move :: "Move \<Rightarrow> DBGame \<Rightarrow> DBGame"
  where
  "play_move m DB \<equiv> if p1playsfield DB then
                       \<lparr>P1field = chooseMove(m)(P1field DB)(DB),
                       P2field = P2field DB,
                       p1playsfield = isTurnPl1 (m)(BoxListfield DB)(p1playsfield DB) ,
                       BoxListfield = removeFromBoxes(m)(BoxListfield DB)\<rparr>
                     else
                      \<lparr>P1field = P1field DB,
                       P2field =chooseMove(m)(P2field DB)(DB),
                       p1playsfield = isTurnPl1 (m)(BoxListfield DB)(p1playsfield DB) ,
                       BoxListfield = removeFromBoxes(m)(BoxListfield DB)\<rparr>"
(*=========================================================================================*)
section {* VDM proof obligations *}

text {* If you use Overture, generate proof obligation text and write it using Isabelle.
        You can name your goals with the same name as the Overture PO for my reference.
      *}
(*-----------------------------------------------------------------------------------------*)
subsection {* Well formedness (if any) *}

(*{* lemma goal_name : "predicate" proof_script *}*)

(*(exists dot:Habbouly160503144`Dot & (dot < (DOTN + 1)))*)

lemma Dot_sat_obl: " \<exists> dot :: Dot . dot < (DOTN+1)"
   by presburger

(*((exists move:Habbouly160503144`Move &
(((move.dot2) > (move.dot1)) and
((DOTN >= (move.dot2)) and
(if (((move.dot1) mod SIZE) = 0)
then ((move.dot2) = ((move.dot1) + SIZE))
else (((move.dot2) = ((move.dot1) + 1))
or ((move.dot2) = ((move.dot1) + SIZE))))))))*)

lemma Move_sat_obl: " \<exists> Move m .
                    inv_Dot (dot1field m) \<and>
                    inv_Dot (dot2field m) \<and>
                    (dot1field m  )< (dot2field m )\<and>
                    (if dot1field m mod SIZE = 0 then
                    dot2field m = (dot1field m) +1
                    else
                    dot2field m = (dot1field m) + SIZE \<or>
                    dot2field m = (dot1field m)+1 )"
  unfolding  inv_Move_def
             inv_Dot_def
             inv_VDMNat1_def
  by (metis Move.simps(1) Move.simps(2) add.commute numeral_le_iff numeral_times_numeral
      one_add_one one_le_numeral one_less_numeral_iff semiring_norm(11) semiring_norm(13) semiring_norm(68)
      semiring_norm(71) semiring_norm(76) zero_less_numeral zero_less_one)

(*  (exists box:Habbouly160503144`Box & ((card (box.moves)) <= 4))  *)

lemma Box_sat_obl: "\<exists> b :: Box . vdm_card (movesfield b) \<le> 4"
  unfolding inv_Box_def
            inv_VDMSet_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
            vdm_card_def
  apply simp
  by (metis Box.simps(2) card.empty empty_iff eq_numeral_Suc finite_if_finite_subsets_card_bdd
      infinite_super int_eq_iff_numeral int_nat_eq nat_numeral
      rel_simps(76) semiring_1_class.of_nat_simps(1) subsetI)

(*(forall s in set {1, ... ,(DOTN - SIZE)} & (((s mod SIZE) <> 0) => inv_Dot(s)))
  and (forall s in set {1, ... ,(DOTN - SIZE)} & (((s mod SIZE) <> 0) => inv_Dot(s+1)))
  and (forall s in set {1, ... ,(DOTN - SIZE)} & (((s mod SIZE) <> 0) => inv_Dot(s+SIZE)))*)

lemma Dot_sat_obl1:  "\<forall> s \<in>  {1 .. DOTN-SIZE} . (s mod SIZE) \<noteq> 0 \<longrightarrow> inv_Dot s \<and> inv_Dot (s+1) \<and> inv_Dot (s+SIZE) "
  unfolding inv_Dot_def
            inv_VDMNat1_def
  by simp

(*(forall s in set {1, ... ,(DOTN - SIZE)} & (((s mod SIZE) <> 0) => inv_Dot(s)))*)

text {* Sledgehammer could not find any proof and nitpick could not find any counter-example.
   the following lemma proves that for every s in the set {1,2,3,5,6,7,9,10,11}, (s+SIZE+1 == s+4+1) =< (DOTN = 16)
   we can see without needing the help of isabelle that this is the case for every value in the set as the maximum value,
   11 , gives us the following : 11+4+1 = 16 *}

lemma Dot_sat_obl2:  "\<forall> s \<in>  {1 .. DOTN-SIZE} . (s mod SIZE) \<noteq> 0 \<longrightarrow> inv_Dot ((s+SIZE)+1) "
  unfolding inv_Dot_def
            inv_VDMNat1_def
  apply simp
  apply safe
  apply simp
  apply safe
  apply (case_tac s)
  sorry

(*(forall s in set {1, ... ,(DOTN - SIZE)} & (((s mod SIZE) <> 0) => ((inv_Move(mk_Move(s, (s + 1))) and inv_Dot(s)) and inv_Dot((s + 1)))))
  and (forall s in set {1, ... ,(DOTN - SIZE)} & (((s mod SIZE) <> 0) => ((inv_Move(mk_Move(s, (s + SIZE))) and inv_Dot(s)) and inv_Dot((s + SIZE)))))*)

lemma BoxList1_Moves_sat_obl1: "\<forall> s \<in> { 1 .. DOTN-SIZE} . (s mod SIZE ) \<noteq> 0 \<longrightarrow> inv_Move( \<lparr>dot1field = s , dot2field = s+1\<rparr>)
                         \<and> inv_Move( \<lparr>dot1field = s, dot2field = s+SIZE \<rparr>)"
  unfolding inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
  by simp

  (*(forall s in set {1, ... ,(DOTN - SIZE)} & (((s mod SIZE) <> 0) => ((inv_Move(mk_Move((s + 1), ((s + 1) + SIZE))) and inv_Dot((s + 1))) and inv_Dot(((s + 1) + SIZE)))))
  and (forall s in set {1, ... ,(DOTN - SIZE)} & (((s mod SIZE) <> 0) => ((inv_Move(mk_Move((s + SIZE), ((s + SIZE) + 1))) and inv_Dot((s + SIZE))) and inv_Dot(((s + SIZE) + 1)))))*)

text {*Similarly to the Dot_sat_obl2 , Sledgehammer could not find any proof and nitpick could not find any counter-example
       However, it is clear when we look at the definition of inv_Move that every value in the set {1,2,3,5,6,7,9,10,11}
       respects the invariant*}

lemma BoxList1_Moves_sat_obl2: "\<forall> s \<in> { 1 .. DOTN-SIZE} . (s mod SIZE ) \<noteq> 0 \<longrightarrow> inv_Move \<lparr>dot1field = s+1 , dot2field = ((s+SIZE)+1)\<rparr>
                         \<and>  inv_Move \<lparr>dot1field = s+SIZE , dot2field = ((s+SIZE)+1)\<rparr>"
  unfolding inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
  sorry

(*(forall s in set {1, ... ,(DOTN - SIZE)} & (((s mod SIZE) <> 0) => inv_Box(mk_Box(s, {mk_Move(s, (s + 1)),
                                                                                mk_Move(s, (s + SIZE)),
                                                                                mk_Move((s + 1), ((s + 1) + SIZE)),
                                                                                mk_Move((s + SIZE), ((s + SIZE) + 1))}))))*)

lemma BoxList1_Boxes_sat_obl: " \<forall> s \<in> {1 .. DOTN-SIZE} . (s mod SIZE) \<noteq> 0 \<longrightarrow> inv_Box (\<lparr>nofield = s, movesfield = {\<lparr>dot1field = s,dot2field = s+1\<rparr>,
                                                                                \<lparr>dot1field = s,dot2field = s+SIZE\<rparr>,
                                                                                \<lparr>dot1field = s+1,dot2field = ((s+1)+SIZE)\<rparr>,
                                                                                \<lparr>dot1field = s+SIZE,dot2field = (s+1)+SIZE\<rparr>}\<rparr>)"

  using  BoxList1_Moves_sat_obl2
  unfolding
            inv_Box_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
  by simp

(*inv_Boxs({mk_Box(s, {mk_Move(s, (s + 1)), mk_Move(s, (s + SIZE)), mk_Move((s + 1), ((s + 1) + SIZE)), mk_Move((s + SIZE), ((s + SIZE) + 1))}) | s in set {1, ... ,(DOTN - SIZE)} & ((s mod SIZE) <> 0)})*)

text {* here, we can clearly see that we are always creating an array of 9 boxes, never more never less, as is explained previously with the dot_sat_obl. since
        since the Box inv asks only that the card of Boxs =< 9, it makes sense that it is the case below.*}

lemma Type_compatibility_Boxs_PO: "inv_Boxs({\<lparr>nofield = s,movesfield = {\<lparr>dot1field = s,dot2field = s+1\<rparr>,
                                                                       \<lparr>dot1field = s,dot2field = s+SIZE\<rparr>,
                                                                       \<lparr>dot1field = s+1,dot2field = ((s+1)+SIZE)\<rparr>,
                                                                       \<lparr>dot1field = s+SIZE,dot2field = (s+1)+SIZE\<rparr>}\<rparr> |s. s \<in> {1 .. DOTN-SIZE} \<and> (s mod SIZE) \<noteq> 0})"
  using  BoxList1_Boxes_sat_obl
  apply simp
  unfolding inv_Boxs_def
            inv_Box_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
            inv_VDMSet_def
            vdm_card_def
  apply simp
  apply safe
  sorry

(*(forall move:Habbouly160503144`Move, bl:set of (Habbouly160503144`Box) & inv_Boxs(bl))*)

lemma findBoxNum_type_compatibility_PO: "\<forall> (move :: Move) (bl :: Boxs) .(inv_Move move \<and> inv_Boxs(bl))\<longrightarrow> inv_Boxs(bl)"
  by simp

(*(forall move:Habbouly160503144`Move, bl:set of (Habbouly160503144`Box) & (pre_findBoxNum(move, bl) => post_findBoxNum(move, bl, {(x.no) | x in set bl & ((x.moves) = {move})})))*)

lemma findBoxNum_pre_post_PO: "\<forall> (move :: Move) (bl :: Boxs) . ( pre_findBoxNum(move )( bl) \<longrightarrow> post_findBoxNum( {nofield x |x . x \<in> bl \<and> movesfield  x = {move}}))"
  unfolding pre_findBoxNum_def post_findBoxNum_def  inv_Boxs_def
            inv_Box_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
            inv_VDMSet_def
  apply simp
  apply safe
   apply simp
  using zless_add1_eq apply auto[1]
  oops

(*(forall move:Habbouly160503144`Move, Boxes:set of (Habbouly160503144`Box) &
(pre_removeFromBoxes(move, Boxes) =>
post_removeFromBoxes(move, Boxes, {mk_Box((box.no),
{x | x in set (box.moves) & (x <> move)}) | box in set Boxes})))*)

lemma removeFromBoxes_pre_post_obl: "(\<forall> (move :: Move) (boxes :: Boxs) .(pre_removeFromBoxes(move)(boxes))
\<longrightarrow> post_removeFromBoxes(move) ({\<lparr>nofield = nofield x , movesfield = {y | y . y \<in> (movesfield x) \<and> y \<noteq> move}\<rparr>
                                        | x . x \<in> boxes})) "

  unfolding pre_removeFromBoxes_def
            inv_Boxs_def
            inv_Box_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
            inv_VDMSet_def
            post_removeFromBoxes_def
            inv_Boxs_def
            inv_Box_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
            inv_VDMSet_def
  apply simp
  apply safe
  by (smt Box.simps(2) isMoveInGame_def mem_Collect_eq)

(*(forall move:Habbouly160503144`Move, Boxes:set of (Habbouly160503144`Box) &
((exists x in set Boxes & (move in set (x.moves))) =>
(forall box in set Boxes & inv_Box(mk_Box((box.no), {x | x in set (box.moves) & (x <> move)})))))*)

lemma removeFromBoxes_sat_obl_0: " (\<forall> (move :: Move) (boxes :: Boxs) . (pre_removeFromBoxes (move)(boxes)
\<longrightarrow> (\<forall> box \<in> boxes . ( inv_Box(box)))))"

  apply safe
  unfolding pre_removeFromBoxes_def
            inv_Boxs_def
            inv_Box_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
            inv_VDMSet_def
  by simp

text {* in the following PO , I was not able to prove using isabelle , But I believe that what I am trying is tru for the following reason:
        the lemma tries to prove that for every move and box that respect their invariant (box's invariant says that the card of it's movelist  must be  smaller or
        equal than 4), the box invariant is respected after removing a move from the box( { x | x . x \<in> (movesfield box) \<and> move \<noteq> x} is the
        part that isabelle doesn't seem to understand, which can be translated to : create a list with every value from the movelist of the box exept for any value = move.
        since I am never adding a Box, it makes sense that if the
        invariant is true for the box before removing a move, it must be true for the box after its card has been reduced .*}

lemma removeFromBoxes_sat_obl_1: " (\<forall> (move :: Move) (boxes :: Boxs) . (pre_removeFromBoxes (move)(boxes)
\<longrightarrow> (\<forall> box \<in> boxes . ( inv_Box(\<lparr> nofield = nofield box , movesfield = { x | x . x \<in> (movesfield box) \<and> move \<noteq> x}\<rparr>)))))"

  apply safe
    unfolding pre_removeFromBoxes_def
            inv_Boxs_def
            inv_Box_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
            inv_VDMSet_def
    apply simp
    sorry

(*(forall move:Habbouly160503144`Move, pl:Habbouly160503144`Player, boxl:set of (Habbouly160503144`Box) & pre_findBoxNum(move, boxl))*)

lemma assign_box_legal_function_application: "\<forall> (move :: Move) (pl :: Player) (boxl :: Boxs) . ( inv_Move(move) \<and> inv_Boxs(boxl) \<longrightarrow> pre_findBoxNum(move)(boxl))"

  apply safe
  apply simp
  unfolding pre_findBoxNum_def
            isMoveInGame_def
            inv_Boxs_def
            inv_Box_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
            inv_VDMSet_def
  apply simp
  apply step
  oops

(*(exists P1:Habbouly160503144`Player, P2:Habbouly160503144`Player, p1plays:bool, BoxList1:set of
(Habbouly160503144`Box) & (forall i in set (P1.movelist) & (forall x in set (P2.movelist) &
((i <> x) and (forall z in set BoxList1 & (forall s in set (z.moves) & ((i <> s) and (i <> x))))))))*)

lemma state_invariant_satisfiable: " \<exists> (p1 :: Player) (p2 :: Player) (p1plays :: bool) (BoxList1 :: Boxs) .
(\<forall> i \<in> movelistfield p1 . ( \<forall> x \<in> movelistfield p2 . ( i \<noteq> x \<and> (\<forall> z \<in> BoxList1 . ( \<forall> s \<in> movesfield z .( i \<noteq> s \<and> i \<noteq> x))))))"

  apply simp
  unfolding  inv_Boxs_def
            inv_Box_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
            pre_findBoxNum_def
  by (metis Player.select_convs(2) equals0D)

(*(forall move:Habbouly160503144`Move, ply1:Habbouly160503144`Player, oldstate:Habbouly160503144`DBGame & ((isMoveInGame(move, BoxList1) and (if (exists x in set BoxList1 & ((x.moves) = {move}))
then (exists x in set BoxList1 & (((x.no) in set findBoxNum(move, BoxList1)) and isMoveFree(move, P1, P2)))
else isMoveFree(move, P1, P2))) => inv_Boxs(BoxList1)))*)

lemma chooseMove_type_compatibility_PO: "\<forall> (move :: Move) (ply1 :: Player) (oldstate :: DBGame) . (inv_Move(move) \<and> inv_DBGame(oldstate) \<longrightarrow> (isMoveInGame(move)(BoxListfield oldstate) \<and>
 (if (\<exists> x \<in> (BoxListfield oldstate) . ((movesfield x ) = {move})) then
(\<exists> x \<in> (BoxListfield oldstate) . ((nofield x) \<in> findBoxNum(move)(BoxListfield oldstate) \<and>
isMoveFree(move)(P1field oldstate)(P2field oldstate) )) else isMoveFree(move)(P1field oldstate)(P2field oldstate) \<longrightarrow> inv_Boxs(BoxListfield oldstate))))"

  apply simp
  apply safe
  unfolding isMoveInGame_def inv_DBGame_def findBoxNum_def isMoveFree_def
            inv_Boxs_def
            inv_VDMSet_def
            inv_Box_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
      apply simp
      apply blast
      apply blast
    apply simp
    apply safe
  oops

(*(forall move:Habbouly160503144`Move, ply1:Habbouly160503144`Player, oldstate:Habbouly160503144`DBGame & ((isMoveInGame(move, BoxList1) and (if (exists x in set BoxList1 & ((x.moves) = {move}))
then (exists x in set BoxList1 & (((x.no) in set findBoxNum(move, BoxList1)) and isMoveFree(move, P1, P2)))
else isMoveFree(move, P1, P2))) => (isMoveInGame(move, BoxList1) => ((exists x in set BoxList1 & ((x.moves) = {move})) => (forall x in set BoxList1 & pre_findBoxNum(move, BoxList1))))))*)

lemma chooseMove_legal_function_application: "\<forall> (m :: Move) (ply1 :: Player) (db :: DBGame) .( inv_Move(m) \<and> inv_DBGame(db)\<and> isMoveInGame(m)(BoxListfield db) \<longrightarrow>
(isMoveInGame(m)(BoxListfield db) \<and>
 (if (\<exists> x \<in> (BoxListfield db) . ((movesfield x ) = {m})) then
(\<exists> x \<in> (BoxListfield db) . ((nofield x) \<in> findBoxNum(m)(BoxListfield db) \<and>
isMoveFree(m)(P1field db)(P2field db) )) else isMoveFree(m)(P1field db)(P2field db)) \<longrightarrow> (isMoveInGame(m)(BoxListfield db) \<longrightarrow> (\<exists> x \<in> (BoxListfield db) .(movesfield x) = {m}
\<longrightarrow>( \<forall> x \<in> BoxListfield db . (pre_findBoxNum(m)(BoxListfield db))) ))))"

  apply simp
  apply safe
    unfolding isMoveInGame_def inv_DBGame_def findBoxNum_def isMoveFree_def
            inv_Boxs_def
            inv_VDMSet_def
            inv_Box_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
     apply safe
     apply simp
    oops

(*(forall move:Habbouly160503144`Move, ply1:Habbouly160503144`Player, oldstate:Habbouly160503144`DBGame & ((isMoveInGame(move, BoxList1) and (if (exists x in set BoxList1 & ((x.moves) = {move}))
then (exists x in set BoxList1 & (((x.no) in set findBoxNum(move, BoxList1)) and isMoveFree(move, P1, P2)))
else isMoveFree(move, P1, P2))) => (exists x in set (RESULT.movelist) & (move = x))))*)

lemma chooseMove_establishes_post_condition: "\<forall> (move :: Move) (ply1 :: Player) (oldstate :: DBGame) . (inv_Move(move) \<and> inv_DBGame(oldstate) \<longrightarrow>  (isMoveInGame(move)(BoxListfield oldstate) \<and>
 (if (\<exists> x \<in> (BoxListfield oldstate) . ((movesfield x ) = {move})) then
(\<exists> x \<in> (BoxListfield oldstate) . ((nofield x) \<in> findBoxNum(move)(BoxListfield oldstate) \<and>
isMoveFree(move)(P1field oldstate)(P2field oldstate) )) else isMoveFree(move)(P1field oldstate)(P2field oldstate)) \<longrightarrow> (\<exists> x \<in> (movelistfield (chooseMove(move)(ply1)(oldstate))) . (move = x))))"

  apply simp
  apply safe
  unfolding  isMoveInGame_def inv_DBGame_def findBoxNum_def isMoveFree_def
            inv_Boxs_def
            inv_VDMSet_def
            inv_Box_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
  apply simp
   apply safe
  oops

(*inv_Boxs(BoxList1)*)

lemma boxlist_type_compatibility: "inv_Boxs(BoxList)"

  using  Type_compatibility_Boxs_PO
  by simp

(*(inv_DBGame(mk_DBGame(P1, P2, p1plays, BoxList1)) =>
inv_DBGame(mk_DBGame(chooseMove(move, P1, removeFromBoxes(move, BoxList1)),
P2, isTurnPl1(move, removeFromBoxes(move, BoxList1), p1plays), removeFromBoxes(move, BoxList1))))*)

lemma state_invariant_holds0: " \<forall> (db :: DBGame) . (inv_DBGame(db)  \<longrightarrow> (\<forall> x \<in> BoxList . ( \<forall> move \<in> movesfield x . (inv_DBGame(
   \<lparr> P1field = p1,
     P2field = chooseMove(move)(p2)(init_DBGame),
     p1playsfield = isTurnPl1(move)(removeFromBoxes(move)(BoxList))(p1playsfield init_DBGame),
     BoxListfield = removeFromBoxes(move)(BoxList)\<rparr>)))))"

  apply simp
  apply safe
  apply simp
  apply safe
  apply simp
  unfolding inv_DBGame_def
            inv_Boxs_def
            inv_Box_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
            removeFromBoxes_def
            isTurnPl1_def
     apply simp
     apply safe
      apply simp
      apply blast
     apply (simp add: inv_DBGame_flat_def)
  using inv_DBGame_flat_def apply auto[1]
  using inv_DBGame_flat_def apply auto[1]
  using inv_DBGame_flat_def by auto

(*(inv_DBGame(mk_DBGame(P1, P2, p1plays, BoxList1)) => inv_DBGame(mk_DBGame(P1,
chooseMove(move, P2, removeFromBoxes(move, BoxList1)),
isTurnPl1(move, removeFromBoxes(move, BoxList1), p1plays), removeFromBoxes(move, BoxList1))))*)

lemma state_invariant_holds1: " \<forall> (db :: DBGame) . (inv_DBGame(db) \<longrightarrow> (\<forall> x \<in> BoxList . ( \<forall> move \<in> movesfield x . (inv_DBGame(
   \<lparr> P1field = p1,
     P2field = chooseMove(move)(p2)(init_DBGame),
     p1playsfield = isTurnPl1(move)(removeFromBoxes(move)(BoxList))(p1playsfield init_DBGame),
     BoxListfield = removeFromBoxes(move)(BoxList)\<rparr>)))))"

  apply simp
  apply safe
  apply simp
  apply safe
  apply simp
  unfolding inv_DBGame_def
            inv_Boxs_def
            inv_Box_def
            inv_Move_def
            inv_Dot_def
            inv_VDMNat1_def
            removeFromBoxes_def
            isTurnPl1_def
     apply simp
     apply safe
      apply simp
      apply blast
     apply (simp add: inv_DBGame_flat_def)
  using inv_DBGame_flat_def apply auto[1]
  using inv_DBGame_flat_def apply auto[1]
  using inv_DBGame_flat_def by auto

lemma choose_Move_sat_obl :"P = NP   "
  oops
(*-----------------------------------------------------------------------------------------*)
subsection {* Satisfiability (of each VDM operation) *}

lemma myFun_satisfiability: "P = NP"
oops

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
subsubsection {* Operation1 .. N *}

lemma "P = NP"
oops

(*-----------------------------------------------------------------------------------------*)
subsection {* Sanity checks *}

lemma "P = NP"
oops

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
subsubsection {* Single winner or draw *}

lemma "P = NP"
oops

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
subsubsection {* Moves within board maximum size *}

lemma "P = NP"
oops

(*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~*)
subsubsection {* Moves fairness (i.e. one player move per round) *}

lemma "P = NP"
oops

end


theory Weakening
imports "../Nominal2"
begin

section {* The Weakening property in the simply-typed lambda-calculus *}

atom_decl name

nominal_datatype lam =
  Var "name"
| App "lam" "lam"
| Lam x::"name" l::"lam" binds x in l ("Lam [_]. _" [100,100] 100)

text {* Typing *}

nominal_datatype ty =
  TVar string
| TFun ty ty ("_ \<rightarrow> _" [100,100] 100)

lemma fresh_ty:
  fixes x::"name"
  and   T::"ty"
  shows "atom x \<sharp> T"
  by (nominal_induct T rule: ty.strong_induct)
     (simp_all add: ty.fresh pure_fresh)

text {* Valid typing contexts *}

inductive
  valid :: "(name \<times> ty) list \<Rightarrow> bool"
where
  v_Nil[intro]: "valid []"
| v_Cons[intro]: "\<lbrakk>atom x \<sharp> Gamma; valid Gamma\<rbrakk> \<Longrightarrow> valid ((x, T) # Gamma)"

equivariance valid

text {* Typing judgements *}

inductive
  typing :: "(name \<times> ty) list \<Rightarrow> lam \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ : _" [60,60,60] 60)
where
    t_Var[intro]: "\<lbrakk>valid \<Gamma>; (x, T) \<in> set \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Var x : T"
  | t_App[intro]: "\<lbrakk>\<Gamma> \<turnstile> t1 : T1 \<rightarrow> T2; \<Gamma> \<turnstile> t2 : T1\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> App t1 t2 : T2"
  | t_Lam[intro]: "\<lbrakk>atom x \<sharp> \<Gamma>; (x, T1) # \<Gamma> \<turnstile> t : T2\<rbrakk> \<Longrightarrow> \<Gamma> \<turnstile> Lam [x]. t : T1 \<rightarrow> T2"

equivariance typing

text {* Strong induction principle for typing judgements *}

nominal_inductive typing
  avoids t_Lam: "x"
  by (simp_all add: fresh_star_def fresh_ty)

abbreviation
  "sub_context" :: "(name \<times> ty) list \<Rightarrow> (name \<times> ty) list \<Rightarrow> bool" (infixr "\<subseteq>" 60)
where
  "\<Gamma>1 \<subseteq> \<Gamma>2 \<equiv> \<forall>x T. (x, T) \<in> set \<Gamma>1 \<longrightarrow> (x, T) \<in> set \<Gamma>2"

text {* The proof *}

lemma weakening_version1:
  fixes \<Gamma>1 \<Gamma>2::"(name \<times> ty) list"
  and   t ::"lam"
  and   \<tau> ::"ty"
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "valid \<Gamma>2"
  and     c: "\<Gamma>1 \<subseteq> \<Gamma>2"
  shows "\<Gamma>2 \<turnstile> t : T"
using a b c
proof (nominal_induct \<Gamma>1 t T avoiding: \<Gamma>2 rule: typing.strong_induct)
  case (t_Var \<Gamma>1 x T)  (* variable case *)
  have "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
  moreover
  have "valid \<Gamma>2" by fact
  moreover
  have "(x, T) \<in> set \<Gamma>1" by fact
  ultimately show "\<Gamma>2 \<turnstile> Var x : T" by auto
next
  case (t_Lam x \<Gamma>1 T1 t T2) (* lambda case *)
  have vc: "atom x \<sharp> \<Gamma>2" by fact   (* variable convention *)
  have ih: "\<lbrakk>valid ((x, T1) # \<Gamma>2); (x, T1) # \<Gamma>1 \<subseteq> (x, T1) # \<Gamma>2\<rbrakk> \<Longrightarrow> (x, T1) # \<Gamma>2 \<turnstile> t : T2" by fact
  have "\<Gamma>1 \<subseteq> \<Gamma>2" by fact
  then have "(x, T1) # \<Gamma>1 \<subseteq> (x, T1) # \<Gamma>2" by simp
  moreover
  have "valid \<Gamma>2" by fact
  then have "valid ((x, T1) # \<Gamma>2)" using vc by auto
  ultimately have "(x, T1) # \<Gamma>2 \<turnstile> t : T2" using ih by simp
  with vc show "\<Gamma>2 \<turnstile> Lam [x]. t : T1 \<rightarrow> T2" by auto
qed (auto) (* app case *)

lemma weakening_version2:
  fixes \<Gamma>1 \<Gamma>2::"(name \<times> ty) list"
  assumes a: "\<Gamma>1 \<turnstile> t : T"
  and     b: "valid \<Gamma>2"
  and     c: "\<Gamma>1 \<subseteq> \<Gamma>2"
  shows "\<Gamma>2 \<turnstile> t : T"
using a b c
by (nominal_induct \<Gamma>1 t T avoiding: \<Gamma>2 rule: typing.strong_induct)
   (auto | atomize)+

text {* A version with finite sets as typing contexts *}

inductive
  valid2 :: "(name \<times> ty) fset \<Rightarrow> bool"
where
  v2_Empty[intro]: "valid2 {||}"
| v2_Insert[intro]: "\<lbrakk>(x, T) |\<notin>| Gamma; valid2 Gamma\<rbrakk> \<Longrightarrow> valid2 (insert_fset (x, T) Gamma)"

equivariance valid2

inductive
  typing2 :: "(name \<times> ty) fset \<Rightarrow> lam \<Rightarrow> ty \<Rightarrow> bool" ("_ 2\<turnstile> _ : _" [60,60,60] 60)
where
    t2_Var[intro]: "\<lbrakk>valid2 \<Gamma>; (x, T) |\<in>| \<Gamma>\<rbrakk> \<Longrightarrow> \<Gamma> 2\<turnstile> Var x : T"
  | t2_App[intro]: "\<lbrakk>\<Gamma> 2\<turnstile> t1 : T1 \<rightarrow> T2; \<Gamma> 2\<turnstile> t2 : T1\<rbrakk> \<Longrightarrow> \<Gamma> 2\<turnstile> App t1 t2 : T2"
  | t2_Lam[intro]: "\<lbrakk>atom x \<sharp> \<Gamma>; insert_fset (x, T1) \<Gamma> 2\<turnstile> t : T2\<rbrakk> \<Longrightarrow> \<Gamma> 2\<turnstile> Lam [x]. t : T1 \<rightarrow> T2"

equivariance typing2

nominal_inductive typing2
  avoids t2_Lam: "x"
  by (simp_all add: fresh_star_def fresh_ty)

lemma weakening_version3:
  fixes \<Gamma>::"(name \<times> ty) fset"
  assumes a: "\<Gamma> 2\<turnstile> t : T"
  and     b: "(x, T') |\<notin>| \<Gamma>"
  shows "{|(x, T')|} |\<union>| \<Gamma> 2\<turnstile> t : T"
using a b
apply(nominal_induct \<Gamma> t T avoiding: x rule: typing2.strong_induct)
apply(auto)[2]
apply(rule t2_Lam)
apply(simp add: fresh_insert_fset fresh_ty)
apply(simp)
apply(drule_tac x="xa" in meta_spec)
apply(drule meta_mp)
apply(simp add: fresh_at_base)
apply(simp add: insert_fset_left_comm)
done

lemma weakening_version4:
  fixes \<Gamma>::"(name \<times> ty) fset"
  assumes a: "\<Gamma> 2\<turnstile> t : T"
  and     b: "(x, T') |\<notin>| \<Gamma>"
  shows "{|(x, T')|} |\<union>| \<Gamma> 2\<turnstile> t : T"
using a b
apply(induct \<Gamma> t T arbitrary: x T')
apply(auto)[2]
apply(blast)
apply(simp)
apply(rule_tac ?'a="name" and x="(x, xa, t, T', \<Gamma>)" in obtain_fresh)
apply(rule_tac t= "Lam [x]. t" and s="Lam [a]. ((a \<leftrightarrow> x) \<bullet> t)" in subst)
defer
apply(rule t2_Lam)
apply(simp add: fresh_insert_fset)
oops

end