theory Typed
  imports Type "../00Utils/Utils"
begin

datatype texpr =
  TVar var
  | TConst nat
  | TLam var ty texpr
  | TApp texpr texpr

primrec all_varst :: "texpr \<Rightarrow> var set" where
  "all_varst (TVar x) = {x}"
| "all_varst (TConst k) = {}"
| "all_varst (TLam x t e) = insert x (all_varst e)"
| "all_varst (TApp e\<^sub>1 e\<^sub>2) = all_varst e\<^sub>1 \<union> all_varst e\<^sub>2"

primrec free_varst :: "texpr \<Rightarrow> var set" where
  "free_varst (TVar x) = {x}"
| "free_varst (TConst k) = {}"
| "free_varst (TLam x t e) = free_varst e - {x}"
| "free_varst (TApp e\<^sub>1 e\<^sub>2) = free_varst e\<^sub>1 \<union> free_varst e\<^sub>2"

primrec tvarst :: "texpr \<Rightarrow> var set" where
  "tvarst (TVar x) = {}"
| "tvarst (TConst k) = {}"
| "tvarst (TLam x t e) = tvars t \<union> tvarst e"
| "tvarst (TApp e\<^sub>1 e\<^sub>2) = tvarst e\<^sub>1 \<union> tvarst e\<^sub>2"

inductive typecheckn :: "(var \<rightharpoonup> ty) \<Rightarrow> texpr \<Rightarrow> ty \<Rightarrow> bool" (infix "\<turnstile>\<^sub>n _ :" 50) where
  tcn_var [simp]: "\<Gamma> x = Some t \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>n TVar x : t"
| tcn_const [simp]: "\<Gamma> \<turnstile>\<^sub>n TConst k : Base"
| tcn_lam [simp]: "\<Gamma>(x \<mapsto> t\<^sub>1) \<turnstile>\<^sub>n e : t\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>n TLam x t\<^sub>1 e : Arrow t\<^sub>1 t\<^sub>2"
| tcn_app [simp]: "\<Gamma> \<turnstile>\<^sub>n e\<^sub>1 : Arrow t\<^sub>1 t\<^sub>2 \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>n e\<^sub>2 : t\<^sub>1 \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>n TApp e\<^sub>1 e\<^sub>2 : t\<^sub>2"

inductive_cases [elim]: "\<Gamma> \<turnstile>\<^sub>n TVar x : t"
inductive_cases [elim]: "\<Gamma> \<turnstile>\<^sub>n TConst k : t"
inductive_cases [elim]: "\<Gamma> \<turnstile>\<^sub>n TLam x t' e : t"
inductive_cases [elim]: "\<Gamma> \<turnstile>\<^sub>n TApp e\<^sub>1 e\<^sub>2 : t"

primrec valt :: "texpr \<Rightarrow> bool" where
  "valt (TVar x) = False"
| "valt (TConst k) = True"
| "valt (TLam x t e) = True"
| "valt (TApp e\<^sub>1 e\<^sub>2) = False"

primrec subst_vart :: "var \<Rightarrow> var \<Rightarrow> texpr \<Rightarrow> texpr" where
  "subst_vart x x' (TVar y) = TVar (if x = y then x' else y)"
| "subst_vart x x' (TConst k) = TConst k"
| "subst_vart x x' (TLam y t e) = TLam y t (if x = y then e else subst_vart x x' e)"
| "subst_vart x x' (TApp e\<^sub>1 e\<^sub>2) = TApp (subst_vart x x' e\<^sub>1) (subst_vart x x' e\<^sub>2)"

fun substt :: "var \<Rightarrow> texpr \<Rightarrow> texpr \<Rightarrow> texpr" where
  "substt x e' (TVar y) = (if x = y then e' else TVar y)"
