(* File: boolexp.thy *)

theory boolexp
imports Main
begin

section{* Basic Type and Evaluation Function
         for Boolean Expressions *}

text{*
 The following type mirrors the BNF grammar
we gave in for boolean expressions.  We will use
only prefixed connectives here
*}

datatype 'a boolexp =
   TRUE | FALSE |Var 'a | Not "'a boolexp"
  | And "'a boolexp" "'a boolexp"
  | Or "'a boolexp" "'a boolexp"
  | Implies "'a boolexp" "'a boolexp"

value "TRUE"

text{*
The following is a recursive definition of the function for evaluating
boolean expressions. It is the same as the definition
of \textit{models} given in class.
*}

fun boolexp_eval
where
   "boolexp_eval env TRUE = True"
 | "boolexp_eval env FALSE = False"
 | "boolexp_eval env (Var x) = env x"
 | "boolexp_eval env (Not b) = (\<not> (boolexp_eval env b))"
 | "boolexp_eval env (And a b) =
    ((boolexp_eval env a) \<and> (boolexp_eval env b))"
 | "boolexp_eval env (Or a b) =
    ((boolexp_eval env a) \<or> (boolexp_eval env b))"
 | "boolexp_eval env (Implies a b) =
    ((\<not> (boolexp_eval env a))\<or> (boolexp_eval env b))"

text{*
Because all our definition have been purely
computational, we may use \tettt{value} to evaluate
expressions using the type \texttt{boolexp} and the term
boolexp_eval.
*}

(*
value "boolexp_eval
(\<lambda> x. case x of ''a'' \<Rightarrow> True | _ \<Rightarrow> False)
 (Implies (Var ''b'') (Var ''a''))"
*)

value "boolexp_eval
(\<lambda> x. case x of (0::nat) \<Rightarrow> True | _ \<Rightarrow> False)
 (Implies (Var (1::nat)) (Var (0::nat)))"

text{*
Our objective is to build a function that will tell
us all the ways a boolean expression can be satisfied.
Our approach is to put the boolean expression in
disjunctive normal form.
We start by eliminating implies.
*}

fun remove_implies where
   "remove_implies TRUE = TRUE"
 | "remove_implies FALSE = FALSE"
 | "remove_implies (Var x) = Var x"
 | "remove_implies (Not a) = Not (remove_implies a)"
 | "remove_implies (And a b) =
    And (remove_implies a) (remove_implies b)"
 | "remove_implies (Or a b) =
    Or (remove_implies a) (remove_implies b)"
 | "remove_implies (Implies a b) =
    (Or (Not (remove_implies a)) (remove_implies b))"

thm boolexp.induct

lemma remove_implies_same_eval [simp]:
"boolexp_eval env (remove_implies a) =
 boolexp_eval env a"
apply (induct "a")
by simp_all
(*
by (induct "a", auto)
*)

fun number_of_implies where
   "number_of_implies TRUE = (0::nat)"
 | "number_of_implies FALSE = 0"
 | "number_of_implies (Var x) = 0"
 | "number_of_implies (Not a) = number_of_implies a"
 | "number_of_implies (And a b) =
   (number_of_implies a) + (number_of_implies b)"
 | "number_of_implies (Or a b) =
   (number_of_implies a) + (number_of_implies b)"
 | "number_of_implies (Implies a b) =
   (number_of_implies a) + (number_of_implies b) + 1"

lemma number_of_implies_remove_implies_0 [simp]:
"number_of_implies (remove_implies a) = 0"
by (induct "a", auto)

fun push_not where
   "push_not TRUE = TRUE"
 | "push_not FALSE = FALSE"
 | "push_not (Var x) = Var x"
 | "push_not (Not TRUE) = FALSE"
 | "push_not (Not FALSE) = TRUE"
 | "push_not (Not (Var x)) = Not (Var x)"
 | "push_not (Not (Not a)) = push_not a"
 | "push_not (Not (And a b)) =
    (Or (push_not (Not a)) (push_not (Not b)))"
 | "push_not (Not (Or a b)) =
    (And (push_not (Not a)) (push_not (Not b)))"
 | "push_not (Not (Implies a b)) =
   (And (push_not a) (push_not (Not b)))"
 | "push_not (And a b) =
   (And (push_not a) (push_not b))"
 | "push_not (Or a b) =
   (Or (push_not a) (push_not b))"
 | "push_not (Implies a b) =
    (Implies (push_not a) (push_not b))"

lemma push_not_same_eval [simp]:
 "(boolexp_eval env (push_not (Not a))
   = (\<not> (boolexp_eval env (push_not a)))) \<and>
  (boolexp_eval env (push_not a) = boolexp_eval env a)"
by (induct "a", auto)

lemma push_not_preserves_no_implies_helper:
"number_of_implies a = 0 \<Longrightarrow>
 (number_of_implies (push_not a) = 0) \<and>
 (number_of_implies (push_not (Not a)) = 0)"
by (induct "a", auto)

lemma push_not_preserves_no_implies:
"number_of_implies a = 0 \<Longrightarrow>
 (number_of_implies (push_not a) = 0)"
by (auto simp add: push_not_preserves_no_implies_helper)

lemma push_not_remove_implies_no_implies [simp]:
"number_of_implies (push_not (remove_implies a)) = 0"
apply (rule push_not_preserves_no_implies)
apply (rule number_of_implies_remove_implies_0)
done

export_code boolexp_eval push_not remove_implies
in OCaml
 module_name Boolexp file "boolexp.ml"

datatype 'a boolexp_no_imp =
      TRUE_ni | FALSE_ni |Var_ni 'a
    | Not_ni "'a boolexp_no_imp"
    | And_ni "'a boolexp_no_imp" "'a boolexp_no_imp"
    | Or_ni "'a boolexp_no_imp" "'a boolexp_no_imp"

fun boolexp_no_imp_eval where
   "boolexp_no_imp_eval env TRUE_ni = True"
 | "boolexp_no_imp_eval env FALSE_ni = False"
 | "boolexp_no_imp_eval env (Var_ni x) = env x"
 | "boolexp_no_imp_eval env (Not_ni a) =
    (\<not> (boolexp_no_imp_eval env a))"
 | "boolexp_no_imp_eval env (And_ni a b) =
    ((boolexp_no_imp_eval env a) \<and>
     (boolexp_no_imp_eval env b))"
 | "boolexp_no_imp_eval env (Or_ni a b) =
    ((boolexp_no_imp_eval env a) \<or>
     (boolexp_no_imp_eval env b))"

