section "Dequeue Proofs"

theory RealTimeDeque_Dequeue
imports Deque RealTimeDeque States_Proof
begin

lemma list_deqL' [simp]: "\<lbrakk>invar deque; listL deque \<noteq> []; deqL' deque = (x, deque')\<rbrakk>
   \<Longrightarrow> x # listL deque' = listL deque"
proof(induction deque arbitrary: x rule: deqL'.induct)
  case (4 left right length_right)

  then obtain left' where pop_left[simp]: "Idle.pop left = (x, left')"
    by(auto simp: Let_def split: if_splits stack.splits prod.splits idle.splits)

  then obtain stack_left' length_left'
    where left'[simp]: "left' = idle.Idle stack_left' length_left'"
    using idle.exhaust by blast

  from 4 have invar_left': "invar left'"
    using Idle_Proof.invar_pop[of left]
    by auto

  then have size_left' [simp]: "size stack_left' = length_left'"
    by auto

  have size_left'_size_left [simp]: "size stack_left' = (size left) - 1"
    using Idle_Proof.size_pop_sub[of left x left']
    by auto

  show ?case
  proof(cases "3 * length_left' \<ge> length_right")
    case True
    with 4 pop_left show ?thesis
      using Idle_Proof.pop_list[of left x left']
      by auto
  next
    case False
    note Start_Transformation = False

    then show ?thesis
    proof(cases "length_left' \<ge> 1")
      case True
      let ?big = "Reverse (Current [] 0 right (size right - Suc length_left'))
                           right [] (size right - Suc length_left')"
      let ?small = "Reverse1 (Current [] 0 stack_left' (Suc (2 * length_left'))) stack_left' []"
      let ?states = "States Left ?big ?small"

      from 4 Start_Transformation True invar_left' have invar: "invar ?states"
        by(auto simp: Let_def rev_take rev_drop)

      with 4 Start_Transformation True invar_left'
      have "States.listL ?states = tl (Idle.list left) @ rev (Stack.list right)"
        using pop_list_tl'[of left x left']
        by (auto simp del: reverseN_def)

      with invar
      have "States.listL ((step^^6) ?states) = tl (Idle.list left) @ rev (Stack.list right)"
        using step_n_listL[of ?states 6]
        by presburger

      with 4 Start_Transformation True show ?thesis
        by(auto simp: Let_def)
    next
      case False
      from False Start_Transformation 4 have [simp]:"size left = 1"
        using size_left' size_left'_size_left by auto

      with False Start_Transformation 4 have [simp]: "Idle.list left = [x]"
        by(induction left)(auto simp: length_one_hd split: stack.splits)

      obtain right1 right2 where "right = Stack right1 right2"
        using Stack.list.cases by blast

      with False Start_Transformation 4 show ?thesis
        by(induction right1 right2 rule: small_deque.induct) auto
    qed
  qed
next
  case (5 big small)

  then have start_invar: "invar (States Left big small)"
    by auto

  from 5 have small_invar: "invar small"
    by auto

  from 5 have small_size: "0 < size small"
    by auto

  with 5(3) obtain small' where pop: "Small.pop small = (x, small')"
    by(cases small)
      (auto simp: Let_def split: states.splits direction.splits state_splits prod.splits)

  let ?states_new = "States Left big small'"
  let ?states_stepped = "(step^^4) ?states_new"

  have invar: "invar ?states_new"
    using pop start_invar small_size invar_pop_small[of Left big small x small']
    by auto

  have "x # Small.list_current small' = Small.list_current small"
    using small_invar small_size pop Small_Proof.pop_list_current[of small x small'] by auto

  then have listL:
      "x # States.listL ?states_new = Small.list_current small @ rev (Big.list_current big)"
    using invar small_size Small_Proof.pop_list_current[of small x small'] 5(1)
    by auto

  from invar have "invar ?states_stepped"
    using invar_step_n by blast

  then have states_listL_list_current [simp]: "x # States.listL ?states_stepped =
                Small.list_current small @ rev (Big.list_current big)"
    using States_Proof.step_n_listL invar listL by metis

  then have "listL (deqL (Transforming (States Left big small))) = States.listL ?states_stepped"
    by(auto simp: Let_def pop split: prod.splits direction.splits states.splits state_splits)

  then have states_listL_list_current:
      "x # listL (deqL (Transforming (States Left big small))) =
       Small.list_current small @ rev (Big.list_current big)"
    by auto

  with 5(1) have "listL (Transforming (States Left big small)) =
                  Small.list_current small @ rev (Big.list_current big)"
    by auto

  with states_listL_list_current
  have "x # listL (deqL (Transforming (States Left big small))) =
        listL (Transforming (States Left big small))"
    by auto

  with 5 show ?case by auto
next
  case (6 big small)
  then have start_invar: "invar (States Right big small)"
    by auto

  from 6 have big_invar: "invar big"
    by auto

  from 6 have big_size: "0 < size big"
    by auto

  with 6(3) obtain big' where pop: "Big.pop big = (x, big')"
    by(cases big)
      (auto simp: Let_def split: prod.splits direction.splits states.splits state_splits)

  let ?states_new = "States Right big' small"
  let ?states_stepped = "(step^^4) ?states_new"

  have invar: "invar ?states_new"
    using pop start_invar big_size invar_pop_big[of Right big small]
    by auto

  have big_list_current: "x # Big.list_current big' = Big.list_current big"
    using big_invar big_size pop by auto

  then have listL:
    "x # States.listL ?states_new = Big.list_current big @ rev (Small.list_current small)"
    proof(cases "States.lists ?states_new")
      case (Pair bigs smalls)
      with invar big_list_current show ?thesis
        using app_rev[of smalls bigs]
        by(auto split: prod.splits)
    qed

  from invar have four_steps: "invar ?states_stepped"
    using invar_step_n by blast

  then have [simp]:
      "x # States.listL ?states_stepped = Big.list_current big @ rev (Small.list_current small)"
    using States_Proof.step_n_listL[of ?states_new 4] invar listL
    by auto

  then have "listL (deqL (Transforming (States Right big small))) = States.listL ?states_stepped"
    by(auto simp: Let_def pop split: prod.splits direction.splits states.splits state_splits)

  then have listL_list_current:
      "x # listL (deqL (Transforming (States Right big small))) =
       Big.list_current big @ rev (Small.list_current small)"
    by auto

  with 6(1) have "listL (Transforming (States Right big small)) =
                  Big.list_current big @ rev (Small.list_current small)"
    using invar_list_big_first[of "States Right big small"] by fastforce

  with listL_list_current have
    "x # listL (deqL (Transforming (States Right big small))) =
     listL (Transforming (States Right big small))"
    by auto

  with 6 show ?case by auto
qed auto

lemma list_deqL [simp]:
    "\<lbrakk>invar deque; listL deque \<noteq> []\<rbrakk> \<Longrightarrow> listL (deqL deque) = tl (listL deque)"
  using cons_tl[of "fst (deqL' deque)" "listL (deqL deque)" "listL deque"]
  by(auto split: prod.splits)

lemma list_firstL [simp]:
    "\<lbrakk>invar deque; listL deque \<noteq> []\<rbrakk> \<Longrightarrow> firstL deque = hd (listL deque)"
  using cons_hd[of "fst (deqL' deque)" "listL (deqL deque)" "listL deque"]
  by(auto split: prod.splits)

lemma invar_deqL:
    "\<lbrakk>invar deque; \<not> is_empty deque\<rbrakk> \<Longrightarrow> invar (deqL deque)"
proof(induction deque rule: deqL'.induct)
  case (4 left right length_right)
  then obtain x left' where pop_left[simp]: "Idle.pop left = (x, left')"
    by fastforce

  then obtain stack_left' length_left'
    where left'[simp]: "left' = idle.Idle stack_left' length_left'"
    using idle.exhaust by blast

  from 4 have invar_left': "invar left'" "invar left"
    using Idle_Proof.invar_pop by fastforce+

  have [simp]: "size stack_left' = size left - 1"
    by (metis Idle_Proof.size_pop_sub left' pop_left size_idle.simps)

  have [simp]: "length_left' = size left - 1"
    using invar_left' by auto

  from 4 have list: "x # Idle.list left' = Idle.list left"
    using Idle_Proof.pop_list[of left x left']
    by auto

  show ?case
  proof(cases "length_right \<le> 3 * size left'")
    case True
    with 4 invar_left' show ?thesis
      by(auto simp: Stack_Proof.size_empty[symmetric])
  next
    case False
    note Start_Transformation = False
    then show ?thesis
    proof(cases "1 \<le> size left'")
      case True
      let ?big =
        "Reverse
            (Current [] 0 right (size right - Suc length_left'))
            right [] (size right - Suc length_left')"
      let ?small = "Reverse1 (Current [] 0 stack_left' (Suc (2 * length_left'))) stack_left' []"
      let ?states = "States Left ?big ?small"

      from 4 Start_Transformation True invar_left'
      have invar: "invar ?states"
        by(auto simp: Let_def rev_take rev_drop)

      then have invar_stepped: "invar ((step^^6) ?states)"
        using invar_step_n by blast

      from 4 Start_Transformation True
      have remaining_steps: "6 < remaining_steps ?states"
        by auto

      then have remaining_steps_end: "0 < remaining_steps ((step^^6) ?states)"
        by(simp only: remaining_steps_n_steps_sub[of ?states 6] invar)

      from 4 Start_Transformation True
      have size_ok': "size_ok' ?states (remaining_steps ?states - 6)"
        by auto

      then have size_ok: "size_ok ((step^^6) ?states)"
        using invar remaining_steps size_ok_steps by blast

      from True Start_Transformation 4 show ?thesis
        using remaining_steps_end size_ok invar_stepped
        by(auto simp: Let_def)
    next
      case False
      from False Start_Transformation 4 have [simp]: "size left = 1"
        by auto

      with False Start_Transformation 4 have [simp]: "Idle.list left = [x]"
        using list[symmetric]
        by(auto simp: list Stack_Proof.list_empty_size)

      obtain right1 right2 where "right = Stack right1 right2"
        using Stack.list.cases by blast

      with False Start_Transformation 4 show ?thesis
        by(induction right1 right2 rule: small_deque.induct) auto
    qed
  qed
next
  case (5 big small)

  obtain x small' where small' [simp]: "Small.pop small = (x, small')"
    by fastforce

  let ?states = "States Left big small'"
  let ?states_stepped = "(step^^4) ?states"

  obtain big_stepped small_stepped where stepped [simp]:
       "?states_stepped = States Left big_stepped small_stepped"
     by (metis remaining_steps_states.cases step_n_same)

  from 5 have invar: "invar ?states"
    using invar_pop_small[of Left big small x small']
    by auto

  then have invar_stepped: "invar ?states_stepped"
    using invar_step_n by blast

  show ?case
  proof(cases "4 < remaining_steps ?states")
    case True

    then have remaining_steps: "0 < remaining_steps ?states_stepped"
      using invar remaining_steps_n_steps_sub[of ?states 4]
      by simp

    from True have size_ok: "size_ok ?states_stepped"
      using step_4_pop_small_size_ok[of Left big small x small'] 5(1)
      by auto

    from remaining_steps size_ok invar_stepped show ?thesis
      by(cases big_stepped; cases small_stepped) (auto simp: Let_def split!: Common.state.split)
  next
    case False
    then have remaining_steps_stepped: "remaining_steps ?states_stepped = 0"
      using invar by(auto simp del: stepped)

    then obtain small_current small_idle big_current big_idle where idle [simp]: "
      States Left big_stepped small_stepped =
      States Left
          (Big.state.Common (state.Idle big_current big_idle))
          (Small.state.Common (state.Idle small_current small_idle))
      "
      using remaining_steps_idle' invar_stepped remaining_steps_stepped
      by fastforce

    have size_new_small : "1 < size_new small"
      using 5 by auto

    have [simp]: "size_new small = Suc (size_new small')"
      using 5 by auto

    have [simp]: "size_new small' = size_new small_stepped"
      using invar step_n_size_new_small stepped
      by metis

    have [simp]: "size_new small_stepped = size small_idle"
      using idle invar_stepped
      by(cases small_stepped) auto

    have [simp]: "\<not>is_empty small_idle"
      using size_new_small
      by (simp add: Idle_Proof.size_not_empty)

    have [simp]: "size_new big = size_new big_stepped"
      by (metis invar step_n_size_new_big stepped)

    have [simp]: "size_new big_stepped = size big_idle"
      using idle invar_stepped
      by(cases big_stepped) auto

    have "0 < size big_idle"
      using 5 by auto

    then have [simp]: "\<not>is_empty big_idle"
      by (auto simp: Idle_Proof.size_not_empty)

    have [simp]: "size small_idle \<le> 3 * size big_idle"
      using 5 by auto

    have [simp]: "size big_idle \<le> 3 * size small_idle"
      using 5 by auto

    show ?thesis
      using invar_stepped by auto
  qed
next
  case (6 big small)

  obtain x big' where big' [simp]: "Big.pop big = (x, big')"
    by fastforce

  let ?states = "States Right big' small"
  let ?states_stepped = "(step^^4) ?states"

  obtain big_stepped small_stepped where stepped [simp]:
       "?states_stepped = States Right big_stepped small_stepped"
     by (metis remaining_steps_states.cases step_n_same)

  from 6 have invar: "invar ?states"
    using invar_pop_big[of Right big small x big']
    by auto

  then have invar_stepped: "invar ?states_stepped"
    using invar_step_n by blast

  show ?case
  proof(cases "4 < remaining_steps ?states")
    case True

    then have remaining_steps: "0 < remaining_steps ?states_stepped"
      using invar remaining_steps_n_steps_sub[of ?states 4]
      by simp

    from True have size_ok: "size_ok ?states_stepped"
      using step_4_pop_big_size_ok[of Right big small x big'] 6(1)
      by auto

    from remaining_steps size_ok invar_stepped show ?thesis
      by(cases big_stepped; cases small_stepped) (auto simp: Let_def split!: Common.state.split)
  next
    case False
    then have remaining_steps_stepped: "remaining_steps ?states_stepped = 0"
      using invar by(auto simp del: stepped)

    then obtain small_current small_idle big_current big_idle where idle [simp]: "
      States Right big_stepped small_stepped =
      States Right
          (Big.state.Common (state.Idle big_current big_idle))
          (Small.state.Common (state.Idle small_current small_idle))
      "
      using remaining_steps_idle' invar_stepped remaining_steps_stepped
      by fastforce

    have size_new_big : "1 < size_new big"
      using 6 by auto

    have [simp]: "size_new big = Suc (size_new big')"
      using 6 by auto

    have [simp]: "size_new big' = size_new big_stepped"
      using invar step_n_size_new_big stepped
      by metis

    have [simp]: "size_new big_stepped = size big_idle"
      using idle invar_stepped
      by(cases big_stepped) auto

    have [simp]: "\<not>is_empty big_idle"
      using size_new_big
      by (simp add: Idle_Proof.size_not_empty)

    have [simp]: "size_new small = size_new small_stepped"
      by (metis invar step_n_size_new_small stepped)

    have [simp]: "size_new small_stepped = size small_idle"
      using idle invar_stepped
      by(cases small_stepped) auto

    have "0 < size small_idle"
      using 6 by auto

    then have [simp]: "\<not>is_empty small_idle"
      by (auto simp: Idle_Proof.size_not_empty)

    have [simp]: "size big_idle \<le> 3 * size small_idle"
      using 6 by auto

    have [simp]: "size small_idle \<le> 3 * size big_idle"
      using 6 by auto

    show ?thesis
      using invar_stepped by auto
  qed
qed auto

end


theory Approximation_Quickcheck_Ex
imports "../Approximation"
begin

lemma
  fixes x::real and y::real
  shows "sin x \<le> tan x"
  using [[quickcheck_approximation_custom_seed = 1]]
  quickcheck[approximation, expect=counterexample]
  oops

lemma "x \<le> y \<Longrightarrow> arctan y / y \<le> arctan x / x"
  using [[quickcheck_approximation_custom_seed = 1]]
  quickcheck[approximation, expect=counterexample]
  oops

lemma "0 < x \<Longrightarrow> x \<le> y \<Longrightarrow> arctan y / y \<le> arctan x / x"
  using [[quickcheck_approximation_custom_seed = 1]]
  quickcheck[approximation, expect=no_counterexample]
  by (rule arctan_divide_mono)

lemma
  fixes x::real
  shows "exp (exp x + exp y + sin x * sin y) - 0.4 > 0 \<or> 0.98 - sin x / (sin x * sin y + 2)^2 > 0"
  using [[quickcheck_approximation_custom_seed = 1]]
  quickcheck[approximation, expect=counterexample, size=10, iterations=1000, verbose]
  oops

lemma
  fixes x::real
  shows "x > 1 \<Longrightarrow> x \<le> 2 powr 20 * log 2 x + 1 \<and> (sin x)\<^sup>2 + (cos x)\<^sup>2 = 1"
  using [[quickcheck_approximation_custom_seed = 1]]
  using [[quickcheck_approximation_epsilon = 0.00000001]]
    --\<open>avoids spurious counterexamples in approximate computation of @{term "(sin x)\<^sup>2 + (cos x)\<^sup>2"}
      and therefore avoids expensive failing attempts for certification\<close>
  quickcheck[approximation, expect=counterexample, size=20]
  oops

end


theory sort_ISortPermutes'
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun null :: "'t list => bool" where
"null (Nil2) = True"
| "null (Cons2 y z) = False"

fun insert2 :: "int => int list => int list" where
"insert2 x (Nil2) = Cons2 x (Nil2)"
| "insert2 x (Cons2 z xs) =
     (if x <= z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"

fun isort :: "int list => int list" where
"isort (Nil2) = Nil2"
| "isort (Cons2 y xs) = insert2 y (isort xs)"

fun elem :: "int => int list => bool" where
"elem x (Nil2) = False"
| "elem x (Cons2 z ys) = or2 (x = z) (elem x ys)"

fun delete :: "int => int list => int list" where
"delete x (Nil2) = Nil2"
| "delete x (Cons2 z ys) =
     (if x = z then ys else Cons2 z (delete x ys))"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun isPermutation :: "int list => int list => bool" where
"isPermutation (Nil2) y = null y"
| "isPermutation (Cons2 z xs) y =
     and2 (elem z y) (isPermutation xs (delete z y))"

(*hipster or2 null insert2 isort elem delete and2 isPermutation *)

theorem x0 :
  "!! (x :: int list) . isPermutation (isort x) x"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory Category
imports Orders
begin

locale Hom_Syntax =
  fixes Hom :: "('obj \<times> 'arrow \<times> 'obj) set" and arr ::
  "'arrow \<Rightarrow> 'arrow \<Rightarrow> 'arrow"

begin

abbreviation in_hom
  where "in_hom f a b \<equiv> (a, f, b) \<in> Hom"

notation in_hom ("\<guillemotleft>_ : _ \<rightarrow> _\<guillemotright>")

abbreviation sources
  where "sources f a \<equiv> \<exists>b. (a, f, b) \<in> Hom"

notation sources ("\<guillemotleft>_ : _ \<rightarrow> ?\<guillemotright>")

abbreviation targets
  where "targets f a \<equiv> \<exists>b. (b, f, a) \<in> Hom"

notation targets ("\<guillemotleft>_ : ? \<rightarrow> _\<guillemotright>")

definition "hom_of a b = {f. \<guillemotleft>f : a \<rightarrow> b\<guillemotright>}"

definition "arrows \<equiv> (\<lambda>c. fst (snd c)) ` Hom"

lemma arrows_iff:  "f \<in> arrows \<longleftrightarrow> (\<exists>a b. \<guillemotleft>f : a \<rightarrow> b\<guillemotright>)"
  by (clarsimp simp: arrows_def image_iff Bex_def)

definition "arrcompose \<equiv> (\<lambda>f g. (fst f, arr ((fst o snd) f) ((fst o snd) g), (snd o snd) g))"

declare arrcompose_def[simp]

definition "compatiblity = {(f, g). f \<in> Hom \<and> g \<in> Hom \<and> snd (snd f) = (fst g)}"

abbreviation compatible
  where "compatible f g \<equiv> (f, g) \<in> compatiblity"

notation compatible (infixr "#>"  50)

lemma compatible_iff: "x #> y \<longleftrightarrow> (x \<in> Hom \<and> y \<in> Hom \<and> snd (snd x) = fst y)"
  by (clarsimp simp: compatiblity_def)

end

locale pre_category = Hom_Syntax Hom arr + a: unital_magma arr arrows +
   partial_semigroup compatiblity arrcompose
   for arr :: "'arrow \<Rightarrow> 'arrow \<Rightarrow> 'arrow" and Hom :: "('obj \<times> 'arrow \<times> 'obj) set"  +
   assumes id_exists: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<Longrightarrow> \<exists>i i'. \<guillemotleft>i' : a \<rightarrow> a\<guillemotright> \<and> \<guillemotleft>i : b \<rightarrow> b\<guillemotright>"

begin

lemma in_units_iff: "(a, f, b) \<in> Hom \<Longrightarrow> f \<in> a.idems \<longleftrightarrow>  (arr f f = f)"
  apply (intro iffI)
   apply (clarsimp simp: a.idems_def )
  apply (clarsimp simp: a.idems_def image_iff arrows_iff)
  apply (metis)
  done

end

locale category = pre_category arr Hom
     for arr :: "'arrow \<Rightarrow> 'arrow \<Rightarrow> 'arrow" and Hom :: "('obj \<times> 'arrow \<times> 'obj) set" +
  assumes uniq_id: "(a, f, a) \<in> Hom \<Longrightarrow> \<exists>!i \<in> a.idems.  (a, i, a) \<in> Hom \<and> (\<forall>g. (\<guillemotleft>g : a \<rightarrow> ?\<guillemotright> \<longrightarrow> arr i g = g) \<and> (\<guillemotleft>g : ? \<rightarrow> a\<guillemotright> \<longrightarrow> arr g i = g))"

begin

definition "identity (a :: 'obj) \<equiv> (THE f. (a, f, a) \<in> Hom \<and>  f \<in> a.idems \<and> (\<forall>g. (\<guillemotleft>g : a \<rightarrow> ?\<guillemotright> \<longrightarrow> arr f g = g) \<and> (\<guillemotleft>g : ? \<rightarrow> a\<guillemotright> \<longrightarrow> arr g f = g) ))"

lemma  carrier_simp[simp]: "x \<in> carrier compatiblity \<longleftrightarrow> x \<in> Hom"
  apply (clarsimp simp: carrier_def Ball_def Hom_Syntax.compatible_iff image_iff, safe; clarsimp)
   using compatible_iff apply blast
   using compatible_iff apply blast
   by (metis compatible_iff eq_snd_iff fst_conv id_exists)

lemma  carrier_simp'[simp]: "(a, f, b) \<in> carrier {(f, g). f \<in> Hom \<and> g \<in> Hom \<and> (snd o snd) f = (snd o snd) g} \<longleftrightarrow> (a, f, b) \<in> Hom"
  by (clarsimp simp: carrier_def image_iff, safe; clarsimp)

lemma id_in_hom_l[simp]: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<Longrightarrow> \<guillemotleft>identity a : a \<rightarrow> a\<guillemotright>"
  apply (clarsimp simp: identity_def)
  apply (rule the1I2)
  apply (frule id_exists, clarsimp)
   apply (frule uniq_id)
   apply (elim ex1E, clarsimp)
   apply (metis)
  apply (clarsimp)
  done

lemma id_comp_l[simp]: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<Longrightarrow> arr (identity a) f = f"
  apply (clarsimp simp: identity_def)
  apply (rule the1I2)
  apply (frule id_exists, clarsimp)
   apply (frule uniq_id)
   apply (elim ex1E, clarsimp)
   apply (metis)
  apply (blast)
  done

lemma id_in_hom_r[simp]: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<Longrightarrow> \<guillemotleft>identity b : b \<rightarrow> b\<guillemotright>"
  apply (clarsimp simp: identity_def)
  apply (rule the1I2)
  apply (frule id_exists, clarsimp)
   apply (frule uniq_id) back
   apply (elim ex1E, clarsimp)
  apply metis
   apply (blast)
  done

lemma id_comp_r[simp]: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<Longrightarrow> arr f (identity b) = f"
  apply (clarsimp simp: identity_def)
  apply (rule the1I2)
  apply (frule id_exists, clarsimp)
   apply (frule uniq_id) back
   apply (elim ex1E, clarsimp)
   apply (metis)
  apply (blast)
  done

sublocale partial_monoid compatiblity arrcompose "\<Union>(a,f,b)\<in>Hom. {(a, identity a, a), (b, identity b, b)}"
  apply (unfold_locales; clarsimp)
    apply (rule_tac x="(a, aa, b)" in bexI)
     apply (rule_tac x="(a, identity a, a)" in bexI; clarsimp simp: rev_image_eqI compatible_iff)
    apply (assumption)
   apply (rule_tac x="(a, aa, b)" in bexI)
     apply (rule_tac x="(b, identity b, b)" in bexI; clarsimp simp: rev_image_eqI compatible_iff)
   apply (assumption)
  apply (elim disjE; clarsimp simp: compatible_iff)
  done

abbreviation (input) "Homset \<equiv> Hom"

abbreviation (input) "arrow \<equiv> arr"

lemma hom_comp: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<Longrightarrow> \<guillemotleft>g : b \<rightarrow> c\<guillemotright> \<Longrightarrow> \<guillemotleft>arr f g : a \<rightarrow> c\<guillemotright>"
  apply (insert D_assoc[simplified], clarsimp simp: compatible_iff)
  by (smt (verit, best) id_comp_l id_in_hom_l)

lemma arr_assoc: "\<guillemotleft>f : a \<rightarrow> b\<guillemotright> \<Longrightarrow> \<guillemotleft>g : b \<rightarrow> c\<guillemotright> \<Longrightarrow> \<guillemotleft>h : c \<rightarrow> d\<guillemotright> \<Longrightarrow> arr (arr f g) h = arr f (arr g h) "
  apply (insert D_assoc[simplified], insert times_assoc[simplified], clarsimp simp: compatible_iff)
  by (smt (verit, best) id_comp_l id_in_hom_l)

end

lemma fst_converse_snd[simp]: "fst ` converse R = snd ` R"
  by (safe; fastforce simp: image_iff Bex_def)

lemma snd_converse_fst[simp]: "snd ` converse R = fst ` R"
  by (safe; fastforce simp: image_iff Bex_def)

lemma carrier_converse_is_carrier: "carrier (Hom\<inverse>) = carrier Hom"
  by (safe; clarsimp simp: carrier_def)

locale op_category = category

begin

abbreviation "opHom \<equiv> {(a, f, b). (b, f, a) \<in> Hom}"

lemma arrows_simp: "image (\<lambda>c. fst (snd c)) opHom  = image (\<lambda>c. fst (snd c)) Hom"
  apply (safe; clarsimp simp: image_iff)
   apply (metis fst_conv snd_conv)
  by (metis)

end

sublocale  op_category \<subseteq> opHom: Hom_Syntax opHom "(\<lambda>a b. arr b a)" done

sublocale op_category \<subseteq> unital_magma "(\<lambda>a b. arr b a)" "opHom.arrows"
  apply (unfold_locales; (clarsimp simp: arrows_simp)?)
   apply (smt (z3) Collect_cong arrows_def arrows_iff arrows_simp id_comp_r id_in_hom_r in_units_iff magma.idems_def opHom.arrows_def)
  by (smt (z3) Collect_cong arrows_def arrows_iff arrows_simp id_comp_l id_in_hom_l in_units_iff magma.idems_def opHom.arrows_def)

sublocale op_category \<subseteq> op: category "(\<lambda>a b. arr b a)" "opHom"
  apply (unfold_locales; clarsimp simp: opHom.compatible_iff carrier_converse_is_carrier )
     apply (safe)
        apply (clarsimp)
  using hom_comp apply presburger
  using hom_comp apply presburger
  using arr_assoc apply force
  using id_in_hom_r apply blast
  using id_in_hom_l apply blast
  defer
   apply metis
  apply (rule_tac x="identity a" in exI, clarsimp)
  apply (intro conjI)
   apply (clarsimp simp: idems_def opHom.arrows_iff)
   apply (intro conjI)
    apply (rule_tac x=a in exI)
  apply (rule_tac x=a in exI)
    apply simp
  using id_comp_r id_in_hom_r apply blast
  apply (clarsimp)
  by fastforce

locale func = source: category arr Hom + target: category arr' Hom'
  for Hom :: "('obj \<times> 'arr \<times> 'obj) set" and Hom' :: "('obj' \<times> 'arr' \<times> 'obj') set"
  and arr  and arr' +
   fixes F_obj :: "'obj \<Rightarrow> 'obj'" and F_arr :: "'arr \<Rightarrow> 'arr'"
   assumes source_target: "(a, f, b) \<in> Hom \<Longrightarrow> (F_obj a, F_arr f, F_obj b) \<in> Hom'"
   assumes hom: "(a, f, b) \<in> Hom \<Longrightarrow> (b, g, c) \<in> Hom \<Longrightarrow>  F_arr (arr f g) = arr' (F_arr f) (F_arr g)"
   assumes func_id: "(a, f, a) \<in> Hom \<Longrightarrow> F_arr (source.identity a) = target.identity (F_obj a) "

begin

abbreviation (input) "fobj \<equiv> F_obj"
abbreviation (input) "farr \<equiv> F_arr"

end

locale subcategory_pre = category +
  fixes objects :: "'b set" and arrows :: "'a set"
begin

definition "subhom = {(a, f, b). a \<in> objects \<and> b \<in> objects \<and> f \<in> arrows \<and> \<guillemotleft> f : a \<rightarrow> b\<guillemotright>} "

sublocale sc: Hom_Syntax  subhom arr done

lemma in_hom_iff: "sc.in_hom f a b \<longleftrightarrow> a \<in> objects \<and> b \<in> objects \<and> f \<in> arrows \<and> \<guillemotleft> f : a \<rightarrow> b\<guillemotright>"
  by (clarsimp simp: subhom_def)

end

locale subcategory = subcategory_pre +
  assumes (*subhom: "\<guillemotleft> f : a \<rightarrow> b\<guillemotright> \<Longrightarrow> \<exists>a' f' b'. a' \<in> objects \<and> b' \<in> objects \<and> f' \<in> arrows \<and> \<guillemotleft> f' : a' \<rightarrow> b'\<guillemotright>" and *)
          arrow_closed: "f \<in> sc.arrows \<Longrightarrow> g \<in> sc.arrows \<Longrightarrow> arr f g \<in> arrows" and
          id_closed: "a \<in> objects \<Longrightarrow> identity a \<in> arrows"

begin

lemma in_sc_arrows_in: "a \<in> sc.arrows \<Longrightarrow> a \<in> arrows"
  by (clarsimp simp: sc.arrows_iff subhom_def Hom_Syntax.arrows_def)

sublocale subcat: category arr subhom
  apply (standard; (clarsimp simp: Hom_Syntax.arrows_def Hom_Syntax.compatiblity_def sc.arrows_iff subhom_def sc.compatible_iff)?)
       apply (clarsimp simp: magma.idems_def)
       apply (rule_tac x=a in exI; clarsimp)
       apply (rule_tac x="identity a" in exI; clarsimp)
       apply (rule_tac x=a in exI; clarsimp)
  apply (frule id_closed, simp only: sc.arrows_iff, clarsimp simp: subhom_def)
  using id_closed id_comp_r id_in_hom_l apply blast
       apply (clarsimp simp: magma.idems_def)

 apply (rule_tac x=b in exI; clarsimp)
       apply (rule_tac x="identity b" in exI; clarsimp)
  apply (rule_tac x=b in exI; clarsimp)
  using sc.arrows_iff subhom_def id_closed id_comp_l id_in_hom_r apply blast
     apply (safe; clarsimp)
        apply (rule in_sc_arrows_in, clarsimp simp: sc.arrows_iff in_hom_iff)
  apply (metis Hom_Syntax.arrows_iff arrow_closed hom_comp local.in_hom_iff)
  using hom_comp apply blast
  apply (rule in_sc_arrows_in, clarsimp simp: sc.arrows_iff in_hom_iff)
  apply (metis Hom_Syntax.arrows_iff arrow_closed hom_comp local.in_hom_iff)
  using hom_comp apply presburger
    apply (simp add: arr_assoc)
   apply (rule_tac x="identity b" in exI)
   apply (rule_tac x="identity a" in exI)
  apply (simp add: id_closed in_sc_arrows_in)
  apply (rule_tac a="identity a" in ex1I; clarsimp simp: image_iff magma.idems_def id_closed )
   apply (intro conjI allI impI)
  using id_in_hom_l apply blast
  using id_closed id_comp_l id_in_hom_r apply blast
  using id_closed id_comp_l id_in_hom_r apply blast
  using id_closed id_comp_r id_in_hom_r apply blast
  by (metis id_closed id_comp_l id_in_hom_r)
end

locale func_comp = source: func Hom_A Hom_B arr_A arr_B f_obj f_arr + target:  func Hom_B Hom_C arr_B arr_C f_obj' f_arr'
  for Hom_A Hom_B Hom_C arr_A arr_B arr_C f_obj f_arr  f_obj' f_arr'
begin

sublocale functor_of: func Hom_A Hom_C arr_A arr_C "f_obj' o f_obj" "f_arr' o f_arr"
  apply (standard)
    apply (simp add: source.source_target target.source_target)
   apply (smt (verit) comp_eq_dest_lhs func.axioms(3) func_axioms_def source.func_axioms target.func_axioms)
  by (metis comp_apply source.func_id source.source_target target.func_id)

end

locale contravariant_func = op_source: op_category arr_A Hom_A   + func "op_source.op.Homset" Hom_B "op_source.op.arrow" arr_B F_obj F_arrow
  for Hom_A arr_A Hom_B arr_B F_obj F_arrow

end


theory Short_Theory_8_3_2
  imports "HOL-IMP.Big_Step" "HOL-IMP.Star"
begin
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
  "(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))" |
  "[] !! i = undefined"

lemma inth_append [simp]: "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
by (induct xs arbitrary: i) (auto simp: algebra_simps)

abbreviation (output)
  "isize xs == int (length xs)"

notation isize ("size")

datatype instr =
  LOADI int | LOAD vname |
  ADD |
  STORE vname |
  JMP int | JMPLESS int | JMPGE int

fun vars_in :: "instr list \<Rightarrow> vname list" where
  "vars_in [] = []" |
  "vars_in (LOAD x # P) = List.insert x (vars_in P)" |
  "vars_in (STORE x # P) = List.insert x (vars_in P)" |
  "vars_in (i # P) = vars_in P"

type_synonym addr = int
lemma vars_in_distinct: "distinct (vars_in P)"
proof (induct P)
  case (Cons a P)
  {
    fix x
    from Cons have "distinct (List.insert x (vars_in P))"
      by (cases "x \<in> set (vars_in P)") (auto simp add: Cons)
  }
  then show ?case  by (cases a) (auto simp add: Cons)
qed simp

fun nth_inv_P :: "instr list \<Rightarrow> vname \<Rightarrow> nat" where
  "nth_inv_P P = the_inv_into {..<length (vars_in P)} ((!) (vars_in P))"

fun addr_of :: "instr list \<Rightarrow> vname \<Rightarrow> int" where
  "addr_of P v = (if v \<in> set (vars_in P)
    then (int \<circ> nth_inv_P P) v
    else -1)"

lemma bij_addr_of: "bij_betw (addr_of P) (set (vars_in P)) (int ` {..<length (vars_in P)})"
proof -
  have "bij_betw ((!) (vars_in P)) {..<length (vars_in P)} (set (vars_in P))"
    by (rule bij_betw_nth, auto simp add: vars_in_distinct)
  then have 0: "bij_betw (nth_inv_P P) (set (vars_in P)) {..<length (vars_in P)}" (is ?P0)
    by (simp add: bij_betw_the_inv_into)
  have 1: "bij_betw int {..<length (vars_in P)} (int ` {..<length (vars_in P)})" (is ?P1) by simp
  thm bij_betw_comp_iff [OF 0, of int "(int ` {..<length (vars_in P)})"]
  have "?P1 \<longleftrightarrow>
    bij_betw (int \<circ> nth_inv_P P) (set (vars_in P)) (int ` {..<length (vars_in P)})" (is "?P1 \<longleftrightarrow> ?P2")
    by (rule bij_betw_comp_iff [OF 0])
  with 1 have 2: ?P2 by blast
  have "bij_betw (addr_of P) (set (vars_in P)) (int ` {..<length (vars_in P)}) \<longleftrightarrow> ?P2"
    by (rule bij_betw_cong, simp)
  with 2 show ?thesis by blast
qed

type_synonym stack = "val list"
type_synonym mem_state = "addr \<Rightarrow> val"
type_synonym addrs = "vname \<Rightarrow> addr"
type_synonym config = "int \<times> mem_state \<times> stack"

abbreviation "hd2 xs == hd (tl xs)"
abbreviation "tl2 xs == tl (tl xs)"

fun iexec :: "addrs \<Rightarrow> instr \<Rightarrow> config \<Rightarrow> config" where
  "iexec a (LOADI n) (i, s, stk) = (i + 1, s, n # stk)" |
  "iexec a (LOAD x) (i, s, stk) = (i + 1, s, s (a x) # stk)" |
  "iexec a ADD (i, s, stk) = (i + 1, s, (hd2 stk + hd stk) # tl2 stk)" |
  "iexec a (STORE x) (i, s, stk) = (i + 1, s(a x := hd stk), tl stk)" |
  "iexec a (JMP n) (i, s, stk) = (i + 1 + n, s, stk)" |
  "iexec a (JMPLESS n) (i, s, stk) = (if hd2 stk < hd stk then i + 1 + n else i + 1, s, tl2 stk)" |
  "iexec a (JMPGE n) (i, s, stk) = (if hd2 stk >= hd stk then i + 1 + n else i + 1, s, tl2 stk)"

definition exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
  ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)  where
  "P \<turnstile> c \<rightarrow> c' \<longleftrightarrow>
  (\<exists>i s stk. c = (i, s, stk) \<and> c' = iexec (addr_of P) (P !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size P)"

(* an introduction rule that expects the LHS config parameters to already be known *)
lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (addr_of P) (P !! i) (i, s, stk) \<Longrightarrow>
  0 \<le> i \<Longrightarrow> i < size P \<Longrightarrow>
  P \<turnstile> (i, s, stk) \<rightarrow> c'"
  by (simp add: exec1_def)
code_pred exec1 by (metis exec1_def)

abbreviation exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
  ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50) where
  "exec P \<equiv> star (exec1 P)"

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

lemma iexec_shift [simp]:
  "(n + i', s', stk') = iexec a x (n + i, s, stk) \<longleftrightarrow>
  (i', s', stk') = iexec a x (i, s, stk)"
  by (cases x, auto)

(* trivial: iexec (P !! i) depends only on first i elements of P, and 0 \<le> i < size P *)
lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P @ P' \<turnstile> c \<rightarrow> c'" unfolding exec1_def
proof -
  assume "\<exists> i s stk. c = (i, s, stk) \<and> c' = iexec (addr_of P) (P !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size P"
  then obtain i s stk where 0: "c = (i, s, stk)"
    and 1: "c' = iexec (addr_of P) (P !! i) (i, s, stk)"
    and 2: "0 \<le> i" and 3: "i < size P" by blast+
  from 3 have 4: "i < size (P @ P')" by auto
qed

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P @ P' \<turnstile> c \<rightarrow>* c'"
  by (induct rule: star.induct) (blast intro: star.step exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows "P \<turnstile> (i, s, stk) \<rightarrow> (i', s', stk') \<Longrightarrow>
    P' @ P \<turnstile> (size P' + i, s, stk) \<rightarrow> (size P' + i', s', stk')"
  by (auto simp add: exec1_def)

lemma exec_appendL:
  fixes i i' :: int
  shows "P \<turnstile> (i, s, stk) \<rightarrow>* (i', s', stk')  \<Longrightarrow>
    P' @ P \<turnstile> (size P' + i, s, stk) \<rightarrow>* (size P' + i', s', stk')"
  by (induct rule: exec_induct) (blast intro: star.step exec1_appendL)+

(* specialize append lemmas to discuss execution through concrete instructions
  while assuming the execution of preceding and following code.
*)
lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0, s, stk) \<rightarrow>* (j, t, stk') \<Longrightarrow>
  instr # P \<turnstile> (1, s, stk) \<rightarrow>* (1 + j, t, stk')"
  by (drule exec_appendL [where P'="[instr]"]) simp

(* as exec_appendL, with (i := i - size P'), precondition necessary to satisfy exec1 precondition *)
lemma exec_appendL_if [intro]:
  fixes i i' j :: int
  shows "size P' <= i \<Longrightarrow>
    P \<turnstile> (i - size P', s, stk) \<rightarrow>* (j, s', stk') \<Longrightarrow>
    i' = size P' + j \<Longrightarrow>
    P' @ P \<turnstile> (i, s, stk) \<rightarrow>* (i', s', stk')"
  by (drule exec_appendL [where P'=P']) simp

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows "P \<turnstile> (0, s, stk) \<rightarrow>* (i', s', stk') \<Longrightarrow>
    size P \<le> i' \<Longrightarrow>
    P' \<turnstile>  (i' - size P, s', stk') \<rightarrow>* (i'', s'', stk'') \<Longrightarrow>
    j'' = size P + i'' \<Longrightarrow>
    P @ P' \<turnstile> (0, s, stk) \<rightarrow>* (j'', s'', stk'')"
  by(metis star_trans [OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "Compilation"

fun acomp :: "aexp \<Rightarrow> instr list" where
  "acomp (N n) = [LOADI n]" |
  "acomp (V x) = [LOAD x]" |
  "acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"

lemma acomp_correct[intro]:
  "acomp a \<turnstile> (0, s, stk) \<rightarrow>* (size(acomp a), s, aval a s # stk)"
  by (induction a arbitrary: stk) fastforce+

(* f = True means that we intend to jump n spaces upon the expression evaluating to True, and
  step to next instruction upon the expression evaluating to False
  f = False means vice versa

  Suppose f = True in bcomp (And b1 b2). Then we want b1 to jump to just past b2 on False,
  (we know early that the And expression evaluates to False),
  and to continue with b2 on True. Thus we let cb1 = bcomp b1 False (size cb2)

  suppose f = False in bcomp (And b1 b2). Then we want b1 to jump to (size cb2 + n) on False
  (we know early that the And expression evaluates to False),
  and to continue with b2 on True.
*)
fun bcomp :: "bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
  "bcomp (Bc v) f n = (if v = f then [JMP n] else [])" |
  "bcomp (Not b) f n = bcomp b (\<not>f) n" |
  "bcomp (And b1 b2) f n = (let
    cb2 = bcomp b2 f n;
    m = if f
      then size cb2
      else size cb2 + n;
    cb1 = bcomp b1 False m in
    cb1 @ cb2)" |
  "bcomp (Less a1 a2) f n =
    acomp a1 @ acomp a2 @ (if f then [JMPLESS n] else [JMPGE n])"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp b f n \<turnstile>
 (0, s, stk) \<rightarrow>* (size (bcomp b f n) + (if f = bval b s then n else 0), s, stk)"
proof (induct b arbitrary: f n)
  case Not
  from Not(1) [where f="\<not>f"] Not(2) show ?case by fastforce
next
  case (And b1 b2)
  from And(1)
    [of "if f then size (bcomp b2 f n) else size (bcomp b2 f n) + n" "False"]
    And(2) [of n f] And(3)
  show ?case by fastforce
qed fastforce+

fun ccomp :: "com \<Rightarrow> instr list" where
  "ccomp SKIP = []" |
  "ccomp (x ::= a) = acomp a @ [STORE x]" |
  "ccomp (c\<^sub>1;; c\<^sub>2) = ccomp c\<^sub>1 @ ccomp c\<^sub>2" |
  "ccomp (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = (let
    cc\<^sub>1 = ccomp c\<^sub>1;
    cc\<^sub>2 = ccomp c\<^sub>2;
    cb = bcomp b False (size cc\<^sub>1 + 1) in
    cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
  "ccomp (WHILE b DO c) = (let
    cc = ccomp c;
    cb = bcomp b False (size cc + 1) in
    cb @ cc @ [JMP (-(size cb + size cc + 1))])"

lemma ccomp_bigstep:
  "(c, s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0, s, stk) \<rightarrow>* (size (ccomp c), t, stk)"
proof(induct arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1" and ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0, s1 ,stk) \<rightarrow>* (size ?cc1, s2, stk)"
    using Seq(2) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1, s2, stk) \<rightarrow>* (size (?cc1 @ ?cc2), s3, stk)"
    using Seq(4) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b False (size ?cc + 1)"
  and ?cw = "ccomp (WHILE b DO c)"
  have "?cw \<turnstile> (0, s1, stk) \<rightarrow>* (size ?cb, s1, stk)" using \<open>bval b s1\<close> by fastforce
  moreover have "?cw \<turnstile> (size ?cb, s1, stk) \<rightarrow>* (size ?cb + size ?cc, s2, stk)"
    using WhileTrue(3) by fastforce
  moreover have "?cw \<turnstile> (size ?cb + size ?cc, s2, stk) \<rightarrow>* (0, s2, stk)" by fastforce
  ultimately show ?case using WhileTrue(5) by(blast intro: star_trans)
qed fastforce+

end


theory IHT_Matrix
  imports
    SLTC_Main Asymptotics_2D
begin

section \<open>Some lemmas about indexing\<close>

lemma matrix_id_less [backward]: "(i::nat) < m \<Longrightarrow> j < n \<Longrightarrow> i * n + j < m * n"
@proof
  @have "i \<le> m - 1"
  @have "i * n \<le> (m - 1) * n"
  @have "i * n + j < (m - 1) * n + n"
@qed

lemma matrix_id_inj [forward]:
  "i * n + j = i' * n + j' \<Longrightarrow> (j::nat) < n \<Longrightarrow> j' < n \<Longrightarrow> i = i' \<and> j = j'"
  by (smt Suc_leI add.commute add_scale_eq_noteq div_eq_0_iff div_mult_mod_eq le_0_eq mod_mult_self3 mult.commute nat.simps(3))

section \<open>Abstract matrix as a list of lists\<close>

definition empty_matrix :: "nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list list" where [rewrite]:
  "empty_matrix m n x = replicate m (replicate n x)"

definition mat_update :: "'a list list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a list list" where [rewrite]:
  "mat_update M i j x = list_update M i (list_update (M ! i) j x)"

section \<open>Implementation of a matrix\<close>

datatype 'a matrix = Matrix (nrow: nat) (ncol: nat) (aref: "'a array")
setup \<open>add_simple_datatype "matrix"\<close>

(* m is number of rows, n is number of columns *)
definition init_matrix :: "nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a::heap matrix Heap" where
  "init_matrix m n x = do {
     a \<leftarrow> Array_Time.new (m * n) x;
     return (Matrix m n a)
   }"

(* i is row index, j is column index *)
fun nth_matrix :: "nat \<Rightarrow> nat \<Rightarrow> 'a::heap matrix \<Rightarrow> 'a Heap" where
  "nth_matrix i j p = (case p of (Matrix m n a) \<Rightarrow>
     Array_Time.nth a (i * n + j))"

(* i is row index, j is column index, x is new value *)
fun upd_matrix :: "nat \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a::heap matrix \<Rightarrow> unit Heap" where
  "upd_matrix i j x p = (case p of (Matrix m n a) \<Rightarrow>
     do {Array_Time.upd (i * n + j) x a; return ()})"

definition matrix_rel :: "'a list list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a list \<Rightarrow> bool" where [rewrite]:
  "matrix_rel xs m n as \<longleftrightarrow> (length as = m * n \<and> length xs = m \<and> (\<forall>i<m. length (xs ! i) = n) \<and> (\<forall>i<m. \<forall>j<n. (xs ! i) ! j = as ! (i * n + j)))"

fun matrix_assn :: "nat \<Rightarrow> 'a::heap list list \<Rightarrow> 'a matrix \<Rightarrow> assn" where
  "matrix_assn nc xs (Matrix m n a) = (\<exists>\<^sub>Aas. a \<mapsto>\<^sub>a as * \<up>(matrix_rel xs m n as) * \<up>(n = nc))"
setup \<open>add_rewrite_ent_rule @{thm matrix_assn.simps}\<close>

lemma matrix_rel_empty [resolve]:
  "matrix_rel (empty_matrix m n x) m n (replicate (m * n) x)"
@proof
  @have "\<forall>i<m. \<forall>j<n. empty_matrix m n x ! i ! j = replicate (m * n) x ! (i * n + j)" @with
    @have "i * n + j < m * n"
  @end
@qed

lemma matrix_rel_nth [rewrite]:
  "matrix_rel xs m n as \<Longrightarrow> i < m \<Longrightarrow> j < n \<Longrightarrow> as ! (i * n + j) = xs ! i ! j" by auto2

fun init_matrix_time :: "nat * nat \<Rightarrow> nat" where
  "init_matrix_time (m,n) = m * n + 2"
declare init_matrix_time.simps [rewrite]

lemma init_matrix_correct [hoare_triple]:
  "<$(init_matrix_time (m, n))>
   init_matrix m n x
   <matrix_assn n (empty_matrix m n x)>" by auto2

lemma init_matrix_time_bound [asym_bound]: "init_matrix_time \<in> \<Theta>\<^sub>2(\<lambda>x. real (fst x * snd x))"
  apply (subst surjective_pairing) unfolding init_matrix_time.simps by auto2

lemma nth_matrix_correct [hoare_triple]:
  "i < length xs \<Longrightarrow> j < n \<Longrightarrow>
   <matrix_assn n xs p * $1>
    nth_matrix i j p
   <\<lambda>r. matrix_assn n xs p * \<up>(r = xs ! i ! j)>" by auto2

lemma upd_matrix_correct [hoare_triple]:
  "i < length xs \<Longrightarrow> j < n \<Longrightarrow>
   <matrix_assn n xs p * $2>
    upd_matrix i j x p
   <\<lambda>_. matrix_assn n (mat_update xs i j x) p>" by auto2

setup \<open>del_prfstep_thm @{thm matrix_assn.simps}\<close>

end


theory GDPR_SDL           (*GDPR CTD Example. C. Benzmüller & Xavier Parent, 2019*)
imports SDL
begin
(*Unimportant.*) sledgehammer_params [max_facts=20,timeout=20,verbose]
(*Unimportant.*) nitpick_params [user_axioms,expect=genuine,show_all,dont_box]

datatype data = d1 | d2  (*We introduce concrete data objects d1 and d2.*)
datatype indiv = Mary | Peter  (*We introduce individuals Mary and Peter.*)
consts process_lawfully::"data\<Rightarrow>\<sigma>" erase::"data\<Rightarrow>\<sigma>" is_protected_by_GDPR::"data\<Rightarrow>\<sigma>"
       belongs_to::"data\<Rightarrow>indiv\<Rightarrow>\<sigma>" is_european::"indiv=>\<sigma> " kill::"indiv\<Rightarrow>\<sigma>"

axiomatization where
(*Data belonging to Europeans is protected by the GDPR.*)
 A0: "\<lfloor>\<^bold>\<forall>x. \<^bold>\<forall>d. (is_european x \<^bold>\<and> belongs_to d x) \<^bold>\<rightarrow> is_protected_by_GDPR d\<rfloor>" and
(*Data d1 is belonging to the European Peter.*)
 F1: "\<lfloor>belongs_to d1 Peter \<^bold>\<and> is_european Peter\<rfloor>" and

(*It is an obligation to process data lawfully.*)
 A1: "\<lfloor>\<^bold>\<forall>d. is_protected_by_GDPR d \<^bold>\<rightarrow> \<^bold>\<circle><process_lawfully d>\<rfloor>"  and
(*If data was not processed lawfully, then it is an obligation to erase the data.*)
 A2: "\<lfloor>\<^bold>\<forall>d.  (is_protected_by_GDPR d  \<^bold>\<and> \<^bold>\<not>process_lawfully d) \<^bold>\<rightarrow> \<^bold>\<circle><erase d>\<rfloor>" and
(*Implicit: It is an obligation to keep the data if it was processed lawfully.*)
 Implicit: "\<lfloor>\<^bold>\<forall>d. \<^bold>\<circle><(is_protected_by_GDPR d \<^bold>\<and> process_lawfully d) \<^bold>\<rightarrow> \<^bold>\<not>erase d>\<rfloor>" and
(*Given a situation where data is processed unlawfully.*)
 Situation: "\<lfloor>\<^bold>\<not>process_lawfully d1\<rfloor>\<^sub>l"

(***Some Experiments***)
 lemma True nitpick [satisfy] oops (*Consistency-check: Nitpick finds no model.*)
 lemma False sledgehammer by (metis A0 F1 A1 A2 Implicit Situation D) (*Prove of Falsum.*)

(*Should the data be erased? — Yes, proof found by ATPs*)
 lemma "\<lfloor>\<^bold>\<circle><erase d1>\<rfloor>\<^sub>l"  sledgehammer nitpick by (metis A0 A2 F1 Situation)
(*Should the data be kept? — Yes, proof found by ATPs*)
 lemma "\<lfloor>\<^bold>\<circle><\<^bold>\<not>erase d1>\<rfloor>\<^sub>l" sledgehammer nitpick by (meson A0 A1 F1 Implicit)
(*Should Mary be killed? — Yes, proof found by ATPs*)
 lemma "\<lfloor>\<^bold>\<circle><kill Mary>\<rfloor>\<^sub>l" sledgehammer nitpick by (meson A0 A1 A2 F1 Implicit Situation)
end


(*  Title:      ZF/Resid/Substitution.thy
    Author:     Ole Rasmussen, University of Cambridge
*)

theory Substitution imports Redex begin

(** The clumsy _aux functions are required because other arguments vary
    in the recursive calls ***)

consts
  lift_aux      :: "i\<Rightarrow>i"
primrec
  "lift_aux(Var(i)) = (\<lambda>k \<in> nat. if i<k then Var(i) else Var(succ(i)))"

  "lift_aux(Fun(t)) = (\<lambda>k \<in> nat. Fun(lift_aux(t) ` succ(k)))"

  "lift_aux(App(b,f,a)) = (\<lambda>k \<in> nat. App(b, lift_aux(f)`k, lift_aux(a)`k))"

definition
  lift_rec      :: "[i,i]\<Rightarrow> i"  where
    "lift_rec(r,k) \<equiv> lift_aux(r)`k"

abbreviation
  lift :: "i\<Rightarrow>i" where
  "lift(r) \<equiv> lift_rec(r,0)"

consts
  subst_aux     :: "i\<Rightarrow>i"
primrec
  "subst_aux(Var(i)) =
     (\<lambda>r \<in> redexes. \<lambda>k \<in> nat. if k<i then Var(i #- 1)
                                else if k=i then r else Var(i))"
  "subst_aux(Fun(t)) =
     (\<lambda>r \<in> redexes. \<lambda>k \<in> nat. Fun(subst_aux(t) ` lift(r) ` succ(k)))"

  "subst_aux(App(b,f,a)) =
     (\<lambda>r \<in> redexes. \<lambda>k \<in> nat. App(b, subst_aux(f)`r`k, subst_aux(a)`r`k))"

definition
  subst_rec     :: "[i,i,i]\<Rightarrow> i"        (**NOTE THE ARGUMENT ORDER BELOW**)  where
    "subst_rec(u,r,k) \<equiv> subst_aux(r)`u`k"

abbreviation
  subst :: "[i,i]\<Rightarrow>i"  (infixl \<open>'/\<close> 70)  where
  "u/v \<equiv> subst_rec(u,v,0)"

(* ------------------------------------------------------------------------- *)
(*   Arithmetic extensions                                                   *)
(* ------------------------------------------------------------------------- *)

lemma gt_not_eq: "p < n \<Longrightarrow> n\<noteq>p"
by blast

lemma succ_pred [rule_format, simp]: "j \<in> nat \<Longrightarrow> i < j \<longrightarrow> succ(j #- 1) = j"
by (induct_tac "j", auto)

lemma lt_pred: "\<lbrakk>succ(x)<n; n \<in> nat\<rbrakk> \<Longrightarrow> x < n #- 1 "
apply (rule succ_leE)
apply (simp add: succ_pred)
done

lemma gt_pred: "\<lbrakk>n < succ(x); p<n; n \<in> nat\<rbrakk> \<Longrightarrow> n #- 1 < x "
apply (rule succ_leE)
apply (simp add: succ_pred)
done

declare not_lt_iff_le [simp] if_P [simp] if_not_P [simp]

(* ------------------------------------------------------------------------- *)
(*     lift_rec equality rules                                               *)
(* ------------------------------------------------------------------------- *)
lemma lift_rec_Var:
     "n \<in> nat \<Longrightarrow> lift_rec(Var(i),n) = (if i<n then Var(i) else Var(succ(i)))"
by (simp add: lift_rec_def)

lemma lift_rec_le [simp]:
     "\<lbrakk>i \<in> nat; k\<le>i\<rbrakk> \<Longrightarrow> lift_rec(Var(i),k) = Var(succ(i))"
by (simp add: lift_rec_def le_in_nat)

lemma lift_rec_gt [simp]: "\<lbrakk>k \<in> nat; i<k\<rbrakk> \<Longrightarrow> lift_rec(Var(i),k) = Var(i)"
by (simp add: lift_rec_def)

lemma lift_rec_Fun [simp]:
     "k \<in> nat \<Longrightarrow> lift_rec(Fun(t),k) = Fun(lift_rec(t,succ(k)))"
by (simp add: lift_rec_def)

lemma lift_rec_App [simp]:
     "k \<in> nat \<Longrightarrow> lift_rec(App(b,f,a),k) = App(b,lift_rec(f,k),lift_rec(a,k))"
by (simp add: lift_rec_def)

(* ------------------------------------------------------------------------- *)
(*    substitution quality rules                                             *)
(* ------------------------------------------------------------------------- *)

lemma subst_Var:
     "\<lbrakk>k \<in> nat; u \<in> redexes\<rbrakk>
      \<Longrightarrow> subst_rec(u,Var(i),k) =
          (if k<i then Var(i #- 1) else if k=i then u else Var(i))"
by (simp add: subst_rec_def gt_not_eq leI)

lemma subst_eq [simp]:
     "\<lbrakk>n \<in> nat; u \<in> redexes\<rbrakk> \<Longrightarrow> subst_rec(u,Var(n),n) = u"
by (simp add: subst_rec_def)

lemma subst_gt [simp]:
     "\<lbrakk>u \<in> redexes; p \<in> nat; p<n\<rbrakk> \<Longrightarrow> subst_rec(u,Var(n),p) = Var(n #- 1)"
by (simp add: subst_rec_def)

lemma subst_lt [simp]:
     "\<lbrakk>u \<in> redexes; p \<in> nat; n<p\<rbrakk> \<Longrightarrow> subst_rec(u,Var(n),p) = Var(n)"
by (simp add: subst_rec_def gt_not_eq leI lt_nat_in_nat)

lemma subst_Fun [simp]:
     "\<lbrakk>p \<in> nat; u \<in> redexes\<rbrakk>
      \<Longrightarrow> subst_rec(u,Fun(t),p) = Fun(subst_rec(lift(u),t,succ(p))) "
by (simp add: subst_rec_def)

lemma subst_App [simp]:
     "\<lbrakk>p \<in> nat; u \<in> redexes\<rbrakk>
      \<Longrightarrow> subst_rec(u,App(b,f,a),p) = App(b,subst_rec(u,f,p),subst_rec(u,a,p))"
by (simp add: subst_rec_def)

lemma lift_rec_type [rule_format, simp]:
     "u \<in> redexes \<Longrightarrow> \<forall>k \<in> nat. lift_rec(u,k) \<in> redexes"
apply (erule redexes.induct)
apply (simp_all add: lift_rec_Var lift_rec_Fun lift_rec_App)
done

lemma subst_type [rule_format, simp]:
     "v \<in> redexes \<Longrightarrow>  \<forall>n \<in> nat. \<forall>u \<in> redexes. subst_rec(u,v,n) \<in> redexes"
apply (erule redexes.induct)
apply (simp_all add: subst_Var lift_rec_type)
done

(* ------------------------------------------------------------------------- *)
(*    lift and  substitution proofs                                          *)
(* ------------------------------------------------------------------------- *)

(*The i\<in>nat is redundant*)
lemma lift_lift_rec [rule_format]:
     "u \<in> redexes
      \<Longrightarrow> \<forall>n \<in> nat. \<forall>i \<in> nat. i\<le>n \<longrightarrow>
           (lift_rec(lift_rec(u,i),succ(n)) = lift_rec(lift_rec(u,n),i))"
apply (erule redexes.induct, auto)
apply (case_tac "n < i")
apply (frule lt_trans2, assumption)
apply (simp_all add: lift_rec_Var leI)
done

lemma lift_lift:
     "\<lbrakk>u \<in> redexes; n \<in> nat\<rbrakk>
      \<Longrightarrow> lift_rec(lift(u),succ(n)) = lift(lift_rec(u,n))"
by (simp add: lift_lift_rec)

lemma lt_not_m1_lt: "\<lbrakk>m < n; n \<in> nat; m \<in> nat\<rbrakk>\<Longrightarrow> \<not> n #- 1 < m"
by (erule natE, auto)

lemma lift_rec_subst_rec [rule_format]:
     "v \<in> redexes \<Longrightarrow>
       \<forall>n \<in> nat. \<forall>m \<in> nat. \<forall>u \<in> redexes. n\<le>m\<longrightarrow>
          lift_rec(subst_rec(u,v,n),m) =
               subst_rec(lift_rec(u,m),lift_rec(v,succ(m)),n)"
apply (erule redexes.induct, simp_all (no_asm_simp) add: lift_lift)
apply safe
apply (rename_tac n n' m u)
apply (case_tac "n < n'")
 apply (frule_tac j = n' in lt_trans2, assumption)
 apply (simp add: leI, simp)
apply (erule_tac j=n in leE)
apply (auto simp add: lift_rec_Var subst_Var leI lt_not_m1_lt)
done

lemma lift_subst:
     "\<lbrakk>v \<in> redexes; u \<in> redexes; n \<in> nat\<rbrakk>
      \<Longrightarrow> lift_rec(u/v,n) = lift_rec(u,n)/lift_rec(v,succ(n))"
by (simp add: lift_rec_subst_rec)

lemma lift_rec_subst_rec_lt [rule_format]:
     "v \<in> redexes \<Longrightarrow>
       \<forall>n \<in> nat. \<forall>m \<in> nat. \<forall>u \<in> redexes. m\<le>n\<longrightarrow>
          lift_rec(subst_rec(u,v,n),m) =
               subst_rec(lift_rec(u,m),lift_rec(v,m),succ(n))"
apply (erule redexes.induct, simp_all (no_asm_simp) add: lift_lift)
apply safe
apply (rename_tac n n' m u)
apply (case_tac "n < n'")
apply (case_tac "n < m")
apply (simp_all add: leI)
apply (erule_tac i=n' in leE)
apply (frule lt_trans1, assumption)
apply (simp_all add: succ_pred leI gt_pred)
done

lemma subst_rec_lift_rec [rule_format]:
     "u \<in> redexes \<Longrightarrow>
        \<forall>n \<in> nat. \<forall>v \<in> redexes. subst_rec(v,lift_rec(u,n),n) = u"
apply (erule redexes.induct, auto)
apply (case_tac "n < na", auto)
done

lemma subst_rec_subst_rec [rule_format]:
     "v \<in> redexes \<Longrightarrow>
        \<forall>m \<in> nat. \<forall>n \<in> nat. \<forall>u \<in> redexes. \<forall>w \<in> redexes. m\<le>n \<longrightarrow>
          subst_rec(subst_rec(w,u,n),subst_rec(lift_rec(w,m),v,succ(n)),m) =
          subst_rec(w,subst_rec(u,v,m),n)"
apply (erule redexes.induct)
apply (simp_all add: lift_lift [symmetric] lift_rec_subst_rec_lt, safe)
apply (rename_tac n' u w)
apply (case_tac "n \<le> succ(n') ")
 apply (erule_tac i = n in leE)
 apply (simp_all add: succ_pred subst_rec_lift_rec leI)
 apply (case_tac "n < m")
  apply (frule lt_trans2, assumption, simp add: gt_pred)
 apply simp
 apply (erule_tac j = n in leE, simp add: gt_pred)
 apply (simp add: subst_rec_lift_rec)
(*final case*)
apply (frule nat_into_Ord [THEN le_refl, THEN lt_trans], assumption)
apply (erule leE)
 apply (frule succ_leI [THEN lt_trans], assumption)
 apply (frule_tac i = m in nat_into_Ord [THEN le_refl, THEN lt_trans],
        assumption)
 apply (simp_all add: succ_pred lt_pred)
done

lemma substitution:
     "\<lbrakk>v \<in> redexes; u \<in> redexes; w \<in> redexes; n \<in> nat\<rbrakk>
      \<Longrightarrow> subst_rec(w,u,n)/subst_rec(lift(w),v,succ(n)) = subst_rec(w,u/v,n)"
by (simp add: subst_rec_subst_rec)

(* ------------------------------------------------------------------------- *)
(*          Preservation lemmas                                              *)
(*          Substitution preserves comp and regular                          *)
(* ------------------------------------------------------------------------- *)

lemma lift_rec_preserve_comp [rule_format, simp]:
     "u \<sim> v \<Longrightarrow> \<forall>m \<in> nat. lift_rec(u,m) \<sim> lift_rec(v,m)"
by (erule Scomp.induct, simp_all add: comp_refl)

lemma subst_rec_preserve_comp [rule_format, simp]:
     "u2 \<sim> v2 \<Longrightarrow> \<forall>m \<in> nat. \<forall>u1 \<in> redexes. \<forall>v1 \<in> redexes.
                  u1 \<sim> v1\<longrightarrow> subst_rec(u1,u2,m) \<sim> subst_rec(v1,v2,m)"
by (erule Scomp.induct,
    simp_all add: subst_Var lift_rec_preserve_comp comp_refl)

lemma lift_rec_preserve_reg [simp]:
     "regular(u) \<Longrightarrow> \<forall>m \<in> nat. regular(lift_rec(u,m))"
by (erule Sreg.induct, simp_all add: lift_rec_Var)

lemma subst_rec_preserve_reg [simp]:
     "regular(v) \<Longrightarrow>
        \<forall>m \<in> nat. \<forall>u \<in> redexes. regular(u)\<longrightarrow>regular(subst_rec(u,v,m))"
by (erule Sreg.induct, simp_all add: subst_Var lift_rec_preserve_reg)

end


(*  Title:      HOL/Map.thy
    Author:     Tobias Nipkow, based on a theory by David von Oheimb
    Copyright   1997-2003 TU Muenchen

The datatype of `maps' (written ~=>); strongly resembles maps in VDM.
*)

section {* Maps *}

theory Map
imports List
begin

type_synonym ('a,'b) "map" = "'a => 'b option" (infixr "~=>" 0)

type_notation (xsymbols)
  "map" (infixr "\<rightharpoonup>" 0)

abbreviation
  empty :: "'a ~=> 'b" where
  "empty == %x. None"

definition
  map_comp :: "('b ~=> 'c) => ('a ~=> 'b) => ('a ~=> 'c)"  (infixl "o'_m" 55) where
  "f o_m g = (\<lambda>k. case g k of None \<Rightarrow> None | Some v \<Rightarrow> f v)"

notation (xsymbols)
  map_comp  (infixl "\<circ>\<^sub>m" 55)

definition
  map_add :: "('a ~=> 'b) => ('a ~=> 'b) => ('a ~=> 'b)"  (infixl "++" 100) where
  "m1 ++ m2 = (\<lambda>x. case m2 x of None => m1 x | Some y => Some y)"

definition
  restrict_map :: "('a ~=> 'b) => 'a set => ('a ~=> 'b)"  (infixl "|`"  110) where
  "m|`A = (\<lambda>x. if x : A then m x else None)"

notation (latex output)
  restrict_map  ("_\<restriction>\<^bsub>_\<^esub>" [111,110] 110)

definition
  dom :: "('a ~=> 'b) => 'a set" where
  "dom m = {a. m a ~= None}"

definition
  ran :: "('a ~=> 'b) => 'b set" where
  "ran m = {b. EX a. m a = Some b}"

definition
  map_le :: "('a ~=> 'b) => ('a ~=> 'b) => bool"  (infix "\<subseteq>\<^sub>m" 50) where
  "(m\<^sub>1 \<subseteq>\<^sub>m m\<^sub>2) = (\<forall>a \<in> dom m\<^sub>1. m\<^sub>1 a = m\<^sub>2 a)"

nonterminal maplets and maplet

syntax
  "_maplet"  :: "['a, 'a] => maplet"             ("_ /|->/ _")
  "_maplets" :: "['a, 'a] => maplet"             ("_ /[|->]/ _")
  ""         :: "maplet => maplets"             ("_")
  "_Maplets" :: "[maplet, maplets] => maplets" ("_,/ _")
  "_MapUpd"  :: "['a ~=> 'b, maplets] => 'a ~=> 'b" ("_/'(_')" [900,0]900)
  "_Map"     :: "maplets => 'a ~=> 'b"            ("(1[_])")

syntax (xsymbols)
  "_maplet"  :: "['a, 'a] => maplet"             ("_ /\<mapsto>/ _")
  "_maplets" :: "['a, 'a] => maplet"             ("_ /[\<mapsto>]/ _")

translations
  "_MapUpd m (_Maplets xy ms)"  == "_MapUpd (_MapUpd m xy) ms"
  "_MapUpd m (_maplet  x y)"    == "m(x := CONST Some y)"
  "_Map ms"                     == "_MapUpd (CONST empty) ms"
  "_Map (_Maplets ms1 ms2)"     <= "_MapUpd (_Map ms1) ms2"
  "_Maplets ms1 (_Maplets ms2 ms3)" <= "_Maplets (_Maplets ms1 ms2) ms3"

primrec
  map_of :: "('a \<times> 'b) list \<Rightarrow> 'a \<rightharpoonup> 'b" where
    "map_of [] = empty"
  | "map_of (p # ps) = (map_of ps)(fst p \<mapsto> snd p)"

definition
  map_upds :: "('a \<rightharpoonup> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list \<Rightarrow> 'a \<rightharpoonup> 'b" where
  "map_upds m xs ys = m ++ map_of (rev (zip xs ys))"

translations
  "_MapUpd m (_maplets x y)"    == "CONST map_upds m x y"

lemma map_of_Cons_code [code]:
  "map_of [] k = None"
  "map_of ((l, v) # ps) k = (if l = k then Some v else map_of ps k)"
  by simp_all

subsection {* @{term [source] empty} *}

lemma empty_upd_none [simp]: "empty(x := None) = empty"
by (rule ext) simp

subsection {* @{term [source] map_upd} *}

lemma map_upd_triv: "t k = Some x ==> t(k|->x) = t"
by (rule ext) simp

lemma map_upd_nonempty [simp]: "t(k|->x) ~= empty"
proof
  assume "t(k \<mapsto> x) = empty"
  then have "(t(k \<mapsto> x)) k = None" by simp
  then show False by simp
qed

lemma map_upd_eqD1:
  assumes "m(a\<mapsto>x) = n(a\<mapsto>y)"
  shows "x = y"
proof -
  from assms have "(m(a\<mapsto>x)) a = (n(a\<mapsto>y)) a" by simp
  then show ?thesis by simp
qed

lemma map_upd_Some_unfold:
  "((m(a|->b)) x = Some y) = (x = a \<and> b = y \<or> x \<noteq> a \<and> m x = Some y)"
by auto

lemma image_map_upd [simp]: "x \<notin> A \<Longrightarrow> m(x \<mapsto> y) ` A = m ` A"
by auto

lemma finite_range_updI: "finite (range f) ==> finite (range (f(a|->b)))"
unfolding image_def
apply (simp (no_asm_use) add:full_SetCompr_eq)
apply (rule finite_subset)
 prefer 2 apply assumption
apply (auto)
done

subsection {* @{term [source] map_of} *}

lemma map_of_eq_None_iff:
  "(map_of xys x = None) = (x \<notin> fst ` (set xys))"
by (induct xys) simp_all

lemma map_of_is_SomeD: "map_of xys x = Some y \<Longrightarrow> (x,y) \<in> set xys"
apply (induct xys)
 apply simp
apply (clarsimp split: if_splits)
done

lemma map_of_eq_Some_iff [simp]:
  "distinct(map fst xys) \<Longrightarrow> (map_of xys x = Some y) = ((x,y) \<in> set xys)"
apply (induct xys)
 apply simp
apply (auto simp: map_of_eq_None_iff [symmetric])
done

lemma Some_eq_map_of_iff [simp]:
  "distinct(map fst xys) \<Longrightarrow> (Some y = map_of xys x) = ((x,y) \<in> set xys)"
by (auto simp del:map_of_eq_Some_iff simp add: map_of_eq_Some_iff [symmetric])

lemma map_of_is_SomeI [simp]: "\<lbrakk> distinct(map fst xys); (x,y) \<in> set xys \<rbrakk>
    \<Longrightarrow> map_of xys x = Some y"
apply (induct xys)
 apply simp
apply force
done

lemma map_of_zip_is_None [simp]:
  "length xs = length ys \<Longrightarrow> (map_of (zip xs ys) x = None) = (x \<notin> set xs)"
by (induct rule: list_induct2) simp_all

lemma map_of_zip_is_Some:
  assumes "length xs = length ys"
  shows "x \<in> set xs \<longleftrightarrow> (\<exists>y. map_of (zip xs ys) x = Some y)"
using assms by (induct rule: list_induct2) simp_all

lemma map_of_zip_upd:
  fixes x :: 'a and xs :: "'a list" and ys zs :: "'b list"
  assumes "length ys = length xs"
    and "length zs = length xs"
    and "x \<notin> set xs"
    and "map_of (zip xs ys)(x \<mapsto> y) = map_of (zip xs zs)(x \<mapsto> z)"
  shows "map_of (zip xs ys) = map_of (zip xs zs)"
proof
  fix x' :: 'a
  show "map_of (zip xs ys) x' = map_of (zip xs zs) x'"
  proof (cases "x = x'")
    case True
    from assms True map_of_zip_is_None [of xs ys x']
      have "map_of (zip xs ys) x' = None" by simp
    moreover from assms True map_of_zip_is_None [of xs zs x']
      have "map_of (zip xs zs) x' = None" by simp
    ultimately show ?thesis by simp
  next
    case False from assms
      have "(map_of (zip xs ys)(x \<mapsto> y)) x' = (map_of (zip xs zs)(x \<mapsto> z)) x'" by auto
    with False show ?thesis by simp
  qed
qed

lemma map_of_zip_inject:
  assumes "length ys = length xs"
    and "length zs = length xs"
    and dist: "distinct xs"
    and map_of: "map_of (zip xs ys) = map_of (zip xs zs)"
  shows "ys = zs"
using assms(1) assms(2)[symmetric] using dist map_of proof (induct ys xs zs rule: list_induct3)
  case Nil show ?case by simp
next
  case (Cons y ys x xs z zs)
  from `map_of (zip (x#xs) (y#ys)) = map_of (zip (x#xs) (z#zs))`
    have map_of: "map_of (zip xs ys)(x \<mapsto> y) = map_of (zip xs zs)(x \<mapsto> z)" by simp
  from Cons have "length ys = length xs" and "length zs = length xs"
    and "x \<notin> set xs" by simp_all
  then have "map_of (zip xs ys) = map_of (zip xs zs)" using map_of by (rule map_of_zip_upd)
  with Cons.hyps `distinct (x # xs)` have "ys = zs" by simp
  moreover from map_of have "y = z" by (rule map_upd_eqD1)
  ultimately show ?case by simp
qed

lemma map_of_zip_map:
  "map_of (zip xs (map f xs)) = (\<lambda>x. if x \<in> set xs then Some (f x) else None)"
  by (induct xs) (simp_all add: fun_eq_iff)

lemma finite_range_map_of: "finite (range (map_of xys))"
apply (induct xys)
 apply (simp_all add: image_constant)
apply (rule finite_subset)
 prefer 2 apply assumption
apply auto
done

lemma map_of_SomeD: "map_of xs k = Some y \<Longrightarrow> (k, y) \<in> set xs"
by (induct xs) (simp, atomize (full), auto)

lemma map_of_mapk_SomeI:
  "inj f ==> map_of t k = Some x ==>
   map_of (map (split (%k. Pair (f k))) t) (f k) = Some x"
by (induct t) (auto simp add: inj_eq)

lemma weak_map_of_SomeI: "(k, x) : set l ==> \<exists>x. map_of l k = Some x"
by (induct l) auto

lemma map_of_filter_in:
  "map_of xs k = Some z \<Longrightarrow> P k z \<Longrightarrow> map_of (filter (split P) xs) k = Some z"
by (induct xs) auto

lemma map_of_map:
  "map_of (map (\<lambda>(k, v). (k, f v)) xs) = map_option f \<circ> map_of xs"
  by (induct xs) (auto simp add: fun_eq_iff)

lemma dom_map_option:
  "dom (\<lambda>k. map_option (f k) (m k)) = dom m"
  by (simp add: dom_def)

lemma dom_map_option_comp [simp]:
  "dom (map_option g \<circ> m) = dom m"
  using dom_map_option [of "\<lambda>_. g" m] by (simp add: comp_def)

subsection {* @{const map_option} related *}

lemma map_option_o_empty [simp]: "map_option f o empty = empty"
by (rule ext) simp

lemma map_option_o_map_upd [simp]:
  "map_option f o m(a|->b) = (map_option f o m)(a|->f b)"
by (rule ext) simp

subsection {* @{term [source] map_comp} related *}

lemma map_comp_empty [simp]:
  "m \<circ>\<^sub>m empty = empty"
  "empty \<circ>\<^sub>m m = empty"
by (auto simp add: map_comp_def split: option.splits)

lemma map_comp_simps [simp]:
  "m2 k = None \<Longrightarrow> (m1 \<circ>\<^sub>m m2) k = None"
  "m2 k = Some k' \<Longrightarrow> (m1 \<circ>\<^sub>m m2) k = m1 k'"
by (auto simp add: map_comp_def)

lemma map_comp_Some_iff:
  "((m1 \<circ>\<^sub>m m2) k = Some v) = (\<exists>k'. m2 k = Some k' \<and> m1 k' = Some v)"
by (auto simp add: map_comp_def split: option.splits)

lemma map_comp_None_iff:
  "((m1 \<circ>\<^sub>m m2) k = None) = (m2 k = None \<or> (\<exists>k'. m2 k = Some k' \<and> m1 k' = None)) "
by (auto simp add: map_comp_def split: option.splits)

subsection {* @{text "++"} *}

lemma map_add_empty[simp]: "m ++ empty = m"
by(simp add: map_add_def)

lemma empty_map_add[simp]: "empty ++ m = m"
by (rule ext) (simp add: map_add_def split: option.split)

lemma map_add_assoc[simp]: "m1 ++ (m2 ++ m3) = (m1 ++ m2) ++ m3"
by (rule ext) (simp add: map_add_def split: option.split)

lemma map_add_Some_iff:
  "((m ++ n) k = Some x) = (n k = Some x | n k = None & m k = Some x)"
by (simp add: map_add_def split: option.split)

lemma map_add_SomeD [dest!]:
  "(m ++ n) k = Some x \<Longrightarrow> n k = Some x \<or> n k = None \<and> m k = Some x"
by (rule map_add_Some_iff [THEN iffD1])

lemma map_add_find_right [simp]: "!!xx. n k = Some xx ==> (m ++ n) k = Some xx"
by (subst map_add_Some_iff) fast

lemma map_add_None [iff]: "((m ++ n) k = None) = (n k = None & m k = None)"
by (simp add: map_add_def split: option.split)

lemma map_add_upd[simp]: "f ++ g(x|->y) = (f ++ g)(x|->y)"
by (rule ext) (simp add: map_add_def)

lemma map_add_upds[simp]: "m1 ++ (m2(xs[\<mapsto>]ys)) = (m1++m2)(xs[\<mapsto>]ys)"
by (simp add: map_upds_def)

lemma map_add_upd_left: "m\<notin>dom e2 \<Longrightarrow> e1(m \<mapsto> u1) ++ e2 = (e1 ++ e2)(m \<mapsto> u1)"
by (rule ext) (auto simp: map_add_def dom_def split: option.split)

lemma map_of_append[simp]: "map_of (xs @ ys) = map_of ys ++ map_of xs"
unfolding map_add_def
apply (induct xs)
 apply simp
apply (rule ext)
apply (simp split add: option.split)
done

lemma finite_range_map_of_map_add:
  "finite (range f) ==> finite (range (f ++ map_of l))"
apply (induct l)
 apply (auto simp del: fun_upd_apply)
apply (erule finite_range_updI)
done

lemma inj_on_map_add_dom [iff]:
  "inj_on (m ++ m') (dom m') = inj_on m' (dom m')"
by (fastforce simp: map_add_def dom_def inj_on_def split: option.splits)

lemma map_upds_fold_map_upd:
  "m(ks[\<mapsto>]vs) = foldl (\<lambda>m (k, v). m(k \<mapsto> v)) m (zip ks vs)"
unfolding map_upds_def proof (rule sym, rule zip_obtain_same_length)
  fix ks :: "'a list" and vs :: "'b list"
  assume "length ks = length vs"
  then show "foldl (\<lambda>m (k, v). m(k\<mapsto>v)) m (zip ks vs) = m ++ map_of (rev (zip ks vs))"
    by(induct arbitrary: m rule: list_induct2) simp_all
qed

lemma map_add_map_of_foldr:
  "m ++ map_of ps = foldr (\<lambda>(k, v) m. m(k \<mapsto> v)) ps m"
  by (induct ps) (auto simp add: fun_eq_iff map_add_def)

subsection {* @{term [source] restrict_map} *}

lemma restrict_map_to_empty [simp]: "m|`{} = empty"
by (simp add: restrict_map_def)

lemma restrict_map_insert: "f |` (insert a A) = (f |` A)(a := f a)"
by (auto simp add: restrict_map_def)

lemma restrict_map_empty [simp]: "empty|`D = empty"
by (simp add: restrict_map_def)

lemma restrict_in [simp]: "x \<in> A \<Longrightarrow> (m|`A) x = m x"
by (simp add: restrict_map_def)

lemma restrict_out [simp]: "x \<notin> A \<Longrightarrow> (m|`A) x = None"
by (simp add: restrict_map_def)

lemma ran_restrictD: "y \<in> ran (m|`A) \<Longrightarrow> \<exists>x\<in>A. m x = Some y"
by (auto simp: restrict_map_def ran_def split: split_if_asm)

lemma dom_restrict [simp]: "dom (m|`A) = dom m \<inter> A"
by (auto simp: restrict_map_def dom_def split: split_if_asm)

lemma restrict_upd_same [simp]: "m(x\<mapsto>y)|`(-{x}) = m|`(-{x})"
by (rule ext) (auto simp: restrict_map_def)

lemma restrict_restrict [simp]: "m|`A|`B = m|`(A\<inter>B)"
by (rule ext) (auto simp: restrict_map_def)

lemma restrict_fun_upd [simp]:
  "m(x := y)|`D = (if x \<in> D then (m|`(D-{x}))(x := y) else m|`D)"
by (simp add: restrict_map_def fun_eq_iff)

lemma fun_upd_None_restrict [simp]:
  "(m|`D)(x := None) = (if x:D then m|`(D - {x}) else m|`D)"
by (simp add: restrict_map_def fun_eq_iff)

lemma fun_upd_restrict: "(m|`D)(x := y) = (m|`(D-{x}))(x := y)"
by (simp add: restrict_map_def fun_eq_iff)

lemma fun_upd_restrict_conv [simp]:
  "x \<in> D \<Longrightarrow> (m|`D)(x := y) = (m|`(D-{x}))(x := y)"
by (simp add: restrict_map_def fun_eq_iff)

lemma map_of_map_restrict:
  "map_of (map (\<lambda>k. (k, f k)) ks) = (Some \<circ> f) |` set ks"
  by (induct ks) (simp_all add: fun_eq_iff restrict_map_insert)

lemma restrict_complement_singleton_eq:
  "f |` (- {x}) = f(x := None)"
  by (simp add: restrict_map_def fun_eq_iff)

subsection {* @{term [source] map_upds} *}

lemma map_upds_Nil1 [simp]: "m([] [|->] bs) = m"
by (simp add: map_upds_def)

lemma map_upds_Nil2 [simp]: "m(as [|->] []) = m"
by (simp add:map_upds_def)

lemma map_upds_Cons [simp]: "m(a#as [|->] b#bs) = (m(a|->b))(as[|->]bs)"
by (simp add:map_upds_def)

lemma map_upds_append1 [simp]: "\<And>ys m. size xs < size ys \<Longrightarrow>
  m(xs@[x] [\<mapsto>] ys) = m(xs [\<mapsto>] ys)(x \<mapsto> ys!size xs)"
apply(induct xs)
 apply (clarsimp simp add: neq_Nil_conv)
apply (case_tac ys)
 apply simp
apply simp
done

lemma map_upds_list_update2_drop [simp]:
  "size xs \<le> i \<Longrightarrow> m(xs[\<mapsto>]ys[i:=y]) = m(xs[\<mapsto>]ys)"
apply (induct xs arbitrary: m ys i)
 apply simp
apply (case_tac ys)
 apply simp
apply (simp split: nat.split)
done

lemma map_upd_upds_conv_if:
  "(f(x|->y))(xs [|->] ys) =
   (if x : set(take (length ys) xs) then f(xs [|->] ys)
                                    else (f(xs [|->] ys))(x|->y))"
apply (induct xs arbitrary: x y ys f)
 apply simp
apply (case_tac ys)
 apply (auto split: split_if simp: fun_upd_twist)
done

lemma map_upds_twist [simp]:
  "a ~: set as ==> m(a|->b)(as[|->]bs) = m(as[|->]bs)(a|->b)"
using set_take_subset by (fastforce simp add: map_upd_upds_conv_if)

lemma map_upds_apply_nontin [simp]:
  "x ~: set xs ==> (f(xs[|->]ys)) x = f x"
apply (induct xs arbitrary: ys)
 apply simp
apply (case_tac ys)
 apply (auto simp: map_upd_upds_conv_if)
done

lemma fun_upds_append_drop [simp]:
  "size xs = size ys \<Longrightarrow> m(xs@zs[\<mapsto>]ys) = m(xs[\<mapsto>]ys)"
apply (induct xs arbitrary: m ys)
 apply simp
apply (case_tac ys)
 apply simp_all
done

lemma fun_upds_append2_drop [simp]:
  "size xs = size ys \<Longrightarrow> m(xs[\<mapsto>]ys@zs) = m(xs[\<mapsto>]ys)"
apply (induct xs arbitrary: m ys)
 apply simp
apply (case_tac ys)
 apply simp_all
done

lemma restrict_map_upds[simp]:
  "\<lbrakk> length xs = length ys; set xs \<subseteq> D \<rbrakk>
    \<Longrightarrow> m(xs [\<mapsto>] ys)|`D = (m|`(D - set xs))(xs [\<mapsto>] ys)"
apply (induct xs arbitrary: m ys)
 apply simp
apply (case_tac ys)
 apply simp
apply (simp add: Diff_insert [symmetric] insert_absorb)
apply (simp add: map_upd_upds_conv_if)
done

subsection {* @{term [source] dom} *}

lemma dom_eq_empty_conv [simp]: "dom f = {} \<longleftrightarrow> f = empty"
  by (auto simp: dom_def)

lemma domI: "m a = Some b ==> a : dom m"
by(simp add:dom_def)
(* declare domI [intro]? *)

lemma domD: "a : dom m ==> \<exists>b. m a = Some b"
by (cases "m a") (auto simp add: dom_def)

lemma domIff [iff, simp del]: "(a : dom m) = (m a ~= None)"
by(simp add:dom_def)

lemma dom_empty [simp]: "dom empty = {}"
by(simp add:dom_def)

lemma dom_fun_upd [simp]:
  "dom(f(x := y)) = (if y=None then dom f - {x} else insert x (dom f))"
by(auto simp add:dom_def)

lemma dom_if:
  "dom (\<lambda>x. if P x then f x else g x) = dom f \<inter> {x. P x} \<union> dom g \<inter> {x. \<not> P x}"
  by (auto split: if_splits)

lemma dom_map_of_conv_image_fst:
  "dom (map_of xys) = fst ` set xys"
  by (induct xys) (auto simp add: dom_if)

lemma dom_map_of_zip [simp]: "length xs = length ys ==> dom (map_of (zip xs ys)) = set xs"
by (induct rule: list_induct2) (auto simp add: dom_if)

lemma finite_dom_map_of: "finite (dom (map_of l))"
by (induct l) (auto simp add: dom_def insert_Collect [symmetric])

lemma dom_map_upds [simp]:
  "dom(m(xs[|->]ys)) = set(take (length ys) xs) Un dom m"
apply (induct xs arbitrary: m ys)
 apply simp
apply (case_tac ys)
 apply auto
done

lemma dom_map_add [simp]: "dom(m++n) = dom n Un dom m"
by(auto simp:dom_def)

lemma dom_override_on [simp]:
  "dom(override_on f g A) =
    (dom f  - {a. a : A - dom g}) Un {a. a : A Int dom g}"
by(auto simp: dom_def override_on_def)

lemma map_add_dom_app_simps:
  "\<lbrakk> m\<in>dom l2 \<rbrakk> \<Longrightarrow> (l1++l2) m = l2 m"
  "\<lbrakk> m\<notin>dom l1 \<rbrakk> \<Longrightarrow> (l1++l2) m = l2 m"
  "\<lbrakk> m\<notin>dom l2 \<rbrakk> \<Longrightarrow> (l1++l2) m = l1 m"
by (auto simp add: map_add_def split: option.split_asm)

lemma dom_const [simp]:
  "dom (\<lambda>x. Some (f x)) = UNIV"
  by auto

(* Due to John Matthews - could be rephrased with dom *)
lemma finite_map_freshness:
  "finite (dom (f :: 'a \<rightharpoonup> 'b)) \<Longrightarrow> \<not> finite (UNIV :: 'a set) \<Longrightarrow>
   \<exists>x. f x = None"
by(bestsimp dest:ex_new_if_finite)

lemma dom_minus:
  "f x = None \<Longrightarrow> dom f - insert x A = dom f - A"
  unfolding dom_def by simp

lemma insert_dom:
  "f x = Some y \<Longrightarrow> insert x (dom f) = dom f"
  unfolding dom_def by auto

lemma map_of_map_keys:
  "set xs = dom m \<Longrightarrow> map_of (map (\<lambda>k. (k, the (m k))) xs) = m"
  by (rule ext) (auto simp add: map_of_map_restrict restrict_map_def)

lemma map_of_eqI:
  assumes set_eq: "set (map fst xs) = set (map fst ys)"
  assumes map_eq: "\<forall>k\<in>set (map fst xs). map_of xs k = map_of ys k"
  shows "map_of xs = map_of ys"
proof (rule ext)
  fix k show "map_of xs k = map_of ys k"
  proof (cases "map_of xs k")
    case None then have "k \<notin> set (map fst xs)" by (simp add: map_of_eq_None_iff)
    with set_eq have "k \<notin> set (map fst ys)" by simp
    then have "map_of ys k = None" by (simp add: map_of_eq_None_iff)
    with None show ?thesis by simp
  next
    case (Some v) then have "k \<in> set (map fst xs)" by (auto simp add: dom_map_of_conv_image_fst [symmetric])
    with map_eq show ?thesis by auto
  qed
qed

lemma map_of_eq_dom:
  assumes "map_of xs = map_of ys"
  shows "fst ` set xs = fst ` set ys"
proof -
  from assms have "dom (map_of xs) = dom (map_of ys)" by simp
  then show ?thesis by (simp add: dom_map_of_conv_image_fst)
qed

lemma finite_set_of_finite_maps:
assumes "finite A" "finite B"
shows  "finite {m. dom m = A \<and> ran m \<subseteq> B}" (is "finite ?S")
proof -
  let ?S' = "{m. \<forall>x. (x \<in> A \<longrightarrow> m x \<in> Some ` B) \<and> (x \<notin> A \<longrightarrow> m x = None)}"
  have "?S = ?S'"
  proof
    show "?S \<subseteq> ?S'" by(auto simp: dom_def ran_def image_def)
    show "?S' \<subseteq> ?S"
    proof
      fix m assume "m \<in> ?S'"
      hence 1: "dom m = A" by force
      hence 2: "ran m \<subseteq> B" using `m \<in> ?S'` by(auto simp: dom_def ran_def)
      from 1 2 show "m \<in> ?S" by blast
    qed
  qed
  with assms show ?thesis by(simp add: finite_set_of_finite_funs)
qed

subsection {* @{term [source] ran} *}

lemma ranI: "m a = Some b ==> b : ran m"
by(auto simp: ran_def)
(* declare ranI [intro]? *)

lemma ran_empty [simp]: "ran empty = {}"
by(auto simp: ran_def)

lemma ran_map_upd [simp]: "m a = None ==> ran(m(a|->b)) = insert b (ran m)"
unfolding ran_def
apply auto
apply (subgoal_tac "aa ~= a")
 apply auto
done

lemma ran_distinct:
  assumes dist: "distinct (map fst al)"
  shows "ran (map_of al) = snd ` set al"
using assms proof (induct al)
  case Nil then show ?case by simp
next
  case (Cons kv al)
  then have "ran (map_of al) = snd ` set al" by simp
  moreover from Cons.prems have "map_of al (fst kv) = None"
    by (simp add: map_of_eq_None_iff)
  ultimately show ?case by (simp only: map_of.simps ran_map_upd) simp
qed

subsection {* @{text "map_le"} *}

lemma map_le_empty [simp]: "empty \<subseteq>\<^sub>m g"
by (simp add: map_le_def)

lemma upd_None_map_le [simp]: "f(x := None) \<subseteq>\<^sub>m f"
by (force simp add: map_le_def)

lemma map_le_upd[simp]: "f \<subseteq>\<^sub>m g ==> f(a := b) \<subseteq>\<^sub>m g(a := b)"
by (fastforce simp add: map_le_def)

lemma map_le_imp_upd_le [simp]: "m1 \<subseteq>\<^sub>m m2 \<Longrightarrow> m1(x := None) \<subseteq>\<^sub>m m2(x \<mapsto> y)"
by (force simp add: map_le_def)

lemma map_le_upds [simp]:
  "f \<subseteq>\<^sub>m g ==> f(as [|->] bs) \<subseteq>\<^sub>m g(as [|->] bs)"
apply (induct as arbitrary: f g bs)
 apply simp
apply (case_tac bs)
 apply auto
done

lemma map_le_implies_dom_le: "(f \<subseteq>\<^sub>m g) \<Longrightarrow> (dom f \<subseteq> dom g)"
by (fastforce simp add: map_le_def dom_def)

lemma map_le_refl [simp]: "f \<subseteq>\<^sub>m f"
by (simp add: map_le_def)

lemma map_le_trans[trans]: "\<lbrakk> m1 \<subseteq>\<^sub>m m2; m2 \<subseteq>\<^sub>m m3\<rbrakk> \<Longrightarrow> m1 \<subseteq>\<^sub>m m3"
by (auto simp add: map_le_def dom_def)

lemma map_le_antisym: "\<lbrakk> f \<subseteq>\<^sub>m g; g \<subseteq>\<^sub>m f \<rbrakk> \<Longrightarrow> f = g"
unfolding map_le_def
apply (rule ext)
apply (case_tac "x \<in> dom f", simp)
apply (case_tac "x \<in> dom g", simp, fastforce)
done

lemma map_le_map_add [simp]: "f \<subseteq>\<^sub>m (g ++ f)"
by (fastforce simp add: map_le_def)

lemma map_le_iff_map_add_commute: "(f \<subseteq>\<^sub>m f ++ g) = (f++g = g++f)"
by(fastforce simp: map_add_def map_le_def fun_eq_iff split: option.splits)

lemma map_add_le_mapE: "f++g \<subseteq>\<^sub>m h \<Longrightarrow> g \<subseteq>\<^sub>m h"
by (fastforce simp add: map_le_def map_add_def dom_def)

lemma map_add_le_mapI: "\<lbrakk> f \<subseteq>\<^sub>m h; g \<subseteq>\<^sub>m h \<rbrakk> \<Longrightarrow> f++g \<subseteq>\<^sub>m h"
by (clarsimp simp add: map_le_def map_add_def dom_def split: option.splits)

lemma dom_eq_singleton_conv: "dom f = {x} \<longleftrightarrow> (\<exists>v. f = [x \<mapsto> v])"
proof(rule iffI)
  assume "\<exists>v. f = [x \<mapsto> v]"
  thus "dom f = {x}" by(auto split: split_if_asm)
next
  assume "dom f = {x}"
  then obtain v where "f x = Some v" by auto
  hence "[x \<mapsto> v] \<subseteq>\<^sub>m f" by(auto simp add: map_le_def)
  moreover have "f \<subseteq>\<^sub>m [x \<mapsto> v]" using `dom f = {x}` `f x = Some v`
    by(auto simp add: map_le_def)
  ultimately have "f = [x \<mapsto> v]" by-(rule map_le_antisym)
  thus "\<exists>v. f = [x \<mapsto> v]" by blast
qed

subsection {* Various *}

lemma set_map_of_compr:
  assumes distinct: "distinct (map fst xs)"
  shows "set xs = {(k, v). map_of xs k = Some v}"
using assms proof (induct xs)
  case Nil then show ?case by simp
next
  case (Cons x xs)
  obtain k v where "x = (k, v)" by (cases x) blast
  with Cons.prems have "k \<notin> dom (map_of xs)"
    by (simp add: dom_map_of_conv_image_fst)
  then have *: "insert (k, v) {(k, v). map_of xs k = Some v} =
    {(k', v'). (map_of xs(k \<mapsto> v)) k' = Some v'}"
    by (auto split: if_splits)
  from Cons have "set xs = {(k, v). map_of xs k = Some v}" by simp
  with * `x = (k, v)` show ?case by simp
qed

lemma map_of_inject_set:
  assumes distinct: "distinct (map fst xs)" "distinct (map fst ys)"
  shows "map_of xs = map_of ys \<longleftrightarrow> set xs = set ys" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  assume ?lhs
  moreover from `distinct (map fst xs)` have "set xs = {(k, v). map_of xs k = Some v}"
    by (rule set_map_of_compr)
  moreover from `distinct (map fst ys)` have "set ys = {(k, v). map_of ys k = Some v}"
    by (rule set_map_of_compr)
  ultimately show ?rhs by simp
next
  assume ?rhs show ?lhs
  proof
    fix k
    show "map_of xs k = map_of ys k" proof (cases "map_of xs k")
      case None
      with `?rhs` have "map_of ys k = None"
        by (simp add: map_of_eq_None_iff)
      with None show ?thesis by simp
    next
      case (Some v)
      with distinct `?rhs` have "map_of ys k = Some v"
        by simp
      with Some show ?thesis by simp
    qed
  qed
qed

end


theory CC_Explain2_Correctness
  imports CC_Explain2_Termination
begin

section \<open>Correctness proof of \<open>cc_explain2\<close>\<close>

lemma explain_along_path2_correctness:
  assumes "explain_along_path2_dom (\<lparr>cc_list = cc_l, use_list = u, lookup = t, pending = pe,
proof_forest = pf, pf_labels = pfl, input = ip\<rparr>, a, c)"
    (is "explain_along_path2_dom (?cc, a, c)")
    "ufa_invar pf"
    "a < length pf"
    "c < length pf"
    "explain_along_path2 \<lparr>cc_list = cc_l, use_list = u, lookup = t, pending = pe,
proof_forest = pf, pf_labels = pfl, input = ip\<rparr> a c = (output, pend)"
    "path pf c pAC a"
    "pf_labels_invar \<lparr>cc_list = cc_l, use_list = u, lookup = t, pending = pe,
proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
  shows "(a \<approx> c) \<in> Congruence_Closure (output \<union> pending_set_explain pend)"
  using assms proof(induction "\<lparr>cc_list = cc_l, use_list = u, lookup = t, pending = pe,
proof_forest = pf, pf_labels = pfl, input = ip\<rparr>"
    a c arbitrary: pAC "output" pend rule: explain_along_path2.pinduct)
  case (1 a c)
  then show ?case proof(cases "a = c")
    case True
    then show ?thesis
      by (simp add: Congruence_Closure.reflexive)
  next
    case False
    let ?cc = "\<lparr>cc_list = cc_l, use_list = u, lookup = t, pending = pe, proof_forest = pf,
pf_labels = pfl,  input = ip\<rparr>"
    from False obtain output' pend' where recursive_step:
      "explain_along_path2 ?cc (pf ! a) c = (output', pend')"
      by fastforce
    obtain pRAC where pRAC: "pf ! a \<noteq> a \<and> path pf c pRAC a"
      using "1.prems" False assms(2) explain_list_invar_imp_valid_rep path_root by blast
    with "1.prems"  have pRAC': "path pf c (butlast pRAC) (pf ! a)"
      using False path_butlast by blast
    obtain aa a\<^sub>1 a\<^sub>2 bb b\<^sub>1 b\<^sub>2 where valid_eq: "
(pfl ! a = Some (One (aa \<approx> bb)) \<or>
          pfl ! a = Some (Two (F a\<^sub>1 a\<^sub>2 \<approx> aa) (F b\<^sub>1 b\<^sub>2 \<approx> bb)))
          \<and> (aa = pf ! a \<and> bb = a \<or> aa = a \<and> bb = pf ! a)
        "using "1.prems" unfolding pf_labels_invar_def congruence_closure.select_convs
      by (meson pRAC path_nodes_lt_length_l)
    have rep_neq: "a \<noteq> (pf ! a)"
      using pRAC "1.prems" False rep_of_a_and_parent_rep_neq by simp
    then have valid: "(pf ! a) < length pf"
      using "1.prems" path_nodes_lt_length_l ufa_invarD(2) ufa_union_invar by blast
        \<comment> \<open>If \<open>(pf ! a) \<approx> c\<close> is in the congruence closure of the recursive call,
        then it will also be in the congruence closure of the output.\<close>
    have cc_output: "((pf ! a) \<approx> c) \<in>
 Congruence_Closure (output'
\<union> pending_set_explain pend')
\<Longrightarrow> ((pf ! a) \<approx> a) \<in> Congruence_Closure
        (output \<union> pending_set_explain pend)
\<Longrightarrow> output' \<subseteq> output
\<Longrightarrow> pending_set_explain pend' \<subseteq> pending_set_explain pend
\<Longrightarrow> ((pf ! a) \<approx> c) \<in> Congruence_Closure
        (output \<union> pending_set_explain pend)"
    proof(rule Congruence_Closure_imp)
      fix eq
      assume prems: "eq \<in> output' \<union> pending_set_explain pend'"
        "((pf ! a) \<approx> a)
         \<in> Congruence_Closure (output \<union> pending_set_explain pend)"
        "output' \<subseteq> output" "pending_set_explain pend' \<subseteq> pending_set_explain pend"
      then show "eq \<in> Congruence_Closure (output \<union> pending_set_explain pend)"
        by blast
    qed
    show ?thesis proof(cases "the (pfl ! a)")
      case (One a')
      from valid_eq have *: "pfl ! a = Some (One a')"
        using One by auto
      with recursive_step 1(2)[OF False] have IH:
        "(pf ! a \<approx> c) \<in> Congruence_Closure (output' \<union> pending_set_explain pend')"
        using "1.prems" One pRAC' * valid  by simp
      have result: "(output, pend) = ({a'} \<union> output', pend')"
        using 1 explain_along_path2_simp2[OF False] One False * recursive_step by simp
      then have a': "a' = (a \<approx> pf ! a) \<or> a' = (pf ! a \<approx> a)"
        using One valid_eq by auto
      then have "(a \<approx> pf ! a) \<in> Congruence_Closure ({a'} \<union> output')"
        by blast
      with result have 2: "(a \<approx> pf ! a) \<in>
Congruence_Closure (output \<union> pending_set_explain pend)"
        using Congruence_Closure_split_rule by (metis (no_types, lifting) Pair_inject sup_commute)
      from result have "output' \<subseteq> output"  "pending_set_explain pend' \<subseteq> pending_set_explain pend"
        by blast+
      with cc_output have 3: "(pf ! a \<approx> c) \<in> Congruence_Closure
        (output \<union> pending_set_explain pend)"
        using "2" IH by blast
      from 2 3 show ?thesis by blast
    next
      case (Two x21 x22)
      then obtain a\<^sub>1 a\<^sub>2 a' b\<^sub>1 b\<^sub>2 b' where *: "(pfl ! a)
= Some (Two (F a\<^sub>1 a\<^sub>2 \<approx> a') (F b\<^sub>1 b\<^sub>2 \<approx> b'))"
        by (metis option.sel pending_equation.distinct(1) valid_eq)
      with recursive_step 1(3)[OF False] have IH:
        "(pf ! a \<approx> c) \<in>
 Congruence_Closure (output'
\<union> pending_set_explain pend')"
        using * pRAC' valid "1.prems" by auto
      have result: "(output, pend) =
({(F a\<^sub>1 a\<^sub>2 \<approx> a'), (F b\<^sub>1 b\<^sub>2 \<approx> b')} \<union> output', [(a\<^sub>1, b\<^sub>1), (a\<^sub>2, b\<^sub>2)] @ pend')"
        using False congruence_closure.select_convs * recursive_step 1(1,7) explain_along_path2_simp3
        by simp
      then have a': "a' = a \<and> b' = pf ! a
\<or> a' = pf ! a \<and> b' = a"
        using valid_eq * by auto
      have "(a\<^sub>1 \<approx> b\<^sub>1) \<in> Congruence_Closure (output \<union> pending_set_explain pend)"
        "(a\<^sub>2 \<approx> b\<^sub>2) \<in> Congruence_Closure (output \<union> pending_set_explain pend)"
        "(F a\<^sub>1 a\<^sub>2 \<approx> a') \<in> Congruence_Closure (output \<union> pending_set_explain pend)"
        "(F b\<^sub>1 b\<^sub>2 \<approx> b') \<in> Congruence_Closure (output \<union> pending_set_explain pend)"
        using result by auto
      then have 2: "(a \<approx> (pf ! a)) \<in>
Congruence_Closure (output \<union> pending_set_explain pend)"
        using a' monotonic by blast
      with cc_output have "((pf ! a) \<approx> c) \<in> Congruence_Closure
        (output \<union> pending_set_explain pend)"
        using Congruence_Closure_monotonic 2 result IH by auto
      then show ?thesis using 2 by blast
    qed
  qed
qed

lemma explain_along_path2_correctness':
  assumes "cc_invar cc"
    "explain_along_path2 cc a c = (output, pend)"
    "path (proof_forest cc) c pAC a"
  shows "(a \<approx> c) \<in> Congruence_Closure (output \<union> pending_set_explain pend)"
proof-
  obtain cc_l u t pe pf pfl ip where cc: "cc =
\<lparr>cc_list = cc_l, use_list = u, lookup = t, pending = pe, proof_forest = pf, pf_labels = pfl,
         input = ip\<rparr>" using congruence_closure.cases by blast
  then have "ufa_invar pf"
    "a < length pf"
    "c < length pf" "pf_labels_invar cc"
    using assms unfolding proof_forest_invar_def same_length_invar_def
       apply (metis congruence_closure.select_convs(5))
    using assms  cc path_nodes_lt_length_l proof_forest_loop propagate_loop.simps(2)
    unfolding proof_forest_invar_def same_length_invar_def
    by metis+
  then show ?thesis using explain_along_path2_correctness cc assms explain_along_path2_domain
    by (metis congruence_closure.select_convs(5))
qed

lemma cc_explain_aux2_correctness:
  assumes "cc_invar_t cc_t"
    "\<forall>(a, b)\<in>set xs. a < length (cc_list cc_t) \<and> b < length (cc_list cc_t)"
    "(x, y) \<in> set xs" "are_congruent cc (x \<approx> y)"
    "\<forall>(a, b)\<in>set xs. are_congruent cc (a \<approx> b)"
    "cc = congruence_closure.truncate cc_t"
  shows "(x \<approx> y) \<in> Congruence_Closure (cc_explain_aux2 cc xs)"
proof-
  have "cc_explain_aux2_dom (cc, xs)"
    using cc_explain_aux2_domain assms by blast
  then show ?thesis
    using assms proof(induction arbitrary: x y rule: cc_explain_aux2.pinduct)
    case (2 cc a b xs)
    have cc: "length (cc_list cc_t) = nr_vars cc" "cc_invar cc" using 2(4)
      unfolding congruence_closure.truncate_def congruence_closure.select_convs 2(9) by auto
    then show ?case proof(cases "are_congruent cc (a \<approx> b)")
      case True
      define c where "c = lowest_common_ancestor (proof_forest cc) a b"
      then obtain p1 p2 where p: "path (proof_forest cc) c p1 a"
        "path (proof_forest cc) c p2 b" using assms(2-) cc unfolding proof_forest_invar_def
        using cc "2.prems"(2) True case_prod_conv explain_along_path_lowest_common_ancestor
        by (metis list.set_intros(1))
      obtain output1 pending1 output2 pending2
        where
          eap: "(output1, pending1) = explain_along_path2 cc a c"
          "(output2, pending2) = explain_along_path2 cc b c"
        by (metis old.prod.exhaust)
      have "\<forall>a\<in>set pending1. case a of (a, b) \<Rightarrow>
 are_congruent cc (a \<approx> b)"
        "\<forall>a\<in>set pending2. case a of (a, b) \<Rightarrow>
 are_congruent cc (a \<approx> b)"
        using explain_along_path2_pending eap p cc
        by (metis case_prodI2 pending_set_explain_set)+
      then have pend: "\<forall>a\<in>set (pending1 @ pending2 @ xs). case a of (a, b) \<Rightarrow>
 are_congruent cc (a \<approx> b)"
        using 2(8) cc by fastforce
have "\<forall>a\<in>set pending1. case a of (a, b) \<Rightarrow>
a < nr_vars cc \<and> b < nr_vars cc"
        "\<forall>a\<in>set pending2. case a of (a, b) \<Rightarrow>
a < nr_vars cc \<and> b < nr_vars cc"
        using explain_along_path2_pending_in_bounds eap p cc
        by (metis)+
      then have pend2: "\<forall>a\<in>set (pending1 @ pending2 @ xs). case a of (a, b) \<Rightarrow>
a < length (cc_list cc_t) \<and> b < length (cc_list cc_t)"
        using 2(5) cc by fastforce
      have pend3: "\<forall>x \<in> pending_set_explain pending1.
are_congruent cc x" "\<forall>x \<in> pending_set_explain pending2.
are_congruent cc x" using explain_along_path2_pending eap p cc
        by (metis)+
      have less: "a < nr_vars cc" "b < nr_vars cc"
        using 2(5) cc by fastforce+
      then have "c < nr_vars cc"  using cc unfolding same_length_invar_def
        by (metis p(2) path_nodes_lt_length_l)
      have recursive: "cc_explain_aux2 cc ((a, b) # xs)
= output1 \<union> output2 \<union> cc_explain_aux2 cc (pending1 @ pending2 @ xs)"
        by (simp add: "2.hyps" cc_explain_aux2_simp2 True c_def eap(1) eap(2))
      have IH: "\<forall> a b. (a \<approx> b) \<in> pending_set_explain pending1 \<longrightarrow> are_congruent cc (a \<approx> b)
\<longrightarrow> (a \<approx> b) \<in> Congruence_Closure (cc_explain_aux2 cc (pending1 @ pending2 @ xs))"
        "\<forall> a b. (a \<approx> b) \<in> pending_set_explain pending2 \<longrightarrow> are_congruent cc (a \<approx> b)
\<longrightarrow> (a \<approx> b) \<in> Congruence_Closure (cc_explain_aux2 cc (pending1 @ pending2 @ xs))"
        using 2(2) True c_def eap 2(4-9) pend pend2
        by auto
      have subsets: "pending_set_explain pending1 \<subseteq>
Congruence_Closure (cc_explain_aux2 cc (pending1 @ pending2 @ xs))"
        "pending_set_explain pending2 \<subseteq>
Congruence_Closure (cc_explain_aux2 cc (pending1 @ pending2 @ xs))"
        using IH pend2 apply auto[1] using IH(2) pend3 by auto
      then show ?thesis using 2
      proof(cases "(x, y) = (a, b)")
        case True
        have "(a \<approx> c) \<in> Congruence_Closure (output1 \<union> pending_set_explain pending1)"
          "(b \<approx> c) \<in> Congruence_Closure (output2 \<union> pending_set_explain pending2)"
          using explain_along_path2_correctness' p less eap using cc by auto
        then have "(a \<approx> c) \<in> Congruence_Closure (output1 \<union> output2 \<union> cc_explain_aux2 cc (pending1 @ pending2 @ xs))"
          "(b \<approx> c) \<in> Congruence_Closure (output1 \<union> output2 \<union> cc_explain_aux2 cc (pending1 @ pending2 @ xs))"
          using Congruence_Closure_split_rule subsets
          by (smt (z3) Congruence_Closure_imp Un_commute Un_iff subset_eq)+
        then show ?thesis using recursive
          by (metis Congruence_Closure.symmetric Congruence_Closure.transitive1 True prod.inject)
      next
        case False
        then have "(x \<approx> y) \<in> Congruence_Closure (cc_explain_aux2 cc (pending1 @ pending2 @ xs))"
          using 2(2)[OF True c_def] eap 2(4,6,8,9) pend pend2
          by (metis "2.prems"(4) "2.prems"(4) Un_iff set_ConsD set_union_code)
        then show ?thesis
          using Congruence_Closure_union' recursive by auto
      qed
    next
      case False
      then show ?thesis using 2
        using cc_explain_aux2_simp3 by auto
    qed
  qed simp
qed

theorem cc_explain2_correctness:
  assumes "are_congruent cc (a \<approx> b)" "cc_invar_t cc_t" "valid_vars (a \<approx> b) (nr_vars cc)"
"cc = congruence_closure.truncate cc_t"
shows "(a \<approx> b) \<in> Congruence_Closure (cc_explain2 cc a b)"
proof-
 have cc: "length (cc_list cc_t) = nr_vars cc" "cc_invar cc" using assms(2)
   unfolding congruence_closure.truncate_def congruence_closure.select_convs assms(4) by auto
  then have "a < length (cc_list cc_t) \<and> b < length (cc_list cc_t)"
   using assms valid_vars.simps by simp
  then show ?thesis
    using cc_explain_aux2_correctness[OF assms(2)] valid_vars.simps assms by auto
qed

end


theory Codatatype
imports Main
begin

section {* Coinductive Datatypes as in Nunchaku or Isabelle/HOL *}

subsection {* Basic Setup *}

hide_type (open) list
hide_const (open) Nil Cons hd tl

text \<open>
This will be called @{text "iota!"} in Nunchaku:
\<close>

definition The_bang :: "('a \<Rightarrow> bool) \<Rightarrow> 'a" where
  "The_bang P = (if \<exists>x. P x then The P else Nitpick.unknown)"

typedecl elem
typedecl list

nitpick_params [user_axioms, dont_box, show_all, atoms elem = a b c d e f g h i j k l,
  atoms list = as bs cs ds es fs gs hs "is" js ks ls]

subsection {* Destructors *}

axiomatization
  null :: "list \<Rightarrow> bool" and
  hd :: "list \<Rightarrow> elem" and
  tl :: "list \<Rightarrow> list"

coinductive bisim :: "list \<Rightarrow> list \<Rightarrow> bool" where
  "null xs \<Longrightarrow> null ys \<Longrightarrow> bisim xs ys"
| "\<not> null xs \<Longrightarrow> \<not> null ys \<Longrightarrow> hd xs = hd ys \<Longrightarrow> bisim (tl xs) (tl ys) \<Longrightarrow> bisim xs ys"

axiomatization where
  unique: "\<And>xs ys. bisim xs ys \<Longrightarrow> xs = ys"

nitpick_params [card elem = 3, card list = 1-5, iter = 1-5]

subsection {* Constructors *}

definition
  Nil :: list
where
  "Nil = The_bang (\<lambda>ys. null ys)"

definition
  Cons :: "elem \<Rightarrow> list \<Rightarrow> list"
where
  "Cons x xs = The_bang (\<lambda>ys. \<not> null ys \<and> hd ys = x \<and> tl ys = xs)"

lemma "Nil \<noteq> Cons x xs"
  nitpick[satisfy, expect = genuine]
  nitpick[expect = none]
  sorry

lemma "xs = Nil \<or> xs = Cons (hd xs) (tl xs)"
  nitpick[satisfy, expect = genuine]
  nitpick [expect = none]
  sorry

lemma "xs \<noteq> Cons x xs"
  nitpick [expect = genuine]
  oops

lemma "xs \<noteq> Cons x (Cons y xs)"
  nitpick [expect = genuine]
  oops

lemma "x \<noteq> y \<Longrightarrow> xs \<noteq> Cons x (Cons y xs)"
  nitpick [expect = genuine]
  oops

lemma "xs = ys \<longleftrightarrow> (null xs \<and> null ys) \<or> (\<not> null xs \<and> \<not> null ys \<and> hd xs = hd ys \<and> tl xs = tl ys)"
  nitpick [expect = none]
  sorry

lemma "xs = Cons x ys \<Longrightarrow> ys = Cons x xs \<Longrightarrow> xs = ys"
  nitpick [expect = none]
  nitpick [satisfy, expect = genuine]
  sorry

end