| "substt x e' (TConst k) = TConst k"
| "substt x e' (TLam y t e) = (
    let z = fresh (all_varst e' \<union> all_varst e \<union> {x, y})
    in TLam z t (substt x e' (subst_vart y z e)))"
| "substt x e' (TApp e\<^sub>1 e\<^sub>2) = TApp (substt x e' e\<^sub>1) (substt x e' e\<^sub>2)"

inductive evalt :: "texpr \<Rightarrow> texpr \<Rightarrow> bool" (infix "\<Down>\<^sub>t" 50) where
  evt_const [simp]: "TConst k \<Down>\<^sub>t TConst k"
| evt_lam [simp]: "TLam x t e \<Down>\<^sub>t TLam x t e"
| evt_app [simp]: "e\<^sub>1 \<Down>\<^sub>t TLam x t e\<^sub>1' \<Longrightarrow> e\<^sub>2 \<Down>\<^sub>t v\<^sub>2 \<Longrightarrow> substt x v\<^sub>2 e\<^sub>1' \<Down>\<^sub>t v \<Longrightarrow> TApp e\<^sub>1 e\<^sub>2 \<Down>\<^sub>t v"

lemma [simp]: "finite (all_varst e)"
  by (induction e) simp_all

lemma [simp]: "free_varst e \<subseteq> insert x xs \<Longrightarrow> free_varst (subst_vart x x' e) \<subseteq> insert x' xs"
proof (induction e arbitrary: xs)
  case (TLam y t e)
  hence "free_varst e \<subseteq> insert x (insert y xs)" by auto
  with TLam have "free_varst (subst_vart x x' e) \<subseteq> insert x' (insert y xs)" by simp
  with TLam show ?case by auto
qed auto

lemma free_vars_substt [simp]: "free_varst e \<subseteq> insert x xs \<Longrightarrow> free_varst e' \<subseteq> xs \<Longrightarrow>
  free_varst (substt x e' e) \<subseteq> xs"
proof (induction x e' e arbitrary: xs rule: substt.induct)
  case (3 x e' y t e)
  let ?z = "fresh (all_varst e' \<union> all_varst e \<union> {x, y})"
  from 3 have "free_varst e \<subseteq> insert y (insert x xs)" by auto
  hence "free_varst (subst_vart y ?z e) \<subseteq> insert ?z (insert x xs)" by simp
  hence "free_varst (subst_vart y ?z e) \<subseteq> insert x (insert ?z xs)" by auto
  with 3 show ?case by (auto simp add: Let_def)
qed auto

lemma free_vars_evalt [simp]: "e \<Down>\<^sub>t v \<Longrightarrow> free_varst e = {} \<Longrightarrow> free_varst v = {}"
proof (induction e v rule: evalt.induct)
  case (evt_app e\<^sub>1 x t e\<^sub>1' e\<^sub>2 v\<^sub>2 v)
  hence "free_varst e\<^sub>1' \<subseteq> insert x {} \<and> free_varst v\<^sub>2 \<subseteq> {}" by simp
  hence "free_varst (substt x v\<^sub>2 e\<^sub>1') \<subseteq> {}" by (metis free_vars_substt)
  with evt_app show ?case by simp
qed simp_all

lemma free_vars_subs [simp]: "\<Gamma> \<turnstile>\<^sub>n e : t \<Longrightarrow> free_varst e \<subseteq> dom \<Gamma>"
  by (induction \<Gamma> e t rule: typecheckn.induct) auto

lemma [simp]: "Map.empty \<turnstile>\<^sub>n e : t \<Longrightarrow> free_varst e = {}"
  using free_vars_subs by fastforce

lemma [simp]: "\<Gamma> \<turnstile>\<^sub>n e : t \<Longrightarrow> v \<notin> \<Union> (tvars ` ran \<Gamma>) \<Longrightarrow> v \<notin> tvarst e \<Longrightarrow> v \<notin> tvars t"
proof (induction \<Gamma> e t rule: typecheckn.induct)
  case (tcn_lam \<Gamma> x t\<^sub>1 e t\<^sub>2)
  hence "v \<notin> \<Union> (tvars ` ran (\<Gamma>(x \<mapsto> t\<^sub>1)))" by (auto simp add: ran_def)
  with tcn_lam show ?case by fastforce
qed (auto simp add: ran_def)

lemma canonical_basen [dest]: "\<Gamma> \<turnstile>\<^sub>n e : Base \<Longrightarrow> valt e \<Longrightarrow> \<exists>k. e = TConst k"
  by (induction \<Gamma> e Base rule: typecheckn.induct) simp_all

lemma canonical_arrown [dest]: "\<Gamma> \<turnstile>\<^sub>n e : Arrow t\<^sub>1 t\<^sub>2 \<Longrightarrow> valt e \<Longrightarrow>
    \<exists>x e'. e = TLam x t\<^sub>1 e' \<and> \<Gamma>(x \<mapsto> t\<^sub>1) \<turnstile>\<^sub>n e' : t\<^sub>2"
  by (induction \<Gamma> e "Arrow t\<^sub>1 t\<^sub>2" rule: typecheckn.induct) simp_all

(* Progress not directly provable here, due to lack of proof of termination.
   We prove it in 02Debruijn/NameRemoval *)

lemma [simp]: "\<Gamma> \<turnstile>\<^sub>n e : t \<Longrightarrow> x \<notin> all_varst e \<Longrightarrow> \<Gamma>(x \<mapsto> t') \<turnstile>\<^sub>n e : t"
  by (induction \<Gamma> e t rule: typecheckn.induct) (simp_all add: fun_upd_twist)

lemma [simp]: "\<Gamma>(x \<mapsto> t') \<turnstile>\<^sub>n e : t \<Longrightarrow> x' \<notin> all_varst e \<Longrightarrow> \<Gamma>(x' \<mapsto> t') \<turnstile>\<^sub>n subst_vart x x' e : t"
proof (induction "\<Gamma>(x \<mapsto> t')" e t arbitrary: \<Gamma> rule: typecheckn.induct)
  case (tcn_lam y t\<^sub>1 e t\<^sub>2)
  thus ?case
  proof (cases "x = y")
    case False
    moreover with tcn_lam have "\<Gamma>(y \<mapsto> t\<^sub>1, x' \<mapsto> t') \<turnstile>\<^sub>n subst_vart x x' e : t\<^sub>2"
      by (simp add: fun_upd_twist)
    moreover from tcn_lam have "x' \<noteq> y" by simp
    ultimately show ?thesis by (simp add: fun_upd_twist)
  qed (simp_all add: fun_upd_twist)
qed fastforce+

lemma [simp]: "\<Gamma>(x \<mapsto> t') \<turnstile>\<^sub>n e : t \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>n e' : t' \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>n substt x e' e : t"
proof (induction x e' e arbitrary: \<Gamma> t rule: substt.induct)
  case (3 x e' y t\<^sub>1 e)
  then obtain t\<^sub>2 where T: "t = Arrow t\<^sub>1 t\<^sub>2 \<and> \<Gamma>(x \<mapsto> t', y \<mapsto> t\<^sub>1) \<turnstile>\<^sub>n e : t\<^sub>2" by blast
  let ?z = "fresh (all_varst e' \<union> all_varst e \<union> {x, y})"
  have "finite (all_varst e' \<union> all_varst e \<union> {x, y})" by simp
  hence Z: "?z \<notin> all_varst e' \<union> all_varst e \<union> {x, y}" by (metis fresh_is_fresh)
  with T have "\<Gamma>(x \<mapsto> t', ?z \<mapsto> t\<^sub>1) \<turnstile>\<^sub>n subst_vart y ?z e : t\<^sub>2" by simp
  with Z have X: "\<Gamma>(?z \<mapsto> t\<^sub>1, x \<mapsto> t') \<turnstile>\<^sub>n subst_vart y ?z e : t\<^sub>2" by (simp add: fun_upd_twist)
  from 3 Z have "\<Gamma>(?z \<mapsto> t\<^sub>1) \<turnstile>\<^sub>n e' : t'" by simp
  with 3 X have "\<Gamma>(?z \<mapsto> t\<^sub>1) \<turnstile>\<^sub>n substt x e' (subst_vart y ?z e) : t\<^sub>2" by fastforce
  with T show ?case by (simp add: Let_def)
qed fastforce+

theorem preservationn: "e \<Down>\<^sub>t v \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>n e : t \<Longrightarrow> \<Gamma> \<turnstile>\<^sub>n v : t"
  by (induction e v arbitrary: t rule: evalt.induct) fastforce+

lemma [simp]: "e \<Down>\<^sub>t v \<Longrightarrow> valt v"
  by (induction e v rule: evalt.induct) simp_all

lemma val_no_evaln: "e \<Down>\<^sub>t v \<Longrightarrow> valt e \<Longrightarrow> v = e"
  by (induction e v rule: evalt.induct) simp_all

theorem determinismn: "e \<Down>\<^sub>t v \<Longrightarrow> e \<Down>\<^sub>t v' \<Longrightarrow> v = v'"
proof (induction e v arbitrary: v' rule: evalt.induct)
  case (evt_const k)
  thus ?case by (induction "TConst k" v' rule: evalt.induct) simp_all
next
  case (evt_lam x t e)
  thus ?case by (induction "TLam x t e" v' rule: evalt.induct) simp_all
next
  case (evt_app e\<^sub>1 x t e\<^sub>1' e\<^sub>2 v\<^sub>2 v)
  from evt_app(7, 1, 2, 3, 4, 5, 6) show ?case
    by (induction "TApp e\<^sub>1 e\<^sub>2" v' rule: evalt.induct) blast+
qed

end


(*  Title:      HOL/Imperative_HOL/ex/Imperative_Quicksort.thy
    Author:     Lukas Bulwahn, TU Muenchen
*)

section {* An imperative implementation of Quicksort on arrays *}

theory Imperative_Quicksort
imports
  "~~/src/HOL/Imperative_HOL/Imperative_HOL"
  Subarray
  "~~/src/HOL/Library/Multiset"
  "~~/src/HOL/Library/Code_Target_Numeral"
begin

text {* We prove QuickSort correct in the Relational Calculus. *}

definition swap :: "nat array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap"
where
  "swap arr i j =
     do {
       x \<leftarrow> Array.nth arr i;
       y \<leftarrow> Array.nth arr j;
       Array.upd i y arr;
       Array.upd j x arr;
       return ()
     }"

lemma effect_swapI [effect_intros]:
  assumes "i < Array.length h a" "j < Array.length h a"
    "x = Array.get h a ! i" "y = Array.get h a ! j"
    "h' = Array.update a j x (Array.update a i y h)"
  shows "effect (swap a i j) h h' r"
  unfolding swap_def using assms by (auto intro!: effect_intros)

lemma swap_permutes:
  assumes "effect (swap a i j) h h' rs"
  shows "multiset_of (Array.get h' a)
  = multiset_of (Array.get h a)"
  using assms
  unfolding swap_def
  by (auto simp add: Array.length_def multiset_of_swap dest: sym [of _ "h'"] elim!: effect_bindE effect_nthE effect_returnE effect_updE)

function part1 :: "nat array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat Heap"
where
  "part1 a left right p = (
     if (right \<le> left) then return right
     else do {
       v \<leftarrow> Array.nth a left;
       (if (v \<le> p) then (part1 a (left + 1) right p)
                    else (do { swap a left right;
  part1 a left (right - 1) p }))
     })"
by pat_completeness auto

termination
by (relation "measure (\<lambda>(_,l,r,_). r - l )") auto

declare part1.simps[simp del]

lemma part_permutes:
  assumes "effect (part1 a l r p) h h' rs"
  shows "multiset_of (Array.get h' a)
  = multiset_of (Array.get h a)"
  using assms
proof (induct a l r p arbitrary: h h' rs rule:part1.induct)
  case (1 a l r p h h' rs)
  thus ?case
    unfolding part1.simps [of a l r p]
    by (elim effect_bindE effect_ifE effect_returnE effect_nthE) (auto simp add: swap_permutes)
qed

lemma part_returns_index_in_bounds:
  assumes "effect (part1 a l r p) h h' rs"
  assumes "l \<le> r"
  shows "l \<le> rs \<and> rs \<le> r"
using assms
proof (induct a l r p arbitrary: h h' rs rule:part1.induct)
  case (1 a l r p h h' rs)
  note cr = `effect (part1 a l r p) h h' rs`
  show ?case
  proof (cases "r \<le> l")
    case True (* Terminating case *)
    with cr `l \<le> r` show ?thesis
      unfolding part1.simps[of a l r p]
      by (elim effect_bindE effect_ifE effect_returnE effect_nthE) auto
  next
    case False (* recursive case *)
    note rec_condition = this
    let ?v = "Array.get h a ! l"
    show ?thesis
    proof (cases "?v \<le> p")
      case True
      with cr False
      have rec1: "effect (part1 a (l + 1) r p) h h' rs"
        unfolding part1.simps[of a l r p]
        by (elim effect_bindE effect_nthE effect_ifE effect_returnE) auto
      from rec_condition have "l + 1 \<le> r" by arith
      from 1(1)[OF rec_condition True rec1 `l + 1 \<le> r`]
      show ?thesis by simp
    next
      case False
      with rec_condition cr
      obtain h1 where swp: "effect (swap a l r) h h1 ()"
        and rec2: "effect (part1 a l (r - 1) p) h1 h' rs"
        unfolding part1.simps[of a l r p]
        by (elim effect_bindE effect_nthE effect_ifE effect_returnE) auto
      from rec_condition have "l \<le> r - 1" by arith
      from 1(2) [OF rec_condition False rec2 `l \<le> r - 1`] show ?thesis by fastforce
    qed
  qed
qed

lemma part_length_remains:
  assumes "effect (part1 a l r p) h h' rs"
  shows "Array.length h a = Array.length h' a"
using assms
proof (induct a l r p arbitrary: h h' rs rule:part1.induct)
  case (1 a l r p h h' rs)
  note cr = `effect (part1 a l r p) h h' rs`

  show ?case
  proof (cases "r \<le> l")
    case True (* Terminating case *)
    with cr show ?thesis
      unfolding part1.simps[of a l r p]
      by (elim effect_bindE effect_ifE effect_returnE effect_nthE) auto
  next
    case False (* recursive case *)
    with cr 1 show ?thesis
      unfolding part1.simps [of a l r p] swap_def
      by (auto elim!: effect_bindE effect_ifE effect_nthE effect_returnE effect_updE) fastforce
  qed
qed

lemma part_outer_remains:
  assumes "effect (part1 a l r p) h h' rs"
  shows "\<forall>i. i < l \<or> r < i \<longrightarrow> Array.get h (a::nat array) ! i = Array.get h' a ! i"
  using assms
proof (induct a l r p arbitrary: h h' rs rule:part1.induct)
  case (1 a l r p h h' rs)
  note cr = `effect (part1 a l r p) h h' rs`

  show ?case
  proof (cases "r \<le> l")
    case True (* Terminating case *)
    with cr show ?thesis
      unfolding part1.simps[of a l r p]
      by (elim effect_bindE effect_ifE effect_returnE effect_nthE) auto
  next
    case False (* recursive case *)
    note rec_condition = this
    let ?v = "Array.get h a ! l"
    show ?thesis
    proof (cases "?v \<le> p")
      case True
      with cr False
      have rec1: "effect (part1 a (l + 1) r p) h h' rs"
        unfolding part1.simps[of a l r p]
        by (elim effect_bindE effect_nthE effect_ifE effect_returnE) auto
      from 1(1)[OF rec_condition True rec1]
      show ?thesis by fastforce
    next
      case False
      with rec_condition cr
      obtain h1 where swp: "effect (swap a l r) h h1 ()"
        and rec2: "effect (part1 a l (r - 1) p) h1 h' rs"
        unfolding part1.simps[of a l r p]
        by (elim effect_bindE effect_nthE effect_ifE effect_returnE) auto
      from swp rec_condition have
        "\<forall>i. i < l \<or> r < i \<longrightarrow> Array.get h a ! i = Array.get h1 a ! i"
        unfolding swap_def
        by (elim effect_bindE effect_nthE effect_updE effect_returnE) auto
      with 1(2) [OF rec_condition False rec2] show ?thesis by fastforce
    qed
  qed
qed

lemma part_partitions:
  assumes "effect (part1 a l r p) h h' rs"
  shows "(\<forall>i. l \<le> i \<and> i < rs \<longrightarrow> Array.get h' (a::nat array) ! i \<le> p)
  \<and> (\<forall>i. rs < i \<and> i \<le> r \<longrightarrow> Array.get h' a ! i \<ge> p)"
  using assms
proof (induct a l r p arbitrary: h h' rs rule:part1.induct)
  case (1 a l r p h h' rs)
  note cr = `effect (part1 a l r p) h h' rs`

  show ?case
  proof (cases "r \<le> l")
    case True (* Terminating case *)
    with cr have "rs = r"
      unfolding part1.simps[of a l r p]
      by (elim effect_bindE effect_ifE effect_returnE effect_nthE) auto
    with True
    show ?thesis by auto
  next
    case False (* recursive case *)
    note lr = this
    let ?v = "Array.get h a ! l"
    show ?thesis
    proof (cases "?v \<le> p")
      case True
      with lr cr
      have rec1: "effect (part1 a (l + 1) r p) h h' rs"
        unfolding part1.simps[of a l r p]
        by (elim effect_bindE effect_nthE effect_ifE effect_returnE) auto
      from True part_outer_remains[OF rec1] have a_l: "Array.get h' a ! l \<le> p"
        by fastforce
      have "\<forall>i. (l \<le> i = (l = i \<or> Suc l \<le> i))" by arith
      with 1(1)[OF False True rec1] a_l show ?thesis
        by auto
    next
      case False
      with lr cr
      obtain h1 where swp: "effect (swap a l r) h h1 ()"
        and rec2: "effect (part1 a l (r - 1) p) h1 h' rs"
        unfolding part1.simps[of a l r p]
        by (elim effect_bindE effect_nthE effect_ifE effect_returnE) auto
      from swp False have "Array.get h1 a ! r \<ge> p"
        unfolding swap_def
        by (auto simp add: Array.length_def elim!: effect_bindE effect_nthE effect_updE effect_returnE)
      with part_outer_remains [OF rec2] lr have a_r: "Array.get h' a ! r \<ge> p"
        by fastforce
      have "\<forall>i. (i \<le> r = (i = r \<or> i \<le> r - 1))" by arith
      with 1(2)[OF lr False rec2] a_r show ?thesis
        by auto
    qed
  qed
qed

fun partition :: "nat array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat Heap"
where
  "partition a left right = do {
     pivot \<leftarrow> Array.nth a right;
     middle \<leftarrow> part1 a left (right - 1) pivot;
     v \<leftarrow> Array.nth a middle;
     m \<leftarrow> return (if (v \<le> pivot) then (middle + 1) else middle);
     swap a m right;
     return m
   }"

declare partition.simps[simp del]

lemma partition_permutes:
  assumes "effect (partition a l r) h h' rs"
  shows "multiset_of (Array.get h' a)
  = multiset_of (Array.get h a)"
proof -
    from assms part_permutes swap_permutes show ?thesis
      unfolding partition.simps
      by (elim effect_bindE effect_returnE effect_nthE effect_ifE effect_updE) auto
qed

lemma partition_length_remains:
  assumes "effect (partition a l r) h h' rs"
  shows "Array.length h a = Array.length h' a"
proof -
  from assms part_length_remains show ?thesis
    unfolding partition.simps swap_def
    by (elim effect_bindE effect_returnE effect_nthE effect_ifE effect_updE) auto
qed

lemma partition_outer_remains:
  assumes "effect (partition a l r) h h' rs"
  assumes "l < r"
  shows "\<forall>i. i < l \<or> r < i \<longrightarrow> Array.get h (a::nat array) ! i = Array.get h' a ! i"
proof -
  from assms part_outer_remains part_returns_index_in_bounds show ?thesis
    unfolding partition.simps swap_def
    by (elim effect_bindE effect_returnE effect_nthE effect_ifE effect_updE) fastforce
qed

lemma partition_returns_index_in_bounds:
  assumes effect: "effect (partition a l r) h h' rs"
  assumes "l < r"
  shows "l \<le> rs \<and> rs \<le> r"
proof -
  from effect obtain middle h'' p where part: "effect (part1 a l (r - 1) p) h h'' middle"
    and rs_equals: "rs = (if Array.get h'' a ! middle \<le> Array.get h a ! r then middle + 1
         else middle)"
    unfolding partition.simps
    by (elim effect_bindE effect_returnE effect_nthE effect_ifE effect_updE) simp
  from `l < r` have "l \<le> r - 1" by arith
  from part_returns_index_in_bounds[OF part this] rs_equals `l < r` show ?thesis by auto
qed

lemma partition_partitions:
  assumes effect: "effect (partition a l r) h h' rs"
  assumes "l < r"
  shows "(\<forall>i. l \<le> i \<and> i < rs \<longrightarrow> Array.get h' (a::nat array) ! i \<le> Array.get h' a ! rs) \<and>
  (\<forall>i. rs < i \<and> i \<le> r \<longrightarrow> Array.get h' a ! rs \<le> Array.get h' a ! i)"
proof -
  let ?pivot = "Array.get h a ! r"
  from effect obtain middle h1 where part: "effect (part1 a l (r - 1) ?pivot) h h1 middle"
    and swap: "effect (swap a rs r) h1 h' ()"
    and rs_equals: "rs = (if Array.get h1 a ! middle \<le> ?pivot then middle + 1
         else middle)"
    unfolding partition.simps
    by (elim effect_bindE effect_returnE effect_nthE effect_ifE effect_updE) simp
  from swap have h'_def: "h' = Array.update a r (Array.get h1 a ! rs)
    (Array.update a rs (Array.get h1 a ! r) h1)"
    unfolding swap_def
    by (elim effect_bindE effect_returnE effect_nthE effect_updE) simp
  from swap have in_bounds: "r < Array.length h1 a \<and> rs < Array.length h1 a"
    unfolding swap_def
    by (elim effect_bindE effect_returnE effect_nthE effect_updE) simp
  from swap have swap_length_remains: "Array.length h1 a = Array.length h' a"
    unfolding swap_def by (elim effect_bindE effect_returnE effect_nthE effect_updE) auto
  from `l < r` have "l \<le> r - 1" by simp
  note middle_in_bounds = part_returns_index_in_bounds[OF part this]
  from part_outer_remains[OF part] `l < r`
  have "Array.get h a ! r = Array.get h1 a ! r"
    by fastforce
  with swap
  have right_remains: "Array.get h a ! r = Array.get h' a ! rs"
    unfolding swap_def
    by (auto simp add: Array.length_def elim!: effect_bindE effect_returnE effect_nthE effect_updE) (cases "r = rs", auto)
  from part_partitions [OF part]
  show ?thesis
  proof (cases "Array.get h1 a ! middle \<le> ?pivot")
    case True
    with rs_equals have rs_equals: "rs = middle + 1" by simp
    {
      fix i
      assume i_is_left: "l \<le> i \<and> i < rs"
      with swap_length_remains in_bounds middle_in_bounds rs_equals `l < r`
      have i_props: "i < Array.length h' a" "i \<noteq> r" "i \<noteq> rs" by auto
      from i_is_left rs_equals have "l \<le> i \<and> i < middle \<or> i = middle" by arith
      with part_partitions[OF part] right_remains True
      have "Array.get h1 a ! i \<le> Array.get h' a ! rs" by fastforce
      with i_props h'_def in_bounds have "Array.get h' a ! i \<le> Array.get h' a ! rs"
        unfolding Array.update_def Array.length_def by simp
    }
    moreover
    {
      fix i
      assume "rs < i \<and> i \<le> r"

      hence "(rs < i \<and> i \<le> r - 1) \<or> (rs < i \<and> i = r)" by arith
      hence "Array.get h' a ! rs \<le> Array.get h' a ! i"
      proof
        assume i_is: "rs < i \<and> i \<le> r - 1"
        with swap_length_remains in_bounds middle_in_bounds rs_equals
        have i_props: "i < Array.length h' a" "i \<noteq> r" "i \<noteq> rs" by auto
        from part_partitions[OF part] rs_equals right_remains i_is
        have "Array.get h' a ! rs \<le> Array.get h1 a ! i"
          by fastforce
        with i_props h'_def show ?thesis by fastforce
      next
        assume i_is: "rs < i \<and> i = r"
        with rs_equals have "Suc middle \<noteq> r" by arith
        with middle_in_bounds `l < r` have "Suc middle \<le> r - 1" by arith
        with part_partitions[OF part] right_remains
        have "Array.get h' a ! rs \<le> Array.get h1 a ! (Suc middle)"
          by fastforce
        with i_is True rs_equals right_remains h'_def
        show ?thesis using in_bounds
          unfolding Array.update_def Array.length_def
          by auto
      qed
    }
    ultimately show ?thesis by auto
  next
    case False
    with rs_equals have rs_equals: "middle = rs" by simp
    {
      fix i
      assume i_is_left: "l \<le> i \<and> i < rs"
      with swap_length_remains in_bounds middle_in_bounds rs_equals
      have i_props: "i < Array.length h' a" "i \<noteq> r" "i \<noteq> rs" by auto
      from part_partitions[OF part] rs_equals right_remains i_is_left
      have "Array.get h1 a ! i \<le> Array.get h' a ! rs" by fastforce
      with i_props h'_def have "Array.get h' a ! i \<le> Array.get h' a ! rs"
        unfolding Array.update_def by simp
    }
    moreover
    {
      fix i
      assume "rs < i \<and> i \<le> r"
      hence "(rs < i \<and> i \<le> r - 1) \<or> i = r" by arith
      hence "Array.get h' a ! rs \<le> Array.get h' a ! i"
      proof
        assume i_is: "rs < i \<and> i \<le> r - 1"
        with swap_length_remains in_bounds middle_in_bounds rs_equals
        have i_props: "i < Array.length h' a" "i \<noteq> r" "i \<noteq> rs" by auto
        from part_partitions[OF part] rs_equals right_remains i_is
        have "Array.get h' a ! rs \<le> Array.get h1 a ! i"
          by fastforce
        with i_props h'_def show ?thesis by fastforce
      next
        assume i_is: "i = r"
        from i_is False rs_equals right_remains h'_def
        show ?thesis using in_bounds
          unfolding Array.update_def Array.length_def
          by auto
      qed
    }
    ultimately
    show ?thesis by auto
  qed
qed

function quicksort :: "nat array \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> unit Heap"
where
  "quicksort arr left right =
     (if (right > left)  then
        do {
          pivotNewIndex \<leftarrow> partition arr left right;
          pivotNewIndex \<leftarrow> assert (\<lambda>x. left \<le> x \<and> x \<le> right) pivotNewIndex;
          quicksort arr left (pivotNewIndex - 1);
          quicksort arr (pivotNewIndex + 1) right
        }
     else return ())"
by pat_completeness auto

(* For termination, we must show that the pivotNewIndex is between left and right *)
termination
by (relation "measure (\<lambda>(a, l, r). (r - l))") auto

declare quicksort.simps[simp del]

lemma quicksort_permutes:
  assumes "effect (quicksort a l r) h h' rs"
  shows "multiset_of (Array.get h' a)
  = multiset_of (Array.get h a)"
  using assms
proof (induct a l r arbitrary: h h' rs rule: quicksort.induct)
  case (1 a l r h h' rs)
  with partition_permutes show ?case
    unfolding quicksort.simps [of a l r]
    by (elim effect_ifE effect_bindE effect_assertE effect_returnE) auto
qed

lemma length_remains:
  assumes "effect (quicksort a l r) h h' rs"
  shows "Array.length h a = Array.length h' a"
using assms
proof (induct a l r arbitrary: h h' rs rule: quicksort.induct)
  case (1 a l r h h' rs)
  with partition_length_remains show ?case
    unfolding quicksort.simps [of a l r]
    by (elim effect_ifE effect_bindE effect_assertE effect_returnE) auto
qed

lemma quicksort_outer_remains:
  assumes "effect (quicksort a l r) h h' rs"
   shows "\<forall>i. i < l \<or> r < i \<longrightarrow> Array.get h (a::nat array) ! i = Array.get h' a ! i"
  using assms
proof (induct a l r arbitrary: h h' rs rule: quicksort.induct)
  case (1 a l r h h' rs)
  note cr = `effect (quicksort a l r) h h' rs`
  thus ?case
  proof (cases "r > l")
    case False
    with cr have "h' = h"
      unfolding quicksort.simps [of a l r]
      by (elim effect_ifE effect_returnE) auto
    thus ?thesis by simp
  next
  case True
   {
      fix h1 h2 p ret1 ret2 i
      assume part: "effect (partition a l r) h h1 p"
      assume qs1: "effect (quicksort a l (p - 1)) h1 h2 ret1"
      assume qs2: "effect (quicksort a (p + 1) r) h2 h' ret2"
      assume pivot: "l \<le> p \<and> p \<le> r"
      assume i_outer: "i < l \<or> r < i"
      from  partition_outer_remains [OF part True] i_outer
      have 2: "Array.get h a !i = Array.get h1 a ! i" by fastforce
      moreover
      from 1(1) [OF True pivot qs1] pivot i_outer 2
      have 3: "Array.get h1 a ! i = Array.get h2 a ! i" by auto
      moreover
      from qs2 1(2) [of p h2 h' ret2] True pivot i_outer 3
      have "Array.get h2 a ! i = Array.get h' a ! i" by auto
      ultimately have "Array.get h a ! i= Array.get h' a ! i" by simp
    }
    with cr show ?thesis
      unfolding quicksort.simps [of a l r]
      by (elim effect_ifE effect_bindE effect_assertE effect_returnE) auto
  qed
qed

lemma quicksort_is_skip:
  assumes "effect (quicksort a l r) h h' rs"
  shows "r \<le> l \<longrightarrow> h = h'"
  using assms
  unfolding quicksort.simps [of a l r]
  by (elim effect_ifE effect_returnE) auto

lemma quicksort_sorts:
  assumes "effect (quicksort a l r) h h' rs"
  assumes l_r_length: "l < Array.length h a" "r < Array.length h a"
  shows "sorted (subarray l (r + 1) a h')"
  using assms
proof (induct a l r arbitrary: h h' rs rule: quicksort.induct)
  case (1 a l r h h' rs)
  note cr = `effect (quicksort a l r) h h' rs`
  thus ?case
  proof (cases "r > l")
    case False
    hence "l \<ge> r + 1 \<or> l = r" by arith
    with length_remains[OF cr] 1(5) show ?thesis
      by (auto simp add: subarray_Nil subarray_single)
  next
    case True
    {
      fix h1 h2 p
      assume part: "effect (partition a l r) h h1 p"
      assume qs1: "effect (quicksort a l (p - 1)) h1 h2 ()"
      assume qs2: "effect (quicksort a (p + 1) r) h2 h' ()"
      from partition_returns_index_in_bounds [OF part True]
      have pivot: "l\<le> p \<and> p \<le> r" .
     note length_remains = length_remains[OF qs2] length_remains[OF qs1] partition_length_remains[OF part]
      from quicksort_outer_remains [OF qs2] quicksort_outer_remains [OF qs1] pivot quicksort_is_skip[OF qs1]
      have pivot_unchanged: "Array.get h1 a ! p = Array.get h' a ! p" by (cases p, auto)
        (*-- First of all, by induction hypothesis both sublists are sorted. *)
      from 1(1)[OF True pivot qs1] length_remains pivot 1(5)
      have IH1: "sorted (subarray l p a h2)"  by (cases p, auto simp add: subarray_Nil)
      from quicksort_outer_remains [OF qs2] length_remains
      have left_subarray_remains: "subarray l p a h2 = subarray l p a h'"
        by (simp add: subarray_eq_samelength_iff)
      with IH1 have IH1': "sorted (subarray l p a h')" by simp
      from 1(2)[OF True pivot qs2] pivot 1(5) length_remains
      have IH2: "sorted (subarray (p + 1) (r + 1) a h')"
        by (cases "Suc p \<le> r", auto simp add: subarray_Nil)
           (* -- Secondly, both sublists remain partitioned. *)
      from partition_partitions[OF part True]
      have part_conds1: "\<forall>j. j \<in> set (subarray l p a h1) \<longrightarrow> j \<le> Array.get h1 a ! p "
        and part_conds2: "\<forall>j. j \<in> set (subarray (p + 1) (r + 1) a h1) \<longrightarrow> Array.get h1 a ! p \<le> j"
        by (auto simp add: all_in_set_subarray_conv)
      from quicksort_outer_remains [OF qs1] quicksort_permutes [OF qs1] True
        length_remains 1(5) pivot multiset_of_sublist [of l p "Array.get h1 a" "Array.get h2 a"]
      have multiset_partconds1: "multiset_of (subarray l p a h2) = multiset_of (subarray l p a h1)"
        unfolding Array.length_def subarray_def by (cases p, auto)
      with left_subarray_remains part_conds1 pivot_unchanged
      have part_conds2': "\<forall>j. j \<in> set (subarray l p a h') \<longrightarrow> j \<le> Array.get h' a ! p"
        by (simp, subst set_of_multiset_of[symmetric], simp)
          (* -- These steps are the analogous for the right sublist \<dots> *)
      from quicksort_outer_remains [OF qs1] length_remains
      have right_subarray_remains: "subarray (p + 1) (r + 1) a h1 = subarray (p + 1) (r + 1) a h2"
        by (auto simp add: subarray_eq_samelength_iff)
      from quicksort_outer_remains [OF qs2] quicksort_permutes [OF qs2] True
        length_remains 1(5) pivot multiset_of_sublist [of "p + 1" "r + 1" "Array.get h2 a" "Array.get h' a"]
      have multiset_partconds2: "multiset_of (subarray (p + 1) (r + 1) a h') = multiset_of (subarray (p + 1) (r + 1) a h2)"
        unfolding Array.length_def subarray_def by auto
      with right_subarray_remains part_conds2 pivot_unchanged
      have part_conds1': "\<forall>j. j \<in> set (subarray (p + 1) (r + 1) a h') \<longrightarrow> Array.get h' a ! p \<le> j"
        by (simp, subst set_of_multiset_of[symmetric], simp)
          (* -- Thirdly and finally, we show that the array is sorted
          following from the facts above. *)
      from True pivot 1(5) length_remains have "subarray l (r + 1) a h' = subarray l p a h' @ [Array.get h' a ! p] @ subarray (p + 1) (r + 1) a h'"
        by (simp add: subarray_nth_array_Cons, cases "l < p") (auto simp add: subarray_append subarray_Nil)
      with IH1' IH2 part_conds1' part_conds2' pivot have ?thesis
        unfolding subarray_def
        apply (auto simp add: sorted_append sorted_Cons all_in_set_sublist'_conv)
        by (auto simp add: set_sublist' dest: le_trans [of _ "Array.get h' a ! p"])
    }
    with True cr show ?thesis
      unfolding quicksort.simps [of a l r]
      by (elim effect_ifE effect_returnE effect_bindE effect_assertE) auto
  qed
qed

lemma quicksort_is_sort:
  assumes effect: "effect (quicksort a 0 (Array.length h a - 1)) h h' rs"
  shows "Array.get h' a = sort (Array.get h a)"
proof (cases "Array.get h a = []")
  case True
  with quicksort_is_skip[OF effect] show ?thesis
  unfolding Array.length_def by simp
next
  case False
  from quicksort_sorts [OF effect] False have "sorted (sublist' 0 (List.length (Array.get h a)) (Array.get h' a))"
    unfolding Array.length_def subarray_def by auto
  with length_remains[OF effect] have "sorted (Array.get h' a)"
    unfolding Array.length_def by simp
  with quicksort_permutes [OF effect] properties_for_sort show ?thesis by fastforce
qed

subsection {* No Errors in quicksort *}
text {* We have proved that quicksort sorts (if no exceptions occur).
We will now show that exceptions do not occur. *}

lemma success_part1I:
  assumes "l < Array.length h a" "r < Array.length h a"
  shows "success (part1 a l r p) h"
  using assms
proof (induct a l r p arbitrary: h rule: part1.induct)
  case (1 a l r p)
  thus ?case unfolding part1.simps [of a l r]
  apply (auto intro!: success_intros simp add: not_le)
  apply (auto intro!: effect_intros)
  done
qed

lemma success_bindI' [success_intros]: (*FIXME move*)
  assumes "success f h"
  assumes "\<And>h' r. effect f h h' r \<Longrightarrow> success (g r) h'"
  shows "success (f \<guillemotright>= g) h"
using assms(1) proof (rule success_effectE)
  fix h' r
  assume *: "effect f h h' r"
  with assms(2) have "success (g r) h'" .
  with * show "success (f \<guillemotright>= g) h" by (rule success_bind_effectI)
qed

lemma success_partitionI:
  assumes "l < r" "l < Array.length h a" "r < Array.length h a"
  shows "success (partition a l r) h"
using assms unfolding partition.simps swap_def
apply (auto intro!: success_bindI' success_ifI success_returnI success_nthI success_updI success_part1I elim!: effect_bindE effect_updE effect_nthE effect_returnE simp add:)
apply (frule part_length_remains)
apply (frule part_returns_index_in_bounds)
apply auto
apply (frule part_length_remains)
apply (frule part_returns_index_in_bounds)
apply auto
apply (frule part_length_remains)
apply auto
done

lemma success_quicksortI:
  assumes "l < Array.length h a" "r < Array.length h a"
  shows "success (quicksort a l r) h"
using assms
proof (induct a l r arbitrary: h rule: quicksort.induct)
  case (1 a l ri h)
  thus ?case
    unfolding quicksort.simps [of a l ri]
    apply (auto intro!: success_ifI success_bindI' success_returnI success_nthI success_updI success_assertI success_partitionI)
    apply (frule partition_returns_index_in_bounds)
    apply auto
    apply (frule partition_returns_index_in_bounds)
    apply auto
    apply (auto elim!: effect_assertE dest!: partition_length_remains length_remains)
    apply (subgoal_tac "Suc r \<le> ri \<or> r = ri")
    apply (erule disjE)
    apply auto
    unfolding quicksort.simps [of a "Suc ri" ri]
    apply (auto intro!: success_ifI success_returnI)
    done
qed

subsection {* Example *}

definition "qsort a = do {
    k \<leftarrow> Array.len a;
    quicksort a 0 (k - 1);
    return a
  }"

code_reserved SML upto

definition "example = do {
    a \<leftarrow> Array.of_list [42, 2, 3, 5, 0, 1705, 8, 3, 15];
    qsort a
  }"

ML_val {* @{code example} () *}

export_code qsort checking SML SML_imp OCaml? OCaml_imp? Haskell? Scala Scala_imp

end


theory concrete_04
  imports Main

begin
(*4.1 Formulas*)
(*form ::=(form) | True | Flase | term = term |
  \<not> form | form \<and> form | form \<or> form |
  form \<longrightarrow> form | \<forall>x.form | \<exists>x.form*)
(*4.2 Sets*)

(*4.3 Proof Automation*)
lemma "\<forall>x. \<exists>y. x=y"
  apply(auto)
  done

lemma "A \<subseteq> B \<inter> C \<Longrightarrow> A \<subseteq> B \<union> C"
  by auto

lemma "\<lbrakk>\<forall>xs \<in> A. \<exists>ys. xs = ys @ ys; us \<in> A\<rbrakk> \<Longrightarrow> \<exists>n. length us = n + n"
  (*apply(auto)*)
  by fastforce

lemma
  "\<lbrakk>\<forall>x y. T x y \<or> T y x;
    \<forall>x y. A x y \<and> A y x \<longrightarrow> x = y;
    \<forall>x y. T x y \<longrightarrow> A x y\<rbrakk>
   \<Longrightarrow> \<forall>x y. A x y \<longrightarrow> T x y"
  by blast

(*4.3.1 Sledgehammer*)
lemma "\<lbrakk>xs @ ys = ys @ xs; length xs = length ys\<rbrakk> \<Longrightarrow> xs = ys"
  (*sledgehammer*)
  using append_eq_append_conv by blast

(*4.3.2 Arithmetic*)
lemma "\<lbrakk>(a::nat) \<le> x + b; 2*x < c\<rbrakk> \<Longrightarrow> 2*a + 1 \<le> 2*b + c"
  by arith

(*4.4 Single Step Proofs*)
(*conjI[of "a=b" "False"]*)

lemma "\<lbrakk>(a::nat) \<le> b; b \<le> c; c \<le> d; d \<le> e\<rbrakk> \<Longrightarrow> a \<le> e"
  by (blast intro: le_trans)

thm conjI[OF refl[of "a"] refl[of "b"]]

thm Suc_leD
lemma "Suc (Suc (Suc a)) \<le> b \<Longrightarrow> a \<le> b"
  by(blast dest:Suc_leD)

inductive ev :: "nat \<Rightarrow> bool" where
ev0: "ev 0" |
evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

fun evn :: "nat \<Rightarrow> bool" where
"evn 0 = True" |
"evn (Suc 0) = False" |
"evn (Suc (Suc n)) = evn n"

(*Prove ev 4*)
(*Doesnt work?\<rightarrow>evSS[OF evSS[OF ev0]]*)
lemma "ev (Suc (Suc (Suc (Suc 0))))"
  apply(rule evSS)
  apply(rule evSS)
  apply(rule ev0)
  done

(*Prove the above is equivalent*)
lemma "ev m \<Longrightarrow> evn m"
  apply(induction rule: ev.induct)
  by(simp_all)

lemma "evn n \<Longrightarrow> ev n"
  apply(induction n rule: evn.induct)
  by(simp_all add: ev0 evSS)

declare ev.intros[simp, intro]

(*4.5.2 The Reflexive Transitive Closure*)
inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
refl: "star r x x" |
step: "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

thm refl
thm step
lemma star_trans: "star r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"
  apply(induction rule: star.induct)
   apply(assumption)
  apply(metis step)
  done

end


theory Ch2
imports Main
begin
  fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
    "add 0 n = n"
  | "add (Suc m) n = Suc (add m n)"

  lemma add_zero: "add m 0 = m"
    apply(induction m)
    apply(auto)
  done

  lemma add_swap: "add (Suc m) n = add m (Suc n)"
    apply(induction m)
    apply(auto)
  done

  lemma add_comm: "add m n = add n m"
    apply(induction m)
    apply(simp add: add_zero[symmetric])
    apply(simp add: add_swap[symmetric])
  done

  lemma add_asso: "add a (add b c) = add (add a b) c"
    apply(induction a)
    apply(auto)
  done

  fun double :: "nat \<Rightarrow> nat" where
    "double 0 = 0"
  | "double (Suc m) = Suc (Suc (double m))"

  lemma doub_add: "double m = add m m"
    apply(induction m)
    apply(auto)
    apply(simp add: add_swap[symmetric])
  done
end


theory 2
  imports Main
begin

datatype nat = zero | s nat
datatype lst = nil | cons nat lst

fun add :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
"add zero y = y" |
"add (s x) y = s (add x y)"

fun app :: "lst \<Rightarrow> lst \<Rightarrow> lst" where
"app nil r = r" |
"app (cons a l) r = cons a (app l r)"

fun len :: "lst \<Rightarrow> nat" where
"len nil = zero" |
"len (cons e l) = s (len l)"

fun leq :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
"leq zero x = True" |
"leq (s x) zero = False" |
"leq (s x) (s y) = leq x y"

fun less :: "nat \<Rightarrow> nat \<Rightarrow> bool" where
"less x y = leq (s x) y"

fun cnt :: "lst \<Rightarrow> nat \<Rightarrow> nat" where
"cnt nil x = zero" |
"cnt (cons x tail) e = (if (\<not>(x=e)) then (cnt tail e) else (s (cnt tail e)))"

fun outOfBounds :: "nat \<Rightarrow> nat" where
"outOfBounds i = i"

fun get :: "lst \<Rightarrow> nat \<Rightarrow> nat" where
"get nil i = outOfBounds i" |
"get (cons x tail) zero = x" |
"get (cons x tail) (s i) = get tail i"

lemma "less i (len x) \<and> get x i = e \<Longrightarrow> less zero (cnt l e)"


(*  Title:       Signed (Finite) Multisets
    Author:      Jasmin Blanchette <jasmin.blanchette at inria.fr>, 2016
    Maintainer:  Jasmin Blanchette <jasmin.blanchette at inria.fr>
*)

section \<open>Signed (Finite) Multisets\<close>

theory Signed_Multiset
imports Multiset_More
abbrevs
  "!z" = "\<^sub>z"
begin

unbundle multiset.lifting

subsection \<open>Definition of Signed Multisets\<close>

definition equiv_zmset :: "'a multiset \<times> 'a multiset \<Rightarrow> 'a multiset \<times> 'a multiset \<Rightarrow> bool" where
  "equiv_zmset = (\<lambda>(Mp, Mn) (Np, Nn). Mp + Nn = Np + Mn)"

quotient_type 'a zmultiset = "'a multiset \<times> 'a multiset" / equiv_zmset
  by (rule equivpI, simp_all add: equiv_zmset_def reflp_def symp_def transp_def)
    (metis multi_union_self_other_eq union_lcomm)

subsection \<open>Basic Operations on Signed Multisets\<close>

instantiation zmultiset :: (type) cancel_comm_monoid_add
begin

lift_definition zero_zmultiset :: "'a zmultiset" is "({#}, {#})" .

abbreviation empty_zmset :: "'a zmultiset" ("{#}\<^sub>z") where
  "empty_zmset \<equiv> 0"

lift_definition minus_zmultiset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> 'a zmultiset" is
  "\<lambda>(Mp, Mn) (Np, Nn). (Mp + Nn, Mn + Np)"
  by (auto simp: equiv_zmset_def union_commute union_lcomm)

lift_definition plus_zmultiset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> 'a zmultiset" is
  "\<lambda>(Mp, Mn) (Np, Nn). (Mp + Np, Mn + Nn)"
  by (auto simp: equiv_zmset_def union_commute union_lcomm)

instance
  by (intro_classes; transfer) (auto simp: equiv_zmset_def)

end

instantiation zmultiset :: (type) group_add
begin

lift_definition uminus_zmultiset :: "'a zmultiset \<Rightarrow> 'a zmultiset" is "\<lambda>(Mp, Mn). (Mn, Mp)"
  by (auto simp: equiv_zmset_def add.commute)

instance
  by (intro_classes; transfer) (auto simp: equiv_zmset_def)

end

lift_definition zcount :: "'a zmultiset \<Rightarrow> 'a \<Rightarrow> int" is
  "\<lambda>(Mp, Mn) x. int (count Mp x) - int (count Mn x)"
  by (auto simp del: of_nat_add simp: equiv_zmset_def fun_eq_iff multiset_eq_iff diff_eq_eq
    diff_add_eq eq_diff_eq of_nat_add[symmetric])

lemma zcount_inject: "zcount M = zcount N \<longleftrightarrow> M = N"
  by transfer (auto simp del: of_nat_add simp: equiv_zmset_def fun_eq_iff multiset_eq_iff
    diff_eq_eq diff_add_eq eq_diff_eq of_nat_add[symmetric])

lemma zmultiset_eq_iff: "M = N \<longleftrightarrow> (\<forall>a. zcount M a = zcount N a)"
  by (simp only: zcount_inject[symmetric] fun_eq_iff)

lemma zmultiset_eqI: "(\<And>x. zcount A x = zcount B x) \<Longrightarrow> A = B"
  using zmultiset_eq_iff by auto

lemma zcount_uminus[simp]: "zcount (- A) x = - zcount A x"
  by transfer auto

lift_definition add_zmset :: "'a \<Rightarrow> 'a zmultiset \<Rightarrow> 'a zmultiset" is
  "\<lambda>x (Mp, Mn). (add_mset x Mp, Mn)"
  by (auto simp: equiv_zmset_def)

syntax
  "_zmultiset" :: "args \<Rightarrow> 'a zmultiset" ("{#(_)#}\<^sub>z")
translations
  "{#x, xs#}\<^sub>z" == "CONST add_zmset x {#xs#}\<^sub>z"
  "{#x#}\<^sub>z" == "CONST add_zmset x {#}\<^sub>z"

lemma zcount_empty[simp]: "zcount {#}\<^sub>z a = 0"
  by transfer auto

lemma zcount_add_zmset[simp]:
  "zcount (add_zmset b A) a = (if b = a then zcount A a + 1 else zcount A a)"
  by transfer auto

lemma zcount_single: "zcount {#b#}\<^sub>z a = (if b = a then 1 else 0)"
  by simp

lemma add_add_same_iff_zmset[simp]: "add_zmset a A = add_zmset a B \<longleftrightarrow> A = B"
  by (auto simp: zmultiset_eq_iff)

lemma add_zmset_commute: "add_zmset x (add_zmset y M) = add_zmset y (add_zmset x M)"
  by (auto simp: zmultiset_eq_iff)

lemma
  singleton_ne_empty_zmset[simp]: "{#x#}\<^sub>z \<noteq> {#}\<^sub>z" and
  empty_ne_singleton_zmset[simp]: "{#}\<^sub>z \<noteq> {#x#}\<^sub>z"
  by (auto dest!: arg_cong2[of _ _ x _ zcount])

lemma
  singleton_ne_uminus_singleton_zmset[simp]: "{#x#}\<^sub>z \<noteq> - {#y#}\<^sub>z" and
  uminus_singleton_ne_singleton_zmset[simp]: "- {#x#}\<^sub>z \<noteq> {#y#}\<^sub>z"
  by (auto dest!: arg_cong2[of _ _ x x zcount] split: if_splits)

subsubsection \<open>Conversion to Set and Membership\<close>

definition set_zmset :: "'a zmultiset \<Rightarrow> 'a set" where
  "set_zmset M = {x. zcount M x \<noteq> 0}"

abbreviation elem_zmset :: "'a \<Rightarrow> 'a zmultiset \<Rightarrow> bool" where
  "elem_zmset a M \<equiv> a \<in> set_zmset M"

notation
  elem_zmset ("'(\<in>#\<^sub>z')") and
  elem_zmset ("(_/ \<in>#\<^sub>z _)" [51, 51] 50)

notation (ASCII)
  elem_zmset ("'(:#z')") and
  elem_zmset ("(_/ :#z _)" [51, 51] 50)

abbreviation not_elem_zmset :: "'a \<Rightarrow> 'a zmultiset \<Rightarrow> bool" where
  "not_elem_zmset a M \<equiv> a \<notin> set_zmset M"

notation
  not_elem_zmset ("'(\<notin>#\<^sub>z')") and
  not_elem_zmset ("(_/ \<notin>#\<^sub>z _)" [51, 51] 50)

notation (ASCII)
  not_elem_zmset ("'(~:#z')") and
  not_elem_zmset ("(_/ ~:#z _)" [51, 51] 50)

context
begin

qualified abbreviation Ball :: "'a zmultiset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
  "Ball M \<equiv> Set.Ball (set_zmset M)"

qualified abbreviation Bex :: "'a zmultiset \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool" where
  "Bex M \<equiv> Set.Bex (set_zmset M)"

end

syntax
  "_ZMBall" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool" ("(3\<forall>_\<in>#\<^sub>z_./ _)" [0, 0, 10] 10)
  "_ZMBex" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool" ("(3\<exists>_\<in>#\<^sub>z_./ _)" [0, 0, 10] 10)

syntax (ASCII)
  "_ZMBall" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool" ("(3\<forall>_:#\<^sub>z_./ _)" [0, 0, 10] 10)
  "_ZMBex" :: "pttrn \<Rightarrow> 'a set \<Rightarrow> bool \<Rightarrow> bool" ("(3\<exists>_:#\<^sub>z_./ _)" [0, 0, 10] 10)

translations
  "\<forall>x\<in>#\<^sub>zA. P" \<rightleftharpoons> "CONST Signed_Multiset.Ball A (\<lambda>x. P)"
  "\<exists>x\<in>#\<^sub>zA. P" \<rightleftharpoons> "CONST Signed_Multiset.Bex A (\<lambda>x. P)"

lemma zcount_eq_zero_iff: "zcount M x = 0 \<longleftrightarrow> x \<notin>#\<^sub>z M"
  by (auto simp add: set_zmset_def)

lemma not_in_iff_zmset: "x \<notin>#\<^sub>z M \<longleftrightarrow> zcount M x = 0"
  by (auto simp add: zcount_eq_zero_iff)

lemma zcount_ne_zero_iff[simp]: "zcount M x \<noteq> 0 \<longleftrightarrow> x \<in>#\<^sub>z M"
  by (auto simp add: set_zmset_def)

lemma zcount_inI:
  assumes "zcount M x = 0 \<Longrightarrow> False"
  shows "x \<in>#\<^sub>z M"
proof (rule ccontr)
  assume "x \<notin>#\<^sub>z M"
  with assms show False by (simp add: not_in_iff_zmset)
qed

lemma set_zmset_empty[simp]: "set_zmset {#}\<^sub>z = {}"
  by (simp add: set_zmset_def)

lemma set_zmset_single: "set_zmset {#b#}\<^sub>z = {b}"
  by (simp add: set_zmset_def)

lemma set_zmset_eq_empty_iff[simp]: "set_zmset M = {} \<longleftrightarrow> M = {#}\<^sub>z"
  by (auto simp add: zmultiset_eq_iff zcount_eq_zero_iff)

lemma finite_count_ne: "finite {x. count M x \<noteq> count N x}"
proof -
  have "{x. count M x \<noteq> count N x} \<subseteq> set_mset M \<union> set_mset N"
    by (auto simp: not_in_iff)
  moreover have "finite (set_mset M \<union> set_mset N)"
    by (rule finite_UnI[OF finite_set_mset finite_set_mset])
  ultimately show ?thesis
    by (rule finite_subset)
qed

lemma finite_set_zmset[iff]: "finite (set_zmset M)"
  unfolding set_zmset_def by transfer (auto intro: finite_count_ne)

lemma zmultiset_nonemptyE[elim]:
  assumes "A \<noteq> {#}\<^sub>z"
  obtains x where "x \<in>#\<^sub>z A"
proof -
  have "\<exists>x. x \<in>#\<^sub>z A"
    by (rule ccontr) (insert assms, auto)
  with that show ?thesis
    by blast
qed

subsubsection \<open>Union\<close>

lemma zcount_union[simp]: "zcount (M + N) a = zcount M a + zcount N a"
  by transfer auto

lemma union_add_left_zmset[simp]: "add_zmset a A + B = add_zmset a (A + B)"
  by (auto simp: zmultiset_eq_iff)

lemma union_zmset_add_zmset_right[simp]: "A + add_zmset a B = add_zmset a (A + B)"
  by (auto simp: zmultiset_eq_iff)

lemma add_zmset_add_single: \<open>add_zmset a A = A + {#a#}\<^sub>z\<close>
  by (subst union_zmset_add_zmset_right, subst add.comm_neutral) (rule refl)

subsubsection \<open>Difference\<close>

lemma zcount_diff[simp]: "zcount (M - N) a = zcount M a - zcount N a"
  by transfer auto

lemma add_zmset_diff_bothsides: \<open>add_zmset a M - add_zmset a A = M - A\<close>
  by (auto simp: zmultiset_eq_iff)

lemma in_diff_zcount: "a \<in>#\<^sub>z M - N \<longleftrightarrow> zcount N a \<noteq> zcount M a"
  by (fastforce simp: set_zmset_def)

lemma diff_add_zmset:
  fixes M N Q :: "'a zmultiset"
  shows "M - (N + Q) = M - N - Q"
  by (rule sym) (fact diff_diff_add)

lemma insert_Diff_zmset[simp]: "add_zmset x (M - {#x#}\<^sub>z) = M"
  by (clarsimp simp: zmultiset_eq_iff)

lemma diff_union_swap_zmset: "add_zmset b (M - {#a#}\<^sub>z) = add_zmset b M - {#a#}\<^sub>z"
  by (auto simp add: zmultiset_eq_iff)

lemma diff_add_zmset_swap[simp]: "add_zmset b M - A = add_zmset b (M - A)"
  by (auto simp add: zmultiset_eq_iff)

lemma diff_diff_add_zmset[simp]: "(M :: 'a zmultiset) - N - P = M - (N + P)"
  by (rule diff_diff_add)

lemma zmset_add[elim?]:
  obtains B where "A = add_zmset a B"
proof -
  have "A = add_zmset a (A - {#a#}\<^sub>z)"
    by simp
  with that show thesis .
qed

subsubsection \<open>Equality of Signed Multisets\<close>

lemma single_eq_single_zmset[simp]: "{#a#}\<^sub>z = {#b#}\<^sub>z \<longleftrightarrow> a = b"
  by (auto simp add: zmultiset_eq_iff)

lemma multi_self_add_other_not_self_zmset[simp]: "M = add_zmset x M \<longleftrightarrow> False"
  by (auto simp add: zmultiset_eq_iff)

lemma add_zmset_remove_trivial: \<open>add_zmset x M - {#x#}\<^sub>z = M\<close>
  by simp

lemma diff_single_eq_union_zmset: "M - {#x#}\<^sub>z = N \<longleftrightarrow> M = add_zmset x N"
  by auto

lemma union_single_eq_diff_zmset: "add_zmset x M = N \<Longrightarrow> M = N - {#x#}\<^sub>z"
  unfolding add_zmset_add_single[of _ M] by (fact add_implies_diff)

lemma add_zmset_eq_conv_diff:
  "add_zmset a M = add_zmset b N \<longleftrightarrow>
   M = N \<and> a = b \<or> M = add_zmset b (N - {#a#}\<^sub>z) \<and> N = add_zmset a (M - {#b#}\<^sub>z)"
  by (simp add: zmultiset_eq_iff) fastforce

lemma add_zmset_eq_conv_ex:
  "(add_zmset a M = add_zmset b N) =
    (M = N \<and> a = b \<or> (\<exists>K. M = add_zmset b K \<and> N = add_zmset a K))"
  by (auto simp add: add_zmset_eq_conv_diff)

lemma multi_member_split: "\<exists>A. M = add_zmset x A"
  by (rule exI[where x = "M - {#x#}\<^sub>z"]) simp

subsection \<open>Conversions from and to Multisets\<close>

lift_definition zmset_of :: "'a multiset \<Rightarrow> 'a zmultiset" is "\<lambda>f. (Abs_multiset f, {#})" .

lemma zmset_of_inject[simp]: "zmset_of M = zmset_of N \<longleftrightarrow> M = N"
  by (simp add: zmset_of_def, transfer', auto simp: equiv_zmset_def)

lemma zmset_of_empty[simp]: "zmset_of {#} = {#}\<^sub>z"
  by (simp add: zmset_of_def zero_zmultiset_def)

lemma zmset_of_add_mset[simp]: "zmset_of (add_mset x M) = add_zmset x (zmset_of M)"
  by transfer (auto simp: equiv_zmset_def add_mset_def cong: if_cong)

lemma zcount_of_mset[simp]: "zcount (zmset_of M) x = int (count M x)"
  by (induct M) auto

lemma zmset_of_plus: "zmset_of (M + N) = zmset_of M + zmset_of N"
  by (transfer, auto simp: equiv_zmset_def eq_onp_same_args plus_multiset.abs_eq)+

lift_definition mset_pos :: "'a zmultiset \<Rightarrow> 'a multiset" is "\<lambda>(Mp, Mn). count (Mp - Mn)"
  by (auto simp add: equiv_zmset_def simp flip: set_mset_diff)
    (metis add.commute add_diff_cancel_right)

lift_definition mset_neg :: "'a zmultiset \<Rightarrow> 'a multiset" is "\<lambda>(Mp, Mn). count (Mn - Mp)"
  by (auto simp add: equiv_zmset_def simp flip: set_mset_diff)
    (metis add.commute add_diff_cancel_right)

lemma
  zmset_of_inverse[simp]: "mset_pos (zmset_of M) = M" and
  minus_zmset_of_inverse[simp]: "mset_neg (- zmset_of M) = M"
  by (transfer, simp)+

lemma neg_zmset_pos[simp]: "mset_neg (zmset_of M) = {#}"
  by (rule zmset_of_inject[THEN iffD1], simp, transfer, auto simp: equiv_zmset_def)+

lemma
  count_mset_pos[simp]: "count (mset_pos M) x = nat (zcount M x)" and
  count_mset_neg[simp]: "count (mset_neg M) x = nat (- zcount M x)"
  by (transfer; auto)+

lemma
  mset_pos_empty[simp]: "mset_pos {#}\<^sub>z = {#}" and
  mset_neg_empty[simp]: "mset_neg {#}\<^sub>z = {#}"
  by (rule multiset_eqI, simp)+

lemma
  mset_pos_singleton[simp]: "mset_pos {#x#}\<^sub>z = {#x#}" and
  mset_neg_singleton[simp]: "mset_neg {#x#}\<^sub>z = {#}"
  by (rule multiset_eqI, simp)+

lemma
  mset_pos_neg_partition: "M = zmset_of (mset_pos M) - zmset_of (mset_neg M)" and
  mset_pos_as_neg: "zmset_of (mset_pos M) = zmset_of (mset_neg M) + M" and
  mset_neg_as_pos: "zmset_of (mset_neg M) = zmset_of (mset_pos M) - M"
  by (rule zmultiset_eqI, simp)+

lemma mset_pos_uminus[simp]: "mset_pos (- A) = mset_neg A"
  by (rule multiset_eqI) simp

lemma mset_neg_uminus[simp]: "mset_neg (- A) = mset_pos A"
  by (rule multiset_eqI) simp

lemma mset_pos_plus[simp]:
  "mset_pos (A + B) = (mset_pos A - mset_neg B) + (mset_pos B - mset_neg A)"
  by (rule multiset_eqI) simp

lemma mset_neg_plus[simp]:
  "mset_neg (A + B) = (mset_neg A - mset_pos B) + (mset_neg B - mset_pos A)"
  by (rule multiset_eqI) simp

lemma mset_pos_diff[simp]:
  "mset_pos (A - B) = (mset_pos A - mset_pos B) + (mset_neg B - mset_neg A)"
  by (rule mset_pos_plus[of A "- B", simplified])

lemma mset_neg_diff[simp]:
  "mset_neg (A - B) = (mset_neg A - mset_neg B) + (mset_pos B - mset_pos A)"
  by (rule mset_neg_plus[of A "- B", simplified])

lemma mset_pos_neg_dual:
  "mset_pos a + mset_pos b + (mset_neg a - mset_pos b) + (mset_neg b - mset_pos a) =
   mset_neg a + mset_neg b + (mset_pos a - mset_neg b) + (mset_pos b - mset_neg a)"
  using [[linarith_split_limit = 20]] by (rule multiset_eqI) simp

lemma decompose_zmset_of2:
  obtains A B C where
    "M = zmset_of A + C" and
    "N = zmset_of B + C"
proof
  let ?A = "zmset_of (mset_pos M + mset_neg N)"
  let ?B = "zmset_of (mset_pos N + mset_neg M)"
  let ?C = "- (zmset_of (mset_neg M) + zmset_of (mset_neg N))"

  show "M = ?A + ?C"
    by (simp add: zmset_of_plus mset_pos_neg_partition)
  show "N = ?B + ?C"
    by (simp add: zmset_of_plus diff_add_zmset mset_pos_neg_partition)
qed

subsubsection \<open>Pointwise Ordering Induced by @{const zcount}\<close>

definition subseteq_zmset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> bool" (infix "\<subseteq>#\<^sub>z" 50) where
  "A \<subseteq>#\<^sub>z B \<longleftrightarrow> (\<forall>a. zcount A a \<le> zcount B a)"

definition subset_zmset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> bool" (infix "\<subset>#\<^sub>z" 50) where
  "A \<subset>#\<^sub>z B \<longleftrightarrow> A \<subseteq>#\<^sub>z B \<and> A \<noteq> B"

abbreviation (input)
  supseteq_zmset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> bool" (infix "\<supseteq>#\<^sub>z" 50)
where
  "supseteq_zmset A B \<equiv> B \<subseteq>#\<^sub>z A"

abbreviation (input)
  supset_zmset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> bool" (infix "\<supset>#\<^sub>z" 50)
where
  "supset_zmset A B \<equiv> B \<subset>#\<^sub>z A"

notation (input)
  subseteq_zmset (infix "\<subseteq>#\<^sub>z" 50) and
  supseteq_zmset (infix "\<supseteq>#\<^sub>z" 50)

notation (ASCII)
  subseteq_zmset (infix "\<subseteq>#\<^sub>z" 50) and
  subset_zmset (infix "\<subset>#\<^sub>z" 50) and
  supseteq_zmset (infix "\<supseteq>#\<^sub>z" 50) and
  supset_zmset (infix ">#\<^sub>z" 50)

interpretation subset_zmset: ordered_ab_semigroup_add_imp_le "(+)" "(-)" "(\<subseteq>#\<^sub>z)" "(\<subset>#\<^sub>z)"
  by unfold_locales (auto simp add: subset_zmset_def subseteq_zmset_def zmultiset_eq_iff
    intro: order_trans antisym)

interpretation subset_zmset:
  ordered_ab_semigroup_monoid_add_imp_le "(+)" 0 "(-)" "(\<subseteq>#\<^sub>z)" "(\<subset>#\<^sub>z)"
  by unfold_locales

lemma zmset_subset_eqI: "(\<And>a. zcount A a \<le> zcount B a) \<Longrightarrow> A \<subseteq>#\<^sub>z B"
  by (simp add: subseteq_zmset_def)

lemma zmset_subset_eq_zcount: "A \<subseteq>#\<^sub>z B \<Longrightarrow> zcount A a \<le> zcount B a"
  by (simp add: subseteq_zmset_def)

lemma zmset_subset_eq_add_zmset_cancel: \<open>add_zmset a A \<subseteq>#\<^sub>z add_zmset a B \<longleftrightarrow> A \<subseteq>#\<^sub>z B\<close>
  unfolding add_zmset_add_single[of _ A] add_zmset_add_single[of _ B]
  by (rule subset_zmset.add_le_cancel_right)

lemma zmset_subset_eq_zmultiset_union_diff_commute:
  "A - B + C = A + C - B" for A B C :: "'a zmultiset"
  by (simp add: add.commute add_diff_eq)

lemma zmset_subset_eq_insertD: "add_zmset x A \<subseteq>#\<^sub>z B \<Longrightarrow> A \<subset>#\<^sub>z B"
  unfolding subset_zmset_def subseteq_zmset_def
  by (metis (no_types) add.commute add_le_same_cancel2 zcount_add_zmset dual_order.trans le_cases
    le_numeral_extra(2))

lemma zmset_subset_insertD: "add_zmset x A \<subset>#\<^sub>z B \<Longrightarrow> A \<subset>#\<^sub>z B"
  by (rule zmset_subset_eq_insertD) (rule subset_zmset.less_imp_le)

lemma subset_eq_diff_conv_zmset: "A - C \<subseteq>#\<^sub>z B \<longleftrightarrow> A \<subseteq>#\<^sub>z B + C"
  by (simp add: subseteq_zmset_def ordered_ab_group_add_class.diff_le_eq)

lemma multi_psub_of_add_self_zmset[simp]: "A \<subset>#\<^sub>z add_zmset x A"
  by (auto simp: subset_zmset_def subseteq_zmset_def)

lemma multi_psub_self_zmset: "A \<subset>#\<^sub>z A = False"
  by simp

lemma zmset_subset_add_zmset[simp]: "add_zmset x N \<subset>#\<^sub>z add_zmset x M \<longleftrightarrow> N \<subset>#\<^sub>z M"
  unfolding add_zmset_add_single[of _ N] add_zmset_add_single[of _ M]
  by (fact subset_zmset.add_less_cancel_right)

lemma zmset_of_subseteq_iff[simp]: "zmset_of M \<subseteq>#\<^sub>z zmset_of N \<longleftrightarrow> M \<subseteq># N"
  by (simp add: subseteq_zmset_def subseteq_mset_def)

lemma zmset_of_subset_iff[simp]: "zmset_of M \<subset>#\<^sub>z zmset_of N \<longleftrightarrow> M \<subset># N"
  by (simp add: subset_zmset_def subset_mset_def)

lemma
  mset_pos_supset: "A \<subseteq>#\<^sub>z zmset_of (mset_pos A)" and
  mset_neg_supset: "- A \<subseteq>#\<^sub>z zmset_of (mset_neg A)"
  by (auto intro: zmset_subset_eqI)

lemma subset_mset_zmsetE:
  assumes "M \<subset>#\<^sub>z N"
  obtains A B C where
    "M = zmset_of A + C" and "N = zmset_of B + C" and "A \<subset># B"
  by (metis assms decompose_zmset_of2 subset_zmset.add_less_cancel_right zmset_of_subset_iff)

lemma subseteq_mset_zmsetE:
  assumes "M \<subseteq>#\<^sub>z N"
  obtains A B C where
    "M = zmset_of A + C" and "N = zmset_of B + C" and "A \<subseteq># B"
  by (metis assms add.commute add.right_neutral subset_mset.order_refl subset_mset_def
    subset_mset_zmsetE subset_zmset_def zmset_of_empty)

subsubsection \<open>Subset is an Order\<close>

interpretation subset_zmset: order "(\<subseteq>#\<^sub>z)" "(\<subset>#\<^sub>z)"
  by unfold_locales

subsection \<open>Replicate and Repeat Operations\<close>

definition replicate_zmset :: "nat \<Rightarrow> 'a \<Rightarrow> 'a zmultiset" where
  "replicate_zmset n x = (add_zmset x ^^ n) {#}\<^sub>z"

lemma replicate_zmset_0[simp]: "replicate_zmset 0 x = {#}\<^sub>z"
  unfolding replicate_zmset_def by simp

lemma replicate_zmset_Suc[simp]: "replicate_zmset (Suc n) x = add_zmset x (replicate_zmset n x)"
  unfolding replicate_zmset_def by (induct n) (auto intro: add.commute)

lemma count_replicate_zmset[simp]:
  "zcount (replicate_zmset n x) y = (if y = x then of_nat n else 0)"
  unfolding replicate_zmset_def by (induct n) auto

fun repeat_zmset :: "nat \<Rightarrow> 'a zmultiset \<Rightarrow> 'a zmultiset" where
  "repeat_zmset 0 _ = {#}\<^sub>z" |
  "repeat_zmset (Suc n) A = A + repeat_zmset n A"

lemma count_repeat_zmset[simp]: "zcount (repeat_zmset i A) a = of_nat i * zcount A a"
  by (induct i) (auto simp: semiring_normalization_rules(3))

lemma repeat_zmset_right[simp]: "repeat_zmset a (repeat_zmset b A) = repeat_zmset (a * b) A"
  by (auto simp: zmultiset_eq_iff left_diff_distrib')

lemma left_diff_repeat_zmset_distrib':
  \<open>i \<ge> j \<Longrightarrow> repeat_zmset (i - j) u = repeat_zmset i u - repeat_zmset j u\<close>
  by (auto simp: zmultiset_eq_iff int_distrib(3) of_nat_diff)

lemma left_add_mult_distrib_zmset:
  "repeat_zmset i u + (repeat_zmset j u + k) = repeat_zmset (i+j) u + k"
  by (auto simp: zmultiset_eq_iff add_mult_distrib int_distrib(1))

lemma repeat_zmset_distrib: "repeat_zmset (m + n) A = repeat_zmset m A + repeat_zmset n A"
  by (auto simp: zmultiset_eq_iff Nat.add_mult_distrib int_distrib(1))

lemma repeat_zmset_distrib2[simp]:
  "repeat_zmset n (A + B) = repeat_zmset n A + repeat_zmset n B"
  by (auto simp: zmultiset_eq_iff add_mult_distrib2 int_distrib(2))

lemma repeat_zmset_replicate_zmset[simp]: "repeat_zmset n {#a#}\<^sub>z = replicate_zmset n a"
  by (auto simp: zmultiset_eq_iff)

lemma repeat_zmset_distrib_add_zmset[simp]:
  "repeat_zmset n (add_zmset a A) = replicate_zmset n a + repeat_zmset n A"
  by (auto simp: zmultiset_eq_iff int_distrib(2))

lemma repeat_zmset_empty[simp]: "repeat_zmset n {#}\<^sub>z = {#}\<^sub>z"
  by (induct n) simp_all

subsubsection \<open>Filter (with Comprehension Syntax)\<close>

lift_definition filter_zmset :: "('a \<Rightarrow> bool) \<Rightarrow> 'a zmultiset \<Rightarrow> 'a zmultiset" is
  "\<lambda>P (Mp, Mn). (filter_mset P Mp, filter_mset P Mn)"
  by (auto simp del: filter_union_mset simp: equiv_zmset_def filter_union_mset[symmetric])

syntax (ASCII)
  "_ZMCollect" :: "pttrn \<Rightarrow> 'a zmultiset \<Rightarrow> bool \<Rightarrow> 'a zmultiset" ("(1{#_ :#z _./ _#})")
syntax
  "_ZMCollect" :: "pttrn \<Rightarrow> 'a zmultiset \<Rightarrow> bool \<Rightarrow> 'a zmultiset" ("(1{#_ \<in>#\<^sub>z _./ _#})")
translations
  "{#x \<in>#\<^sub>z M. P#}" == "CONST filter_zmset (\<lambda>x. P) M"

lemma count_filter_zmset[simp]:
  "zcount (filter_zmset P M) a = (if P a then zcount M a else 0)"
  by transfer auto

lemma filter_empty_zmset[simp]: "filter_zmset P {#}\<^sub>z = {#}\<^sub>z"
  by (rule zmultiset_eqI) simp

lemma filter_single_zmset: "filter_zmset P {#x#}\<^sub>z = (if P x then {#x#}\<^sub>z else {#}\<^sub>z)"
  by (rule zmultiset_eqI) simp

lemma filter_union_zmset[simp]: "filter_zmset P (M + N) = filter_zmset P M + filter_zmset P N"
  by (rule zmultiset_eqI) simp

lemma filter_diff_zmset[simp]: "filter_zmset P (M - N) = filter_zmset P M - filter_zmset P N"
  by (rule zmultiset_eqI) simp

lemma filter_add_zmset[simp]:
  "filter_zmset P (add_zmset x A) =
   (if P x then add_zmset x (filter_zmset P A) else filter_zmset P A)"
  by (auto simp: zmultiset_eq_iff)

lemma zmultiset_filter_mono:
  assumes "A \<subseteq>#\<^sub>z B"
  shows "filter_zmset f A \<subseteq>#\<^sub>z filter_zmset f B"
  using assms by (simp add: subseteq_zmset_def)

lemma filter_filter_zmset: "filter_zmset P (filter_zmset Q M) = {#x \<in>#\<^sub>z M. Q x \<and> P x#}"
  by (auto simp: zmultiset_eq_iff)

lemma
  filter_zmset_True[simp]: "{#y \<in>#\<^sub>z M. True#} = M" and
  filter_zmset_False[simp]: "{#y \<in>#\<^sub>z M. False#} = {#}\<^sub>z"
  by (auto simp: zmultiset_eq_iff)

subsection \<open>Uncategorized\<close>

lemma multi_drop_mem_not_eq_zmset: "B - {#c#}\<^sub>z \<noteq> B"
  by (simp add: diff_single_eq_union_zmset)

lemma zmultiset_partition: "M = {#x \<in>#\<^sub>z M. P x #} + {#x \<in>#\<^sub>z M. \<not> P x#}"
  by (subst zmultiset_eq_iff) auto

subsection \<open>Image\<close>

definition image_zmset :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a zmultiset \<Rightarrow> 'b zmultiset" where
  "image_zmset f M =
   zmset_of (fold_mset (add_mset \<circ> f) {#} (mset_pos M)) -
   zmset_of (fold_mset (add_mset \<circ> f) {#} (mset_neg M))"

subsection \<open>Multiset Order\<close>

instantiation zmultiset :: (preorder) order
begin

lift_definition less_zmultiset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> bool" is
  "\<lambda>(Mp, Mn) (Np, Nn). Mp + Nn < Mn + Np"
proof (clarsimp simp: equiv_zmset_def)
  fix A1 B2 B1 A2 C1 D2 D1 C2 :: "'a multiset"
  assume
    ab: "A1 + A2 = B1 + B2" and
    cd: "C1 + C2 = D1 + D2"

  have "A1 + D2 < B2 + C1 \<longleftrightarrow> A1 + A2 + D2 < A2 + B2 + C1"
    by simp
  also have "\<dots> \<longleftrightarrow> B1 + B2 + D2 < A2 + B2 + C1"
    unfolding ab by (rule refl)
  also have "\<dots> \<longleftrightarrow> B1 + D2 < A2 + C1"
    by simp
  also have "\<dots> \<longleftrightarrow> B1 + D1 + D2 < A2 + C1 + D1"
    by simp
  also have "\<dots> \<longleftrightarrow> B1 + C1 + C2 < A2 + C1 + D1"
    using cd by (simp add: add.assoc)
  also have "\<dots> \<longleftrightarrow> B1 + C2 < A2 + D1"
    by simp
  finally show "A1 + D2 < B2 + C1 \<longleftrightarrow> B1 + C2 < A2 + D1"
    by assumption
qed

definition less_eq_zmultiset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> bool" where
  "less_eq_zmultiset M' M \<longleftrightarrow> M' < M \<or> M' = M"

instance
proof ((intro_classes; unfold less_eq_zmultiset_def; transfer),
    auto simp: equiv_zmset_def union_commute)
  fix A1 B1 D C B2 A2 :: "'a multiset"
  assume ab: "A1 + A2 \<noteq> B1 + B2"

  {
    assume ab1: "A1 + C < B1 + D"

    {
      assume ab2: "D + A2 < C + B2"
      show "A1 + A2 < B1 + B2"
      proof -
        have f1: "\<And>m. D + A2 + m < C + B2 + m"
          using ab2 add_less_cancel_right by blast
        have "\<And>m. C + (A1 + m) < D + (B1 + m)"
          by (simp add: ab1 add.commute)
        then have "D + (A2 + A1) < D + (B1 + B2)"
          using f1 by (metis add.assoc add.commute mset_le_trans)
        then show ?thesis
          by (simp add: add.commute)
      qed
    }
    {
      assume ab2: "D + A2 = C + B2"
      show "A1 + A2 < B1 + B2"
      proof -
        have "\<And>m. C + A1 + m < D + B1 + m"
          by (simp add: ab1 add.commute)
        then have "D + (A2 + A1) < D + (B1 + B2)"
          by (metis (no_types) ab2 add.assoc add.commute)
        then show ?thesis
          by (simp add: add.commute)
      qed
    }
  }

  {
    assume ab1: "A1 + C = B1 + D"

    {
      assume ab2: "D + A2 < C + B2"
      show "A1 + A2 < B1 + B2"
      proof -
        have "A1 + (D + A2) < B1 + (D + B2)"
          by (metis (no_types) ab1 ab2 add.assoc add_less_cancel_left)
        then show ?thesis
          by simp
      qed
    }
    {
      assume ab2: "D + A2 = C + B2"
      have False
        by (metis (no_types) ab ab1 ab2 add.assoc add.commute add_diff_cancel_right')
      thus "A1 + A2 < B1 + B2"
        by sat
    }
  }
qed

end

instance zmultiset :: (preorder) ordered_cancel_comm_monoid_add
  by (intro_classes, unfold less_eq_zmultiset_def, transfer, auto simp: equiv_zmset_def)

instance zmultiset :: (preorder) ordered_ab_group_add
  by (intro_classes; transfer; auto simp: equiv_zmset_def)

instantiation zmultiset :: (linorder) distrib_lattice
begin

definition inf_zmultiset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> 'a zmultiset" where
  "inf_zmultiset A B = (if A < B then A else B)"

definition sup_zmultiset :: "'a zmultiset \<Rightarrow> 'a zmultiset \<Rightarrow> 'a zmultiset" where
  "sup_zmultiset A B = (if B > A then B else A)"

lemma not_lt_iff_ge_zmset: "\<not> x < y \<longleftrightarrow> x \<ge> y" for x y :: "'a zmultiset"
  by (unfold less_eq_zmultiset_def, transfer, auto simp: equiv_zmset_def algebra_simps)

instance
  by intro_classes (auto simp: less_eq_zmultiset_def inf_zmultiset_def sup_zmultiset_def
    dest!: not_lt_iff_ge_zmset[THEN iffD1])

end

lemma zmset_of_less: "zmset_of M < zmset_of N \<longleftrightarrow> M < N"
  by (clarsimp simp: zmset_of_def, transfer', simp)+

lemma zmset_of_le: "zmset_of M \<le> zmset_of N \<longleftrightarrow> M \<le> N"
  by (simp_all add: less_eq_zmultiset_def zmset_of_def; transfer'; auto simp: equiv_zmset_def)

instance zmultiset :: (preorder) ordered_ab_semigroup_add
  by (intro_classes, unfold less_eq_zmultiset_def, transfer, auto simp: equiv_zmset_def)

lemma uminus_add_conv_diff_mset[cancelation_simproc_pre]: \<open>-a + b = b - a\<close> for a :: \<open>'a zmultiset\<close>
  by (simp add: add.commute)

lemma uminus_add_add_uminus[cancelation_simproc_pre]: \<open>b -a + c = b + c - a\<close> for a :: \<open>'a zmultiset\<close>
  by (simp add: uminus_add_conv_diff_mset zmset_subset_eq_zmultiset_union_diff_commute)

lemma add_zmset_eq_add_NO_MATCH[cancelation_simproc_pre]:
  \<open>NO_MATCH {#}\<^sub>z H \<Longrightarrow> add_zmset a H = {#a#}\<^sub>z + H\<close>
  by auto

lemma repeat_zmset_iterate_add: \<open>repeat_zmset n M = iterate_add n M\<close>
  unfolding iterate_add_def by (induction n) auto

declare repeat_zmset_iterate_add[cancelation_simproc_pre]

declare repeat_zmset_iterate_add[symmetric, cancelation_simproc_post]

simproc_setup zmseteq_cancel_numerals
  ("(l::'a zmultiset) + m = n" | "(l::'a zmultiset) = m + n" |
   "add_zmset a m = n" | "m = add_zmset a n" |
   "replicate_zmset p a = n" | "m = replicate_zmset p a" |
   "repeat_zmset p m = n" | "m = repeat_zmset p m") =
  \<open>fn phi => Cancel_Simprocs.eq_cancel\<close>

lemma zmset_subseteq_add_iff1:
  \<open>j \<le> i \<Longrightarrow> (repeat_zmset i u + m \<subseteq>#\<^sub>z repeat_zmset j u + n) = (repeat_zmset (i - j) u + m \<subseteq>#\<^sub>z n)\<close>
  by (simp add: add.commute add_diff_eq left_diff_repeat_zmset_distrib' subset_eq_diff_conv_zmset)

lemma zmset_subseteq_add_iff2:
  \<open>i \<le> j \<Longrightarrow> (repeat_zmset i u + m \<subseteq>#\<^sub>z repeat_zmset j u + n) = (m \<subseteq>#\<^sub>z repeat_zmset (j - i) u + n)\<close>
proof -
  assume "i \<le> j"
  then have "\<And>z. repeat_zmset j (z::'a zmultiset) - repeat_zmset i z = repeat_zmset (j - i) z"
    by (simp add: left_diff_repeat_zmset_distrib')
  then show ?thesis
    by (metis add.commute diff_diff_eq2 subset_eq_diff_conv_zmset)
qed

lemma zmset_subset_add_iff1:
  \<open>j \<le> i \<Longrightarrow> (repeat_zmset i u + m \<subset>#\<^sub>z repeat_zmset j u + n) = (repeat_zmset (i - j) u + m \<subset>#\<^sub>z n)\<close>
  by (simp add: subset_zmset.less_le_not_le zmset_subseteq_add_iff1 zmset_subseteq_add_iff2)

lemma zmset_subset_add_iff2:
  \<open>i \<le> j \<Longrightarrow> (repeat_zmset i u + m \<subset>#\<^sub>z repeat_zmset j u + n) = (m \<subset>#\<^sub>z repeat_zmset (j - i) u + n)\<close>
  by (simp add: subset_zmset.less_le_not_le zmset_subseteq_add_iff1 zmset_subseteq_add_iff2)

ML_file \<open>zmultiset_simprocs.ML\<close>

simproc_setup zmsetsubset_cancel
  ("(l::'a zmultiset) + m \<subset>#\<^sub>z n" | "(l::'a zmultiset) \<subset>#\<^sub>z m + n" |
   "add_zmset a m \<subset>#\<^sub>z n" | "m \<subset>#\<^sub>z add_zmset a n" |
   "replicate_zmset p a \<subset>#\<^sub>z n" | "m \<subset>#\<^sub>z replicate_zmset p a" |
   "repeat_zmset p m \<subset>#\<^sub>z n" | "m \<subset>#\<^sub>z repeat_zmset p m") =
  \<open>fn phi => ZMultiset_Simprocs.subset_cancel_zmsets\<close>

simproc_setup zmsetsubseteq_cancel
  ("(l::'a zmultiset) + m \<subseteq>#\<^sub>z n" | "(l::'a zmultiset) \<subseteq>#\<^sub>z m + n" |
   "add_zmset a m \<subseteq>#\<^sub>z n" | "m \<subseteq>#\<^sub>z add_zmset a n" |
   "replicate_zmset p a \<subseteq>#\<^sub>z n" | "m \<subseteq>#\<^sub>z replicate_zmset p a" |
   "repeat_zmset p m \<subseteq>#\<^sub>z n" | "m \<subseteq>#\<^sub>z repeat_zmset p m") =
  \<open>fn phi => ZMultiset_Simprocs.subseteq_cancel_zmsets\<close>

instance zmultiset :: (preorder) ordered_ab_semigroup_add_imp_le
  by (intro_classes; unfold less_eq_zmultiset_def; transfer; auto)

simproc_setup zmsetless_cancel
  ("(l::'a::preorder zmultiset) + m < n" | "(l::'a zmultiset) < m + n" |
   "add_zmset a m < n" | "m < add_zmset a n" |
   "replicate_zmset p a < n" | "m < replicate_zmset p a" |
   "repeat_zmset p m < n" | "m < repeat_zmset p m") =
  \<open>fn phi => Cancel_Simprocs.less_cancel\<close>

simproc_setup zmsetless_eq_cancel
  ("(l::'a::preorder zmultiset) + m \<le> n" | "(l::'a zmultiset) \<le> m + n" |
   "add_zmset a m \<le> n" | "m \<le> add_zmset a n" |
   "replicate_zmset p a \<le> n" | "m \<le> replicate_zmset p a" |
   "repeat_zmset p m \<le> n" | "m \<le> repeat_zmset p m") =
  \<open>fn phi => Cancel_Simprocs.less_eq_cancel\<close>

simproc_setup zmsetdiff_cancel
  ("n + (l::'a zmultiset)" | "(l::'a zmultiset) - m" |
   "add_zmset a m - n" | "m - add_zmset a n" |
   "replicate_zmset p r - n" | "m - replicate_zmset p r" |
   "repeat_zmset p m - n" | "m - repeat_zmset p m") =
  \<open>fn phi => Cancel_Simprocs.diff_cancel\<close>

instance zmultiset :: (linorder) linordered_cancel_ab_semigroup_add
  by (intro_classes, unfold less_eq_zmultiset_def, transfer, auto simp: equiv_zmset_def add.commute)

lemma less_mset_zmsetE:
  assumes "M < N"
  obtains A B C where
    "M = zmset_of A + C" and "N = zmset_of B + C" and "A < B"
  by (metis add_less_imp_less_right assms decompose_zmset_of2 zmset_of_less)

lemma less_eq_mset_zmsetE:
  assumes "M \<le> N"
  obtains A B C where
    "M = zmset_of A + C" and "N = zmset_of B + C" and "A \<le> B"
  by (metis add.commute add.right_neutral assms le_neq_trans less_imp_le less_mset_zmsetE order_refl
    zmset_of_empty)

lemma subset_eq_imp_le_zmset: "M \<subseteq>#\<^sub>z N \<Longrightarrow> M \<le> N"
  by (metis (no_types) add_mono_thms_linordered_semiring(3) subset_eq_imp_le_multiset
    subseteq_mset_zmsetE zmset_of_le)

lemma subset_imp_less_zmset: "M \<subset>#\<^sub>z N \<Longrightarrow> M < N"
  by (metis le_neq_trans subset_eq_imp_le_zmset subset_zmset_def)

lemma lt_imp_ex_zcount_lt:
  assumes m_lt_n: "M < N"
  shows "\<exists>y. zcount M y < zcount N y"
proof (rule ccontr, clarsimp)
  assume "\<forall>y. \<not> zcount M y < zcount N y"
  hence "\<forall>y. zcount M y \<ge> zcount N y"
    by (simp add: leI)
  hence "M \<supseteq>#\<^sub>z N"
    by (simp add: zmset_subset_eqI)
  hence "M \<ge> N"
    by (simp add: subset_eq_imp_le_zmset)
  thus False
    using m_lt_n by simp
qed

instance zmultiset :: (preorder) no_top
proof
  fix M :: \<open>'a zmultiset\<close>
  obtain a :: 'a where True by fast
  let ?M = \<open>zmset_of (mset_pos M) + zmset_of (mset_neg M)\<close>
  have \<open>M < add_zmset a ?M + ?M\<close>
    by (subst mset_pos_neg_partition)
      (auto simp: subset_zmset_def subseteq_zmset_def zmultiset_eq_iff
        intro!: subset_imp_less_zmset)
  then show \<open>\<exists>N. M < N\<close>
    by blast
qed

lifting_update multiset.lifting
lifting_forget multiset.lifting

end


theory ex3_06 imports Main "~~/src/HOL/IMP/AExp" begin

datatype lexp = Nl int | Vl vname | Plusl lexp lexp | LET vname lexp lexp

fun lval :: "lexp \<Rightarrow> state \<Rightarrow> val" where
"lval (Nl n) s = n" |
"lval (Vl x) s = s x" |
"lval (Plusl l r) s = lval l s + lval r s" |
"lval (LET x a b) s = lval b (s(x := lval a s))"

(** let x = (let y = 1 in y+y) in 1+x == 3 **)
value "lval (LET ''x'' (LET ''y'' (Nl 1) (Plusl (Vl ''y'') (Vl ''y''))) (Plusl (Nl 1) (Vl ''x''))) <>"

(** see ex3.3 **)
fun subst :: "vname \<Rightarrow> aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
"subst x a (N n) = N n" |
"subst x a (V v) = (if x = v then a else (V v))" |
"subst x a (Plus l r) = Plus (subst x a l) (subst x a r)"

theorem[simp]: "aval (subst x a e) s = aval e (s(x := aval a s))"
by (induction e, auto)

theorem[simp]: "aval a_1 s = aval a_2 s \<Longrightarrow> aval (subst x a_1 e) s = aval (subst x a_2 e) s"
by (induction e, auto)

fun inline :: "lexp \<Rightarrow> aexp" where
"inline (Nl n) = N n" |
"inline (Vl x) = V x" |
"inline (Plusl l r) = Plus (inline l) (inline r)" |
"inline (LET x a b) = subst x (inline a) (inline b)"

(** let x = (let y = 1 in y+y) in 1+x **)
value "inline (LET ''x'' (LET ''y'' (Nl 1) (Plusl (Vl ''y'') (Vl ''y''))) (Plusl (Nl 1) (Vl ''x'')))"

theorem "aval (inline e) s = lval e s"
apply(induction e arbitrary: s)
apply auto
done

end


(* Authors: F. Maric, M. Spasic, R. Thiemann *)
section \<open>Linear Polynomials and Constraints\<close>

theory Abstract_Linear_Poly
  imports
    Simplex_Algebra
begin

type_synonym var = nat

text\<open>(Infinite) linear polynomials as functions from vars to coeffs\<close>

definition fun_zero :: "var \<Rightarrow> 'a::zero" where
  [simp]: "fun_zero == \<lambda> v. 0"
definition fun_plus :: "(var \<Rightarrow> 'a) \<Rightarrow> (var \<Rightarrow> 'a) \<Rightarrow> var \<Rightarrow> 'a::plus" where
  [simp]: "fun_plus f1 f2 == \<lambda> v. f1 v + f2 v"
definition fun_scale :: "'a \<Rightarrow> (var \<Rightarrow> 'a) \<Rightarrow> (var \<Rightarrow> 'a::ring)" where
  [simp]: "fun_scale c f == \<lambda> v. c*(f v)"
definition fun_coeff :: "(var \<Rightarrow> 'a) \<Rightarrow> var \<Rightarrow> 'a" where
  [simp]: "fun_coeff f var = f var"
definition fun_vars :: "(var \<Rightarrow> 'a::zero) \<Rightarrow> var set" where
  [simp]: "fun_vars f = {v. f v \<noteq> 0}"
definition fun_vars_list :: "(var \<Rightarrow> 'a::zero) \<Rightarrow> var list" where
  [simp]: "fun_vars_list f = sorted_list_of_set {v. f v \<noteq> 0}"
definition fun_var :: "var \<Rightarrow> (var \<Rightarrow> 'a::{zero,one})" where
  [simp]: "fun_var x = (\<lambda> x'. if x' = x then 1 else 0)"
type_synonym 'a valuation = "var \<Rightarrow> 'a"
definition fun_valuate :: "(var \<Rightarrow> rat) \<Rightarrow> 'a valuation \<Rightarrow> ('a::rational_vector)" where
  [simp]: "fun_valuate lp val = (\<Sum>x\<in>{v. lp v \<noteq> 0}. lp x *R val x)"

text\<open>Invariant -- only finitely many variables\<close>
definition inv where
  [simp]: "inv c == finite {v. c v \<noteq> 0}"

lemma inv_fun_zero [simp]:
  "inv fun_zero" by simp

lemma inv_fun_plus [simp]:
  "\<lbrakk>inv (f1 :: nat \<Rightarrow> 'a::monoid_add); inv f2\<rbrakk> \<Longrightarrow> inv (fun_plus f1 f2)"
proof-
  have *: "{v. f1 v + f2 v \<noteq> (0 :: 'a)} \<subseteq> {v. f1 v \<noteq> (0 :: 'a)} \<union> {v. f2 v \<noteq> (0 :: 'a)}"
    by auto
  assume "inv f1" "inv f2"
  then show ?thesis
    using *
    by (auto simp add: finite_subset)
qed

lemma inv_fun_scale [simp]:
  "inv (f :: nat \<Rightarrow> 'a::ring) \<Longrightarrow> inv (fun_scale r f)"
proof-
  have *: "{v. r * (f v) \<noteq> 0} \<subseteq> {v. f v \<noteq> 0}"
    by auto
  assume "inv f"
  then show ?thesis
    using *
    by (auto simp add: finite_subset)
qed

text\<open>linear-poly type -- rat coeffs\<close>
  (* TODO: change rat to arbitrary ring *)

typedef  linear_poly = "{c :: var \<Rightarrow> rat. inv c}"
  by (rule_tac x="\<lambda> v. 0" in exI) auto

text\<open>Linear polynomials are of the form $a_1 \cdot x_1 + ... + a_n
\cdot x_n$. Their formalization follows the data-refinement approach
of Isabelle/HOL \cite{florian-refinement}. Abstract representation of
polynomials are functions mapping variables to their coefficients,
where only finitely many variables have non-zero
coefficients. Operations on polynomials are defined as operations on
functions. For example, the sum of @{term "p\<^sub>1"} and \<open>p\<^sub>2\<close> is
defined by @{term "\<lambda> v. p\<^sub>1 v + p\<^sub>2 v"} and the value of a polynomial
@{term "p"} for a valuation @{term "v"} (denoted by \<open>p\<lbrace>v\<rbrace>\<close>),
is defined by @{term "\<Sum>x\<in>{x. p x \<noteq> 0}. p x * v x"}. Executable
representation of polynomials uses RBT mappings instead of functions.
\<close>

setup_lifting type_definition_linear_poly

text\<open>Vector space operations on polynomials\<close>
instantiation linear_poly :: rational_vector
begin

lift_definition zero_linear_poly :: "linear_poly" is fun_zero by (rule inv_fun_zero)

lift_definition plus_linear_poly :: "linear_poly \<Rightarrow> linear_poly \<Rightarrow> linear_poly" is fun_plus
  by (rule inv_fun_plus)

lift_definition scaleRat_linear_poly :: "rat \<Rightarrow> linear_poly \<Rightarrow> linear_poly" is fun_scale
  by (rule inv_fun_scale)

definition uminus_linear_poly :: "linear_poly \<Rightarrow> linear_poly" where
  "uminus_linear_poly lp = -1 *R lp"

definition minus_linear_poly :: "linear_poly \<Rightarrow> linear_poly \<Rightarrow> linear_poly" where
  "minus_linear_poly lp1 lp2 = lp1 + (- lp2)"

instance
proof
  fix a b c::linear_poly
  show "a + b + c = a + (b + c)" by (transfer, auto)
  show "a + b = b + a" by (transfer, auto)
  show "0 + a = a" by (transfer, auto)
  show "-a + a = 0" unfolding uminus_linear_poly_def by (transfer, auto)
  show "a - b = a + (- b)" unfolding minus_linear_poly_def ..
next
  fix a :: rat and x y :: linear_poly
  show "a *R (x + y) = a *R x + a *R y" by (transfer, auto simp: field_simps)
next
  fix a b::rat and x::linear_poly
  show "(a + b) *R x = a *R x + b *R x" by (transfer, auto simp: field_simps)
  show "a *R b *R x = (a * b) *R x" by (transfer, auto simp: field_simps)
next
  fix x::linear_poly
  show "1 *R x = x" by (transfer, auto)
qed

end

text\<open>Coefficient\<close>
lift_definition coeff :: "linear_poly \<Rightarrow> var \<Rightarrow> rat" is fun_coeff .

lemma coeff_plus [simp] : "coeff (lp1 + lp2) var = coeff lp1 var + coeff lp2 var"
  by transfer auto

lemma coeff_scaleRat [simp]: "coeff (k *R lp1) var = k * coeff lp1 var"
  by transfer auto

lemma coeff_uminus [simp]: "coeff (-lp) var = - coeff lp var"
  unfolding uminus_linear_poly_def
  by transfer auto

lemma coeff_minus [simp]: "coeff (lp1 - lp2) var = coeff lp1 var - coeff lp2 var"
  unfolding minus_linear_poly_def uminus_linear_poly_def
  by transfer auto

text\<open>Set of variables\<close>

lift_definition vars :: "linear_poly \<Rightarrow> var set" is fun_vars .

lemma coeff_zero: "coeff p x \<noteq> 0 \<longleftrightarrow> x \<in> vars p"
  by transfer auto

lemma finite_vars: "finite (vars p)"
  by transfer auto

text\<open>List of variables\<close>
lift_definition vars_list :: "linear_poly \<Rightarrow> var list" is fun_vars_list .

lemma set_vars_list: "set (vars_list lp) = vars lp"
  by transfer auto

text\<open>Construct single variable polynomial\<close>
lift_definition Var :: "var \<Rightarrow> linear_poly" is fun_var by auto

text\<open>Value of a polynomial in a given valuation\<close>
lift_definition valuate :: "linear_poly \<Rightarrow> 'a valuation \<Rightarrow> ('a::rational_vector)" is fun_valuate .

syntax
  "_valuate" :: "linear_poly \<Rightarrow> 'a valuation \<Rightarrow> 'a"    ("_ \<lbrace> _ \<rbrace>")
translations
  "p\<lbrace>v\<rbrace> " == "CONST valuate p v"

lemma valuate_zero: "(0 \<lbrace>v\<rbrace>) = 0"
  by transfer auto

lemma
  valuate_diff: "(p \<lbrace>v1\<rbrace>) - (p \<lbrace>v2\<rbrace>) = (p \<lbrace> \<lambda> x. v1 x - v2 x \<rbrace>)"
  by (transfer, simp add: sum_subtractf[THEN sym], auto simp: rational_vector.scale_right_diff_distrib)

lemma valuate_opposite_val:
  shows "p \<lbrace> \<lambda> x. - v x \<rbrace> = - (p \<lbrace> v \<rbrace>)"
  using valuate_diff[of p "\<lambda> x. 0" v]
  by (auto simp add: valuate_def)

lemma valuate_nonneg:
  fixes v :: "'a::linordered_rational_vector valuation"
  assumes "\<forall> x \<in> vars p. (coeff p x > 0 \<longrightarrow> v x \<ge> 0) \<and> (coeff p x < 0 \<longrightarrow> v x \<le> 0)"
  shows "p \<lbrace> v \<rbrace> \<ge> 0"
  using assms
proof (transfer, unfold fun_valuate_def, goal_cases)
  case (1 p v)
  from 1 have fin: "finite {v. p v \<noteq> 0}" by auto
  then show "0 \<le> (\<Sum>x\<in>{v. p v \<noteq> 0}. p x *R v x)"
  proof (induct rule: finite_induct)
    case empty show ?case by auto
  next
    case (insert x F)
    show ?case unfolding sum.insert[OF insert(1-2)]
    proof (rule order.trans[OF _ add_mono[OF _ insert(3)]])
      show "0 \<le> p x *R v x" using scaleRat_leq1[of 0 "v x" "p x"]
        using scaleRat_leq2[of "v x" 0 "p x"] 1(2)
        by (cases "p x > 0"; cases "p x < 0"; auto)
    qed auto
  qed
qed

lemma valuate_nonpos:
  fixes v :: "'a::linordered_rational_vector valuation"
  assumes "\<forall> x \<in> vars p. (coeff p x > 0 \<longrightarrow> v x \<le> 0) \<and> (coeff p x < 0 \<longrightarrow> v x \<ge> 0)"
  shows "p \<lbrace> v \<rbrace> \<le> 0"
  using assms
  using valuate_opposite_val[of p v]
  using valuate_nonneg[of p "\<lambda> x. - v x"]
  using scaleRat_leq2[of "0::'a" _ "-1"]
  using scaleRat_leq2[of _ "0::'a" "-1"]
  by force

lemma valuate_uminus: "(-p) \<lbrace>v\<rbrace> = - (p \<lbrace>v\<rbrace>)"
  unfolding uminus_linear_poly_def
  by (transfer, auto simp: sum_negf)

lemma valuate_add_lemma:
  fixes v :: "'a \<Rightarrow> 'b::rational_vector"
  assumes "finite {v. f1 v \<noteq> 0}" "finite {v. f2 v \<noteq> 0}"
  shows
    "(\<Sum>x\<in>{v. f1 v + f2 v \<noteq> 0}. (f1 x + f2 x) *R v x) =
   (\<Sum>x\<in>{v. f1 v \<noteq> 0}. f1 x *R v x) +  (\<Sum>x\<in>{v. f2 v \<noteq> 0}. f2 x *R v x)"
proof-
  let ?A = "{v. f1 v + f2 v \<noteq> 0} \<union> {v. f1 v + f2 v = 0 \<and> (f1 v \<noteq> 0 \<or> f2 v \<noteq> 0)}"
  have "?A = {v. f1 v \<noteq> 0 \<or> f2 v \<noteq> 0}"
    by auto
  then have
    "finite ?A"
    using assms
    by (subgoal_tac "{v. f1 v \<noteq> 0 \<or> f2 v \<noteq> 0} = {v. f1 v \<noteq> 0} \<union> {v. f2 v \<noteq> 0}") auto

  then have "(\<Sum>x\<in>{v. f1 v + f2 v \<noteq> 0}. (f1 x + f2 x) *R v x) =
    (\<Sum>x\<in>{v. f1 v + f2 v \<noteq> 0} \<union> {v. f1 v + f2 v = 0 \<and> (f1 v \<noteq> 0 \<or> f2 v \<noteq> 0)}. (f1 x + f2 x) *R v x)"
    by (rule sum.mono_neutral_left) auto
  also have "... = (\<Sum>x \<in> {v. f1 v \<noteq> 0 \<or> f2 v \<noteq> 0}. (f1 x + f2 x) *R v x)"
    by (rule sum.cong) auto
  also have "... = (\<Sum>x \<in> {v. f1 v \<noteq> 0 \<or> f2 v \<noteq> 0}. f1 x *R v x) +
                   (\<Sum>x \<in> {v. f1 v \<noteq> 0 \<or> f2 v \<noteq> 0}. f2 x *R v x)"
    by (simp add: scaleRat_left_distrib sum.distrib)
  also have "... = (\<Sum>x\<in>{v. f1 v \<noteq> 0}. f1 x *R v x) +  (\<Sum>x\<in>{v. f2 v \<noteq> 0}. f2 x *R v x)"
  proof-
    {
      fix f1 f2::"'a \<Rightarrow> rat"
      assume "finite {v. f1 v \<noteq> 0}" "finite {v. f2 v \<noteq> 0}"
      then have "finite {v. f1 v \<noteq> 0 \<or> f2 v \<noteq> 0 \<and> f1 v = 0}"
        by (subgoal_tac "{v. f1 v \<noteq> 0 \<or> f2 v \<noteq> 0} = {v. f1 v \<noteq> 0} \<union> {v. f2 v \<noteq> 0}") auto
      have "(\<Sum>x\<in>{v. f1 v \<noteq> 0 \<or> f2 v \<noteq> 0}. f1 x *R v x) =
        (\<Sum>x\<in>{v. f1 v \<noteq> 0 \<or> (f2 v \<noteq> 0 \<and> f1 v = 0)}. f1 x *R v x)"
        by auto
      also have "... = (\<Sum>x\<in>{v. f1 v \<noteq> 0}. f1 x *R v x)"
        using \<open>finite {v. f1 v \<noteq> 0 \<or> f2 v \<noteq> 0 \<and> f1 v = 0}\<close>
        by (rule sum.mono_neutral_left[THEN sym]) auto
      ultimately have "(\<Sum>x\<in>{v. f1 v \<noteq> 0 \<or> f2 v \<noteq> 0}. f1 x *R v x) =
        (\<Sum>x\<in>{v. f1 v \<noteq> 0}. f1 x *R v x)"
        by simp
    }
    note * = this
    show ?thesis
      using assms
      using *[of f1 f2]
      using *[of f2 f1]
      by (subgoal_tac "{v. f2 v \<noteq> 0 \<or> f1 v \<noteq> 0} = {v. f1 v \<noteq> 0 \<or> f2 v \<noteq> 0}") auto
  qed
  ultimately
  show ?thesis by simp
qed

lemma valuate_add:  "(p1 + p2) \<lbrace>v\<rbrace> = (p1 \<lbrace>v\<rbrace>) + (p2 \<lbrace>v\<rbrace>)"
  by (transfer, simp add: valuate_add_lemma)

lemma valuate_minus: "(p1 - p2) \<lbrace>v\<rbrace> = (p1 \<lbrace>v\<rbrace>) - (p2 \<lbrace>v\<rbrace>)"
  unfolding minus_linear_poly_def valuate_add
  by (simp add: valuate_uminus)

lemma valuate_scaleRat:
  "(c *R lp) \<lbrace> v \<rbrace> = c *R ( lp\<lbrace>v\<rbrace> )"
proof (cases "c=0")
  case True
  then show ?thesis
    by (auto simp add: valuate_def zero_linear_poly_def Abs_linear_poly_inverse)
next
  case False
  then have "\<And> v. Rep_linear_poly (c *R lp) v = c * (Rep_linear_poly lp v)"
    unfolding scaleRat_linear_poly_def
    using Abs_linear_poly_inverse[of "\<lambda>v. c * Rep_linear_poly lp v"]
    using Rep_linear_poly
    by auto
  then show ?thesis
    unfolding valuate_def
    using \<open>c \<noteq> 0\<close>
    by auto (subst rational_vector.scale_sum_right, auto)
qed

lemma valuate_Var: "(Var x) \<lbrace>v\<rbrace> = v x"
  by transfer auto

lemma valuate_sum: "((\<Sum>x\<in>A. f x) \<lbrace> v \<rbrace>) = (\<Sum>x\<in>A. ((f x) \<lbrace> v \<rbrace>))"
  by (induct A rule: infinite_finite_induct, auto simp: valuate_zero valuate_add)

lemma zero_coeff_zero: "p = 0 \<longleftrightarrow> (\<forall> v. coeff p v = 0)"
  by transfer auto

lemma all_val:
  assumes "\<forall> (v::var \<Rightarrow> 'a::lrv). \<exists> v'. (\<forall> x \<in> vars p. v' x = v x) \<and> (p \<lbrace>v'\<rbrace> = 0)"
  shows "p = 0"
proof (subst zero_coeff_zero, rule allI)
  fix x
  show "coeff p x = 0"
  proof (cases "x \<in> vars p")
    case False
    then show ?thesis
      using coeff_zero[of p x]
      by simp
  next
    case True
    have "(0::'a::lrv) \<noteq> (1::'a)"
      using zero_neq_one
      by auto

    let ?v = "\<lambda> x'. if x = x' then 1 else 0::'a"
    obtain v' where "\<forall> x \<in> vars p. v' x = ?v x" "p \<lbrace>v'\<rbrace> = 0"
      using assms
      by (erule_tac x="?v" in allE) auto
    then have "\<forall> x' \<in> vars p. v' x' = (if x = x' then 1 else 0)" "p \<lbrace>v'\<rbrace> = 0"
      by auto

    let ?fp = "Rep_linear_poly p"
    have "{x. ?fp x \<noteq> 0 \<and> v' x \<noteq> (0 :: 'a)} = {x}"
      using \<open>x \<in> vars p\<close> unfolding vars_def
    proof (safe, simp_all)
      fix x'
      assume "v' x' \<noteq> 0" "Rep_linear_poly p x' \<noteq> 0"
      then show "x' = x"
        using \<open>\<forall> x' \<in> vars p. v' x' = (if x = x' then 1 else 0)\<close>
        unfolding vars_def
        by (erule_tac x="x'" in ballE) (simp_all split: if_splits)
    next
      assume "v' x = 0" "Rep_linear_poly p x \<noteq> 0"
      then show False
        using \<open>\<forall> x' \<in> vars p. v' x' = (if x = x' then 1 else 0)\<close>
        using \<open>0 \<noteq> 1\<close>
        unfolding vars_def
        by simp
    qed

    have "p \<lbrace>v'\<rbrace> = (\<Sum>x\<in>{v. ?fp v \<noteq> 0}. ?fp x *R v' x)"
      unfolding valuate_def
      by auto
    also have "... = (\<Sum>x\<in>{v. ?fp v \<noteq> 0 \<and> v' v \<noteq> 0}. ?fp x *R v' x)"
      apply (rule sum.mono_neutral_left[THEN sym])
      using Rep_linear_poly[of p]
      by auto
    also have "... = ?fp x *R v' x"
      using \<open>{x. ?fp x \<noteq> 0 \<and> v' x \<noteq> (0 :: 'a)} = {x}\<close>
      by simp
    also have "... = ?fp x *R 1"
      using \<open>x \<in> vars p\<close>
      using \<open>\<forall> x' \<in> vars p. v' x' = (if x = x' then 1 else 0)\<close>
      by simp
    ultimately
    have "p \<lbrace>v'\<rbrace> = ?fp x *R 1"
      by simp
    then have "coeff p x *R (1::'a)= 0"
      using \<open>p \<lbrace>v'\<rbrace> = 0\<close>
      unfolding coeff_def
      by simp
    then show ?thesis
      using rational_vector.scale_eq_0_iff
      using \<open>0 \<noteq> 1\<close>
      by simp
  qed
qed

lift_definition lp_monom :: "rat \<Rightarrow> var \<Rightarrow> linear_poly" is
  "\<lambda> c x y. if x = y then c else 0" by auto

lemma valuate_lp_monom: "((lp_monom c x) \<lbrace>v\<rbrace>) = c * (v x)"
proof (transfer, simp, goal_cases)
  case (1 c x v)
  have id: "{v. x = v \<and> (x = v \<longrightarrow> c \<noteq> 0)} = (if c = 0 then {} else {x})" by auto
  show ?case unfolding id
    by (cases "c = 0", auto)
qed

lemma valuate_lp_monom_1[simp]: "((lp_monom 1 x) \<lbrace>v\<rbrace>) = v x"
  by transfer simp

lemma coeff_lp_monom [simp]:
  shows "coeff (lp_monom c v) v' = (if v = v' then c else 0)"
  by (transfer, auto)

lemma vars_uminus [simp]: "vars (-p) = vars p"
  unfolding uminus_linear_poly_def
  by transfer auto

lemma vars_plus [simp]: "vars (p1 + p2) \<subseteq> vars p1 \<union> vars p2"
  by transfer auto

lemma vars_minus [simp]: "vars (p1 - p2) \<subseteq> vars p1 \<union> vars p2"
  unfolding minus_linear_poly_def
  using vars_plus[of p1 "-p2"] vars_uminus[of p2]
  by simp

lemma vars_lp_monom: "vars (lp_monom r x) = (if r = 0 then {} else {x})"
  by (transfer, auto)

lemma vars_scaleRat1: "vars (c *R p) \<subseteq> vars p"
  by transfer auto

lemma vars_scaleRat: "c \<noteq> 0 \<Longrightarrow> vars(c *R p) = vars p"
  by transfer auto

lemma vars_Var [simp]: "vars (Var x) = {x}"
  by transfer auto

lemma coeff_Var1 [simp]: "coeff (Var x) x = 1"
  by transfer auto

lemma coeff_Var2: "x \<noteq> y \<Longrightarrow> coeff (Var x) y = 0"
  by transfer auto

lemma valuate_depend:
  assumes "\<forall> x \<in> vars p. v x = v' x"
  shows "(p \<lbrace>v\<rbrace>) = (p \<lbrace>v'\<rbrace>)"
  using assms
  by transfer auto

lemma valuate_update_x_lemma:
  fixes v1 v2 :: "'a::rational_vector valuation"
  assumes
    "\<forall>y. f y \<noteq> 0 \<longrightarrow> y \<noteq> x \<longrightarrow> v1 y = v2 y"
    "finite {v. f v \<noteq> 0}"
  shows
    "(\<Sum>x\<in>{v. f v \<noteq> 0}. f x *R v1 x) + f x *R (v2 x - v1 x) = (\<Sum>x\<in>{v. f v \<noteq> 0}. f x *R v2 x)"
proof (cases "f x = 0")
  case True
  then have "\<forall>y. f y \<noteq> 0 \<longrightarrow> v1 y = v2 y"
    using assms(1) by auto
  then show ?thesis using \<open>f x = 0\<close> by auto
next
  case False
  let ?A = "{v. f v \<noteq> 0}" and ?Ax = "{v. v \<noteq> x \<and> f v \<noteq> 0}"
  have "?A = ?Ax \<union> {x}"
    using \<open>f x \<noteq> 0\<close> by auto
  then have "(\<Sum>x\<in>?A. f x *R v1 x) = f x *R v1 x + (\<Sum>x\<in>?Ax. f x *R v1 x)"
    "(\<Sum>x\<in>?A. f x *R v2 x) = f x *R v2 x + (\<Sum>x\<in>?Ax. f x *R v2 x)"
    using assms(2) by auto
  moreover
  have "\<forall> y \<in> ?Ax. v1 y = v2 y"
    using assms by auto
  moreover
  have "f x *R v1 x + f x *R (v2 x - v1 x) = f x *R v2 x"
    by (subst rational_vector.scale_right_diff_distrib) auto
  ultimately
  show ?thesis by simp
qed

lemma valuate_update_x:
  fixes v1 v2 :: "'a::rational_vector valuation"
  assumes "\<forall>y \<in> vars lp. y\<noteq>x \<longrightarrow> v1 y = v2 y"
  shows "lp \<lbrace>v1\<rbrace>  + coeff lp x *R (v2 x - v1 x) = (lp \<lbrace>v2\<rbrace>)"
  using assms
  unfolding valuate_def vars_def coeff_def
  using valuate_update_x_lemma[of "Rep_linear_poly lp" x v1 v2] Rep_linear_poly
  by auto

lemma vars_zero: "vars 0 = {}"
  using zero_coeff_zero coeff_zero by auto

lemma vars_empty_zero: "vars lp = {} \<longleftrightarrow> lp = 0"
  using zero_coeff_zero coeff_zero by auto

definition max_var:: "linear_poly \<Rightarrow> var" where
  "max_var lp \<equiv> if lp = 0 then 0 else Max (vars lp)"

lemma max_var_max:
  assumes "a \<in> vars lp"
  shows "max_var lp \<ge> a"
  using assms
  by (auto simp add: finite_vars max_var_def vars_zero)

lemma max_var_code[code]:
  "max_var lp = (let vl = vars_list lp
                in if vl = [] then 0 else foldl max (hd vl) (tl vl))"
proof (cases "lp = (0::linear_poly)")
  case True
  then show ?thesis
    using set_vars_list[of lp]
    by (auto simp add: max_var_def vars_zero)
next
  case False
  then show ?thesis
    using set_vars_list[of lp, THEN sym]
    using vars_empty_zero[of lp]
    unfolding max_var_def Let_def
    using Max.set_eq_fold[of "hd (vars_list lp)" "tl (vars_list lp)"]
    by (cases "vars_list lp", auto simp: foldl_conv_fold intro!: fold_cong)
qed

definition monom_var:: "linear_poly \<Rightarrow> var" where
  "monom_var l = max_var l"

definition monom_coeff:: "linear_poly \<Rightarrow> rat" where
  "monom_coeff l = coeff l (monom_var l)"

definition is_monom :: "linear_poly \<Rightarrow> bool" where
  "is_monom l \<longleftrightarrow> length (vars_list l) = 1"

lemma is_monom_vars_not_empty:
  "is_monom l \<Longrightarrow> vars l \<noteq> {}"
  by (auto simp add: is_monom_def vars_list_def) (auto simp add: vars_def)

lemma monom_var_in_vars:
  "is_monom l \<Longrightarrow> monom_var l \<in> vars l"
  using vars_zero
  by (auto simp add: monom_var_def max_var_def is_monom_vars_not_empty finite_vars is_monom_def)

lemma zero_is_no_monom[simp]: "\<not> is_monom 0"
  using is_monom_vars_not_empty vars_zero by blast

lemma is_monom_monom_coeff_not_zero:
  "is_monom l \<Longrightarrow> monom_coeff l \<noteq> 0"
  by (simp add: coeff_zero monom_var_in_vars monom_coeff_def)

lemma list_two_elements:
  "\<lbrakk>y \<in> set l; x \<in> set l; length l = Suc 0; y \<noteq> x\<rbrakk> \<Longrightarrow> False"
  by (induct l) auto

lemma is_monom_vars_monom_var:
  assumes "is_monom l"
  shows "vars l = {monom_var l}"
proof-
  have "\<And>x. \<lbrakk>is_monom l; x \<in> vars l\<rbrakk> \<Longrightarrow> monom_var l = x"
  proof-
    fix x
    assume "is_monom l" "x \<in> vars l"
    then have "x \<in> set (vars_list l)"
      using finite_vars
      by (auto simp add: vars_list_def vars_def)
    show "monom_var l = x"
    proof(rule ccontr)
      assume "monom_var l \<noteq> x"
      then have "\<exists>y. monom_var l = y \<and> y \<noteq> x"
        by simp
      then obtain y where "monom_var l = y" "y \<noteq> x"
        by auto
      then have "Rep_linear_poly l y \<noteq> 0"
        using monom_var_in_vars \<open>is_monom l\<close>
        by (auto simp add: vars_def)
      then have "y \<in> set (vars_list l)"
        using finite_vars
        by (auto simp add: vars_def vars_list_def)
      then show False
        using \<open>x \<in> set (vars_list l)\<close> \<open>is_monom l\<close> \<open>y \<noteq> x\<close>
        using list_two_elements
        by (simp add: is_monom_def)
    qed
  qed
  then show "vars l = {monom_var l}"
    using assms
    by (auto simp add: monom_var_in_vars)
qed

lemma monom_valuate:
  assumes "is_monom m"
  shows "m\<lbrace>v\<rbrace> = (monom_coeff m) *R v (monom_var m)"
  using assms
  using is_monom_vars_monom_var
  by (simp add: vars_def coeff_def monom_coeff_def valuate_def)

lemma coeff_zero_simp [simp]:
  "coeff 0 v = 0"
  using zero_coeff_zero by blast

lemma poly_eq_iff: "p = q \<longleftrightarrow> (\<forall> v. coeff p v = coeff q v)"
  by transfer auto

lemma poly_eqI:
  assumes "\<And>v. coeff p v = coeff q v"
  shows "p = q"
  using assms poly_eq_iff by simp

lemma coeff_sum_list:
  assumes "distinct xs"
  shows "coeff (\<Sum>x\<leftarrow>xs. f x *R lp_monom 1 x) v = (if v \<in> set xs then f v else 0)"
  using assms by (induction xs) auto

lemma linear_poly_sum:
  "p \<lbrace> v \<rbrace> = (\<Sum>x\<in>vars p. coeff p x *R v x)"
  by transfer simp

lemma all_valuate_zero: assumes "\<And>(v::'a::lrv valuation). p \<lbrace>v\<rbrace> = 0"
  shows "p = 0"
  using all_val assms by blast

lemma linear_poly_eqI: assumes "\<And>(v::'a::lrv valuation). (p \<lbrace>v\<rbrace>) = (q \<lbrace>v\<rbrace>)"
  shows "p = q"
  using assms
proof -
  have "(p - q) \<lbrace> v \<rbrace> = 0" for v::"'a::lrv valuation"
    using assms by (subst valuate_minus) auto
  then have "p - q = 0"
    by (intro all_valuate_zero) auto
  then show ?thesis
    by simp
qed

lemma monom_poly_assemble:
  assumes "is_monom p"
  shows "monom_coeff p *R lp_monom 1 (monom_var p) = p"
  by (simp add: assms linear_poly_eqI monom_valuate valuate_scaleRat)

lemma coeff_sum: "coeff (sum (f :: _ \<Rightarrow> linear_poly) is) x = sum (\<lambda> i. coeff (f i) x) is"
  by (induct "is" rule: infinite_finite_induct, auto)

end