fun remove_implies_ni where
   "remove_implies_ni TRUE = TRUE_ni"
 | "remove_implies_ni FALSE = FALSE_ni"
 | "remove_implies_ni (Var x) = Var_ni x"
 | "remove_implies_ni (Not a) =
    Not_ni (remove_implies_ni a)"
 | "remove_implies_ni (And a b) =
    And_ni (remove_implies_ni a) (remove_implies_ni b)"
 | "remove_implies_ni (Or a b) =
    Or_ni (remove_implies_ni a) (remove_implies_ni b)"
 | "remove_implies_ni (Implies a b) =
    (Or_ni (Not_ni (remove_implies_ni a))
           (remove_implies_ni b))"

lemma remove_implies_ni_same_eval:
  "boolexp_no_imp_eval env (remove_implies_ni a) =
   boolexp_eval env (remove_implies a)"
by (induct_tac a, auto)

datatype 'a boolexp_nipn =
    TRUE_nipn | FALSE_nipn |Var_nipn 'a
    | Not_Var_nipn 'a
    | And_nipn "'a boolexp_nipn" "'a boolexp_nipn"
    | Or_nipn "'a boolexp_nipn" "'a boolexp_nipn"

fun push_not_pn where
   "push_not_pn TRUE_ni = TRUE_nipn"
 | "push_not_pn FALSE_ni = FALSE_nipn"
 | "push_not_pn (Var_ni x) = Var_nipn x"
 | "push_not_pn (Not_ni TRUE_ni) = FALSE_nipn"
 | "push_not_pn (Not_ni FALSE_ni) = TRUE_nipn"
 | "push_not_pn (Not_ni (Var_ni x)) = Not_Var_nipn x"
 | "push_not_pn (Not_ni (Not_ni a)) = push_not_pn a"
 | "push_not_pn (Not_ni (And_ni a b)) =
    (Or_nipn (push_not_pn (Not_ni a))
             (push_not_pn (Not_ni b)))"
 | "push_not_pn (Not_ni (Or_ni a b)) =
    (And_nipn (push_not_pn (Not_ni a))
              (push_not_pn (Not_ni b)))"
 | "push_not_pn (And_ni a b) =
   (And_nipn (push_not_pn a) (push_not_pn b))"
 | "push_not_pn (Or_ni a b) =
   (Or_nipn (push_not_pn a) (push_not_pn b))"

fun boolexp_nipn_eval where
   "boolexp_nipn_eval env TRUE_nipn = True"
 | "boolexp_nipn_eval env FALSE_nipn = False"
 | "boolexp_nipn_eval env (Var_nipn x) = env x"
 | "boolexp_nipn_eval env (Not_Var_nipn a) =
    (\<not> (env a))"
 | "boolexp_nipn_eval env (And_nipn a b) =
    ((boolexp_nipn_eval env a) \<and>
     (boolexp_nipn_eval env b))"
 | "boolexp_nipn_eval env (Or_nipn a b) =
    ((boolexp_nipn_eval env a) \<or>
     (boolexp_nipn_eval env b))"

lemma push_not_pn_same_eval [simp]:
"(boolexp_nipn_eval env (push_not_pn (Not_ni b)) =
  (\<not> (boolexp_no_imp_eval env b))) \<and>
 (boolexp_nipn_eval env (push_not_pn b) =
  boolexp_no_imp_eval env b)"
by (induct_tac b, auto)

fun node_count where
   "node_count TRUE = (1::nat)"
 | "node_count FALSE = 1"
 | "node_count (Var x) = 1"
 | "node_count (Not x) = 1 + node_count x"
 | "node_count (And a b) =
    1 + (node_count a) + (node_count b)"
 | "node_count (Or a b) =
    1 + (node_count a) + (node_count b)"
 | "node_count (Implies a b) =
    1 + (node_count a) + (node_count b)"

lemma node_count_non_zero [simp]:
"0 < node_count b"
by (induct_tac b, auto)

function push_not_elim_imp where
   "push_not_elim_imp TRUE = TRUE_nipn"
 | "push_not_elim_imp FALSE = FALSE_nipn"
 | "push_not_elim_imp (Var x) = Var_nipn x"
 | "push_not_elim_imp (Not TRUE) = FALSE_nipn"
 | "push_not_elim_imp (Not FALSE) = TRUE_nipn"
 | "push_not_elim_imp (Not (Var x)) = Not_Var_nipn x"
 | "push_not_elim_imp (Not (Not b)) =
    push_not_elim_imp b"
 | "push_not_elim_imp (Not (And a b)) =
    (Or_nipn (push_not_elim_imp (Not a))
             (push_not_elim_imp (Not b)))"
 | "push_not_elim_imp (Not (Or a b)) =
    (And_nipn (push_not_elim_imp (Not a))
              (push_not_elim_imp (Not b)))"
 | "push_not_elim_imp (Not (Implies a b)) =
   (And_nipn (push_not_elim_imp a)
             (push_not_elim_imp (Not b)))"
 | "push_not_elim_imp (And a b) =
   (And_nipn (push_not_elim_imp a)
             (push_not_elim_imp b))"
 | "push_not_elim_imp (Or a b) =
   (Or_nipn (push_not_elim_imp a)
            (push_not_elim_imp b))"
 | "push_not_elim_imp (Implies a b) =
    (Or_nipn (push_not_elim_imp (Not a))
             (push_not_elim_imp b))"
by (pat_completeness, auto)
term "op <*mlex*>"
termination
by (relation "measures [node_count]", auto)

lemma push_not_elim_imp_push_not_pn_remove_implies_ni [simp]:
"(push_not_elim_imp (boolexp.Not a) =
  push_not_pn (Not_ni (remove_implies_ni a))) \<and>
 (push_not_elim_imp a =
  push_not_pn (remove_implies_ni a))"
by (induct_tac a, auto)

lemma push_not_elim_imp_same_eval [simp]:
"(boolexp_nipn_eval env (push_not_elim_imp (Not a)) =
  (\<not>(boolexp_eval env a))) \<and>
 (boolexp_nipn_eval env (push_not_elim_imp a) =
  boolexp_eval env a)"
by (induct_tac a, auto)

datatype 'a bool_atom =
   TRUE_at | FALSE_at |Var_at 'a | Not_Var_at 'a

fun bool_atom_eval where
   "bool_atom_eval env TRUE_at = True"
 | "bool_atom_eval env FALSE_at = False"
 | "bool_atom_eval env (Var_at x) = env x"
 | "bool_atom_eval env (Not_Var_at x) = (\<not>(env x))"

datatype 'a bool_conj =
   Atom "'a bool_atom"
 | And_conj "'a bool_atom" "'a bool_conj"

