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

section \<open>An efficient checker for proofs from a SAT solver\<close>

theory SatChecker
imports "HOL-Library.RBT_Impl" Sorted_List "../Imperative_HOL"
begin

section\<open>General settings and functions for our representation of clauses\<close>

subsection\<open>Types for Literals, Clauses and ProofSteps\<close>
text \<open>We encode Literals as integers and Clauses as sorted Lists.\<close>

type_synonym ClauseId = nat
type_synonym Lit = int
type_synonym Clause = "Lit list"

text \<open>This resembles exactly to Isat's Proof Steps\<close>

type_synonym Resolvants = "ClauseId * (Lit * ClauseId) list"
datatype ProofStep =
  ProofDone bool
  | Root ClauseId Clause
  | Conflict ClauseId Resolvants
  | Delete ClauseId
  | Xstep ClauseId ClauseId

subsection\<open>Interpretation of Literals, Clauses, and an array of Clauses\<close>
text \<open>Specific definitions for Literals as integers\<close>

definition compl :: "Lit \<Rightarrow> Lit"
where
  "compl a = -a"

definition interpLit :: "(nat \<Rightarrow> bool) \<Rightarrow> Lit \<Rightarrow> bool"
where
  "interpLit assgnmt lit = (if lit > 0 then assgnmt (nat lit) else (if (lit < 0) then \<not> (assgnmt (nat (- lit))) else undefined))"

lemma interpLit_compl[simp]:
  assumes lit_not_zero: "lit \<noteq> 0"
  shows "interpLit a (compl lit) = (\<not> interpLit a lit)"
unfolding interpLit_def compl_def using lit_not_zero by auto

lemma compl_compl_is_id[simp]:
  "compl (compl x) = x"
unfolding compl_def by simp

lemma compl_not_zero[simp]:
  "(compl x \<noteq> 0) = (x \<noteq> 0)"
unfolding compl_def by simp

lemma compl_exists: "\<exists>l'. l = compl l'"
unfolding compl_def by arith

text \<open>Specific definitions for Clauses as sorted lists\<close>

definition interpClause :: "(nat \<Rightarrow> bool) \<Rightarrow> Clause \<Rightarrow> bool"
where
  "interpClause assgnmt cl = (\<exists> l \<in> set cl. interpLit assgnmt l)"

lemma interpClause_empty[simp]:
  "interpClause a [] = False"
unfolding interpClause_def by simp

lemma interpClause_sort[simp]: "interpClause a (sort clause) = interpClause a clause"
unfolding interpClause_def
by simp

lemma interpClause_remdups[simp]: "interpClause a (remdups clause) = interpClause a clause"
unfolding interpClause_def
by simp

definition
  "inconsistent cs = (\<forall>a.\<exists>c\<in>set cs. \<not> interpClause a c)"

lemma interpClause_resolvants':
  assumes lit_not_zero: "lit \<noteq> 0"
  assumes resolv_clauses: "lit \<in> cli" "compl lit \<in> clj"
  assumes interp: "\<exists>x \<in> cli. interpLit a x" "\<exists>x \<in> clj. interpLit a x"
  shows "\<exists>x \<in> (cli - {lit} \<union> (clj - {compl lit})). interpLit a x"
proof -
  from resolv_clauses interp have "(\<exists>l \<in> cli - {lit}. interpLit a l) \<or> interpLit a lit"
    "(\<exists>l \<in> clj - {compl lit}. interpLit a l) \<or> interpLit a (compl lit)" by auto
  with lit_not_zero show ?thesis by (fastforce simp add: bex_Un)
qed

lemma interpClause_resolvants:
  assumes lit_not_zero: "lit \<noteq> 0"
  assumes sorted_and_distinct: "sorted cli" "distinct cli" "sorted clj" "distinct clj"
  assumes resolv_clauses: "lit \<in> set cli" "compl lit \<in> set clj"
  assumes interp: "interpClause a cli" "interpClause a clj"
  shows "interpClause a (merge (remove lit cli) (remove (compl lit) clj))"
proof -
  from lit_not_zero resolv_clauses interp sorted_and_distinct show ?thesis
    unfolding interpClause_def
    using interpClause_resolvants' by simp
qed

definition correctClause :: "Clause list \<Rightarrow> Clause \<Rightarrow> bool"
where
  "correctClause rootcls cl = (\<forall>a. (\<forall>rcl \<in> set rootcls. interpClause a rcl) \<longrightarrow> (interpClause a cl))"

lemma correctClause_resolvants:
  assumes lit_not_zero: "lit \<noteq> 0"
  assumes sorted_and_distinct: "sorted cli" "distinct cli" "sorted clj" "distinct clj"
  assumes resolv_clauses: "lit \<in> set cli" "compl lit \<in> set clj"
  assumes correct: "correctClause r cli" "correctClause r clj"
  shows "correctClause r (merge (remove lit cli) (remove (compl lit) clj))"
  using assms interpClause_resolvants unfolding correctClause_def by auto

lemma implies_empty_inconsistent:
  "correctClause cs [] \<Longrightarrow> inconsistent cs"
unfolding inconsistent_def correctClause_def
by auto

text \<open>Specific definition for derived clauses in the Array\<close>

definition
  array_ran :: "('a::heap) option array \<Rightarrow> heap \<Rightarrow> 'a set" where
  "array_ran a h = {e. Some e \<in> set (Array.get h a)}"
    \<comment> \<open>FIXME\<close>

lemma array_ranI: "\<lbrakk> Some b = Array.get h a ! i; i < Array.length h a \<rbrakk> \<Longrightarrow> b \<in> array_ran a h"
unfolding array_ran_def Array.length_def by simp

lemma array_ran_upd_array_Some:
  assumes "cl \<in> array_ran a (Array.update a i (Some b) h)"
  shows "cl \<in> array_ran a h \<or> cl = b"
proof -
  have "set ((Array.get h a)[i := Some b]) \<subseteq> insert (Some b) (set (Array.get h a))" by (rule set_update_subset_insert)
  with assms show ?thesis
    unfolding array_ran_def Array.update_def by fastforce
qed

lemma array_ran_upd_array_None:
  assumes "cl \<in> array_ran a (Array.update a i None h)"
  shows "cl \<in> array_ran a h"
proof -
  have "set ((Array.get h a)[i := None]) \<subseteq> insert None (set (Array.get h a))" by (rule set_update_subset_insert)
  with assms show ?thesis
    unfolding array_ran_def Array.update_def by auto
qed

definition correctArray :: "Clause list \<Rightarrow> Clause option array \<Rightarrow> heap \<Rightarrow> bool"
where
  "correctArray rootcls a h =
  (\<forall>cl \<in> array_ran a h. correctClause rootcls cl \<and> sorted cl \<and> distinct cl)"

lemma correctArray_update:
  assumes "correctArray rcs a h"
  assumes "correctClause rcs c" "sorted c" "distinct c"
  shows "correctArray rcs a (Array.update a i (Some c) h)"
  using assms
  unfolding correctArray_def
  by (auto dest:array_ran_upd_array_Some)

lemma correctClause_mono:
  assumes "correctClause rcs c"
  assumes "set rcs \<subseteq> set rcs'"
  shows "correctClause rcs' c"
  using assms unfolding correctClause_def
  by auto

section\<open>Improved version of SatChecker\<close>

text\<open>This version just uses a single list traversal.\<close>

subsection\<open>Function definitions\<close>

primrec res_mem :: "Lit \<Rightarrow> Clause \<Rightarrow> Clause Heap"
where
  "res_mem l [] = raise STR ''MiniSatChecked.res_thm: Cannot find literal''"
| "res_mem l (x#xs) = (if (x = l) then return xs else do { v \<leftarrow> res_mem l xs; return (x # v) })"