fun bool_conj_eval where
   "bool_conj_eval env (Atom a) = bool_atom_eval env a"
 | "bool_conj_eval env (And_conj a b) =
    ((bool_atom_eval env a) \<and>
     (bool_conj_eval env b))"

fun conj_and where
   "conj_and (Atom a) b = And_conj a b"
 | "conj_and (And_conj a b) c =
    And_conj a (conj_and b c)"

lemma conj_and_eval [simp]:
"bool_conj_eval env (conj_and a b) =
 ((bool_conj_eval env a) \<and> (bool_conj_eval env b))"
by (induct_tac a, auto)

datatype 'a bool_dnf =
   Conj "'a bool_conj"
 | Or_dnf "'a bool_conj" "'a bool_dnf"

fun bool_dnf_eval where
   "bool_dnf_eval env (Conj c) = bool_conj_eval env c"
 | "bool_dnf_eval env (Or_dnf a b) =
    ((bool_conj_eval env a) \<or> (bool_dnf_eval env b))"

fun dnf_or where
   "dnf_or (Conj a) b = Or_dnf a b"
 | "dnf_or (Or_dnf a b) c = Or_dnf a (dnf_or b c)"

lemma dnf_or_eval [simp]:
"bool_dnf_eval env (dnf_or a b) =
  ((bool_dnf_eval env a) \<or> (bool_dnf_eval env b))"
by (induct_tac "a", auto)

fun conj_or where
   "conj_or a (Conj b) = Conj (conj_and a b)"
 | "conj_or a (Or_dnf b c) =
    Or_dnf(conj_and a b) (conj_or a c)"

lemma conj_or_eval [simp]:
"bool_dnf_eval env (conj_or a b) =
  ((bool_conj_eval env a) \<and> (bool_dnf_eval env b))"
by (induct_tac "b", auto)

fun dist_and_or where
   "dist_and_or (Conj a) b = conj_or a b"
 | "dist_and_or (Or_dnf a b) c =
    dnf_or (conj_or a c) (dist_and_or b c)"

lemma dist_and_or_and_eval [simp]:
"bool_dnf_eval env (dist_and_or a b) =
 ((bool_dnf_eval env a) \<and> (bool_dnf_eval env b))"
by (induct_tac a, auto)

fun basic_dnf where
   "basic_dnf TRUE_nipn = Conj(Atom TRUE_at)"
 | "basic_dnf FALSE_nipn = Conj(Atom FALSE_at)"
 | "basic_dnf (Var_nipn x) = Conj(Atom (Var_at x))"
 | "basic_dnf (Not_Var_nipn x) =
    Conj(Atom (Not_Var_at x))"
 | "basic_dnf (And_nipn a b) =
    dist_and_or (basic_dnf a) (basic_dnf b)"
 | "basic_dnf (Or_nipn a b) =
    dnf_or (basic_dnf a) (basic_dnf b)"

lemma basic_dnv_eval [simp]:
"bool_dnf_eval env (basic_dnf a) =
 boolexp_nipn_eval env a"
by (induct_tac a, auto)

definition dnf where
"dnf a = basic_dnf (push_not_elim_imp a)"

lemma dnf_eval [simp]:
"boolexp_eval env a = bool_dnf_eval env (dnf a)"
by (auto simp only: dnf_def push_not_elim_imp_same_eval basic_dnv_eval)

fun sat_bool_atom where
   "sat_bool_atom TRUE_at = Some (None)"
 | "sat_bool_atom FALSE_at = None"
 | "sat_bool_atom (Var_at x) = Some(Some(x,True))"
 | "sat_bool_atom (Not_Var_at x) = Some(Some(x,False))"

lemma sat_bool_atom_no_sat [simp]:
"sat_bool_atom a = None \<Longrightarrow> \<not>(bool_atom_eval env a)"
by (case_tac "a", simp_all)

lemma sat_bool_atom_sound [simp]:
"\<lbrakk> sat_bool_atom a = Some l;
   (l = None) \<or> l = Some (y, env y) \<rbrakk> \<Longrightarrow>
 bool_atom_eval env a"
by (induct a, auto)

lemma sat_bool_atom_complete [simp]:
"bool_atom_eval env a \<Longrightarrow>
\<exists> l y. ((sat_bool_atom a = Some l) \<and>
     ((l = None) \<or> l = Some(y, env y)))"
apply (case_tac "sat_bool_atom a", auto)
by (induct a, auto)

fun member where
   "member x [] = False"
 | "member x (y#ys) = ((x = y) \<or> (member x ys))"

fun sat_conj where
   "sat_conj (Atom a) =
    (case sat_bool_atom a of None \<Rightarrow> None
        | Some None \<Rightarrow> Some []
        | Some (Some (y,t)) \<Rightarrow> Some[(y,t)])"
 | "sat_conj (And_conj a b) =
    (case sat_bool_atom a of None \<Rightarrow> None
        | Some None \<Rightarrow> sat_conj b
        | Some (Some (y,t)) \<Rightarrow>
         (case sat_conj b of None \<Rightarrow> None
             | Some l \<Rightarrow>
               (if member (y,\<not>t) l then None
                else if member (y,t) l then Some l
                else Some ((y,t)#l))))"

fun sat_to_env where
   "sat_to_env [] = {env. True}"
 | "sat_to_env ((y,b)#l) = {env. env y = b} \<inter> (sat_to_env l)"

(*
lemma sat_conj_sound:
"\<lbrakk> sat_conj a = Some l; env \<in> sat_to_env l \<rbrakk> \<Longrightarrow> bool_conj_eval env a"
apply (induct "a", simp_all)
apply (case_tac "bool_atom", simp_all)
apply auto
*)

fun sat_dnf where
    "sat_dnf (Conj a) =
     (case sat_conj a of None \<Rightarrow> []
         | Some l \<Rightarrow> [l])"
 | "sat_dnf (Or_dnf a b) =
    (case sat_conj a of None \<Rightarrow> sat_dnf b
        | Some l => l# (sat_dnf b))"

definition sat where
"sat a \<equiv> sat_dnf (dnf a)"

export_code sat
in OCaml
 module_name Sat file "sat.ml"

end


theory Insertion_Sort
imports Sorting
begin

context begin

qualified primrec insert :: "'a::linorder \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"insert x [] = [x]" |
"insert x (y # ys) = (if x \<le> y then x # y # ys else y # insert x ys)"

qualified lemma insert_sorted: "sorted xs \<Longrightarrow> sorted (insert x xs)"
proof (induction xs rule: sorted.induct)
  case empty
  show ?case
    by (auto intro: single)
next
  case (single y)
  show ?case
    by (cases "x \<le> y") (auto intro: sorted.intros) (* if_splits *)
next
  case (cons x\<^sub>1 x\<^sub>2 xs)
  show ?case
    proof (cases "x \<le> x\<^sub>1")
      case True
      hence "insert x (x\<^sub>1 # x\<^sub>2 # xs) = x # x\<^sub>1 # x\<^sub>2 # xs"
        by simp
      moreover have "sorted (x # x\<^sub>1 # x\<^sub>2 # xs)"
        apply (rule sorted.intros)
        apply fact
        apply (rule sorted.intros)
        apply fact+
        done
      ultimately show ?thesis
        by simp
    next
      case False
      hence "insert x (x\<^sub>1 # x\<^sub>2 # xs) = x\<^sub>1 # insert x (x\<^sub>2 # xs)"
        by simp
      moreover have "sorted (x\<^sub>1 # insert x (x\<^sub>2 # xs))"
        apply (cases "x \<le> x\<^sub>2")
        using cons apply (auto intro: sorted.intros)
        apply (rule sorted.cons)
        using False apply simp
        apply assumption
        done
      ultimately show ?thesis
        by simp
    qed
qed

qualified lemma insert_permutation: "mset (insert x xs) = {#x#} + mset xs"
proof (induction xs)
  case Nil
  show ?case
    by simp
next
  case (Cons y ys)
  show ?case
    proof (cases "x \<le> y")
      case True
      thus ?thesis
        by (simp add: union_commute)
    next
      case False
      thus ?thesis
        apply simp
        apply (subst Cons)
        by (simp add: union_assoc)
    qed
qed

primrec insort :: "'a::linorder list \<Rightarrow> 'a list" where
"insort [] = []" |
"insort (x # xs) = insert x (insort xs)"

end

global_interpretation insertion_sort: sorting insort
proof
  fix xs :: "'a::linorder list"
  show "sorted (insort xs)"
    proof (induction xs)
      case Nil
      show ?case
        apply simp
        apply (rule sorted.empty)
        done
    next
      case (Cons y ys)
      show ?case
        apply simp
        apply (rule Insertion_Sort.insert_sorted)
        apply (rule Cons)
        done
  qed

  show "mset (insort xs) = mset xs"
    by (induction xs) (auto simp: Insertion_Sort.insert_permutation union_commute)
qed

export_code insort
  checking Scala

end


(*
  File: Semiring.thy
  Author: Bohua Zhan

  Semirings.
*)

theory Semiring
  imports Group AbGroup OrderRel
begin

(* We define semirings to be commutative (it is only used for Nat). *)

section \<open>Semirings\<close>

definition is_zero_mult :: "i \<Rightarrow> o" where [rewrite]:
  "is_zero_mult(R) \<longleftrightarrow> (\<forall>x\<in>.R. \<zero>\<^sub>R *\<^sub>R x = \<zero>\<^sub>R \<and> x *\<^sub>R \<zero>\<^sub>R = \<zero>\<^sub>R)"

lemma is_zero_multD [rewrite]:
  "is_zero_mult(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> \<zero>\<^sub>R *\<^sub>R x = \<zero>\<^sub>R"
  "is_zero_mult(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> x *\<^sub>R \<zero>\<^sub>R = \<zero>\<^sub>R" by auto2+
setup {* del_prfstep_thm_eqforward @{thm is_zero_mult_def} *}

definition is_semiring :: "i \<Rightarrow> o" where [rewrite]:
  "is_semiring(R) \<longleftrightarrow> (is_ring_raw(R) \<and> is_ab_monoid(R) \<and> is_monoid(R) \<and>
    is_times_comm(R) \<and> is_left_distrib(R) \<and> is_zero_mult(R) \<and> \<zero>\<^sub>R \<noteq> \<one>\<^sub>R)"

lemma is_semiringD [forward]:
  "is_semiring(R) \<Longrightarrow> is_ring_raw(R)"
  "is_semiring(R) \<Longrightarrow> is_ab_monoid(R)"
  "is_semiring(R) \<Longrightarrow> is_monoid(R)"
  "is_semiring(R) \<Longrightarrow> is_times_comm(R)"
  "is_semiring(R) \<Longrightarrow> is_left_distrib(R)"
  "is_semiring(R) \<Longrightarrow> is_zero_mult(R)" by auto2+

lemma is_semiringD' [resolve]: "is_semiring(R) \<Longrightarrow> \<zero>\<^sub>R \<noteq> \<one>\<^sub>R" by auto2
setup {* del_prfstep_thm_eqforward @{thm is_semiring_def} *}

ML_file "alg_semiring.ML"

section \<open>Ordered semirings\<close>

definition is_ord_semiring :: "i \<Rightarrow> o" where [rewrite]:
  "is_ord_semiring(R) \<longleftrightarrow> (is_ord_ring_raw(R) \<and> is_semiring(R) \<and> linorder(R) \<and>
                           ord_ring_add_left(R) \<and> ord_semiring_mult_left(R))"

lemma is_ord_semiringD [forward]:
  "is_ord_semiring(R) \<Longrightarrow> is_ord_ring_raw(R)"
  "is_ord_semiring(R) \<Longrightarrow> is_semiring(R)"
  "is_ord_semiring(R) \<Longrightarrow> linorder(R)"
  "is_ord_semiring(R) \<Longrightarrow> ord_ring_add_left(R)"
  "is_ord_semiring(R) \<Longrightarrow> ord_semiring_mult_left(R)" by auto2+
setup {* del_prfstep_thm_eqforward @{thm is_ord_semiring_def} *}

lemma ord_semiring_mult_right [backward]:
  "is_ord_semiring(R) \<Longrightarrow> c \<in>. R \<Longrightarrow> a \<le>\<^sub>R b \<Longrightarrow> a *\<^sub>R c \<le>\<^sub>R b *\<^sub>R c"
@proof @have "c *\<^sub>R a \<le>\<^sub>R c *\<^sub>R b" @qed

lemma ord_semiring_add_right [backward]:
  "is_ord_semiring(R) \<Longrightarrow> c \<in>. R \<Longrightarrow> a \<le>\<^sub>R b \<Longrightarrow> a +\<^sub>R c \<le>\<^sub>R b +\<^sub>R c"
@proof @have "c +\<^sub>R a \<le>\<^sub>R c +\<^sub>R b" @qed

lemma ord_semiring_add_mix [backward1, backward2]:
  "is_ord_semiring(R) \<Longrightarrow> p \<le>\<^sub>R q \<Longrightarrow> r \<le>\<^sub>R s \<Longrightarrow> p +\<^sub>R r \<le>\<^sub>R q +\<^sub>R s"
@proof @have "p +\<^sub>R r \<le>\<^sub>R p +\<^sub>R s" @qed

end


header "Sequents"

theory Sequents
imports Formula
begin

type_synonym sequent = "formula list"

definition
  evalS :: "[model,vbl => object,formula list] => bool" where
  "evalS M phi fs \<longleftrightarrow> (? f : set fs . evalF M phi f = True)"

lemma evalS_nil[simp]: "evalS M phi [] = False"
  by(simp add: evalS_def)

lemma evalS_cons[simp]: "evalS M phi (A # Gamma) = (evalF M phi A | evalS M phi Gamma)"
  by(simp add: evalS_def)

lemma evalS_append: "evalS M phi (Gamma @ Delta) = (evalS M phi Gamma | evalS M phi Delta)"
  by(force simp add: evalS_def)

lemma evalS_equiv[rule_format]: "(equalOn (freeVarsFL Gamma) f g) --> (evalS M f Gamma = evalS M g Gamma)"
  apply (induct Gamma, simp, rule)
  apply(simp add: freeVarsFL_cons)
  apply(drule_tac equalOn_UnD)
  apply(blast dest: evalF_equiv)
  done

definition
  modelAssigns :: "[model] => (vbl => object) set" where
  "modelAssigns M = { phi . range phi <= objects M }"

lemma modelAssignsI: "range f <= objects M \<Longrightarrow> f : modelAssigns M"
  by(simp add: modelAssigns_def)

lemma modelAssignsD: "f : modelAssigns M \<Longrightarrow> range f <= objects M"
  by(simp add: modelAssigns_def)

definition
  validS :: "formula list => bool" where
  "validS fs \<longleftrightarrow> (! M . ! phi : modelAssigns M . evalS M phi fs = True)"

subsection "Rules"

type_synonym rule = "sequent * (sequent set)"

definition
  concR :: "rule => sequent" where
  "concR = (%(conc,prems). conc)"

definition
  premsR :: "rule => sequent set" where
  "premsR = (%(conc,prems). prems)"

definition
  mapRule :: "(formula => formula) => rule => rule" where
  "mapRule = (%f (conc,prems) . (map f conc,(map f) ` prems))"

lemma mapRuleI: "[| A = map f a; B = (map f) ` b |] ==> (A,B) = mapRule f (a,b)"
  by(simp add: mapRule_def)
    -- "FIXME tjr would like symmetric"

subsection "Deductions"

(*FIXME. I don't see why plain Pow_mono is rejected.*)
lemmas Powp_mono [mono] = Pow_mono [to_pred pred_subset_eq]

inductive_set
  deductions  :: "rule set => formula list set"
  for rules :: "rule set"
  (******
   * Given a set of rules,
   *   1. Given a rule conc/prem(i) in rules,
   *       and the prem(i) are deductions from rules,
   *       then conc is a deduction from rules.
   *   2. can derive permutation of any deducible formula list.
   *      (supposed to be multisets not lists).
   ******)
  where
    inferI: "[| (conc,prems) : rules;
               prems : Pow(deductions(rules))
            |] ==> conc : deductions(rules)"
(*
    perms   "[| permutation conc' conc;
                conc' : deductions(rules)
             |] ==> conc : deductions(rules)"
*)

lemma mono_deductions: "[| A <= B |] ==> deductions(A) <= deductions(B)"
  apply(best intro: deductions.inferI elim: deductions.induct) done

(*lemmas deductionsMono = mono_deductions*)

(*
-- "tjr following should be subsetD?"
lemmas deductionSubsetI = mono_deductions[THEN subsetD]
thm deductionSubsetI
*)

(******
 * (f : formula -> formula) extended structurally over rules, deductions etc...
 * (((If f maps rules into themselves then can consider mapping derivation trees.)))
 * (((Is the asm necessary - think not?)))
 * The mapped deductions from the rules are same as
 * the deductions from the mapped rules.
 *
 * WHY:
 *
 * map f `` deductions rules <= deductions (mapRule f `` rules)     (this thm)
 *                           <= deductions rules                    (closed)
 *
 * If rules are closed under f then so are deductions.
 * Can take f = (subst u v) and have application to exercise #1.
 *
 * Q: maybe also make f dual mapping, (what about quantifier side conditions...?).
 ******)

(*
lemma map_deductions: "map f ` deductions rules <= deductions (mapRule f ` rules)"
  apply(rule subsetI)
  apply (erule_tac imageE, simp)
  apply(erule deductions.induct)
  apply(blast intro: deductions.inferI mapRuleI)
  done

lemma deductionsCloseRules: "! (conc,prems) : S . prems <= deductions R --> conc : deductions R ==> deductions (R Un S) = deductions R"
  apply(rule equalityI)
  prefer 2
  apply(rule mono_deductions) apply blast
  apply(rule subsetI)
  apply (erule_tac deductions.induct, simp) apply(erule conjE) apply(thin_tac "prems \<subseteq> deductions (R \<union> S)")
  apply(erule disjE)
  apply(rule inferI) apply assumption apply force
  apply blast
  done
*)

subsection "Basic Rule sets"

definition
  "Axioms  = { z. ? p vs.              z = ([FAtom Pos p vs,FAtom Neg p vs],{}) }"
definition
  "Conjs   = { z. ? A0 A1 Delta Gamma. z = (FConj Pos A0 A1#Gamma @ Delta,{A0#Gamma,A1#Delta}) }"
definition
  "Disjs   = { z. ? A0 A1       Gamma. z = (FConj Neg A0 A1#Gamma,{A0#A1#Gamma}) }"
definition
  "Alls    = { z. ? A x         Gamma. z = (FAll Pos A#Gamma,{instanceF x A#Gamma}) & x ~: freeVarsFL (FAll Pos A#Gamma) }"
definition
  "Exs     = { z. ? A x         Gamma. z = (FAll Neg A#Gamma,{instanceF x A#Gamma})}"
definition
  "Weaks   = { z. ? A           Gamma. z = (A#Gamma,{Gamma})}"
definition
  "Contrs  = { z. ? A           Gamma. z = (A#Gamma,{A#A#Gamma})}"
definition
  "Cuts    = { z. ? C Delta     Gamma. z = (Gamma @ Delta,{C#Gamma,FNot C#Delta})}"
definition
  "Perms   = { z. ? Gamma Gamma'     . z = (Gamma,{Gamma'}) & Gamma <~~> Gamma'}"
definition
  "DAxioms = { z. ? p vs.              z = ([FAtom Neg p vs,FAtom Pos p vs],{}) }"

lemma AxiomI: "[| Axioms <= A |] ==> [FAtom Pos p vs,FAtom Neg p vs] : deductions(A)"
  apply(rule deductions.inferI)
  apply(auto simp add: Axioms_def) done

lemma DAxiomsI: "[| DAxioms <= A |] ==> [FAtom Neg p vs,FAtom Pos p vs] : deductions(A)"
  apply(rule deductions.inferI)
  apply(auto simp add: DAxioms_def) done

lemma DisjI: "[| A0#A1#Gamma : deductions(A); Disjs <= A |] ==> (FConj Neg A0 A1#Gamma) : deductions(A)"
  apply(rule deductions.inferI)
  apply(auto simp add: Disjs_def) done

lemma ConjI: "[| (A0#Gamma) : deductions(A); (A1#Delta) : deductions(A); Conjs <= A |] ==> FConj Pos A0 A1#Gamma @ Delta : deductions(A)"
  apply(rule_tac prems="{A0#Gamma,A1#Delta}" in deductions.inferI)
  apply(auto simp add: Conjs_def) apply force done

lemma AllI: "[| instanceF w A#Gamma : deductions(R); w ~: freeVarsFL (FAll Pos A#Gamma); Alls <= R |] ==> (FAll Pos A#Gamma) : deductions(R)"
  apply(rule_tac prems="{instanceF w A#Gamma}" in deductions.inferI)
  apply(auto simp add: Alls_def) done

lemma ExI: "[| instanceF w A#Gamma : deductions(R); Exs <= R |] ==> (FAll Neg A#Gamma) : deductions(R)"
  apply(rule_tac prems = "{instanceF w A#Gamma}" in deductions.inferI)
  apply(auto simp add: Exs_def) done

lemma WeakI: "[| Gamma : deductions R; Weaks <= R |] ==> A#Gamma : deductions(R)"
  apply(rule_tac prems="{Gamma}" in deductions.inferI)
  apply(auto simp add: Weaks_def) done

lemma ContrI: "[| A#A#Gamma : deductions R; Contrs <= R |] ==> A#Gamma : deductions(R)"
  apply(rule_tac prems="{A#A#Gamma}" in deductions.inferI)
  apply(auto simp add: Contrs_def) done

lemma PermI: "[| Gamma' : deductions R; Gamma <~~> Gamma'; Perms <= R |] ==> Gamma : deductions(R)"
  apply(rule_tac prems="{Gamma'}" in deductions.inferI)
  apply(auto simp add: Perms_def) done

subsection "Derived Rules"

lemma WeakI1: "[| Gamma : deductions(A); Weaks <= A |] ==> (Delta @ Gamma) : deductions(A)"
  apply (induct Delta, simp)
  apply(auto intro: WeakI) done

lemma WeakI2: "[| Gamma : deductions(A); Perms <= A; Weaks <= A |] ==> (Gamma @ Delta) : deductions(A)"
  apply(blast intro: PermI perm_append_swap WeakI1) done

lemma SATAxiomI: "[| Axioms <= A; Weaks <= A; Perms <= A; forms = [FAtom Pos n vs,FAtom Neg n vs] @ Gamma |] ==> forms : deductions(A)"
  apply(simp only:)
  apply(blast intro: WeakI2 AxiomI)
  done

lemma DisjI1: "[| (A1#Gamma) : deductions(A); Disjs <= A; Weaks <= A |] ==> FConj Neg A0 A1#Gamma : deductions(A)"
  apply(blast intro: DisjI WeakI)
  done

lemma DisjI2: "!!A. [| (A0#Gamma) : deductions(A); Disjs <= A; Weaks <= A; Perms <= A |] ==> FConj Neg A0 A1#Gamma : deductions(A)"
  apply(rule DisjI)
  apply(rule PermI[OF _ perm.swap])
  apply(rule WeakI)
  .

    -- "FIXME the following 4 lemmas could all be proved for the standard rule sets using monotonicity as below"
    -- "we keep proofs as in original, but they are slightly ugly, and do not state what is intuitively happening"
lemma perm_tmp4: "Perms \<subseteq> R \<Longrightarrow> A @ (a # list) @ (a # list) : deductions R \<Longrightarrow> (a # a # A) @ list @ list : deductions R"
  apply (rule PermI, auto)
  apply(simp add: perm_count_conv count_append) done

lemma weaken_append[rule_format]: "Contrs <= R ==> Perms <= R ==> !A. A @ Gamma @ Gamma : deductions(R) -->  A @ Gamma : deductions(R)"
  apply (induct_tac Gamma, simp, rule) apply rule
  apply(drule_tac x="a#a#A" in spec)
  apply(erule_tac impE)
  apply(rule perm_tmp4) apply(assumption, assumption)
  apply(thin_tac "A @ (a # list) @ a # list \<in> deductions R")
  apply simp
  apply(frule_tac ContrI) apply assumption
  apply(thin_tac "a # a # A @ list \<in> deductions R")
  apply(rule PermI) apply assumption
  apply(simp add: perm_count_conv count_append)
  by assumption
  -- "FIXME horrible"

lemma ListWeakI: "Perms <= R ==> Contrs <= R ==> x # Gamma @ Gamma : deductions(R) ==> x # Gamma : deductions(R)"
  by(rule weaken_append[of R "[x]" Gamma, simplified])

lemma ConjI': "[| (A0#Gamma) : deductions(A);  (A1#Gamma) : deductions(A); Contrs <= A; Conjs <= A; Perms <= A |] ==> FConj Pos A0 A1#Gamma : deductions(A)"
  apply(rule ListWeakI, assumption, assumption)
  apply(rule ConjI) .

subsection "Standard Rule Sets For Predicate Calculus"

definition
  PC :: "rule set" where
  "PC = Union {Perms,Axioms,Conjs,Disjs,Alls,Exs,Weaks,Contrs,Cuts}"

definition
  CutFreePC :: "rule set" where
  "CutFreePC = Union {Perms,Axioms,Conjs,Disjs,Alls,Exs,Weaks,Contrs}"

lemma rulesInPCs: "Axioms <= PC" "Axioms <= CutFreePC"
  "Conjs  <= PC" "Conjs  <= CutFreePC"
  "Disjs  <= PC" "Disjs  <= CutFreePC"
  "Alls   <= PC" "Alls   <= CutFreePC"
  "Exs    <= PC" "Exs    <= CutFreePC"
  "Weaks  <= PC" "Weaks  <= CutFreePC"
  "Contrs <= PC" "Contrs <= CutFreePC"
  "Perms  <= PC" "Perms  <= CutFreePC"
  "Cuts   <= PC"
  "CutFreePC <= PC"
  by(auto simp: PC_def CutFreePC_def)

subsection "Monotonicity for CutFreePC deductions"

  -- "these lemmas can be used to replace complicated permutation reasoning above"
  -- "essentially if x is a deduction, and set x subset set y, then y is a deduction"

definition
  inDed :: "formula list => bool" where
  "inDed xs \<longleftrightarrow> xs : deductions CutFreePC"

lemma perm: "! xs ys. xs <~~> ys --> (inDed xs = inDed ys)"
  apply(subgoal_tac "! xs ys. xs <~~> ys --> inDed xs --> inDed ys")
  apply (blast intro: perm_sym, clarify)
  apply(simp add: inDed_def)
  apply (rule PermI, assumption)
  apply(rule perm_sym) apply assumption
  by(blast intro!: rulesInPCs)

lemma contr: "! x xs. inDed (x#x#xs) --> inDed (x#xs)"
  apply(simp add: inDed_def)
  apply(blast intro!: ContrI rulesInPCs)
  done

lemma weak: "! x xs. inDed xs --> inDed (x#xs)"
  apply(simp add: inDed_def)
  apply(blast intro!: WeakI rulesInPCs)
  done

lemma inDed_mono[simplified inDed_def]: "inDed x ==> set x <= set y ==> inDed y"
  using perm_weak_contr_mono[OF perm contr weak] .

end


section \<open>Horner Evaluation\<close>
theory Horner_Eval
  imports "HOL-Library.Interval"
begin

text \<open>Function and lemmas for evaluating polynomials via the horner scheme.
   Because interval multiplication is not distributive, interval polynomials
   expressed as a sum of monomials are not equivalent to their respective horner form.
   The functions and lemmas in this theory can be used to express interval
   polynomials in horner form and prove facts about them.\<close>

fun horner_eval' where
  "horner_eval' f x v 0 = v"
| "horner_eval' f x v (Suc i) = horner_eval' f x (f i + x * v) i"

definition horner_eval
  where "horner_eval f x n = horner_eval' f x 0 n"

lemma horner_eval_cong:
  assumes "\<And>i. i < n \<Longrightarrow> f i = g i"
  assumes "x = y"
  assumes "n = m"
  shows "horner_eval f x n = horner_eval g y m"
proof-
  {
    fix v have "horner_eval' f x v n = horner_eval' g x v n"
      using assms(1) by (induction n arbitrary: v, simp_all)
  }
  thus ?thesis
    by (simp add: assms(2,3) horner_eval_def)
qed

lemma horner_eval_eq_setsum:
  fixes x::"'a::linordered_idom"
  shows "horner_eval f x n = (\<Sum>i<n. f i * x^i)"
proof-
  {
    fix v have "horner_eval' f x v n = (\<Sum>i<n. f i * x^i) + v * x^n"
      by (induction n arbitrary: v, simp_all add: distrib_left mult.commute)
  }
  thus ?thesis by (simp add: horner_eval_def)
qed

lemma horner_eval_Suc[simp]:
  fixes x::"'a::linordered_idom"
  shows "horner_eval f x (Suc n) = horner_eval f x n + (f n) * x^n"
  unfolding horner_eval_eq_setsum
  by simp

lemma horner_eval_Suc'[simp]:
  fixes x::"'a::{comm_monoid_add, times}"
  shows "horner_eval f x (Suc n) = f 0 + x * (horner_eval (\<lambda>i. f (Suc i)) x n)"
proof-
  {
    fix v have "horner_eval' f x v (Suc n) = f 0 + x * horner_eval' (\<lambda>i. f (Suc i)) x v n"
      by (induction n arbitrary: v, simp_all)
  }
  thus ?thesis by (simp add: horner_eval_def)
qed

lemma horner_eval_0[simp]:
  shows "horner_eval f x 0 = 0"
  by (simp add: horner_eval_def)

lemma horner_eval'_interval:
  fixes x::"'a::linordered_ring"
  assumes "\<And>i. i < n \<Longrightarrow> f i \<in> set_of (g i)"
  assumes "x \<in>\<^sub>i I" "v \<in>\<^sub>i V"
  shows "horner_eval' f x v n \<in>\<^sub>i horner_eval' g I V n"
  using assms
  by (induction n arbitrary: v V) (auto intro!: plus_in_intervalI times_in_intervalI)

lemma horner_eval_interval:
  fixes x::"'a::linordered_idom"
  assumes "\<And>i. i < n \<Longrightarrow> f i \<in> set_of (g i)"
  assumes "x \<in> set_of I"
  shows "horner_eval f x n \<in>\<^sub>i horner_eval g I n"
  unfolding horner_eval_def
  using assms
  by (rule horner_eval'_interval) (auto simp: set_of_eq)

end


subsection \<open>The Knapsack Problem\<close>

theory Knapsack
  imports
    "HOL-Library.Code_Target_Numeral"
    "../state_monad/State_Main"
    "../heap_monad/Heap_Default"
    Example_Misc
begin

subsubsection \<open>Definitions\<close>

context (* Subset Sum *)
  fixes w :: "nat \<Rightarrow> nat"
begin

context (* Knapsack *)
  fixes v :: "nat \<Rightarrow> nat"
begin

fun knapsack :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "knapsack 0 W = 0" |
  "knapsack (Suc i) W = (if W < w (Suc i)
    then knapsack i W
    else max (knapsack i W) (v (Suc i) + knapsack i (W - w (Suc i))))"

no_notation fun_app_lifted (infixl "." 999)

text \<open>
  The correctness proof closely follows Kleinberg \<open>&\<close> Tardos: "Algorithm Design",
  chapter "Dynamic Programming" \<^cite>\<open>"Kleinberg-Tardos"\<close>
\<close>

definition
  "OPT n W = Max {\<Sum> i \<in> S. v i | S. S \<subseteq> {1..n} \<and> (\<Sum> i \<in> S. w i) \<le> W}"

lemma OPT_0:
  "OPT 0 W = 0"
  unfolding OPT_def by simp

subsubsection \<open>Functional Correctness\<close>

lemma Max_add_left:
  "(x :: nat) + Max S = Max (((+) x) ` S)" (is "?A = ?B") if "finite S" "S \<noteq> {}"
proof -
  have "?A \<le> ?B"
    using that by (force intro: Min.boundedI)
  moreover have "?B \<le> ?A"
    using that by (force intro: Min.boundedI)
  ultimately show ?thesis
    by simp
qed

lemma OPT_Suc:
  "OPT (Suc i) W = (
    if W < w (Suc i)
    then OPT i W
    else max(v (Suc i) + OPT i (W - w (Suc i))) (OPT i W)
  )" (is "?lhs = ?rhs")
proof -
  have OPT_in: "OPT n W \<in> {\<Sum> i \<in> S. v i | S. S \<subseteq> {1..n} \<and> (\<Sum> i \<in> S. w i) \<le> W}" for n W
    unfolding OPT_def by - (rule Max_in; force)
  from OPT_in[of "Suc i" W] obtain S where S:
    "S \<subseteq> {1..Suc i}" "sum w S \<le> W" and [simp]: "OPT (Suc i) W = sum v S"
    by auto

  have "OPT i W \<le> OPT (Suc i) W"
    unfolding OPT_def by (force intro: Max_mono)
  moreover have "v (Suc i) + OPT i (W - w (Suc i)) \<le> OPT (Suc i) W" if "w (Suc i) \<le> W"
  proof -
    have *: "
      v (Suc i) + sum v S = sum v (S \<union> {Suc i}) \<and> (S \<union> {Suc i}) \<subseteq> {1..Suc i}
      \<and> sum w (S \<union> {Suc i}) \<le> W" if "S \<subseteq> {1..i}" "sum w S \<le> W - w (Suc i)" for S
      using that \<open>w (Suc i) \<le> W\<close>
      by (subst sum.insert_if | auto intro: finite_subset[OF _ finite_atLeastAtMost])+
    show ?thesis
      unfolding OPT_def
      by (subst Max_add_left;
          fastforce intro: Max_mono finite_subset[OF _ finite_atLeastAtMost] dest: *
         )
  qed
  ultimately have "?lhs \<ge> ?rhs"
    by auto

  from S have *: "sum v S \<le> OPT i W" if "Suc i \<notin> S"
    using that unfolding OPT_def by (auto simp: atLeastAtMostSuc_conv intro!: Max_ge)

  have "sum v S \<le> OPT i W" if "W < w (Suc i)"
  proof (rule *, rule ccontr, simp)
    assume "Suc i \<in> S"
    then have "sum w S \<ge> w (Suc i)"
      using S(1) by (subst sum.remove) (auto intro: finite_subset[OF _ finite_atLeastAtMost])
    with \<open>W < _\<close> \<open>_ \<le> W\<close> show False
      by simp
  qed
  moreover have
    "OPT (Suc i) W \<le> max(v (Suc i) + OPT i (W - w (Suc i))) (OPT i W)" if "w (Suc i) \<le> W"
  proof (cases "Suc i \<in> S")
    case True
    then have [simp]:
      "sum v S = v (Suc i) + sum v (S - {Suc i})" "sum w S = w (Suc i) + sum w (S - {Suc i})"
      using S(1) by (auto intro: finite_subset[OF _ finite_atLeastAtMost] sum.remove)
    have "OPT i (W - w (Suc i)) \<ge> sum v (S - {Suc i})"
      unfolding OPT_def using S by (fastforce intro!: Max_ge)
    then show ?thesis
      by simp
  next
    case False
    then show ?thesis
      by (auto dest: *)
  qed
  ultimately have "?lhs \<le> ?rhs"
    by auto
  with \<open>?lhs \<ge> ?rhs\<close> show ?thesis
    by simp
qed

theorem knapsack_correct:
  "OPT n W = knapsack n W"
  by (induction n arbitrary: W; auto simp: OPT_0 OPT_Suc)

subsubsection \<open>Functional Memoization\<close>

memoize_fun knapsack\<^sub>m: knapsack with_memory dp_consistency_mapping monadifies (state) knapsack.simps

text \<open>Generated Definitions\<close>
context includes state_monad_syntax begin
thm knapsack\<^sub>m'.simps knapsack\<^sub>m_def
end

text \<open>Correspondence Proof\<close>
memoize_correct
  by memoize_prover
print_theorems
lemmas [code] = knapsack\<^sub>m.memoized_correct

subsubsection \<open>Imperative Memoization\<close>

context fixes
  mem :: "nat option array"
  and n W :: nat
begin

memoize_fun knapsack\<^sub>T: knapsack
  with_memory dp_consistency_heap_default where bound = "Bound (0, 0) (n, W)" and mem="mem"
  monadifies (heap) knapsack.simps

context includes heap_monad_syntax begin
thm knapsack\<^sub>T'.simps knapsack\<^sub>T_def
end

memoize_correct
  by memoize_prover

lemmas memoized_empty = knapsack\<^sub>T.memoized_empty

end (* Fixed array *)

text \<open>Adding Memory Initialization\<close>
context
  includes heap_monad_syntax
  notes [simp del] = knapsack\<^sub>T'.simps
begin

definition
  "knapsack\<^sub>h \<equiv> \<lambda> i j. Heap_Monad.bind (mem_empty (i * j)) (\<lambda> mem. knapsack\<^sub>T' mem i j i j)"

lemmas memoized_empty' = memoized_empty[
      of mem n W "\<lambda> m. \<lambda>(i,j). knapsack\<^sub>T' m n W i j",
      OF knapsack\<^sub>T.crel[of mem n W], of "(n, W)" for mem n W
    ]