fun resolve1 :: "Lit \<Rightarrow> Clause \<Rightarrow> Clause \<Rightarrow> Clause Heap"
where
  "resolve1 l (x#xs) (y#ys) =
  (if (x = l) then return (merge xs (y#ys))
  else (if (x < y) then do { v \<leftarrow> resolve1 l xs (y#ys); return (x # v) }
  else (if (x > y) then do { v \<leftarrow> resolve1 l (x#xs) ys; return (y # v) }
  else do { v \<leftarrow> resolve1 l xs ys; return (x # v) })))"
| "resolve1 l [] ys = raise STR ''MiniSatChecked.res_thm: Cannot find literal''"
| "resolve1 l xs [] = res_mem l xs"

fun resolve2 :: "Lit \<Rightarrow> Clause \<Rightarrow> Clause \<Rightarrow> Clause Heap"
where
  "resolve2 l (x#xs) (y#ys) =
  (if (y = l) then return (merge (x#xs) ys)
  else (if (x < y) then do { v \<leftarrow> resolve2 l xs (y#ys); return (x # v) }
  else (if (x > y) then do { v \<leftarrow> resolve2 l (x#xs) ys; return (y # v) }
  else do { v \<leftarrow> resolve2 l xs ys; return (x # v) })))"
  | "resolve2 l xs [] = raise STR ''MiniSatChecked.res_thm: Cannot find literal''"
  | "resolve2 l [] ys = res_mem l ys"

fun res_thm' :: "Lit \<Rightarrow> Clause \<Rightarrow> Clause \<Rightarrow> Clause Heap"
where
  "res_thm' l (x#xs) (y#ys) =
  (if (x = l \<or> x = compl l) then resolve2 (compl x) xs (y#ys)
  else (if (y = l \<or> y = compl l) then resolve1 (compl y) (x#xs) ys
  else (if (x < y) then (res_thm' l xs (y#ys)) \<bind> (\<lambda>v. return (x # v))
  else (if (x > y) then (res_thm' l (x#xs) ys) \<bind> (\<lambda>v. return (y # v))
  else (res_thm' l xs ys) \<bind> (\<lambda>v. return (x # v))))))"
| "res_thm' l [] ys = raise STR ''MiniSatChecked.res_thm: Cannot find literal''"
| "res_thm' l xs [] = raise STR ''MiniSatChecked.res_thm: Cannot find literal''"

declare res_mem.simps [simp del] resolve1.simps [simp del] resolve2.simps [simp del] res_thm'.simps [simp del]

subsection \<open>Proofs about these functions\<close>

lemma res_mem:
assumes "effect (res_mem l xs) h h' r"
  shows "l \<in> set xs \<and> r = remove1 l xs"
using assms
proof (induct xs arbitrary: r)
  case Nil
  thus ?case unfolding res_mem.simps by (auto elim: effect_raiseE)
next
  case (Cons x xs')
  thus ?case
    unfolding res_mem.simps
    by (elim effect_raiseE effect_returnE effect_ifE effect_bindE) auto
qed

lemma resolve1_Inv:
assumes "effect (resolve1 l xs ys) h h' r"
  shows "l \<in> set xs \<and> r = merge (remove1 l xs) ys"
using assms
proof (induct xs ys arbitrary: r rule: resolve1.induct)
  case (1 l x xs y ys r)
  thus ?case
    unfolding resolve1.simps
    by (elim effect_bindE effect_ifE effect_returnE) auto
next
  case (2 l ys r)
  thus ?case
    unfolding resolve1.simps
    by (elim effect_raiseE) auto
next
  case (3 l v va r)
  thus ?case
    unfolding resolve1.simps
    by (fastforce dest!: res_mem)
qed

lemma resolve2_Inv:
  assumes "effect (resolve2 l xs ys) h h' r"
  shows "l \<in> set ys \<and> r = merge xs (remove1 l ys)"
using assms
proof (induct xs ys arbitrary: r rule: resolve2.induct)
  case (1 l x xs y ys r)
  thus ?case
    unfolding resolve2.simps
    by (elim effect_bindE effect_ifE effect_returnE) auto
next
  case (2 l ys r)
  thus ?case
    unfolding resolve2.simps
    by (elim effect_raiseE) auto
next
  case (3 l v va r)
  thus ?case
    unfolding resolve2.simps
    by (fastforce dest!: res_mem)
qed

lemma res_thm'_Inv:
assumes "effect (res_thm' l xs ys) h h' r"
shows "\<exists>l'. (l' \<in> set xs \<and> compl l' \<in> set ys \<and> (l' = compl l \<or> l' = l)) \<and> r = merge (remove1 l' xs) (remove1 (compl l') ys)"
using assms
proof (induct xs ys arbitrary: r rule: res_thm'.induct)
case (1 l x xs y ys r)
(* There are five cases for res_thm: We will consider them one after another: *)
  {
    assume cond: "x = l \<or> x = compl l"
    assume resolve2: "effect (resolve2 (compl x) xs (y # ys)) h h' r"
    from resolve2_Inv [OF resolve2] cond have ?case
      apply -
      by (rule exI[of _ "x"]) fastforce
  } moreover
  {
    assume cond: "\<not> (x = l \<or> x = compl l)" "y = l \<or> y = compl l"
    assume resolve1: "effect (resolve1 (compl y) (x # xs) ys) h h' r"
    from resolve1_Inv [OF resolve1] cond have ?case
      apply -
      by (rule exI[of _ "compl y"]) fastforce
  } moreover
  {
    fix r'
    assume cond: "\<not> (x = l \<or> x = compl l)" "\<not> (y = l \<or> y = compl l)" "x < y"
    assume res_thm: "effect (res_thm' l xs (y # ys)) h h' r'"
    assume return: "r = x # r'"
    from "1.hyps"(1) [OF cond res_thm] cond return have ?case by auto
  } moreover
  {
    fix r'
    assume cond: "\<not> (x = l \<or> x = compl l)" "\<not> (y = l \<or> y = compl l)" "\<not> x < y" "y < x"
    assume res_thm: "effect (res_thm' l (x # xs) ys) h h' r'"
    assume return: "r = y # r'"
    from "1.hyps"(2) [OF cond res_thm] cond return have ?case by auto
  } moreover
  {
    fix r'
    assume cond: "\<not> (x = l \<or> x = compl l)" "\<not> (y = l \<or> y = compl l)" "\<not> x < y" "\<not> y < x"
    assume res_thm: "effect (res_thm' l xs ys) h h' r'"
    assume return: "r = x # r'"
    from "1.hyps"(3) [OF cond res_thm] cond return have ?case by auto
  } moreover
  note "1.prems"
  ultimately show ?case
    unfolding res_thm'.simps
    apply (elim effect_bindE effect_ifE effect_returnE)
    apply simp
    apply simp
    apply simp
    apply simp
    apply fastforce
    done
next
  case (2 l ys r)
  thus ?case
    unfolding res_thm'.simps
    by (elim effect_raiseE) auto
next
  case (3 l v va r)
  thus ?case
    unfolding res_thm'.simps
    by (elim effect_raiseE) auto
qed

lemma res_mem_no_heap:
assumes "effect (res_mem l xs) h h' r"
  shows "h = h'"
using assms
apply (induct xs arbitrary: r)
unfolding res_mem.simps
apply (elim effect_raiseE)
apply auto
apply (elim effect_ifE effect_bindE effect_raiseE effect_returnE)
apply auto
done

lemma resolve1_no_heap:
assumes "effect (resolve1 l xs ys) h h' r"
  shows "h = h'"
using assms
apply (induct xs ys arbitrary: r rule: resolve1.induct)
unfolding resolve1.simps
apply (elim effect_bindE effect_ifE effect_returnE effect_raiseE)
apply (auto simp add: res_mem_no_heap)
by (elim effect_raiseE) auto

lemma resolve2_no_heap:
assumes "effect (resolve2 l xs ys) h h' r"
  shows "h = h'"
using assms
apply (induct xs ys arbitrary: r rule: resolve2.induct)
unfolding resolve2.simps
apply (elim effect_bindE effect_ifE effect_returnE effect_raiseE)
apply (auto simp add: res_mem_no_heap)
by (elim effect_raiseE) auto

lemma res_thm'_no_heap:
  assumes "effect (res_thm' l xs ys) h h' r"
  shows "h = h'"
  using assms
proof (induct xs ys arbitrary: r rule: res_thm'.induct)
  case (1 l x xs y ys r)
  thus ?thesis
    unfolding res_thm'.simps
    by (elim effect_bindE effect_ifE effect_returnE)
  (auto simp add: resolve1_no_heap resolve2_no_heap)
next
  case (2 l ys r)
  thus ?case
    unfolding res_thm'.simps
    by (elim effect_raiseE) auto
next
  case (3 l v va r)
  thus ?case
    unfolding res_thm'.simps
    by (elim effect_raiseE) auto
qed

lemma res_thm'_Inv2:
  assumes res_thm: "effect (res_thm' l xs ys) h h' rcl"
  assumes l_not_null: "l \<noteq> 0"
  assumes ys: "correctClause r ys \<and> sorted ys \<and> distinct ys"
  assumes xs: "correctClause r xs \<and> sorted xs \<and> distinct xs"
  shows "correctClause r rcl \<and> sorted rcl \<and> distinct rcl"
proof -
  from res_thm'_Inv [OF res_thm] xs ys l_not_null show ?thesis
    apply (auto simp add: sorted_remove1)
    unfolding correctClause_def
    apply (auto simp add: remove1_eq_remove)
    prefer 2
    apply (rule interpClause_resolvants)
    apply simp_all
    apply (insert compl_exists [of l])
    apply auto
    apply (rule interpClause_resolvants)
    apply simp_all
    done
qed

subsection \<open>res_thm and doProofStep\<close>

definition get_clause :: "Clause option array \<Rightarrow> ClauseId \<Rightarrow> Clause Heap"
where
  "get_clause a i =
       do { c \<leftarrow> Array.nth a i;
           (case c of None \<Rightarrow> raise STR ''Clause not found''
                    | Some x \<Rightarrow> return x)
       }"

primrec res_thm2 :: "Clause option array \<Rightarrow> (Lit * ClauseId) \<Rightarrow> Clause \<Rightarrow> Clause Heap"
where
  "res_thm2 a (l, j) cli =
  ( if l = 0 then raise STR ''Illegal literal''
    else
     do { clj \<leftarrow> get_clause a j;
         res_thm' l cli clj
     })"

primrec
  foldM :: "('a \<Rightarrow> 'b \<Rightarrow> 'b Heap) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b Heap"
where
  "foldM f [] s = return s"
  | "foldM f (x#xs) s = f x s \<bind> foldM f xs"

fun doProofStep2 :: "Clause option array \<Rightarrow> ProofStep \<Rightarrow> Clause list \<Rightarrow> Clause list Heap"
where
  "doProofStep2 a (Conflict saveTo (i, rs)) rcs =
  do {
     cli \<leftarrow> get_clause a i;
     result \<leftarrow> foldM (res_thm2 a) rs cli;
     Array.upd saveTo (Some result) a;
     return rcs
  }"
| "doProofStep2 a (Delete cid) rcs = do { Array.upd cid None a; return rcs }"
| "doProofStep2 a (Root cid clause) rcs = do { Array.upd cid (Some (remdups (sort clause))) a; return (clause # rcs) }"
| "doProofStep2 a (Xstep cid1 cid2) rcs = raise STR ''MiniSatChecked.doProofStep: Xstep constructor found.''"
| "doProofStep2 a (ProofDone b) rcs = raise STR ''MiniSatChecked.doProofStep: ProofDone constructor found.''"

definition checker :: "nat \<Rightarrow> ProofStep list \<Rightarrow> nat \<Rightarrow> Clause list Heap"
where
  "checker n p i =
  do {
     a \<leftarrow> Array.new n None;
     rcs \<leftarrow> foldM (doProofStep2 a) p [];
     ec \<leftarrow> Array.nth a i;
     (if ec = Some [] then return rcs
                else raise STR ''No empty clause'')
  }"

lemma effect_case_option:
  assumes "effect (case x of None \<Rightarrow> n | Some y \<Rightarrow> s y) h h' r"
  obtains "x = None" "effect n h h' r"
         | y where "x = Some y" "effect (s y) h h' r"
  using assms unfolding effect_def by (auto split: option.splits)

lemma res_thm2_Inv:
  assumes res_thm: "effect (res_thm2 a (l, j) cli) h h' rs"
  assumes correct_a: "correctArray r a h"
  assumes correct_cli: "correctClause r cli \<and> sorted cli \<and> distinct cli"
  shows "h = h' \<and> correctClause r rs \<and> sorted rs \<and> distinct rs"
proof -
  from res_thm have l_not_zero: "l \<noteq> 0"
    by (auto elim: effect_raiseE)
  {
    fix clj
    let ?rs = "merge (remove l cli) (remove (compl l) clj)"
    let ?rs' = "merge (remove (compl l) cli) (remove l clj)"
    assume "h = h'" "Some clj = Array.get h' a ! j" "j < Array.length h' a"
    with correct_a have clj: "correctClause r clj" "sorted clj" "distinct clj"
      unfolding correctArray_def by (auto intro: array_ranI)
    with clj l_not_zero correct_cli
    have "(l \<in> set cli \<and> compl l \<in> set clj
      \<longrightarrow> correctClause r ?rs \<and> sorted ?rs \<and> distinct ?rs) \<and>
      (compl l \<in> set cli \<and> l \<in> set clj
      \<longrightarrow> correctClause r ?rs' \<and> sorted ?rs' \<and> distinct ?rs')"
      apply (auto intro!: correctClause_resolvants)
      apply (insert compl_exists [of l])
      by (auto intro!: correctClause_resolvants)
  }
  {
    fix v clj
    assume "Some clj = Array.get h a ! j" "j < Array.length h a"
    with correct_a have clj: "correctClause r clj \<and> sorted clj \<and> distinct clj"
      unfolding correctArray_def by (auto intro: array_ranI)
    assume "effect (res_thm' l cli clj) h h' rs"
    from res_thm'_no_heap[OF this] res_thm'_Inv2[OF this l_not_zero clj correct_cli]
    have "h = h' \<and> correctClause r rs \<and> sorted rs \<and> distinct rs" by simp
  }
  with assms show ?thesis
    unfolding res_thm2.simps get_clause_def
    by (elim effect_bindE effect_ifE effect_nthE effect_raiseE effect_returnE effect_case_option) auto
qed

lemma foldM_Inv2:
  assumes "effect (foldM (res_thm2 a) rs cli) h h' rcl"
  assumes correct_a: "correctArray r a h"
  assumes correct_cli: "correctClause r cli \<and> sorted cli \<and> distinct cli"
  shows "h = h' \<and> correctClause r rcl \<and> sorted rcl \<and> distinct rcl"
using assms
proof (induct rs arbitrary: h h' cli)
  case Nil thus ?case
    unfolding foldM.simps
    by (elim effect_returnE) auto
next
  case (Cons x xs)
  {
    fix h1 ret
    obtain l j where x_is: "x = (l, j)" by fastforce
    assume res_thm2: "effect (res_thm2 a x cli) h h1 ret"
    with x_is have res_thm2': "effect (res_thm2 a (l, j) cli) h h1 ret" by simp
    note step = res_thm2_Inv [OF res_thm2' Cons.prems(2) Cons.prems(3)]
    from step have ret: "correctClause r ret \<and> sorted ret \<and> distinct ret" by simp
    from step Cons.prems(2) have correct_a: "correctArray r a h1"  by simp
    assume foldM: "effect (foldM (res_thm2 a) xs ret) h1 h' rcl"
    from step Cons.hyps [OF foldM correct_a ret] have
    "h = h' \<and> correctClause r rcl \<and> sorted rcl \<and> distinct rcl" by auto
  }
  with Cons show ?case
    unfolding foldM.simps
    by (elim effect_bindE) auto
qed

lemma step_correct2:
  assumes effect: "effect (doProofStep2 a step rcs) h h' res"
  assumes correctArray: "correctArray rcs a h"
  shows "correctArray res a h'"
proof (cases "(a,step,rcs)" rule: doProofStep2.cases)
  case (1 a saveTo i rs rcs)
  with effect correctArray
  show ?thesis
    apply auto
    apply (auto simp: get_clause_def elim!: effect_bindE effect_nthE)
    apply (auto elim!: effect_bindE effect_nthE effect_case_option effect_raiseE
      effect_returnE effect_updE)
    apply (frule foldM_Inv2)
    apply assumption
    apply (simp add: correctArray_def)
    apply (drule_tac x="y" in bspec)
    apply (rule array_ranI[where i=i])
    by (auto intro: correctArray_update)
next
  case (2 a cid rcs)
  with effect correctArray
  show ?thesis
    by (auto simp: correctArray_def elim!: effect_bindE effect_updE effect_returnE
     dest: array_ran_upd_array_None)
next
  case (3 a cid c rcs)
  with effect correctArray
  show ?thesis
    apply (auto elim!: effect_bindE effect_updE effect_returnE)
    apply (auto simp: correctArray_def dest!: array_ran_upd_array_Some)
    apply (auto intro: correctClause_mono)
    by (auto simp: correctClause_def)
next
  case 4
  with effect correctArray
  show ?thesis by (auto elim: effect_raiseE)
next
  case 5
  with effect correctArray
  show ?thesis by (auto elim: effect_raiseE)
qed

theorem fold_steps_correct:
  assumes "effect (foldM (doProofStep2 a) steps rcs) h h' res"
  assumes "correctArray rcs a h"
  shows "correctArray res a h'"
using assms
by (induct steps arbitrary: rcs h h' res)
 (auto elim!: effect_bindE effect_returnE dest:step_correct2)

theorem checker_soundness:
  assumes "effect (checker n p i) h h' cs"
  shows "inconsistent cs"
using assms unfolding checker_def
apply (elim effect_bindE effect_nthE effect_ifE effect_returnE effect_raiseE effect_newE)
prefer 2 apply simp
apply auto
apply (drule fold_steps_correct)
apply (simp add: correctArray_def array_ran_def)
apply (rule implies_empty_inconsistent)
apply (simp add:correctArray_def)
apply (drule bspec)
by (rule array_ranI, auto)

section \<open>Functional version with Lists as Array\<close>

subsection \<open>List specific definitions\<close>

definition list_ran :: "'a option list \<Rightarrow> 'a set"
where
  "list_ran xs = {e. Some e \<in> set xs }"

lemma list_ranI: "\<lbrakk> i < List.length xs; xs ! i = Some b \<rbrakk> \<Longrightarrow> b \<in> list_ran xs"
unfolding list_ran_def by (drule sym, simp)

lemma list_ran_update_Some:
  "cl \<in> list_ran (xs[i := (Some b)]) \<Longrightarrow> cl \<in> list_ran xs \<or> cl = b"
proof -
  assume assms: "cl \<in> list_ran (xs[i := (Some b)])"
  have "set (xs[i := Some b]) \<subseteq> insert (Some b) (set xs)"
    by (simp only: set_update_subset_insert)
  with assms have "Some cl \<in> insert (Some b) (set xs)"
    unfolding list_ran_def by fastforce
  thus ?thesis
    unfolding list_ran_def by auto
qed

lemma list_ran_update_None:
  "cl \<in> list_ran (xs[i := None]) \<Longrightarrow> cl \<in> list_ran xs"
proof -
  assume assms: "cl \<in> list_ran (xs[i := None])"
  have "set (xs[i := None]) \<subseteq> insert None (set xs)"
    by (simp only: set_update_subset_insert)
  with assms show ?thesis
    unfolding list_ran_def by auto
qed

definition correctList :: "Clause list \<Rightarrow> Clause option list \<Rightarrow> bool"
where
  "correctList rootcls xs =
  (\<forall>cl \<in> list_ran xs. correctClause rootcls cl \<and> sorted cl \<and> distinct cl)"

subsection \<open>Checker functions\<close>

primrec lres_thm :: "Clause option list \<Rightarrow> (Lit * ClauseId) \<Rightarrow> Clause \<Rightarrow> Clause Heap"
where
  "lres_thm xs (l, j) cli = (if (j < List.length xs) then (case (xs ! j) of
  None \<Rightarrow> raise STR ''MiniSatChecked.res_thm: No resolvant clause in thms array for Conflict step.''
  | Some clj \<Rightarrow> res_thm' l cli clj
 ) else raise STR ''Error'')"

fun ldoProofStep :: " ProofStep \<Rightarrow> (Clause option list  * Clause list) \<Rightarrow> (Clause option list * Clause list) Heap"
where
  "ldoProofStep (Conflict saveTo (i, rs)) (xs, rcl) =
     (case (xs ! i) of
       None \<Rightarrow> raise STR ''MiniSatChecked.doProofStep: No starting clause in thms array for Conflict step.''
     | Some cli \<Rightarrow> do {
                      result \<leftarrow> foldM (lres_thm xs) rs cli ;
                      return ((xs[saveTo:=Some result]), rcl)
                   })"
| "ldoProofStep (Delete cid) (xs, rcl) = return (xs[cid:=None], rcl)"
| "ldoProofStep (Root cid clause) (xs, rcl) = return (xs[cid:=Some (sort clause)], (remdups(sort clause)) # rcl)"
| "ldoProofStep (Xstep cid1 cid2) (xs, rcl) = raise STR ''MiniSatChecked.doProofStep: Xstep constructor found.''"
| "ldoProofStep (ProofDone b) (xs, rcl) = raise STR ''MiniSatChecked.doProofStep: ProofDone constructor found.''"

definition lchecker :: "nat \<Rightarrow> ProofStep list \<Rightarrow> nat \<Rightarrow> Clause list Heap"
where
  "lchecker n p i =
  do {
     rcs \<leftarrow> foldM (ldoProofStep) p ([], []);
     (if (fst rcs ! i) = Some [] then return (snd rcs)
                else raise STR ''No empty clause'')
  }"

section \<open>Functional version with RedBlackTrees\<close>

primrec tres_thm :: "(ClauseId, Clause) RBT_Impl.rbt \<Rightarrow> Lit \<times> ClauseId \<Rightarrow> Clause \<Rightarrow> Clause Heap"
where
  "tres_thm t (l, j) cli =
  (case (rbt_lookup t j) of
     None \<Rightarrow> raise STR ''MiniSatChecked.res_thm: No resolvant clause in thms array for Conflict step.''
   | Some clj \<Rightarrow> res_thm' l cli clj)"

fun tdoProofStep :: " ProofStep \<Rightarrow> ((ClauseId, Clause) RBT_Impl.rbt * Clause list) \<Rightarrow> ((ClauseId, Clause) RBT_Impl.rbt * Clause list) Heap"
where
  "tdoProofStep (Conflict saveTo (i, rs)) (t, rcl) =
     (case (rbt_lookup t i) of
       None \<Rightarrow> raise STR ''MiniSatChecked.doProofStep: No starting clause in thms array for Conflict step.''
     | Some cli \<Rightarrow> do {
                      result \<leftarrow> foldM (tres_thm t) rs cli;
                      return ((rbt_insert saveTo result t), rcl)
                   })"
| "tdoProofStep (Delete cid) (t, rcl) = return ((rbt_delete cid t), rcl)"
| "tdoProofStep (Root cid clause) (t, rcl) = return (rbt_insert cid (sort clause) t, (remdups(sort clause)) # rcl)"
| "tdoProofStep (Xstep cid1 cid2) (t, rcl) = raise STR ''MiniSatChecked.doProofStep: Xstep constructor found.''"
| "tdoProofStep (ProofDone b) (t, rcl) = raise STR ''MiniSatChecked.doProofStep: ProofDone constructor found.''"

definition tchecker :: "nat \<Rightarrow> ProofStep list \<Rightarrow> nat \<Rightarrow> Clause list Heap"
where
  "tchecker n p i =
  do {
     rcs \<leftarrow> foldM (tdoProofStep) p (RBT_Impl.Empty, []);
     (if (rbt_lookup (fst rcs) i) = Some [] then return (snd rcs)
                else raise STR ''No empty clause'')
  }"

export_code checker tchecker lchecker checking SML

end


(*  Title:      JinjaThreads/Common/BinOp.thy
    Author:     Andreas Lochbihler
*)

section \<open>Binary Operators\<close>

theory BinOp
imports
  WellForm
begin

datatype bop =  \<comment> \<open>names of binary operations\<close>
    Eq
  | NotEq
  | LessThan
  | LessOrEqual
  | GreaterThan
  | GreaterOrEqual
  | Add
  | Subtract
  | Mult
  | Div
  | Mod
  | BinAnd
  | BinOr
  | BinXor
  | ShiftLeft
  | ShiftRightZeros
  | ShiftRightSigned

subsection\<open>The semantics of binary operators\<close>

type_synonym 'addr binop_ret = "'addr val + 'addr" \<comment> \<open>a value or the address of an exception\<close>

fun binop_LessThan :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_LessThan (Intg i1) (Intg i2) = Some (Inl (Bool (i1 <s i2)))"
| "binop_LessThan v1 v2 = None"

fun binop_LessOrEqual :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_LessOrEqual (Intg i1) (Intg i2) = Some (Inl (Bool (i1 <=s i2)))"
| "binop_LessOrEqual v1 v2 = None"

fun binop_GreaterThan :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_GreaterThan (Intg i1) (Intg i2) = Some (Inl (Bool (i2 <s i1)))"
| "binop_GreaterThan v1 v2 = None"

fun binop_GreaterOrEqual :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_GreaterOrEqual (Intg i1) (Intg i2) = Some (Inl (Bool (i2 <=s i1)))"
| "binop_GreaterOrEqual v1 v2 = None"

fun binop_Add :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_Add (Intg i1) (Intg i2) = Some (Inl (Intg (i1 + i2)))"
| "binop_Add v1 v2 = None"

fun binop_Subtract :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_Subtract (Intg i1) (Intg i2) = Some (Inl (Intg (i1 - i2)))"
| "binop_Subtract v1 v2 = None"

fun binop_Mult :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_Mult (Intg i1) (Intg i2) = Some (Inl (Intg (i1 * i2)))"
| "binop_Mult v1 v2 = None"

fun binop_BinAnd :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_BinAnd (Intg i1) (Intg i2) = Some (Inl (Intg (i1 AND i2)))"
| "binop_BinAnd (Bool b1) (Bool b2) = Some (Inl (Bool (b1 \<and> b2)))"
| "binop_BinAnd v1 v2 = None"

fun binop_BinOr :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_BinOr (Intg i1) (Intg i2) = Some (Inl (Intg (i1 OR i2)))"
| "binop_BinOr (Bool b1) (Bool b2) = Some (Inl (Bool (b1 \<or> b2)))"
| "binop_BinOr v1 v2 = None"

fun binop_BinXor :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_BinXor (Intg i1) (Intg i2) = Some (Inl (Intg (i1 XOR i2)))"
| "binop_BinXor (Bool b1) (Bool b2) = Some (Inl (Bool (b1 \<noteq> b2)))"
| "binop_BinXor v1 v2 = None"

fun binop_ShiftLeft :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_ShiftLeft (Intg i1) (Intg i2) = Some (Inl (Intg (i1 << unat (i2 AND 0x1f))))"
| "binop_ShiftLeft v1 v2 = None"

fun binop_ShiftRightZeros :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_ShiftRightZeros (Intg i1) (Intg i2) = Some (Inl (Intg (i1 >> unat (i2 AND 0x1f))))"
| "binop_ShiftRightZeros v1 v2 = None"

fun binop_ShiftRightSigned :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_ShiftRightSigned (Intg i1) (Intg i2) = Some (Inl (Intg (i1 >>> unat (i2 AND 0x1f))))"
| "binop_ShiftRightSigned v1 v2 = None"

text \<open>
  Division on @{typ "'a word"} is unsigned, but JLS specifies signed division.
\<close>
definition word_sdiv :: "'a :: len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixl "sdiv" 70)
where [code]:
  "x sdiv y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0) \<noteq> (y' < 0);
        result = abs x' div abs y'
    in word_of_int (if negative then -result else result))"

definition word_smod :: "'a :: len word \<Rightarrow> 'a word \<Rightarrow> 'a word" (infixl "smod" 70)
where [code]:
  "x smod y =
   (let x' = sint x; y' = sint y;
        negative = (x' < 0);
        result = abs x' mod abs y'
    in word_of_int (if negative then -result else result))"

declare word_sdiv_def [simp] word_smod_def [simp]

lemma sdiv_smod_id: "(a sdiv b) * b + (a smod b) = a"
proof -
  have F5: "\<forall>u::'a word. - (- u) = u" by (metis word_sint.Rep_inverse' minus_minus wi_hom_neg)
  have F7: "\<forall>v u::'a word. u + v = v + u" by(metis add.left_commute add_0_right)
  have F8: "\<forall>(w::'a word) (v::int) u::int. word_of_int u + word_of_int v * w = word_of_int (u + v * sint w)"
    by (metis word_sint.Rep_inverse wi_hom_syms(1) wi_hom_syms(3))
  have "\<exists>u. u = - sint b \<and> word_of_int (sint a mod u + - (- u * (sint a div u))) = a"
    using F5 by (metis minus_minus word_sint.Rep_inverse' mult_minus_left add.commute mult_div_mod_eq [symmetric])
  hence "word_of_int (sint a mod - sint b + - (sint b * (sint a div - sint b))) = a" by (metis equation_minus_iff)
  hence "word_of_int (sint a mod - sint b) + word_of_int (- (sint a div - sint b)) * b = a"
    using F8 by(metis mult.commute mult_minus_left)
  hence eq: "word_of_int (- (sint a div - sint b)) * b + word_of_int (sint a mod - sint b) = a" using F7 by metis

  show ?thesis
  proof(cases "sint a < 0")
    case True note a = this
    show ?thesis
    proof(cases "sint b < 0")
      case True
      with a show ?thesis
        by simp (metis F7 F8 eq minus_equation_iff minus_mult_minus mod_div_mult_eq)
    next
      case False
      from eq have "word_of_int (- (- sint a div sint b)) * b + word_of_int (- (- sint a mod sint b)) = a"
        by (metis div_minus_right mod_minus_right)
      with a False show ?thesis by simp
    qed
  next
    case False note a = this
    show ?thesis
    proof(cases "sint b < 0")
      case True
      with a eq show ?thesis by simp
    next
      case False with a show ?thesis
        by simp (metis wi_hom_add wi_hom_mult add.commute mult.commute word_sint.Rep_inverse add.commute mult_div_mod_eq [symmetric])
    qed
  qed
qed

notepad begin
have  "  5  sdiv ( 3 :: word32) =  1"
  and "  5  smod ( 3 :: word32) =  2"
  and "  5  sdiv (-3 :: word32) = -1"
  and "  5  smod (-3 :: word32) =  2"
  and "(-5) sdiv ( 3 :: word32) = -1"
  and "(-5) smod ( 3 :: word32) = -2"
  and "(-5) sdiv (-3 :: word32) =  1"
  and "(-5) smod (-3 :: word32) = -2"
  and "-2147483648 sdiv 1 = (-2147483648 :: word32)"
  by eval+
end

context heap_base begin

fun binop_Mod :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_Mod (Intg i1) (Intg i2) =
   Some (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg (i1 smod i2)))"
| "binop_Mod v1 v2 = None"

fun binop_Div :: "'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop_Div (Intg i1) (Intg i2) =
   Some (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg (i1 sdiv i2)))"
| "binop_Div v1 v2 = None"

primrec binop :: "bop \<Rightarrow> 'addr val \<Rightarrow> 'addr val \<Rightarrow> 'addr binop_ret option"
where
  "binop Eq v1 v2 =  Some (Inl (Bool (v1 = v2)))"
| "binop NotEq v1 v2 = Some (Inl (Bool (v1 \<noteq> v2)))"
| "binop LessThan = binop_LessThan"
| "binop LessOrEqual = binop_LessOrEqual"
| "binop GreaterThan = binop_GreaterThan"
| "binop GreaterOrEqual = binop_GreaterOrEqual"
| "binop Add = binop_Add"
| "binop Subtract = binop_Subtract"
| "binop Mult = binop_Mult"
| "binop Mod = binop_Mod"
| "binop Div = binop_Div"
| "binop BinAnd = binop_BinAnd"
| "binop BinOr = binop_BinOr"
| "binop BinXor = binop_BinXor"
| "binop ShiftLeft = binop_ShiftLeft"
| "binop ShiftRightZeros = binop_ShiftRightZeros"
| "binop ShiftRightSigned = binop_ShiftRightSigned"

end

lemma [simp]:
  "(binop_LessOrEqual v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Bool (i1 <=s i2)))"
by(cases "(v1, v2)" rule: binop_LessOrEqual.cases) auto

lemma [simp]:
  "(binop_GreaterThan v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Bool (i2 <s i1)))"
by(cases "(v1, v2)" rule: binop_GreaterThan.cases) auto

lemma [simp]:
  "(binop_GreaterOrEqual v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Bool (i2 <=s i1)))"
by(cases "(v1, v2)" rule: binop_GreaterOrEqual.cases) auto

lemma [simp]:
  "(binop_Add v\<^sub>1 v\<^sub>2  = Some va) \<longleftrightarrow>
   (\<exists>i\<^sub>1 i\<^sub>2. v\<^sub>1 = Intg i\<^sub>1 \<and> v\<^sub>2 = Intg i\<^sub>2 \<and> va = Inl (Intg (i\<^sub>1+i\<^sub>2)))"
by(cases "(v\<^sub>1, v\<^sub>2)" rule: binop_Add.cases) auto

lemma [simp]:
  "(binop_Subtract v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 - i2)))"
by(cases "(v1, v2)" rule: binop_Subtract.cases) auto

lemma [simp]:
  "(binop_Mult v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 * i2)))"
by(cases "(v1, v2)" rule: binop_Mult.cases) auto

lemma [simp]:
  "(binop_BinAnd v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>b1 b2. v1 = Bool b1 \<and> v2 = Bool b2 \<and> va = Inl (Bool (b1 \<and> b2))) \<or>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 AND i2)))"
by(cases "(v1, v2)" rule: binop_BinAnd.cases) auto

lemma [simp]:
  "(binop_BinOr v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>b1 b2. v1 = Bool b1 \<and> v2 = Bool b2 \<and> va = Inl (Bool (b1 \<or> b2))) \<or>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 OR i2)))"
by(cases "(v1, v2)" rule: binop_BinOr.cases) auto

lemma [simp]:
  "(binop_BinXor v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>b1 b2. v1 = Bool b1 \<and> v2 = Bool b2 \<and> va = Inl (Bool (b1 \<noteq> b2))) \<or>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 XOR i2)))"
by(cases "(v1, v2)" rule: binop_BinXor.cases) auto

lemma [simp]:
  "(binop_ShiftLeft v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 << unat (i2 AND 0x1f))))"
by(cases "(v1, v2)" rule: binop_ShiftLeft.cases) auto

lemma [simp]:
  "(binop_ShiftRightZeros v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 >> unat (i2 AND 0x1f))))"
by(cases "(v1, v2)" rule: binop_ShiftRightZeros.cases) auto

lemma [simp]:
  "(binop_ShiftRightSigned v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and> va = Inl (Intg (i1 >>> unat (i2 AND 0x1f))))"
by(cases "(v1, v2)" rule: binop_ShiftRightSigned.cases) auto

context heap_base begin

lemma [simp]:
  "(binop_Mod v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and>
      va = (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg(i1 smod i2))))"
by(cases "(v1, v2)" rule: binop_Mod.cases) auto

lemma [simp]:
  "(binop_Div v1 v2 = Some va) \<longleftrightarrow>
   (\<exists>i1 i2. v1 = Intg i1 \<and> v2 = Intg i2 \<and>
      va = (if i2 = 0 then Inr (addr_of_sys_xcpt ArithmeticException) else Inl (Intg(i1 sdiv i2))))"
by(cases "(v1, v2)" rule: binop_Div.cases) auto

end

subsection \<open>Typing for binary operators\<close>

inductive WT_binop :: "'m prog \<Rightarrow> ty \<Rightarrow> bop \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _\<guillemotleft>_\<guillemotright>_ :: _" [51,0,0,0,51] 50)
where
  WT_binop_Eq:
  "P \<turnstile> T1 \<le> T2 \<or> P \<turnstile> T2 \<le> T1 \<Longrightarrow> P \<turnstile> T1\<guillemotleft>Eq\<guillemotright>T2 :: Boolean"

| WT_binop_NotEq:
  "P \<turnstile> T1 \<le> T2 \<or> P \<turnstile> T2 \<le> T1 \<Longrightarrow> P \<turnstile> T1\<guillemotleft>NotEq\<guillemotright>T2 :: Boolean"

| WT_binop_LessThan:
  "P \<turnstile> Integer\<guillemotleft>LessThan\<guillemotright>Integer :: Boolean"

| WT_binop_LessOrEqual:
  "P \<turnstile> Integer\<guillemotleft>LessOrEqual\<guillemotright>Integer :: Boolean"

| WT_binop_GreaterThan:
  "P \<turnstile> Integer\<guillemotleft>GreaterThan\<guillemotright>Integer :: Boolean"

| WT_binop_GreaterOrEqual:
  "P \<turnstile> Integer\<guillemotleft>GreaterOrEqual\<guillemotright>Integer :: Boolean"

| WT_binop_Add:
  "P \<turnstile> Integer\<guillemotleft>Add\<guillemotright>Integer :: Integer"

| WT_binop_Subtract:
  "P \<turnstile> Integer\<guillemotleft>Subtract\<guillemotright>Integer :: Integer"

| WT_binop_Mult:
  "P \<turnstile> Integer\<guillemotleft>Mult\<guillemotright>Integer :: Integer"

| WT_binop_Div:
  "P \<turnstile> Integer\<guillemotleft>Div\<guillemotright>Integer :: Integer"

| WT_binop_Mod:
  "P \<turnstile> Integer\<guillemotleft>Mod\<guillemotright>Integer :: Integer"

| WT_binop_BinAnd_Bool:
  "P \<turnstile> Boolean\<guillemotleft>BinAnd\<guillemotright>Boolean :: Boolean"

| WT_binop_BinAnd_Int:
  "P \<turnstile> Integer\<guillemotleft>BinAnd\<guillemotright>Integer :: Integer"

| WT_binop_BinOr_Bool:
  "P \<turnstile> Boolean\<guillemotleft>BinOr\<guillemotright>Boolean :: Boolean"

| WT_binop_BinOr_Int:
  "P \<turnstile> Integer\<guillemotleft>BinOr\<guillemotright>Integer :: Integer"

| WT_binop_BinXor_Bool:
  "P \<turnstile> Boolean\<guillemotleft>BinXor\<guillemotright>Boolean :: Boolean"

| WT_binop_BinXor_Int:
  "P \<turnstile> Integer\<guillemotleft>BinXor\<guillemotright>Integer :: Integer"

| WT_binop_ShiftLeft:
  "P \<turnstile> Integer\<guillemotleft>ShiftLeft\<guillemotright>Integer :: Integer"

| WT_binop_ShiftRightZeros:
  "P \<turnstile> Integer\<guillemotleft>ShiftRightZeros\<guillemotright>Integer :: Integer"

| WT_binop_ShiftRightSigned:
  "P \<turnstile> Integer\<guillemotleft>ShiftRightSigned\<guillemotright>Integer :: Integer"

lemma WT_binopI [intro]:
  "P \<turnstile> T1 \<le> T2 \<or> P \<turnstile> T2 \<le> T1 \<Longrightarrow> P \<turnstile> T1\<guillemotleft>Eq\<guillemotright>T2 :: Boolean"
  "P \<turnstile> T1 \<le> T2 \<or> P \<turnstile> T2 \<le> T1 \<Longrightarrow> P \<turnstile> T1\<guillemotleft>NotEq\<guillemotright>T2 :: Boolean"
  "bop = Add \<or> bop = Subtract \<or> bop = Mult \<or> bop = Mod \<or> bop = Div \<or> bop = BinAnd \<or> bop = BinOr \<or> bop = BinXor \<or>
   bop = ShiftLeft \<or> bop = ShiftRightZeros \<or> bop = ShiftRightSigned
   \<Longrightarrow> P \<turnstile> Integer\<guillemotleft>bop\<guillemotright>Integer :: Integer"
  "bop = LessThan \<or> bop = LessOrEqual \<or> bop = GreaterThan \<or> bop = GreaterOrEqual \<Longrightarrow> P \<turnstile> Integer\<guillemotleft>bop\<guillemotright>Integer :: Boolean"
  "bop = BinAnd \<or> bop = BinOr \<or> bop = BinXor \<Longrightarrow> P \<turnstile> Boolean\<guillemotleft>bop\<guillemotright>Boolean :: Boolean"
by(auto intro: WT_binop.intros)

inductive_cases [elim]:
  "P \<turnstile> T1\<guillemotleft>Eq\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>NotEq\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>LessThan\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>LessOrEqual\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>GreaterThan\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>GreaterOrEqual\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>Add\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>Subtract\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>Mult\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>Div\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>Mod\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>BinAnd\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>BinOr\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>BinXor\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>ShiftLeft\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>ShiftRightZeros\<guillemotright>T2 :: T"
  "P \<turnstile> T1\<guillemotleft>ShiftRightSigned\<guillemotright>T2 :: T"

lemma WT_binop_fun: "\<lbrakk> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 :: T; P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 :: T' \<rbrakk> \<Longrightarrow> T = T'"
by(cases bop)(auto)

lemma WT_binop_is_type:
  "\<lbrakk> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 :: T; is_type P T1; is_type P T2 \<rbrakk> \<Longrightarrow> is_type P T"
by(cases bop) auto

inductive WTrt_binop :: "'m prog \<Rightarrow> ty \<Rightarrow> bop \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _\<guillemotleft>_\<guillemotright>_ : _" [51,0,0,0,51] 50)
where
  WTrt_binop_Eq:
  "P \<turnstile> T1\<guillemotleft>Eq\<guillemotright>T2 : Boolean"

| WTrt_binop_NotEq:
  "P \<turnstile> T1\<guillemotleft>NotEq\<guillemotright>T2 : Boolean"

| WTrt_binop_LessThan:
  "P \<turnstile> Integer\<guillemotleft>LessThan\<guillemotright>Integer : Boolean"

| WTrt_binop_LessOrEqual:
  "P \<turnstile> Integer\<guillemotleft>LessOrEqual\<guillemotright>Integer : Boolean"

| WTrt_binop_GreaterThan:
  "P \<turnstile> Integer\<guillemotleft>GreaterThan\<guillemotright>Integer : Boolean"

| WTrt_binop_GreaterOrEqual:
  "P \<turnstile> Integer\<guillemotleft>GreaterOrEqual\<guillemotright>Integer : Boolean"

| WTrt_binop_Add:
  "P \<turnstile> Integer\<guillemotleft>Add\<guillemotright>Integer : Integer"

| WTrt_binop_Subtract:
  "P \<turnstile> Integer\<guillemotleft>Subtract\<guillemotright>Integer : Integer"

| WTrt_binop_Mult:
  "P \<turnstile> Integer\<guillemotleft>Mult\<guillemotright>Integer : Integer"

| WTrt_binop_Div:
  "P \<turnstile> Integer\<guillemotleft>Div\<guillemotright>Integer : Integer"

| WTrt_binop_Mod:
  "P \<turnstile> Integer\<guillemotleft>Mod\<guillemotright>Integer : Integer"

| WTrt_binop_BinAnd_Bool:
  "P \<turnstile> Boolean\<guillemotleft>BinAnd\<guillemotright>Boolean : Boolean"

| WTrt_binop_BinAnd_Int:
  "P \<turnstile> Integer\<guillemotleft>BinAnd\<guillemotright>Integer : Integer"

| WTrt_binop_BinOr_Bool:
  "P \<turnstile> Boolean\<guillemotleft>BinOr\<guillemotright>Boolean : Boolean"

| WTrt_binop_BinOr_Int:
  "P \<turnstile> Integer\<guillemotleft>BinOr\<guillemotright>Integer : Integer"

| WTrt_binop_BinXor_Bool:
  "P \<turnstile> Boolean\<guillemotleft>BinXor\<guillemotright>Boolean : Boolean"

| WTrt_binop_BinXor_Int:
  "P \<turnstile> Integer\<guillemotleft>BinXor\<guillemotright>Integer : Integer"

| WTrt_binop_ShiftLeft:
  "P \<turnstile> Integer\<guillemotleft>ShiftLeft\<guillemotright>Integer : Integer"

| WTrt_binop_ShiftRightZeros:
  "P \<turnstile> Integer\<guillemotleft>ShiftRightZeros\<guillemotright>Integer : Integer"

| WTrt_binop_ShiftRightSigned:
  "P \<turnstile> Integer\<guillemotleft>ShiftRightSigned\<guillemotright>Integer : Integer"

inductive_cases WTrt_binop_cases [elim]:
  "P \<turnstile> T1\<guillemotleft>Eq\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>NotEq\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>LessThan\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>LessOrEqual\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>GreaterThan\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>GreaterOrEqual\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Add\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Subtract\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Mult\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Div\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Mod\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>BinAnd\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>BinOr\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>BinXor\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>ShiftLeft\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>ShiftRightZeros\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>ShiftRightSigned\<guillemotright>T2 : T"

inductive_simps WTrt_binop_simps [simp]:
  "P \<turnstile> T1\<guillemotleft>Eq\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>NotEq\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>LessThan\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>LessOrEqual\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>GreaterThan\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>GreaterOrEqual\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Add\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Subtract\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Mult\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Div\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>Mod\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>BinAnd\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>BinOr\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>BinXor\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>ShiftLeft\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>ShiftRightZeros\<guillemotright>T2 : T"
  "P \<turnstile> T1\<guillemotleft>ShiftRightSigned\<guillemotright>T2 : T"

fun binop_relevant_class :: "bop \<Rightarrow> 'm prog \<Rightarrow> cname \<Rightarrow> bool"
where
  "binop_relevant_class Div = (\<lambda>P C. P \<turnstile> ArithmeticException \<preceq>\<^sup>* C )"
| "binop_relevant_class Mod = (\<lambda>P C. P \<turnstile> ArithmeticException \<preceq>\<^sup>* C )"
| "binop_relevant_class _ = (\<lambda>P C. False)"

lemma WT_binop_WTrt_binop:
  "P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 :: T \<Longrightarrow> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T"
by(auto elim: WT_binop.cases)

context heap begin

lemma binop_progress:
  "\<lbrakk> typeof\<^bsub>h\<^esub> v1 = \<lfloor>T1\<rfloor>; typeof\<^bsub>h\<^esub> v2 = \<lfloor>T2\<rfloor>; P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T \<rbrakk>
  \<Longrightarrow> \<exists>va. binop bop v1 v2 = \<lfloor>va\<rfloor>"
by(cases bop)(auto del: disjCI split del: if_split)

lemma binop_type:
  assumes wf: "wf_prog wf_md P"
  and pre: "preallocated h"
  and type: "typeof\<^bsub>h\<^esub> v1 = \<lfloor>T1\<rfloor>" "typeof\<^bsub>h\<^esub> v2 = \<lfloor>T2\<rfloor>" "P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T"
  shows "binop bop v1 v2 = \<lfloor>Inl v\<rfloor> \<Longrightarrow> P,h \<turnstile> v :\<le> T"
  and "binop bop v1 v2 = \<lfloor>Inr a\<rfloor> \<Longrightarrow> P,h \<turnstile> Addr a :\<le> Class Throwable"
using type
apply(case_tac [!] bop)
apply(auto split: if_split_asm simp add: conf_def wf_preallocatedD[OF wf pre])
done

lemma binop_relevant_class:
  assumes wf: "wf_prog wf_md P"
  and pre: "preallocated h"
  and bop: "binop bop v1 v2 = \<lfloor>Inr a\<rfloor>"
  and sup: "P \<turnstile> cname_of h a \<preceq>\<^sup>* C"
  shows "binop_relevant_class bop P C"
using assms
by(cases bop)(auto split: if_split_asm)

end

lemma WTrt_binop_fun: "\<lbrakk> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T; P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T' \<rbrakk> \<Longrightarrow> T = T'"
by(cases bop)(auto)

lemma WTrt_binop_THE [simp]: "P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T \<Longrightarrow> The (WTrt_binop P T1 bop T2) = T"
by(auto dest: WTrt_binop_fun)

lemma WTrt_binop_widen_mono:
  "\<lbrakk> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T; P \<turnstile> T1' \<le> T1; P \<turnstile> T2' \<le> T2 \<rbrakk> \<Longrightarrow> \<exists>T'. P \<turnstile> T1'\<guillemotleft>bop\<guillemotright>T2' : T' \<and> P \<turnstile> T' \<le> T"
by(cases bop)(auto elim!: WTrt_binop_cases)

lemma WTrt_binop_is_type:
  "\<lbrakk> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T; is_type P T1; is_type P T2 \<rbrakk> \<Longrightarrow> is_type P T"
by(cases bop) auto

subsection \<open>Code generator setup\<close>

lemmas [code] =
  heap_base.binop_Div.simps
  heap_base.binop_Mod.simps
  heap_base.binop.simps

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  WT_binop
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  WTrt_binop
.

lemma eval_WTrt_binop_i_i_i_i_o:
  "Predicate.eval (WTrt_binop_i_i_i_i_o P T1 bop T2) T \<longleftrightarrow> P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T"
by(auto elim: WTrt_binop_i_i_i_i_oE intro: WTrt_binop_i_i_i_i_oI)

lemma the_WTrt_binop_code:
  "(THE T. P \<turnstile> T1\<guillemotleft>bop\<guillemotright>T2 : T) = Predicate.the (WTrt_binop_i_i_i_i_o P T1 bop T2)"
by(simp add: Predicate.the_def eval_WTrt_binop_i_i_i_i_o)

end


(*
Copyright 2009-2014 Christian Sternagel, René Thiemann

This file is part of IsaFoR/CeTA.

IsaFoR/CeTA is free software: you can redistribute it and/or modify it under the
terms of the GNU Lesser General Public License as published by the Free Software
Foundation, either version 3 of the License, or (at your option) any later
version.

IsaFoR/CeTA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE.  See the GNU Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public License along
with IsaFoR/CeTA. If not, see <http://www.gnu.org/licenses/>.
*)

section {* Instances of the Show Class for Standard Types *}

theory Old_Show_Instances
imports
  Old_Show_Generator
  "~~/src/HOL/Rat"
begin

text {*
  For several types, we just derive the show function.
*}

derive "show" bool option sum

text {*
  The derive-command is not used for @{type unit}, @{type prod}, and numbers: for @{type unit} and
  @{type prod}, we do not want to display ``Unity'' and ``Pair''; for @{type nat}, we do not want to
  display ``Suc (Suc ... Suc (0))''; and neither @{type int} nor @{type rat} are datatypes.
*}

instantiation unit :: "show"
begin

definition "shows_prec d (x::unit) = shows_string ''()''"

lemma assoc_unit:
  "shows_prec d (x::unit) r @ s = shows_prec d x (r @ s)"
  by (simp add: shows_prec_unit_def)

standard_shows_list assoc_unit

end

instantiation prod :: ("show", "show") "show"
begin

definition "shows_prec d (p :: 'a \<times> 'b) = shows_paren (shows (fst p) +@+ '','' +#+ shows (snd p))"

lemma assoc_prod:
  "shows_prec d (p::('a::show \<times> 'b::show)) r @ s = shows_prec d p (r @ s)"
  by (cases p) (simp add: shows_prec_prod_def show_defs)

standard_shows_list assoc_prod

end

instantiation nat :: "show"
begin

fun
  digit2string :: "nat \<Rightarrow> string"
where
  "digit2string n = (
    if n = 0 then ''0''
    else if n = 1 then ''1''
    else if n = 2 then ''2''
    else if n = 3 then ''3''
    else if n = 4 then ''4''
    else if n = 5 then ''5''
    else if n = 6 then ''6''
    else if n = 7 then ''7''
    else if n = 8 then ''8''
    else ''9'')"

fun shows_nat :: "nat \<Rightarrow> shows"
where
  "shows_nat (n::nat) = (
    if n < 10 then shows_string (digit2string n)
    else shows_nat (n div 10) \<circ> shows_string (digit2string (n mod 10)))"

definition "shows_prec (d::nat) (n::nat) = shows_nat n"

lemma assoc_nat: "shows_prec d (n::nat) r @ s = shows_prec d n (r @ s)"
proof (induct n arbitrary: r s rule: nat_less_induct)
  case (1 n)
  show ?case
  proof (cases "n < 10")
    case True thus ?thesis unfolding shows_prec_nat_def by simp
  next
    let ?m = "n div 10"
    case False
    hence "?m < n" by simp
    with 1 have "\<And>s t. shows_prec d ?m s @ t = shows_prec d ?m (s @ t)" by simp
    thus ?thesis unfolding shows_prec_nat_def by auto
  qed
qed

standard_shows_list assoc_nat

end

instantiation int :: "show"
begin

definition "shows_prec (d::nat) (i::int) = (
  if i < 0 then shows (CHR ''-'') \<circ> shows (nat (- i))
  else shows (nat i))"

lemma assoc_int:
  "shows_prec d (i::int) r @ s = shows_prec d i (r @ s)"
  by (simp add: shows_prec_int_def)

standard_shows_list assoc_int

end

instantiation rat :: "show"
begin

definition "shows_prec (d::nat) (x::rat) =
  (case quotient_of x of
    Pair den num \<Rightarrow>
    if num = 1 then shows den else shows den \<circ> shows (CHR ''/'') \<circ> shows num)"

lemma assoc_rat:
  "shows_prec d (x::rat) r @ s = shows_prec d x (r @ s)"
  unfolding shows_prec_rat_def by (cases "quotient_of x") auto

standard_shows_list assoc_rat

end

end


section \<open>Distributivity and Factorisability\<close>

text \<open>This section corresponds to Section 2.4 and Figure 4 of the paper~\<^cite>\<open>"UnboundedSL"\<close>.\<close>

theory Distributivity
  imports UnboundedLogic
begin

context logic
begin

subsection DotPos

lemma DotPos:
  "A, \<Delta> \<turnstile> B \<longleftrightarrow> (Mult \<pi> A, \<Delta> \<turnstile> Mult \<pi> B)" (is "?A \<longleftrightarrow> ?B")
proof
  show "?A \<Longrightarrow> ?B"
    by (metis (no_types, lifting) entails_def sat.simps(1))
  show "?B \<Longrightarrow> ?A"
    using can_divide entails_def sat.simps(1)
    by metis
qed

text \<open>Only one direction holds with a wildcard\<close>

lemma WildPos:
  "A, \<Delta> \<turnstile> B \<Longrightarrow> (Wildcard A, \<Delta> \<turnstile> Wildcard B)"
  by (metis (no_types, lifting) entails_def sat.simps(12))

subsection DotDot

lemma dot_mult1:
  "Mult p (Mult q A), \<Delta> \<turnstile> Mult (smult p q) A"
proof (rule entailsI)
  fix \<sigma> s
  assume "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Mult q A)"
  then show "\<sigma>, s, \<Delta> \<Turnstile> Mult (smult p q) A"
    using double_mult by auto
qed

lemma dot_mult2:
  "Mult (smult p q) A, \<Delta> \<turnstile> Mult p (Mult q A)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> Mult (smult p q) A"
  then obtain a where "a, s, \<Delta> \<Turnstile> A" "\<sigma> = (smult p q) \<odot> a"
    by auto
  then have "q \<odot> a, s, \<Delta> \<Turnstile> Mult q A" by auto
  then show "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Mult q A)"
    by (metis \<open>\<sigma> = smult p q \<odot> a\<close> double_mult sat.simps(1))
qed

lemma DotDot:
  "Mult p (Mult q A), \<Delta> \<equiv> Mult (smult p q) A"
  by (simp add: dot_mult1 dot_mult2 equivalent_def)

lemma can_factorize:
  "\<exists>r. q = smult r p"
  by (metis sinv_inverse smult_asso smult_comm sone_neutral)

lemma WildDot:
  "Wildcard (Mult p A), \<Delta> \<equiv> Wildcard A"
proof (rule equivalentI)
  show "\<And>\<sigma> s. \<sigma>, s, \<Delta> \<Turnstile> Wildcard (Mult p A) \<Longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> Wildcard A"
    using double_mult by fastforce
  fix \<sigma> s
  assume asm0: "\<sigma>, s, \<Delta> \<Turnstile> Wildcard A"
  then obtain q a where "\<sigma> = q \<odot> a" "a, s, \<Delta> \<Turnstile> A"
    using sat.simps(12) by blast
  then obtain r where "q = smult r p"
    using can_factorize by blast
  then have "\<sigma> = r \<odot> (p \<odot> a)"
    by (simp add: \<open>\<sigma> = q \<odot> a\<close> double_mult)
  then show "\<sigma>, s, \<Delta> \<Turnstile> Wildcard (Mult p A)"
    using \<open>a, s, \<Delta> \<Turnstile> A\<close> sat.simps(1) sat.simps(12) by blast
qed

lemma DotWild:
  "Mult p (Wildcard A), \<Delta> \<equiv> Wildcard A"
proof (rule equivalentI)
  show "\<And>\<sigma> s. \<sigma>, s, \<Delta> \<Turnstile> Mult p (Wildcard A) \<Longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> Wildcard A"
    using double_mult by fastforce
  fix \<sigma> s
  assume asm0: "\<sigma>, s, \<Delta> \<Turnstile> Wildcard A"
  then obtain q a where "\<sigma> = q \<odot> a" "a, s, \<Delta> \<Turnstile> A"
    by force
  then obtain r where "q = smult p r"
    using can_factorize smult_comm by presburger
  then have "\<sigma> = p \<odot> (r \<odot> a)"
    by (simp add: \<open>\<sigma> = q \<odot> a\<close> double_mult)
  then show "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Wildcard A)"
    using \<open>a, s, \<Delta> \<Turnstile> A\<close> by auto
qed

lemma WildWild:
  "Wildcard (Wildcard A), \<Delta> \<equiv> Wildcard A"
proof (rule equivalentI)
  show "\<And>\<sigma> s. \<sigma>, s, \<Delta> \<Turnstile> Wildcard (Wildcard A) \<Longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> Wildcard A"
    using double_mult by fastforce
  show "\<And>\<sigma> s. \<sigma>, s, \<Delta> \<Turnstile> Wildcard A \<Longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> Wildcard (Wildcard A)"
    by (metis one_neutral sat.simps(12))
qed

subsection DotStar

lemma dot_star1:
  "Mult p (Star A B), \<Delta> \<turnstile> Star (Mult p A) (Mult p B)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Star A B)"
  then obtain a b x where "\<sigma> = p \<odot> x" "Some x = a \<oplus> b" "a, s, \<Delta> \<Turnstile> A" "b, s, \<Delta> \<Turnstile> B"
    by auto
  then show "\<sigma>, s, \<Delta> \<Turnstile> Star (Mult p A) (Mult p B)"
    using plus_mult by auto
qed

lemma dot_star2:
  "Star (Mult p A) (Mult p B), \<Delta> \<turnstile> Mult p (Star A B)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> Star (Mult p A) (Mult p B)"
  then obtain a b where "Some \<sigma> = (p \<odot> a) \<oplus> (p \<odot> b)" "a, s, \<Delta> \<Turnstile> A" "b, s, \<Delta> \<Turnstile> B"
    by auto
  then obtain x where "Some x = a \<oplus> b"
    by (metis plus_mult unique_inv)
  then have "\<sigma> = p \<odot> x"
    by (metis \<open>Some \<sigma> = p \<odot> a \<oplus> p \<odot> b\<close> option.sel plus_mult)
  then show "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Star A B)"
    using \<open>Some x = a \<oplus> b\<close> \<open>a, s, \<Delta> \<Turnstile> A\<close> \<open>b, s, \<Delta> \<Turnstile> B\<close> by auto
qed

lemma DotStar:
  "Mult p (Star A B), \<Delta> \<equiv> Star (Mult p A) (Mult p B)"
  by (simp add: dot_star1 dot_star2 equivalent_def)

lemma WildStar1:
  "Wildcard (Star A B), \<Delta> \<turnstile> Star (Wildcard A) (Wildcard B)"
proof (rule entailsI)
  fix \<sigma> s assume asm0: "\<sigma>, s, \<Delta> \<Turnstile> Wildcard (Star A B)"
  then obtain p ab a b where "\<sigma> = p \<odot> ab" "Some ab = a \<oplus> b" "a, s, \<Delta> \<Turnstile> A" "b, s, \<Delta> \<Turnstile> B"
    by auto
  then have "Some \<sigma> = (p \<odot> a) \<oplus> (p \<odot> b)"
    using plus_mult by blast
  then show "\<sigma>, s, \<Delta> \<Turnstile> Star (Wildcard A) (Wildcard B)"
    using \<open>a, s, \<Delta> \<Turnstile> A\<close> \<open>b, s, \<Delta> \<Turnstile> B\<close> by auto
qed

subsection DotWand

lemma dot_wand1:
  "Mult p (Wand A B), \<Delta> \<turnstile> Wand (Mult p A) (Mult p B)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Wand A B)"
  then obtain x where "\<sigma> = p \<odot> x" "x, s, \<Delta> \<Turnstile> Wand A B"
    by auto
  show "\<sigma>, s, \<Delta> \<Turnstile> Wand (Mult p A) (Mult p B)"
  proof (rule sat_wand)
    fix a \<sigma>'
    assume "a, s, \<Delta> \<Turnstile> Mult p A \<and> Some \<sigma>' = \<sigma> \<oplus> a"
    then obtain aa where "aa, s, \<Delta> \<Turnstile> A" "a = p \<odot> aa"
      by auto
    then obtain b where "Some b = x \<oplus> aa"
      by (metis \<open>\<sigma> = p \<odot> x\<close> \<open>a, s, \<Delta> \<Turnstile> Mult p A \<and> Some \<sigma>' = \<sigma> \<oplus> a\<close> compatible_def compatible_iff option.exhaust_sel)
    then have "b, s, \<Delta> \<Turnstile> B"
      using \<open>aa, s, \<Delta> \<Turnstile> A\<close> \<open>x, s, \<Delta> \<Turnstile> Wand A B\<close> by auto
    then show "\<sigma>', s, \<Delta> \<Turnstile> Mult p B"
      by (metis \<open>Some b = x \<oplus> aa\<close> \<open>\<sigma> = p \<odot> x\<close> \<open>a = p \<odot> aa\<close> \<open>a, s, \<Delta> \<Turnstile> Mult p A \<and> Some \<sigma>' = \<sigma> \<oplus> a\<close> can_divide option.inject plus_mult sat_mult)
  qed
qed

lemma dot_wand2:
  "Wand (Mult p A) (Mult p B), \<Delta> \<turnstile> Mult p (Wand A B)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume asm: "\<sigma>, s, \<Delta> \<Turnstile> Wand (Mult p A) (Mult p B)"
  show "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Wand A B)"
  proof (rule sat_mult)
    fix a assume "\<sigma> = p \<odot> a"
    show "a, s, \<Delta> \<Turnstile> Wand A B"
    proof (rule sat_wand)
      fix aa \<sigma>'
      assume "aa, s, \<Delta> \<Turnstile> A \<and> Some \<sigma>' = a \<oplus> aa"
      then have "p \<odot> aa, s, \<Delta> \<Turnstile> Mult p A" by auto
      then have "Some (p \<odot> \<sigma>') = \<sigma> \<oplus> p \<odot> aa"
        by (simp add: \<open>\<sigma> = p \<odot> a\<close> \<open>aa, s, \<Delta> \<Turnstile> A \<and> Some \<sigma>' = a \<oplus> aa\<close> plus_mult)
      then have "p \<odot> \<sigma>', s, \<Delta> \<Turnstile> Mult p B"
        using \<open>p \<odot> aa, s, \<Delta> \<Turnstile> Mult p A\<close> asm by force
      then show "\<sigma>', s, \<Delta> \<Turnstile> B"
        by (metis can_divide sat.simps(1))
    qed
  qed
qed

lemma DotWand:
  "Mult p (Wand A B), \<Delta> \<equiv> Wand (Mult p A) (Mult p B)"
  by (simp add: dot_wand1 dot_wand2 equivalent_def)

(* Again: Need intuitionism
lemma WildWand:
  "Wildcard (Wand A B), \<Delta> \<turnstile> Wand (Wildcard A) (Wildcard B)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> Wildcard (Wand A B)"
  then obtain x p where "\<sigma> = p \<odot> x" "x, s, \<Delta> \<Turnstile> Wand A B"
    by auto
  show "\<sigma>, s, \<Delta> \<Turnstile> Wand (Wildcard A) (Wildcard B)"
  proof (rule sat_wand)
    fix a \<sigma>'
    assume "a, s, \<Delta> \<Turnstile> Wildcard A \<and> Some \<sigma>' = \<sigma> \<oplus> a"
    then obtain aa q where "aa, s, \<Delta> \<Turnstile> A" "a = q \<odot> aa"
      by auto
    then obtain b where "Some b = x \<oplus> aa"
      by (metis \<open>\<sigma> = p \<odot> x\<close> \<open>a, s, \<Delta> \<Turnstile> Wildcard A \<and> Some \<sigma>' = \<sigma> \<oplus> a\<close> compatible_def compatible_multiples not_None_eq)

    then have "b, s, \<Delta> \<Turnstile> B"
      using \<open>aa, s, \<Delta> \<Turnstile> A\<close> \<open>x, s, \<Delta> \<Turnstile> Wand A B\<close> by auto

    then show "\<sigma>', s, \<Delta> \<Turnstile> Wildcard B"

      by (metis \<open>Some b = x \<oplus> aa\<close> \<open>\<sigma> = p \<odot> x\<close> \<open>a = p \<odot> aa\<close> \<open>a, s, \<Delta> \<Turnstile> Mult p A \<and> Some \<sigma>' = \<sigma> \<oplus> a\<close> can_divide option.inject plus_mult sat_mult)
  qed
qed

*)

subsection DotOr

lemma dot_or1:
  "Mult p (Or A B), \<Delta> \<turnstile> Or (Mult p A) (Mult p B)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Or A B)"
  then obtain x where "\<sigma> = p \<odot> x" "x, s, \<Delta> \<Turnstile> A \<or> x, s, \<Delta> \<Turnstile> B"
    by auto
  then show "\<sigma>, s, \<Delta> \<Turnstile> Or (Mult p A) (Mult p B)"
  proof (cases "x, s, \<Delta> \<Turnstile> A")
    case True
    then show ?thesis
      using \<open>\<sigma> = p \<odot> x\<close> by auto
  next
    case False
    then show ?thesis
      using \<open>\<sigma> = p \<odot> x\<close> \<open>x, s, \<Delta> \<Turnstile> A \<or> x, s, \<Delta> \<Turnstile> B\<close> by auto
  qed
qed

lemma dot_or2:
  "Or (Mult p A) (Mult p B), \<Delta> \<turnstile> Mult p (Or A B)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> Or (Mult p A) (Mult p B)"
  then show "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Or A B)"
  proof (cases "\<sigma>, s, \<Delta> \<Turnstile> Mult p A")
    case True
    then show ?thesis by auto
  next
    case False
    then show ?thesis
      using \<open>\<sigma>, s, \<Delta> \<Turnstile> Or (Mult p A) (Mult p B)\<close> by auto
  qed
qed

lemma DotOr:
  "Mult p (Or A B), \<Delta> \<equiv> Or (Mult p A) (Mult p B)"
  by (simp add: dot_or1 dot_or2 equivalent_def)

lemma WildOr:
  "Wildcard (Or A B), \<Delta> \<equiv> Or (Wildcard A) (Wildcard B)"
proof (rule equivalentI)
  show "\<And>\<sigma> s. \<sigma>, s, \<Delta> \<Turnstile> Wildcard (Or A B) \<Longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> Or (Wildcard A) (Wildcard B)"
    by auto
  show "\<And>\<sigma> s. \<sigma>, s, \<Delta> \<Turnstile> Or (Wildcard A) (Wildcard B) \<Longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> Wildcard (Or A B)"
    by auto
qed

subsection DotAnd

lemma dot_and1:
  "Mult p (And A B), \<Delta> \<turnstile> And (Mult p A) (Mult p B)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> Mult p (And A B)"
  then obtain x where "\<sigma> = p \<odot> x" "x, s, \<Delta> \<Turnstile> A" "x, s, \<Delta> \<Turnstile> B"
    by auto
  then show "\<sigma>, s, \<Delta> \<Turnstile> And (Mult p A) (Mult p B)"
    by auto
qed

lemma dot_and2:
  "And (Mult p A) (Mult p B), \<Delta> \<turnstile> Mult p (And A B)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> And (Mult p A) (Mult p B)"
  then show "\<sigma>, s, \<Delta> \<Turnstile> Mult p (And A B)"
    using logic.can_divide logic_axioms by fastforce
qed

lemma DotAnd:
  "And (Mult p A) (Mult p B), \<Delta> \<equiv> Mult p (And A B)"
  by (simp add: dot_and1 dot_and2 equivalent_def)

lemma WildAnd:
  "Wildcard (And A B), \<Delta> \<turnstile> And (Wildcard A) (Wildcard B)"
  using entails_def by fastforce

subsection DotImp

lemma dot_imp1:
  "Imp (Mult p A) (Mult p B), \<Delta> \<turnstile> Mult p (Imp A B)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> Imp (Mult p A) (Mult p B)"
  then show "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Imp A B)"
    using sat_mult by force
qed

lemma dot_imp2:
  "Mult p (Imp A B), \<Delta> \<turnstile> Imp (Mult p A) (Mult p B)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Imp A B)"
  then show "\<sigma>, s, \<Delta> \<Turnstile> Imp (Mult p A) (Mult p B)"
    using can_divide by auto
qed

lemma DotImp:
  "Mult p (Imp A B), \<Delta> \<equiv> Imp (Mult p A) (Mult p B)"
  by (simp add: dot_imp1 dot_imp2 equivalent_def)

subsection DotPure

lemma pure_mult1:
  assumes "pure A"
  shows "Mult p A, \<Delta> \<turnstile> A"
  using assms entails_def logic.pure_def logic_axioms by fastforce

lemma pure_mult2:
  assumes "pure A"
  shows "A, \<Delta> \<turnstile> Mult p A"
    using assms entailsI pure_def sat_mult
    by metis

lemma DotPure:
  assumes "pure A"
  shows "Mult p A, \<Delta> \<equiv> A"
  by (simp add: assms equivalent_def pure_mult1 pure_mult2)

lemma WildPure:
  assumes "pure A"
  shows "Wildcard A, \<Delta> \<equiv> A"
proof (rule equivalentI)
  show "\<And>\<sigma> s. \<sigma>, s, \<Delta> \<Turnstile> Wildcard A \<Longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> A"
    using assms pure_def sat.simps(12) by blast
  show "\<And>\<sigma> s. \<sigma>, s, \<Delta> \<Turnstile> A \<Longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> Wildcard A"
    by (metis one_neutral sat.simps(12))
qed

subsection DotFull

lemma mult_one_same1:
  "Mult one A, \<Delta> \<turnstile> A"
  by (simp add: entails_def one_neutral)

lemma mult_one_same2:
  "A, \<Delta> \<turnstile> Mult one A"
  by (simp add: entailsI one_neutral)

lemma DotFull:
  "Mult one A, \<Delta> \<equiv> A"
  using equivalent_def mult_one_same1 mult_one_same2 by blast

subsection DotExists

lemma dot_exists1:
  "Mult p (Exists x A), \<Delta> \<turnstile> Exists x (Mult p A)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Exists x A)"
  then show "\<sigma>, s, \<Delta> \<Turnstile> Exists x (Mult p A)"
    by auto
qed

lemma dot_exists2:
  "Exists x (Mult p A), \<Delta> \<turnstile> Mult p (Exists x A)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> Exists x (Mult p A)"
  then show "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Exists x A)" by auto
qed

lemma DotExists:
  "Mult p (Exists x A), \<Delta> \<equiv> Exists x (Mult p A)"
  by (simp add: dot_exists1 dot_exists2 equivalent_def)

lemma WildExists:
  "Wildcard (Exists x A), \<Delta> \<equiv> Exists x (Wildcard A)"
proof (rule equivalentI)
  show "\<And>\<sigma> s. \<sigma>, s, \<Delta> \<Turnstile> Wildcard (Exists x A) \<Longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> Exists x (Wildcard A)"
    by auto
  show "\<And>\<sigma> s. \<sigma>, s, \<Delta> \<Turnstile> Exists x (Wildcard A) \<Longrightarrow> \<sigma>, s, \<Delta> \<Turnstile> Wildcard (Exists x A)"
    by auto
qed

subsection DotForall

lemma dot_forall1:
  "Mult p (Forall x A), \<Delta> \<turnstile> Forall x (Mult p A)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Forall x A)"
  then show "\<sigma>, s, \<Delta> \<Turnstile> Forall x (Mult p A)"
    by auto
qed

lemma dot_forall2:
  "Forall x (Mult p A), \<Delta> \<turnstile> Mult p (Forall x A)"
proof (rule entailsI)
  fix \<sigma> s \<Delta>
  assume "\<sigma>, s, \<Delta> \<Turnstile> Forall x (Mult p A)"
  obtain a where "\<sigma> = p \<odot> a"
    using sat.simps(1) sat_mult by blast
  have "a, s, \<Delta> \<Turnstile> Forall x A"
  proof (rule sat_forall)
    fix v show "a, s(x := v), \<Delta> \<Turnstile> A"
      using \<open>\<sigma> = p \<odot> a\<close> \<open>\<sigma>, s, \<Delta> \<Turnstile> Forall x (Mult p A)\<close> can_divide by auto
  qed
  then show "\<sigma>, s, \<Delta> \<Turnstile> Mult p (Forall x A)"
    using \<open>\<sigma> = p \<odot> a\<close> by auto
qed

lemma DotForall:
  "Mult p (Forall x A), \<Delta> \<equiv> Forall x (Mult p A)"
  by (simp add: dot_forall1 dot_forall2 equivalent_def)

lemma WildForall:
  "Wildcard (Forall x A), \<Delta> \<turnstile> Forall x (Wildcard A)"
  by (metis (no_types, lifting) entailsI sat.simps(12) sat.simps(9))

subsection Split

lemma split:
  "Mult (sadd a b) A, \<Delta> \<turnstile> Star (Mult a A) (Mult b A)"
proof (rule entailsI)
  fix \<sigma> s
  assume "\<sigma>, s, \<Delta> \<Turnstile> Mult (sadd a b) A"
  then show "\<sigma>, s, \<Delta> \<Turnstile> Star (Mult a A) (Mult b A)"
    using distrib_mult by fastforce
qed

end

end