lemma knapsack_heap:
  "knapsack n W = result_of (knapsack\<^sub>h n W) Heap.empty"
  unfolding knapsack\<^sub>h_def using memoized_empty'[of _ n W] by (simp add: index_size_defs)

end

end (* Knapsack *)

fun su :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "su 0 W = 0" |
  "su (Suc i) W = (if W < w (Suc i)
    then su i W
    else max (su i W) (w (Suc i) + su i (W - w (Suc i))))"

lemma su_knapsack:
  "su n W = knapsack w n W"
  by (induction n arbitrary: W; simp)

lemma su_correct:
  "Max {\<Sum> i \<in> S. w i | S. S \<subseteq> {1..n} \<and> (\<Sum> i \<in> S. w i) \<le> W} = su n W"
  unfolding su_knapsack knapsack_correct[symmetric] OPT_def ..

subsubsection \<open>Memoization\<close>

memoize_fun su\<^sub>m: su with_memory dp_consistency_mapping monadifies (state) su.simps

text \<open>Generated Definitions\<close>
context includes state_monad_syntax begin
thm su\<^sub>m'.simps su\<^sub>m_def
end

text \<open>Correspondence Proof\<close>
memoize_correct
  by memoize_prover
print_theorems
lemmas [code] = su\<^sub>m.memoized_correct

end (* Subset Sum *)

subsubsection \<open>Regression Test\<close>

definition
  "knapsack_test = (knapsack\<^sub>h (\<lambda> i. [2,3,4] ! (i - 1)) (\<lambda> i. [2,3,4] ! (i - 1)) 3 8)"

code_reflect Test functions knapsack_test

ML \<open>Test.knapsack_test ()\<close>

end (* Theory *)