(* Author:     Giampaolo Bella, Catania University
*)

section\<open>Theory of smartcards\<close>

theory Smartcard
imports EventSC "../All_Symmetric"
begin

text\<open>
As smartcards handle long-term (symmetric) keys, this theoy extends and
supersedes theory Private.thy

An agent is bad if she reveals her PIN to the spy, not the shared key that
is embedded in her card. An agent's being bad implies nothing about her
smartcard, which independently may be stolen or cloned.
\<close>

axiomatization
  shrK    :: "agent => key" and  (*long-term keys saved in smart cards*)
  crdK    :: "card  => key" and  (*smart cards' symmetric keys*)
  pin     :: "agent => key" and  (*pin to activate the smart cards*)

  (*Mostly for Shoup-Rubin*)
  Pairkey :: "agent * agent => nat" and
  pairK   :: "agent * agent => key"
where
  inj_shrK: "inj shrK" and  \<comment>\<open>No two smartcards store the same key\<close>
  inj_crdK: "inj crdK" and  \<comment>\<open>Nor do two cards\<close>
  inj_pin : "inj pin" and   \<comment>\<open>Nor do two agents have the same pin\<close>

  (*pairK is injective on each component, if we assume encryption to be a PRF
    or at least collision free *)
  inj_pairK    [iff]: "(pairK(A,B) = pairK(A',B')) = (A = A' & B = B')" and
  comm_Pairkey [iff]: "Pairkey(A,B) = Pairkey(B,A)" and

  (*long-term keys differ from each other*)
  pairK_disj_crdK [iff]: "pairK(A,B) \<noteq> crdK C" and
  pairK_disj_shrK [iff]: "pairK(A,B) \<noteq> shrK P" and
  pairK_disj_pin [iff]:  "pairK(A,B) \<noteq> pin P" and
  shrK_disj_crdK [iff]:  "shrK P \<noteq> crdK C" and
  shrK_disj_pin [iff]:  "shrK P \<noteq> pin Q" and
  crdK_disj_pin [iff]:   "crdK C \<noteq> pin P"

definition legalUse :: "card => bool" ("legalUse (_)") where
  "legalUse C == C \<notin> stolen"

primrec illegalUse :: "card  => bool" where
  illegalUse_def: "illegalUse (Card A) = ( (Card A \<in> stolen \<and> A \<in> bad)  \<or>  Card A \<in> cloned )"

text\<open>initState must be defined with care\<close>

overloading
  initState \<equiv> initState
begin

primrec initState where
(*Server knows all long-term keys; adding cards' keys may be redundant but
  helps prove crdK_in_initState and crdK_in_used to distinguish cards' keys
  from fresh (session) keys*)
  initState_Server:  "initState Server =
        (Key`(range shrK \<union> range crdK \<union> range pin \<union> range pairK)) \<union>
        (Nonce`(range Pairkey))" |

(*Other agents know only their own*)
  initState_Friend:  "initState (Friend i) = {Key (pin (Friend i))}" |

(*Spy knows bad agents' pins, cloned cards' keys, pairKs, and Pairkeys *)
  initState_Spy: "initState Spy  =
                 (Key`((pin`bad) \<union> (pin `{A. Card A \<in> cloned}) \<union>
                                      (shrK`{A. Card A \<in> cloned}) \<union>
                        (crdK`cloned) \<union>
                        (pairK`{(X,A). Card A \<in> cloned})))
           \<union> (Nonce`(Pairkey`{(A,B). Card A \<in> cloned & Card B \<in> cloned}))"

end

text\<open>Still relying on axioms\<close>
axiomatization where
  Key_supply_ax:  "finite KK \<Longrightarrow> \<exists> K. K \<notin> KK & Key K \<notin> used evs" and

  (*Needed because of Spy's knowledge of Pairkeys*)
  Nonce_supply_ax: "finite NN \<Longrightarrow> \<exists> N. N \<notin> NN & Nonce N \<notin> used evs"

subsection\<open>Basic properties of shrK\<close>

(*Injectiveness: Agents' long-term keys are distinct.*)
declare inj_shrK [THEN inj_eq, iff]
declare inj_crdK [THEN inj_eq, iff]
declare inj_pin  [THEN inj_eq, iff]

lemma invKey_K [simp]: "invKey K = K"
apply (insert isSym_keys)
apply (simp add: symKeys_def)
done

lemma analz_Decrypt' [dest]:
     "\<lbrakk> Crypt K X \<in> analz H;  Key K  \<in> analz H \<rbrakk> \<Longrightarrow> X \<in> analz H"
by auto

text\<open>Now cancel the \<open>dest\<close> attribute given to
 \<open>analz.Decrypt\<close> in its declaration.\<close>
declare analz.Decrypt [rule del]

text\<open>Rewrites should not refer to  @{term "initState(Friend i)"} because
  that expression is not in normal form.\<close>

text\<open>Added to extend initstate with set of nonces\<close>
lemma parts_image_Nonce [simp]: "parts (Nonce`N) = Nonce`N"
  by auto

lemma keysFor_parts_initState [simp]: "keysFor (parts (initState C)) = {}"
apply (unfold keysFor_def)
apply (induct_tac "C", auto)
done

(*Specialized to shared-key model: no @{term invKey}*)
lemma keysFor_parts_insert:
     "\<lbrakk> K \<in> keysFor (parts (insert X G));  X \<in> synth (analz H) \<rbrakk>
     \<Longrightarrow> K \<in> keysFor (parts (G \<union> H)) | Key K \<in> parts H"
by (force dest: EventSC.keysFor_parts_insert)

lemma Crypt_imp_keysFor: "Crypt K X \<in> H \<Longrightarrow> K \<in> keysFor H"
by (drule Crypt_imp_invKey_keysFor, simp)

subsection\<open>Function "knows"\<close>

(*Spy knows the pins of bad agents!*)
lemma Spy_knows_bad [intro!]: "A \<in> bad \<Longrightarrow> Key (pin A) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split: event.split)
done

(*Spy knows the long-term keys of cloned cards!*)
lemma Spy_knows_cloned [intro!]:
     "Card A \<in> cloned \<Longrightarrow>  Key (crdK (Card A)) \<in> knows Spy evs &
                           Key (shrK A) \<in> knows Spy evs &
                           Key (pin A)  \<in> knows Spy evs &
                          (\<forall> B. Key (pairK(B,A)) \<in> knows Spy evs)"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split: event.split)
done

lemma Spy_knows_cloned1 [intro!]: "C \<in> cloned \<Longrightarrow> Key (crdK C) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split: event.split)
done

lemma Spy_knows_cloned2 [intro!]: "\<lbrakk> Card A \<in> cloned; Card B \<in> cloned \<rbrakk>
   \<Longrightarrow> Nonce (Pairkey(A,B))\<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split: event.split)
done

(*Spy only knows pins of bad agents!*)
lemma Spy_knows_Spy_bad [intro!]: "A\<in> bad \<Longrightarrow> Key (pin A) \<in> knows Spy evs"
apply (induct_tac "evs")
apply (simp_all (no_asm_simp) add: imageI knows_Cons split: event.split)
done

(*For case analysis on whether or not an agent is compromised*)
lemma Crypt_Spy_analz_bad:
  "\<lbrakk> Crypt (pin A) X \<in> analz (knows Spy evs);  A\<in>bad \<rbrakk>
      \<Longrightarrow> X \<in> analz (knows Spy evs)"
apply (force dest!: analz.Decrypt)
done

(** Fresh keys never clash with other keys **)

lemma shrK_in_initState [iff]: "Key (shrK A) \<in> initState Server"
apply (induct_tac "A")
apply auto
done

lemma shrK_in_used [iff]: "Key (shrK A) \<in> used evs"
apply (rule initState_into_used)
apply blast
done

lemma crdK_in_initState [iff]: "Key (crdK A) \<in> initState Server"
apply (induct_tac "A")
apply auto
done

lemma crdK_in_used [iff]: "Key (crdK A) \<in> used evs"
apply (rule initState_into_used)
apply blast
done

lemma pin_in_initState [iff]: "Key (pin A) \<in> initState A"
apply (induct_tac "A")
apply auto
done

lemma pin_in_used [iff]: "Key (pin A) \<in> used evs"
apply (rule initState_into_used)
apply blast
done

lemma pairK_in_initState [iff]: "Key (pairK X) \<in> initState Server"
apply (induct_tac "X")
apply auto
done

lemma pairK_in_used [iff]: "Key (pairK X) \<in> used evs"
apply (rule initState_into_used)
apply blast
done

(*Used in parts_induct_tac and analz_Fake_tac to distinguish session keys
  from long-term shared keys*)
lemma Key_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range shrK"
by blast

lemma shrK_neq [simp]: "Key K \<notin> used evs \<Longrightarrow> shrK B \<noteq> K"
by blast

lemma crdK_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range crdK"
apply clarify
done

lemma crdK_neq [simp]: "Key K \<notin> used evs \<Longrightarrow> crdK C \<noteq> K"
apply clarify
done

lemma pin_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range pin"
apply clarify
done

lemma pin_neq [simp]: "Key K \<notin> used evs \<Longrightarrow> pin A \<noteq> K"
apply clarify
done

lemma pairK_not_used [simp]: "Key K \<notin> used evs \<Longrightarrow> K \<notin> range pairK"
apply clarify
done

lemma pairK_neq [simp]: "Key K \<notin> used evs \<Longrightarrow> pairK(A,B) \<noteq> K"
apply clarify
done

declare shrK_neq [THEN not_sym, simp]
declare crdK_neq [THEN not_sym, simp]
declare pin_neq [THEN not_sym, simp]
declare pairK_neq [THEN not_sym, simp]

subsection\<open>Fresh nonces\<close>

lemma Nonce_notin_initState [iff]: "Nonce N \<notin> parts (initState (Friend i))"
by auto

(*This lemma no longer holds of smartcard protocols, where the cards can store
  nonces.

lemma Nonce_notin_used_empty [simp]: "Nonce N \<notin> used []"
apply (simp (no_asm) add: used_Nil)
done

So, we must use old-style supply fresh nonce theorems relying on the appropriate axiom*)

subsection\<open>Supply fresh nonces for possibility theorems.\<close>

lemma Nonce_supply1: "\<exists>N. Nonce N \<notin> used evs"
apply (rule finite.emptyI [THEN Nonce_supply_ax, THEN exE], blast)
done

lemma Nonce_supply2:
  "\<exists>N N'. Nonce N \<notin> used evs & Nonce N' \<notin> used evs' & N \<noteq> N'"
apply (cut_tac evs = evs in finite.emptyI [THEN Nonce_supply_ax])
apply (erule exE)
apply (cut_tac evs = evs' in finite.emptyI [THEN finite.insertI, THEN Nonce_supply_ax])
apply auto
done

lemma Nonce_supply3: "\<exists>N N' N''. Nonce N \<notin> used evs & Nonce N' \<notin> used evs' &
                    Nonce N'' \<notin> used evs'' & N \<noteq> N' & N' \<noteq> N'' & N \<noteq> N''"
apply (cut_tac evs = evs in finite.emptyI [THEN Nonce_supply_ax])
apply (erule exE)
apply (cut_tac evs = evs' and a1 = N in finite.emptyI [THEN finite.insertI, THEN Nonce_supply_ax])
apply (erule exE)
apply (cut_tac evs = evs'' and a1 = Na and a2 = N in finite.emptyI [THEN finite.insertI, THEN finite.insertI, THEN Nonce_supply_ax])
apply blast
done

lemma Nonce_supply: "Nonce (@ N. Nonce N \<notin> used evs) \<notin> used evs"
apply (rule finite.emptyI [THEN Nonce_supply_ax, THEN exE])
apply (rule someI, blast)
done

text\<open>Unlike the corresponding property of nonces, we cannot prove
    @{term "finite KK \<Longrightarrow> \<exists>K. K \<notin> KK & Key K \<notin> used evs"}.
    We have infinitely many agents and there is nothing to stop their
    long-term keys from exhausting all the natural numbers.  Instead,
    possibility theorems must assume the existence of a few keys.\<close>

subsection\<open>Specialized Rewriting for Theorems About @{term analz} and Image\<close>

lemma subset_Compl_range_shrK: "A \<subseteq> - (range shrK) \<Longrightarrow> shrK x \<notin> A"
by blast

lemma subset_Compl_range_crdK: "A \<subseteq> - (range crdK) \<Longrightarrow> crdK x \<notin> A"
apply blast
done

lemma subset_Compl_range_pin: "A \<subseteq> - (range pin) \<Longrightarrow> pin x \<notin> A"
apply blast
done

lemma subset_Compl_range_pairK: "A \<subseteq> - (range pairK) \<Longrightarrow> pairK x \<notin> A"
apply blast
done
lemma insert_Key_singleton: "insert (Key K) H = Key ` {K} \<union> H"
by blast

lemma insert_Key_image: "insert (Key K) (Key`KK \<union> C) = Key`(insert K KK) \<union> C"
by blast

(** Reverse the normal simplification of "image" to build up (not break down)
    the set of keys.  Use analz_insert_eq with (Un_upper2 RS analz_mono) to
    erase occurrences of forwarded message components (X). **)

lemmas analz_image_freshK_simps =
       simp_thms mem_simps \<comment>\<open>these two allow its use with \<open>only:\<close>\<close>
       disj_comms
       image_insert [THEN sym] image_Un [THEN sym] empty_subsetI insert_subset
       analz_insert_eq Un_upper2 [THEN analz_mono, THEN [2] rev_subsetD]
       insert_Key_singleton subset_Compl_range_shrK subset_Compl_range_crdK
       subset_Compl_range_pin subset_Compl_range_pairK
       Key_not_used insert_Key_image Un_assoc [THEN sym]

(*Lemma for the trivial direction of the if-and-only-if*)
lemma analz_image_freshK_lemma:
     "(Key K \<in> analz (Key`nE \<union> H)) \<longrightarrow> (K \<in> nE | Key K \<in> analz H)  \<Longrightarrow>
         (Key K \<in> analz (Key`nE \<union> H)) = (K \<in> nE | Key K \<in> analz H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsection\<open>Tactics for possibility theorems\<close>

ML
\<open>
structure Smartcard =
struct

(*Omitting used_Says makes the tactic much faster: it leaves expressions
    such as  Nonce ?N \<notin> used evs that match Nonce_supply*)
fun possibility_tac ctxt =
   (REPEAT
    (ALLGOALS (simp_tac (ctxt
      delsimps @{thms used_Cons_simps}
      setSolver safe_solver))
     THEN
     REPEAT_FIRST (eq_assume_tac ORELSE'
                   resolve_tac ctxt [refl, conjI, @{thm Nonce_supply}])))

(*For harder protocols (such as Recur) where we have to set up some
  nonces and keys initially*)
fun basic_possibility_tac ctxt =
    REPEAT
    (ALLGOALS (asm_simp_tac (ctxt setSolver safe_solver))
     THEN
     REPEAT_FIRST (resolve_tac ctxt [refl, conjI]))

val analz_image_freshK_ss =
  simpset_of
   (@{context} delsimps [image_insert, image_Un]
               delsimps [@{thm imp_disjL}]    (*reduces blow-up*)
               addsimps @{thms analz_image_freshK_simps})
end
\<close>

(*Lets blast_tac perform this step without needing the simplifier*)
lemma invKey_shrK_iff [iff]:
     "(Key (invKey K) \<in> X) = (Key K \<in> X)"
by auto

(*Specialized methods*)

method_setup analz_freshK = \<open>
    Scan.succeed (fn ctxt =>
     (SIMPLE_METHOD
      (EVERY [REPEAT_FIRST (resolve_tac ctxt [allI, ballI, impI]),
          REPEAT_FIRST (resolve_tac ctxt @{thms analz_image_freshK_lemma}),
          ALLGOALS (asm_simp_tac (put_simpset Smartcard.analz_image_freshK_ss ctxt))])))\<close>
    "for proving the Session Key Compromise theorem"

method_setup possibility = \<open>
    Scan.succeed (fn ctxt =>
        SIMPLE_METHOD (Smartcard.possibility_tac ctxt))\<close>
    "for proving possibility theorems"

method_setup basic_possibility = \<open>
    Scan.succeed (fn ctxt =>
        SIMPLE_METHOD (Smartcard.basic_possibility_tac ctxt))\<close>
    "for proving possibility theorems"

lemma knows_subset_knows_Cons: "knows A evs \<subseteq> knows A (e # evs)"
by (induct e) (auto simp: knows_Cons)

(*Needed for actual protocols that will follow*)
declare shrK_disj_crdK[THEN not_sym, iff]
declare shrK_disj_pin[THEN not_sym, iff]
declare pairK_disj_shrK[THEN not_sym, iff]
declare pairK_disj_crdK[THEN not_sym, iff]
declare pairK_disj_pin[THEN not_sym, iff]
declare crdK_disj_pin[THEN not_sym, iff]

declare legalUse_def [iff] illegalUse_def [iff]

end


section \<open>Transfer Setup\<close>
theory Refine_Transfer
imports
  Refine_Basic
  Refine_While
  Refine_Det
  "Generic/RefineG_Transfer"
begin

subsection \<open>Transfer to Deterministic Result Lattice\<close>
text \<open>
  TODO: Once lattice and ccpo are connected, also transfer to option monad, that
  is a ccpo, but no complete lattice!
\<close>
subsubsection \<open>Connecting Deterministic and Non-Deterministic Result Lattices\<close>
definition "nres_of r \<equiv> case r of
  dSUCCEEDi \<Rightarrow> SUCCEED
| dFAILi \<Rightarrow> FAIL
| dRETURN x \<Rightarrow> RETURN x"

lemma nres_of_simps[simp]:
  "nres_of dSUCCEED = SUCCEED"
  "nres_of dFAIL = FAIL"
  "nres_of (dRETURN x) = RETURN x"
  apply -
  unfolding nres_of_def bot_dres_def top_dres_def
  by (auto simp del: dres_internal_simps)

lemma nres_of_mono: "mono nres_of"
  apply (rule)
  apply (case_tac x, simp_all, case_tac y, simp_all)
  done

lemma nres_transfer:
  "nres_of dSUCCEED = SUCCEED"
  "nres_of dFAIL = FAIL"
  "nres_of a \<le> nres_of b \<longleftrightarrow> a\<le>b"
  "nres_of a < nres_of b \<longleftrightarrow> a<b"
  "is_chain A \<Longrightarrow> nres_of (Sup A) = Sup (nres_of`A)"
  "is_chain A \<Longrightarrow> nres_of (Inf A) = Inf (nres_of`A)"
  apply simp_all
  apply (case_tac a, simp_all, case_tac [!] b, simp_all) [1]

  apply (simp add: less_le)
  apply (case_tac a, simp_all, case_tac [!] b, simp_all) [1]

  apply (erule dres_Sup_chain_cases)
    apply (cases "A={}")
    apply auto []
    apply (subgoal_tac "A={dSUCCEED}", auto) []

    apply (case_tac "A={dRETURN r}")
    apply auto []
    apply (subgoal_tac "A={dSUCCEED,dRETURN r}", auto) []

    apply (drule imageI[where f=nres_of])
    apply auto []

  apply (erule dres_Inf_chain_cases)
    apply (cases "A={}")
    apply auto []
    apply (subgoal_tac "A={dFAIL}", auto) []

    apply (case_tac "A={dRETURN r}")
    apply auto []
    apply (subgoal_tac "A={dFAIL,dRETURN r}", auto) []

    apply (drule imageI[where f=nres_of])
    apply (auto intro: bot_Inf [symmetric]) []
  done

lemma nres_correctD:
  assumes "nres_of S \<le> SPEC \<Phi>"
  shows
  "S=dRETURN x \<Longrightarrow> \<Phi> x"
  "S\<noteq>dFAIL"
  using assms apply -
  apply (cases S, simp_all)+
  done

subsubsection \<open>Transfer Theorems Setup\<close>
interpretation dres: dist_transfer nres_of
  apply unfold_locales
  apply (simp add: nres_transfer)
  done

lemma nres_of_transfer[refine_transfer]: "nres_of x \<le> nres_of x" by simp

lemma det_FAIL[refine_transfer]: "nres_of (dFAIL) \<le> FAIL" by auto
lemma det_SUCCEED[refine_transfer]: "nres_of (dSUCCEED) \<le> SUCCEED" by auto
lemma det_SPEC: "\<Phi> x \<Longrightarrow> nres_of (dRETURN x) \<le> SPEC \<Phi>" by simp
lemma det_RETURN[refine_transfer]:
  "nres_of (dRETURN x) \<le> RETURN x" by simp
lemma det_bind[refine_transfer]:
  assumes "nres_of m \<le> M"
  assumes "\<And>x. nres_of (f x) \<le> F x"
  shows "nres_of (dbind m f) \<le> bind M F"
  using assms
  apply (cases m)
  apply (auto simp: pw_le_iff refine_pw_simps)
  done

interpretation det_assert: transfer_generic_Assert_remove
  bind RETURN ASSERT ASSUME
  nres_of
  by unfold_locales

interpretation det_while: transfer_WHILE
  dbind dRETURN dWHILEIT dWHILEI dWHILET dWHILE
  bind RETURN WHILEIT WHILEI WHILET WHILE nres_of
  apply unfold_locales
  apply (auto intro: det_bind)
  done

(*
interpretation det_foreach:
  transfer_FOREACH nres_of dRETURN dbind "case_dres True True"
  apply unfold_locales
  apply (blast intro: det_bind)
  apply simp
  apply (case_tac m)
  apply simp_all
  done
*)

(* Done generally in RefineG_Transfer
lemma det_rec_list[refine_transfer]:
  assumes FN: "\<And>s. RETURN (fn s) \<le> (fn' s)"
  assumes FC: "\<And>x l rec rec' s. \<lbrakk> \<And>s. RETURN (rec s) \<le> (rec' s) \<rbrakk>
    \<Longrightarrow> RETURN (fc x l rec s) \<le> fc' x l rec' s"
  shows "RETURN (rec_list fn fc l s) \<le> rec_list fn' fc' l s"
  apply (induct l arbitrary: s)
  apply (simp add: FN)
  apply (simp add: FC)
  done

lemma det_rec_nat[refine_transfer]:
  assumes FN: "\<And>s. RETURN (fn s) \<le> (fn' s)"
  assumes FC: "\<And>n rec rec' s. \<lbrakk> \<And>s. RETURN (rec s) \<le> (rec' s) \<rbrakk>
    \<Longrightarrow> RETURN (fc x l rec s) \<le> fc' x l rec' s"
  shows "RETURN (rec_list fn fc l s) \<le> rec_list fn' fc' l s"
  apply (induct l arbitrary: s)
  apply (simp add: FN)
  apply (simp add: FC)
  done
*)

subsection \<open>Transfer to Plain Function\<close>

interpretation plain: transfer RETURN .

lemma plain_RETURN[refine_transfer]: "RETURN a \<le> RETURN a" by simp
lemma plain_bind[refine_transfer]:
  "\<lbrakk>RETURN x \<le> M; \<And>x. RETURN (f x) \<le> F x\<rbrakk> \<Longrightarrow> RETURN (Let x f) \<le> bind M F"
  apply (erule order_trans[rotated,OF bind_mono(1)])
  apply assumption
  apply simp
  done

interpretation plain_assert: transfer_generic_Assert_remove
  bind RETURN ASSERT ASSUME
  RETURN
  by unfold_locales

(*
interpretation plain: transfer_FOREACH RETURN "(\<lambda>x. x)" Let "(\<lambda>x. x)"
  apply (unfold_locales)
  apply (erule plain_bind, assumption)
  apply simp
  apply simp
  done
*)

subsection \<open>Total correctness in deterministic monad\<close>
text \<open>
  Sometimes one cannot extract total correct programs to executable plain
  Isabelle functions, for example, if the total correctness only holds for
  certain preconditions. In those cases, one can still show
  \<open>RETURN (the_res S) \<le> S'\<close>. Here, \<open>the_res\<close> extracts
  the result from a deterministic monad. As \<open>the_res\<close> is executable,
  the above shows that \<open>(the_res S)\<close> is always a correct result.
\<close>

fun the_res where "the_res (dRETURN x) = x"

text \<open>The following lemma converts a proof-obligation
  with result extraction to a transfer proof obligation,
  and a proof obligation that the program yields not bottom.

  Note that this rule has to be applied manually, as, otherwise,
  it would interfere with the default setup, that tries to generate a
  plain function.
\<close>
lemma the_resI:
  assumes "nres_of S \<le> S'"
  assumes "S \<noteq> dSUCCEED"
  shows "RETURN (the_res S) \<le> S'"
  using assms
  by (cases S, simp_all)

text \<open>The following rule sets up a refinement goal, a transfer goal, and a
  final optimization goal.\<close>
definition "detTAG x \<equiv> x"
lemma detTAGI: "x = detTAG x" unfolding detTAG_def by simp
lemma autoref_detI:
  assumes "(b,a)\<in>\<langle>R\<rangle>nres_rel"
  assumes "RETURN c \<le> b"
  assumes "c = detTAG d"
  shows "(RETURN d, a)\<in>\<langle>R\<rangle>nres_rel"
  using assms
  unfolding nres_rel_def detTAG_def
  by simp

subsection \<open>Relator-Based Transfer\<close>

definition dres_nres_rel_internal_def:
  "dres_nres_rel R \<equiv> {(c,a). nres_of c \<le> \<Down> R a}"

lemma dres_nres_rel_def: "\<langle>R\<rangle>dres_nres_rel \<equiv> {(c,a). nres_of c \<le> \<Down> R a}"
  by (simp add: dres_nres_rel_internal_def relAPP_def)

lemma dres_nres_relI[intro?]: "nres_of c \<le> \<Down> R a \<Longrightarrow> (c,a)\<in>\<langle>R\<rangle>dres_nres_rel"
  by (simp add: dres_nres_rel_def)

lemma dres_nres_relD: "(c,a)\<in>\<langle>R\<rangle>dres_nres_rel \<Longrightarrow> nres_of c \<le> \<Down> R a"
  by (simp add: dres_nres_rel_def)

lemma dres_nres_rel_as_br_conv:
  "\<langle>R\<rangle>dres_nres_rel = br nres_of (\<lambda>_. True) O \<langle>R\<rangle>nres_rel"
  unfolding dres_nres_rel_def br_def nres_rel_def by auto

definition plain_nres_rel_internal_def:
  "plain_nres_rel R \<equiv> {(c,a). RETURN c \<le> \<Down> R a}"

lemma plain_nres_rel_def: "\<langle>R\<rangle>plain_nres_rel \<equiv> {(c,a). RETURN c \<le> \<Down> R a}"
  by (simp add: plain_nres_rel_internal_def relAPP_def)

lemma plain_nres_relI[intro?]: "RETURN c \<le> \<Down> R a \<Longrightarrow> (c,a)\<in>\<langle>R\<rangle>plain_nres_rel"
  by (simp add: plain_nres_rel_def)

lemma plain_nres_relD: "(c,a)\<in>\<langle>R\<rangle>plain_nres_rel \<Longrightarrow> RETURN c \<le> \<Down> R a"
  by (simp add: plain_nres_rel_def)

lemma plain_nres_rel_as_br_conv:
  "\<langle>R\<rangle>plain_nres_rel = br RETURN (\<lambda>_. True) O \<langle>R\<rangle>nres_rel"
  unfolding plain_nres_rel_def br_def nres_rel_def by auto

(* TODO: Refine_Transfer could be expressed also just as a
    parametricity based transfer, and based on the same infrastructure
    as autoref *)

subsection \<open>Post-Simplification Setup\<close>
lemma dres_unit_simps[refine_transfer_post_simp]:
  "dbind (dRETURN (u::unit)) f = f ()"
  by auto

lemma Let_dRETURN_simp[refine_transfer_post_simp]:
  "Let m dRETURN = dRETURN m" by auto

lemmas [refine_transfer_post_simp] = dres_monad_laws

end


theory Setup_AutoCorres
imports
  Case_Labeling.Case_Labeling
  "HOL-Eisbach.Eisbach"
  AutoCorres_Misc
begin

section \<open>AutoCorres setup for VCG labelling\<close>

text \<open>Theorem collections for the VCG\<close>

ML_file \<open>../../Case_Labeling/util.ML\<close>

ML \<open>
  fun vcg_tac nt_rules nt_comb ctxt =
    let
      val rules = Named_Theorems.get ctxt nt_rules
      val comb = Named_Theorems.get ctxt nt_comb
    in REPEAT_ALL_NEW_FWD ( resolve_tac ctxt rules ORELSE' (resolve_tac ctxt comb THEN' resolve_tac ctxt rules)) end
\<close>

named_theorems vcg_l
named_theorems vcg_l_comb
named_theorems vcg_elim
named_theorems vcg_simp

method_setup vcg_l = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD (FIRSTGOAL (vcg_tac @{named_theorems "vcg_l"} @{named_theorems "vcg_l_comb"} ctxt)))
\<close>

method vcg_l' = (vcg_l; (elim vcg_elim)?; (unfold vcg_simp)?)

method vcg_casify = (rule Initial_Label, vcg_l', casify)

subsection \<open>Labeled VCG theorems for branching\<close>

definition "BRANCH P \<equiv> P"

named_theorems branch_l
named_theorems branch_l_comb

context begin
  interpretation Labeling_Syntax .

  lemma DC_if[branch_l]:
    fixes ct defines "ct' \<equiv> \<lambda>pos name. (name, pos,[]) # ct"
    assumes "a \<Longrightarrow> C\<langle>Suc inp,ct' inp ''then'', outp': b\<rangle>"
    assumes "\<not>a \<Longrightarrow> C\<langle>Suc outp',ct' outp' ''else'', outp: c\<rangle>"
    shows "C\<langle>inp,ct,outp: BRANCH (if a then b else c)\<rangle>"
    using assms(2-) unfolding LABEL_simps BRANCH_def by auto

end

method_setup branch_l = \<open>
  Scan.succeed (fn ctxt => SIMPLE_METHOD (FIRSTGOAL (vcg_tac @{named_theorems branch_l} @{named_theorems branch_l_comb} ctxt)))
\<close>

method branch_casify = ((rule Initial_Label, branch_l; (rule DC_final)?), casify)

subsection \<open>Labelled VCG theorems for the option monad\<close>

definition
  lpred_conj :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool)" (infixr "land" 35)
where
  "lpred_conj P Q \<equiv> \<lambda>x. P x \<and> Q x"

context begin
  interpretation Labeling_Syntax .

  lemma ovalidNF_obind_K_bind [vcg_l]:
    assumes "CTXT (Suc OC1) CT OC (ovalidNF R g Q)"
      and "CTXT IC CT OC1 (ovalidNF P f (\<lambda>_. R))"
    shows "CTXT IC CT OC (ovalidNF P (f |>> K_bind g) Q)"
    using assms unfolding LABEL_simps by wp

  lemma L_ovalidNF_obind_oreturn[vcg_l]:
    assumes "CTXT IC CT OC (ovalidNF P (g x) Q)"
    shows "CTXT IC CT OC (ovalidNF P (oreturn x |>> g) Q)"
    using assms by (simp add: LABEL_simps)

  lemma L_ovalidNF_obind[vcg_l]:
    assumes "\<And>r. CTXT (Suc OC1) ((''bind'', Suc OC1, [VAR r]) # CT) OC
        (ovalidNF (R r) (g r) Q)"
      and "CTXT IC CT OC1 (ovalidNF P f R)"
    shows "CTXT IC CT OC (ovalidNF P (f |>> (\<lambda>r. g r)) Q)"
    using assms unfolding LABEL_simps by wp

  lemma ovalidNF_K_bind[vcg_l]:
    assumes "CTXT IC CT OC (ovalidNF P f Q)"
    shows "CTXT IC CT OC (ovalidNF P (K_bind f x) Q)"
    using assms by simp

  lemma L_ovalidNF_prod_case[vcg_l]:
    assumes "\<And>x y. SPLIT v (x,y) \<Longrightarrow> CTXT IC CT OC (ovalidNF (P x y) (B x y) Q)"
    shows "CTXT IC CT OC (ovalidNF (case v of (x, y) \<Rightarrow> P x y) (case v of (x, y) \<Rightarrow> B x y) Q)"
    using assms unfolding LABEL_simps by (auto simp: ovalidNF_def)

  lemma L_ovalidNF_oreturn_NF[vcg_l]:
    shows "CTXT IC CT IC (ovalidNF (P x) (oreturn x) P)"
    unfolding LABEL_simps by wp

  lemma L_ovalidNF_owhile_inv[vcg_l]:
    fixes CT IC
    defines "CT' \<equiv> \<lambda>r. (''while'', IC, [VAR r]) # CT"
    assumes "\<And>r s. CTXT IC ((''invariant'', IC, [VAR s]) # CT' r) OC
        (ovalidNF
          (BIND ''loop_inv'' IC (I r) land
            BIND ''loop_cond'' IC (C r) land
            BIND ''loop_var'' IC (\<lambda>s'. s' = s))
          (B r)
          (\<lambda>r'. BIND ''inv'' IC (I r') land BIND ''var'' IC (\<lambda>_. (r', r) \<in> R)))"
      and "\<And>r. VC (''wf'', OC, []) (CT' r) (wf R)"
      and "\<And>r s. I r s \<Longrightarrow> \<not> C r s \<Longrightarrow>
        VC (''postcondition'', Suc OC, [VAR s]) (CT' r) (Q r s)"
    shows "CTXT IC CT (Suc OC) (ovalidNF (I r) (owhile_inv C B r I R) Q)"
    using assms unfolding LABEL_simps lpred_conj_def by wp auto

  lemma L_ovalidNF_wp_comb2[vcg_l_comb]:
    assumes "CTXT IC CT OC (ovalidNF P f Q)"
      and "\<And>s. P' s \<Longrightarrow> VC (''weaken'', IC, [VAR s]) CT (P s)"
    shows "CTXT IC CT OC (ovalidNF P' f Q)"
    using assms unfolding LABEL_simps by (rule ovalidNF_wp_comb2)

  lemma L_condition_NF_wp[vcg_l]:
    fixes CT IC
    defines "CT' \<equiv> (''if'', IC, []) # CT"
    assumes "CTXT IC ((''then'', IC, []) # CT') OC1 (ovalidNF L l Q)"
      and "CTXT (Suc OC1) ((''else'', Suc OC1, []) # CT') OC (ovalidNF R r Q)"
    shows "CTXT IC CT OC (ovalidNF (\<lambda>s. BRANCH (if C s then L s else R s)) (ocondition C l r) Q)"
    using assms unfolding LABEL_simps BRANCH_def by wp

  lemma L_ogets_NF_wp[vcg_l]: "CTXT IC CT IC (ovalidNF (\<lambda>s. P (f s) s) (ogets f) P)"
    unfolding LABEL_simps by wp

  lemma elim_land[vcg_elim]:
    assumes "(P land Q) s" obtains "P s" "Q s"
    using assms by (auto simp: lpred_conj_def)

  lemma simp_bind[vcg_simp]: "BIND ct n P s \<longleftrightarrow> BIND ct n (P s)"
    by (auto simp: LABEL_simps)

  lemma simp_land[vcg_simp]: "(P land Q) s \<longleftrightarrow> P s \<and> Q s"
    by (auto simp: lpred_conj_def)
end

end


theory v1_isar_T
  imports Main "../../QML"
begin

consts makeTable ::  "\<mu> \<Rightarrow> \<mu> \<Rightarrow> \<sigma>"  ("T") (* (T x y) \<equiv> x made from y *)

(* abbreviation refl :: "bool"
  where "refl \<equiv> (\<forall>x. x r x)"
 *)

axiomatization where refl :"(\<forall>x. x r x)"

lemma
  (* assumes refl : "(\<forall>x. x r x)" *)
  assumes compossibilty1: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. ((T x y) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. T t z)) \<^bold>\<rightarrow> \<^bold>\<diamond>((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z))))\<rfloor>"
  assumes origin_uniqueness: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<not>(\<^bold>\<diamond>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))))\<rfloor>"
  assumes sufficiency1: "\<lfloor>(\<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<diamond>(T x' y) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. (T x y) \<^bold>\<rightarrow> (x\<^bold>=\<^sup>Lx')))\<rfloor>"
  shows origin_essentialism1: "\<lfloor>(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. (((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y))) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(T x z)))\<rfloor>"
proof (rule allI)
  fix w (* for the outer \<lfloor> \<rfloor> *)
  show "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. ((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(T x z))) w"
  proof (rule allI)
    fix x (* for table x *)
    show "(\<^bold>\<forall>y. \<^bold>\<forall>z. ((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(T x z))) w"
    proof (rule allI)
      fix y (* for material y *)
      show "(\<^bold>\<forall>z. ((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(T x z))) w"
      proof (rule allI)
        fix z (* for material z *)
        show "(((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y)) \<^bold>\<rightarrow> \<^bold>\<not>(\<^bold>\<diamond>(T x z))) w"
        proof (rule impI)
          assume antecedent: "(((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y))) w"
          show "(\<^bold>\<not>(\<^bold>\<diamond>(T x z))) w"
          proof(rule notI)
            assume table_x_from_z: "(\<^bold>\<diamond>(T x z)) w"
              from antecedent have "(((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y))) w" by simp
              then have non_overlapping: "(\<^bold>\<not>(y \<^bold>=\<^sup>L z)) w" by (rule conjE)
              have table_x_from_y: "T x y w"
                using `((\<^bold>\<not>(y \<^bold>=\<^sup>L z)) \<^bold>\<and> (T x y)) w` by (rule conjE)

              have compossibilty1_ante: "((T x y) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. T t z)) w"
                using antecedent and table_x_from_z by auto

              from compossibilty1 have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. ((T x y) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. T t z)) \<^bold>\<rightarrow> \<^bold>\<diamond>((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z)))) w"..
              then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. ((T x y) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. T t z)) \<^bold>\<rightarrow> \<^bold>\<diamond>((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z)))) w"
                by (rule allE)
              then have "(\<^bold>\<forall>z. ((T x y) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. T t z)) \<^bold>\<rightarrow> \<^bold>\<diamond>((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z)))) w"
                by (rule allE)
              then have "(((T x y) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z) \<^bold>\<and> \<^bold>\<diamond>(\<^bold>\<exists>t. T t z)) \<^bold>\<rightarrow> \<^bold>\<diamond>((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z)))) w"
                by (rule allE)
              then have "(\<^bold>\<diamond>((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z)))) w"
                using compossibilty1_ante by (rule mp)
              then obtain u where u:  "(w r u) \<and> (((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z))) u)"
                by (rule exE)
              then have "((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z))) u" by simp
              then have "(\<exists>t. T t z u)" by (rule conjE)
              then obtain x' where x': "T x' z u" by (rule exE)
              then have  "T x' z u" by simp

(* Relation between u, v and w, prove "w r u" *)
              have "w r u"
                using `(w r u) \<and> (((T x y) \<^bold>\<and> (\<^bold>\<exists>x'. (T x' z))) u)` by (rule conjE)

              from sufficiency1 have "(\<^bold>\<forall>y. \<^bold>\<forall>x'. \<^bold>\<diamond>(T x' y) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. (T x y) \<^bold>\<rightarrow> (x\<^bold>=\<^sup>Lx'))) w"..
              then have "(\<^bold>\<forall>x'. \<^bold>\<diamond>(T x' z) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>x. (T x z) \<^bold>\<rightarrow> (x\<^bold>=\<^sup>Lx'))) w"
                by (rule allE)
              then have "(\<^bold>\<diamond>(T x z) \<^bold>\<rightarrow> \<^bold>\<box>(\<^bold>\<forall>t. (T t z) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx))) w"
                by (rule allE)
              then have  "(\<^bold>\<box>(\<^bold>\<forall>t. (T t z) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx))) w"
                using `(\<^bold>\<diamond>(T x z)) w` by (rule mp)
              then have "(\<^bold>\<forall>t. (T t z) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx)) u"
                using `w r u` by (simp add: `(\<^bold>\<box>(\<^bold>\<forall>t. (T t z) \<^bold>\<rightarrow> (t\<^bold>=\<^sup>Lx))) w`)

              then have "((T x' z) \<^bold>\<rightarrow> (x'\<^bold>=\<^sup>Lx)) u" by (rule allE)
              then have "(x' \<^bold>=\<^sup>L x) u"
                using `T x' z u` by (rule mp)
              then have "(T x z) u"
                using `(T x' z) u` by auto
              have "(T x y) u" using u by blast
              then have "(T x y) u \<and> (T x z) u"
                using `(T x z) u` by (rule conjI)
              then have impossible_arg: "(T x y \<^bold>\<and> T x z \<^bold>\<and> (\<^bold>\<not>(y \<^bold>=\<^sup>L z))) u"
                using non_overlapping by auto

              from origin_uniqueness have "(\<^bold>\<forall>x. \<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<not>(\<^bold>\<diamond>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u"..
              then have "(\<^bold>\<forall>y. \<^bold>\<forall>z. \<^bold>\<not>(\<^bold>\<diamond>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u"
                by (rule allE)
              then have "(\<^bold>\<forall>z. \<^bold>\<not>(\<^bold>\<diamond>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u"
                by (rule allE)
              then have "(\<^bold>\<not>(\<^bold>\<diamond>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z)))) u"
                by (rule allE)
              then have "\<^bold>\<box>(\<^bold>\<not>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u"
                by auto
              then have "(\<^bold>\<not>((T x y) \<^bold>\<and> (T x z) \<^bold>\<and> \<^bold>\<not>(y \<^bold>=\<^sup>L z))) u"
                using refl by blast
              then show "False" using impossible_arg by (rule notE)
            qed
          qed
        qed
      qed
        qed
      qed
end


(*  Title:      Imperative_HOL_Time/Array_Time.thy
    Author:     Maximilian P. L. Haslbeck & Bohua Zhan, TU Muenchen
*)
section \<open>Monadic arrays\<close>

text \<open>This theory is an adaptation of \<open>HOL/Imperative_HOL/Array.thy\<close>,
 adding time bookkeeping.\<close>

theory Array_Time
imports Heap_Time_Monad
begin

subsection \<open>Primitives\<close>

definition present :: "heap \<Rightarrow> 'a::heap array \<Rightarrow> bool" where
  "present h a \<longleftrightarrow> addr_of_array a < lim h"

definition get :: "heap \<Rightarrow> 'a::heap array \<Rightarrow> 'a list" where
  "get h a = map from_nat (arrays h (TYPEREP('a)) (addr_of_array a))"

definition set :: "'a::heap array \<Rightarrow> 'a list \<Rightarrow> heap \<Rightarrow> heap" where
  "set a x = arrays_update (\<lambda>h. h(TYPEREP('a) := ((h(TYPEREP('a))) (addr_of_array a:=map to_nat x))))"

definition alloc :: "'a list \<Rightarrow> heap \<Rightarrow> 'a::heap array \<times> heap" where
  "alloc xs h = (let
     l = lim h;
     r = Array l;
     h'' = set r xs (h\<lparr>lim := l + 1\<rparr>)
   in (r, h''))"

definition length :: "heap \<Rightarrow> 'a::heap array \<Rightarrow> nat" where
  "length h a = List.length (get h a)"

definition update :: "'a::heap array \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> heap \<Rightarrow> heap" where
  "update a i x h = set a ((get h a)[i:=x]) h"

definition noteq :: "'a::heap array \<Rightarrow> 'b::heap array \<Rightarrow> bool" (infix "=!!=" 70) where
  "r =!!= s \<longleftrightarrow> TYPEREP('a) \<noteq> TYPEREP('b) \<or> addr_of_array r \<noteq> addr_of_array s"

subsection \<open>Monad operations\<close>

definition new :: "nat \<Rightarrow> 'a::heap \<Rightarrow> 'a array Heap" where
  [code del]: "new n x = Heap_Time_Monad.heap (%h. let (r,h') = alloc (replicate n x) h in (r,h',n+1))"

definition of_list :: "'a::heap list \<Rightarrow> 'a array Heap" where
  [code del]: "of_list xs = Heap_Time_Monad.heap (%h. let (r,h') = alloc xs h in (r,h',1+List.length xs))"

definition make :: "nat \<Rightarrow> (nat \<Rightarrow> 'a::heap) \<Rightarrow> 'a array Heap" where
  [code del]: "make n f = Heap_Time_Monad.heap (%h. let (r,h') = alloc (map f [0 ..< n]) h in (r,h',n+1))"

definition len :: "'a::heap array \<Rightarrow> nat Heap" where
  [code del]: "len a = Heap_Time_Monad.tap (\<lambda>h. length h a)"

definition nth :: "'a::heap array \<Rightarrow> nat \<Rightarrow> 'a Heap" where
  [code del]: "nth a i = Heap_Time_Monad.guard (\<lambda>h. i < length h a)
    (\<lambda>h. (get h a ! i, h, 1))"

definition upd :: "nat \<Rightarrow> 'a \<Rightarrow> 'a::heap array \<Rightarrow> 'a::heap array Heap" where
  [code del]: "upd i x a = Heap_Time_Monad.guard (\<lambda>h. i < length h a)
    (\<lambda>h. (a, update a i x h, 1))"

definition map_entry :: "nat \<Rightarrow> ('a::heap \<Rightarrow> 'a) \<Rightarrow> 'a array \<Rightarrow> 'a array Heap" where
  [code del]: "map_entry i f a = Heap_Time_Monad.guard (\<lambda>h. i < length h a)
    (\<lambda>h. (a, update a i (f (get h a ! i)) h, 2))"

definition swap :: "nat \<Rightarrow> 'a \<Rightarrow> 'a::heap array \<Rightarrow> 'a Heap" where
  [code del]: "swap i x a = Heap_Time_Monad.guard (\<lambda>h. i < length h a)
    (\<lambda>h. (get h a ! i, update a i x h, 2 ))"  (* questionable *)

definition freeze :: "'a::heap array \<Rightarrow> 'a list Heap" where
  [code del]: "freeze a = Heap_Time_Monad.heap (\<lambda>h. (get h a, h, 1+length h a)) "

subsection \<open>Properties\<close>

text \<open>FIXME: Does there exist a "canonical" array axiomatisation in
the literature?\<close>

text \<open>Primitives\<close>

lemma noteq_sym: "a =!!= b \<Longrightarrow> b =!!= a"
  and unequal [simp]: "a \<noteq> a' \<longleftrightarrow> a =!!= a'"
  unfolding noteq_def by auto

lemma noteq_irrefl: "r =!!= r \<Longrightarrow> False"
  unfolding noteq_def by auto

lemma present_alloc_noteq: "present h a \<Longrightarrow> a =!!= fst (alloc xs h)"
  by (simp add: present_def noteq_def alloc_def Let_def)

lemma get_set_eq [simp]: "get (set r x h) r = x"
  by (simp add: get_def set_def o_def)

lemma get_set_neq [simp]: "r =!!= s \<Longrightarrow> get (set s x h) r = get h r"
  by (simp add: noteq_def get_def set_def)

lemma set_same [simp]:
  "set r x (set r y h) = set r x h"
  by (simp add: set_def)

lemma set_set_swap:
  "r =!!= r' \<Longrightarrow> set r x (set r' x' h) = set r' x' (set r x h)"
  by (simp add: Let_def fun_eq_iff noteq_def set_def)

lemma get_update_eq [simp]:
  "get (update a i v h) a = (get h a) [i := v]"
  by (simp add: update_def)

lemma nth_update_neq [simp]:
  "a =!!= b \<Longrightarrow> get (update b j v h) a ! i = get h a ! i"
  by (simp add: update_def noteq_def)

lemma get_update_elem_neqIndex [simp]:
  "i \<noteq> j \<Longrightarrow> get (update a j v h) a ! i = get h a ! i"
  by simp

lemma length_update [simp]:
  "length (update b i v h) = length h"
  by (simp add: update_def length_def set_def get_def fun_eq_iff)

lemma update_swap_neq:
  "a =!!= a' \<Longrightarrow>
  update a i v (update a' i' v' h)
  = update a' i' v' (update a i v h)"
apply (unfold update_def)
apply simp
apply (subst set_set_swap, assumption)
apply (subst get_set_neq)
apply (erule noteq_sym)
apply simp
done

lemma update_swap_neqIndex:
  "\<lbrakk> i \<noteq> i' \<rbrakk> \<Longrightarrow> update a i v (update a i' v' h) = update a i' v' (update a i v h)"
  by (auto simp add: update_def set_set_swap list_update_swap)

lemma get_alloc:
  "get (snd (alloc xs h)) (fst (alloc ys h)) = xs"
  by (simp add: Let_def split_def alloc_def)

lemma length_alloc:
  "length (snd (alloc (xs :: 'a::heap list) h)) (fst (alloc (ys :: 'a list) h)) = List.length xs"
  by (simp add: Array_Time.length_def get_alloc)

lemma set:
  "set (fst (alloc ls h))
     new_ls (snd (alloc ls h))
       = snd (alloc new_ls h)"
  by (simp add: Let_def split_def alloc_def)

lemma present_update [simp]:
  "present (update b i v h) = present h"
  by (simp add: update_def present_def set_def get_def fun_eq_iff)

lemma present_alloc [simp]:
  "present (snd (alloc xs h)) (fst (alloc xs h))"
  by (simp add: present_def alloc_def set_def Let_def)

lemma not_present_alloc [simp]:
  "\<not> present h (fst (alloc xs h))"
  by (simp add: present_def alloc_def Let_def)

text \<open>Monad operations\<close>

lemma execute_new [execute_simps]:
  "execute (new n x) h = Some (let (r,h') = alloc (replicate n x) h in (r,h',n+1))"
  by (simp add: new_def execute_simps)

lemma success_newI [success_intros]:
  "success (new n x) h"
  by (auto intro: success_intros simp add: new_def)

lemma effect_newI [effect_intros]:
  assumes "(a, h') = alloc (replicate n x) h"
  shows "effect (new n x) h h' a (n+1)"
  apply (rule effectI) apply (simp add: assms execute_simps)  by (metis assms case_prod_conv)

lemma effect_newE [effect_elims]:
  assumes "effect (new n x) h h' r n'"
  obtains "r = fst (alloc (replicate n x) h)" "h' = snd (alloc (replicate n x) h)"
    "get h' r = replicate n x" "present h' r" "\<not> present h r" "n+1=n'"
  using assms apply (rule effectE) using  case_prod_beta get_alloc execute_new
  by (metis (mono_tags, lifting) fst_conv not_present_alloc option.sel present_alloc sndI)

  (* apply (si mp add: case_prod_beta get_alloc execute_simps) refactor proof *)

lemma execute_of_list [execute_simps]:
  "execute (of_list xs) h = Some (let (r,h') = alloc xs h in (r,h',1 + List.length xs))"
  by (simp add: of_list_def execute_simps)

lemma success_of_listI [success_intros]:
  "success (of_list xs) h"
  by (auto intro: success_intros simp add: of_list_def)

lemma effect_of_listI [effect_intros]:
  assumes "(a, h') = alloc xs h"
  shows "effect (of_list xs) h h' a (1 + List.length xs)"
  by (rule effectI, simp add: assms execute_simps, metis assms case_prod_conv)

lemma effect_of_listE [effect_elims]:
  assumes "effect (of_list xs) h h' r n'"
  obtains "r = fst (alloc xs h)" "h' = snd (alloc xs h)"
    "get h' r = xs" "present h' r" "\<not> present h r" "n' = 1 + List.length xs"
  using assms apply (rule effectE) apply (simp add: get_alloc  execute_of_list) by (simp add: case_prod_unfold)

lemma execute_make [execute_simps]:
  "execute (make n f) h = Some (let (r,h') = alloc (map f [0 ..< n]) h in (r,h',n+1))"
  by (simp add: make_def execute_simps)

lemma success_makeI [success_intros]:
  "success (make n f) h"
  by (auto intro: success_intros simp add: make_def)

lemma effect_makeI [effect_intros]:
  assumes "(a, h') = alloc (map f [0 ..< n]) h"
  shows "effect (make n f) h h' a (n+1)"
  by (rule effectI) (simp add: assms execute_simps, metis assms case_prod_conv)

lemma effect_makeE [effect_elims]:
  assumes "effect (make n f) h h' r n'"
  obtains "r = fst (alloc (map f [0 ..< n]) h)" "h' = snd (alloc (map f [0 ..< n]) h)"
    "get h' r = map f [0 ..< n]" "present h' r" "\<not> present h r" "n+1=n'"
  using assms apply (rule effectE) using get_alloc
  by (metis (mono_tags, opaque_lifting) effectE effect_makeI not_present_alloc present_alloc prod.collapse)

  (* apply (si mp add: get_alloc execute_make) by (s imp add: case_prod_unfold) *)

lemma execute_len [execute_simps]:
  "execute (len a) h = Some (length h a, h, 1)"
  by (simp add: len_def execute_simps)

lemma success_lenI [success_intros]:
  "success (len a) h"
  by (auto intro: success_intros simp add: len_def)

lemma effect_lengthI [effect_intros]:
  assumes "h' = h" "r = length h a" "n=1"
  shows "effect (len a) h h' r n"
  by (rule effectI) (simp add: assms execute_simps)

lemma effect_lengthE [effect_elims]:
  assumes "effect (len a) h h' r n"
  obtains "r = length h' a" "h' = h" "n=1"
  using assms by (rule effectE) (simp add: execute_simps)

lemma execute_nth [execute_simps]:
  "i < length h a \<Longrightarrow>
    execute (nth a i) h = Some (get h a ! i, h,1)"
  "i \<ge> length h a \<Longrightarrow> execute (nth a i) h = None"
  by (simp_all add: nth_def execute_simps)

lemma success_nthI [success_intros]:
  "i < length h a \<Longrightarrow> success (nth a i) h"
  by (auto intro: success_intros simp add: nth_def)

lemma effect_nthI [effect_intros]:
  assumes "i < length h a" "h' = h" "r = get h a ! i" "n=1"
  shows "effect (nth a i) h h' r n"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_nthE [effect_elims]:
  assumes "effect (nth a i) h h' r n"
  obtains "i < length h a" "r = get h a ! i" "h' = h" "n=1"
  using assms by (rule effectE) (cases "i < length h a", auto simp: execute_simps elim: successE)

lemma execute_upd [execute_simps]:
  "i < length h a \<Longrightarrow>
    execute (upd i x a) h = Some (a, update a i x h, 1)"
  "i \<ge> length h a \<Longrightarrow> execute (upd i x a) h = None"
  by (simp_all add: upd_def execute_simps)

lemma success_updI [success_intros]:
  "i < length h a \<Longrightarrow> success (upd i x a) h"
  by (auto intro: success_intros simp add: upd_def)

lemma effect_updI [effect_intros]:
  assumes "i < length h a" "h' = update a i v h" "n=1"
  shows "effect (upd i v a) h h' a n"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_updE [effect_elims]:
  assumes "effect (upd i v a) h h' r n"
  obtains "r = a" "h' = update a i v h" "i < length h a" "n=1"
  using assms by (rule effectE) (cases "i < length h a", auto simp: execute_simps elim: successE)

lemma execute_map_entry [execute_simps]:
  "i < length h a \<Longrightarrow>
   execute (map_entry i f a) h =
      Some (a, update a i (f (get h a ! i)) h, 2)"
  "i \<ge> length h a \<Longrightarrow> execute (map_entry i f a) h = None"
  by (simp_all add: map_entry_def execute_simps)

lemma success_map_entryI [success_intros]:
  "i < length h a \<Longrightarrow> success (map_entry i f a) h"
  by (auto intro: success_intros simp add: map_entry_def)

lemma effect_map_entryI [effect_intros]:
  assumes "i < length h a" "h' = update a i (f (get h a ! i)) h" "r = a" "n=2"
  shows "effect (map_entry i f a) h h' r n"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_map_entryE [effect_elims]:
  assumes "effect (map_entry i f a) h h' r n"
  obtains "r = a" "h' = update a i (f (get h a ! i)) h" "i < length h a" "n=2"
  using assms by (rule effectE) (cases "i < length h a", auto simp: execute_simps elim: successE)

lemma execute_swap [execute_simps]:
  "i < length h a \<Longrightarrow>
   execute (swap i x a) h =
      Some (get h a ! i, update a i x h, 2)"
  "i \<ge> length h a \<Longrightarrow> execute (swap i x a) h = None"
  by (simp_all add: swap_def execute_simps)

lemma success_swapI [success_intros]:
  "i < length h a \<Longrightarrow> success (swap i x a) h"
  by (auto intro: success_intros simp add: swap_def)

lemma effect_swapI [effect_intros]:
  assumes "i < length h a" "h' = update a i x h" "r = get h a ! i" "n=2"
  shows "effect (swap i x a) h h' r n"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_swapE [effect_elims]:
  assumes "effect (swap i x a) h h' r n"
  obtains "r = get h a ! i" "h' = update a i x h" "i < length h a" "n=2"
  using assms by (rule effectE) (cases "i < length h a", auto simp: execute_simps elim: successE)

lemma execute_freeze [execute_simps]:
  "execute (freeze a) h = Some (get h a, h, 1+length h a)"
  by (simp add: freeze_def execute_simps)

lemma success_freezeI [success_intros]:
  "success (freeze a) h"
  by (auto intro: success_intros simp add: freeze_def)

lemma effect_freezeI [effect_intros]:
  assumes "h' = h" "r = get h a" "n=length h a"
  shows "effect (freeze a) h h' r (n+1)"
  by (rule effectI) (insert assms, simp add: execute_simps)

lemma effect_freezeE [effect_elims]:
  assumes "effect (freeze a) h h' r n"
  obtains "h' = h" "r = get h a" "n=length h a+1"
  using assms by (rule effectE) (simp add: execute_simps)

lemma upd_ureturn:
  "upd i x a \<then> ureturn a =   upd i x a "
  by (rule Heap_eqI) (simp add: bind_def guard_def upd_def execute_simps)

lemma array_make:
  "new n x = make n (\<lambda>_. x)"
  by (rule Heap_eqI) (simp add: map_replicate_trivial execute_simps)

lemma array_of_list_make [code]:
  "of_list xs = make (List.length xs) (\<lambda>n. xs ! n)"
  by (rule Heap_eqI) (simp add: map_nth execute_simps)

hide_const (open) present get set alloc length update noteq new of_list make len nth upd map_entry swap freeze

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

subsubsection \<open>Logical intermediate layer\<close>

definition new' where
  [code del]: "new' = Array_Time.new o nat_of_integer"

definition make' where
  [code del]: "make' i f = Array_Time.make (nat_of_integer i) (f o of_nat)"

lemma [code]:
  "Array_Time.make n f = make' (of_nat n) (f o nat_of_integer)"
  by (simp add: make'_def o_def)

definition len' where
  [code del]: "len' a = Array_Time.len a \<bind> (\<lambda>n. ureturn (of_nat n))"

lemma [code]:
  "Array_Time.len a = len' a \<bind> (\<lambda>i. ureturn (nat_of_integer i))"
  by (simp add: len'_def execute_simps)

definition nth' where
  [code del]: "nth' a = Array_Time.nth a o nat_of_integer"

lemma [code]:
  "Array_Time.nth a n = nth' a (of_nat n)"
  by (simp add: nth'_def)

definition upd' where
  [code del]: "upd' a i x = Array_Time.upd (nat_of_integer i) x a \<then> ureturn ()"

lemma [code]:
  "Array_Time.upd i x a = upd' a (of_nat i) x \<then> ureturn a"
  by (simp add: upd'_def upd_ureturn execute_simps)

lemma [code]:
  "Array_Time.map_entry i f a = do {
     x \<leftarrow> Array_Time.nth a i;
     Array_Time.upd i (f x) a
   }"
  by (rule Heap_eqI) (simp add: bind_def guard_def map_entry_def execute_simps)

lemma [code]:
  "Array_Time.swap i x a = do {
     y \<leftarrow> Array_Time.nth a i;
     Array_Time.upd i x a;
     ureturn y
   }"
  by (rule Heap_eqI) (simp add: bind_def guard_def swap_def execute_simps)
(*
lemma [code]:
  "Array_Time.freeze a = do {
     n \<leftarrow> Array_Time.len a;
     Heap_Monad.fold_map (\<lambda>i. Array_Time.nth a i) [0..<n]
   }"
proof (rule Heap_eqI)
  fix h
  have *: "List.map
     (\<lambda>x. fst (the (if x < Array_Time.length h a
                    then Some (Array_Time.get h a ! x, h) else None)))
     [0..<Array_Time.length h a] =
       List.map (List.nth (Array_Time.get h a)) [0..<Array_Time.length h a]"
    by simp
  have "execute (Heap_Monad.fold_map (Array_Time.nth a) [0..<Array_Time.length h a]) h =
    Some (Array_Time.get h a, h)"
    apply (subst execute_fold_map_unchanged_heap)
    apply (simp_all add: nth_def guard_def * )
    apply (simp add: length_def map_nth)
    done
  then have "execute (do {
      n \<leftarrow> Array_Time.len a;
      Heap_Monad.fold_map (Array_Time.nth a) [0..<n]
    }) h = Some (Array_Time.get h a, h)"
    by (auto intro: execute_bind_eq_SomeI simp add: execute_simps)
  then show "execute (Array_Time.freeze a) h = execute (do {
      n \<leftarrow> Array_Time.len a;
      Heap_Monad.fold_map (Array_Time.nth a) [0..<n]
    }) h" by (simp add: execute_simps)
qed
*)
hide_const (open) new' make' len' nth' upd'

text \<open>SML\<close>

code_printing type_constructor array \<rightharpoonup> (SML) "_/ array"
code_printing constant Array \<rightharpoonup> (SML) "raise/ (Fail/ \"bare Array\")"
code_printing constant Array_Time.new' \<rightharpoonup> (SML) "(fn/ ()/ =>/ Array.array/ ((_),/ (_)))"
code_printing constant Array_Time.of_list \<rightharpoonup> (SML) "(fn/ ()/ =>/ Array.fromList/ _)"
code_printing constant Array_Time.make' \<rightharpoonup> (SML) "(fn/ ()/ =>/ Array.tabulate/ ((_),/ (_)))"
code_printing constant Array_Time.len' \<rightharpoonup> (SML) "(fn/ ()/ =>/ Array.length/ _)"
code_printing constant Array_Time.nth' \<rightharpoonup> (SML) "(fn/ ()/ =>/ Array.sub/ ((_),/ (_)))"
code_printing constant Array_Time.upd' \<rightharpoonup> (SML) "(fn/ ()/ =>/ Array.update/ ((_),/ (_),/ (_)))"
code_printing constant "HOL.equal :: 'a array \<Rightarrow> 'a array \<Rightarrow> bool" \<rightharpoonup> (SML) infixl 6 "="

code_reserved SML Array

text \<open>OCaml\<close>

code_printing type_constructor array \<rightharpoonup> (OCaml) "_/ array"
code_printing constant Array \<rightharpoonup> (OCaml) "failwith/ \"bare Array\""
code_printing constant Array_Time.new' \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ Array.make/ (Big'_int.int'_of'_big'_int/ _)/ _)"
code_printing constant Array_Time.of_list \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ Array.of'_list/ _)"
code_printing constant Array_Time.make' \<rightharpoonup> (OCaml)
  "(fun/ ()/ ->/ Array.init/ (Big'_int.int'_of'_big'_int/ _)/ (fun k'_ ->/ _/ (Big'_int.big'_int'_of'_int/ k'_)))"
code_printing constant Array_Time.len' \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ Big'_int.big'_int'_of'_int/ (Array.length/ _))"
code_printing constant Array_Time.nth' \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ Array.get/ _/ (Big'_int.int'_of'_big'_int/ _))"
code_printing constant Array_Time.upd' \<rightharpoonup> (OCaml) "(fun/ ()/ ->/ Array.set/ _/ (Big'_int.int'_of'_big'_int/ _)/ _)"
code_printing constant "HOL.equal :: 'a array \<Rightarrow> 'a array \<Rightarrow> bool" \<rightharpoonup> (OCaml) infixl 4 "="

code_reserved OCaml Array

text \<open>Haskell\<close>

code_printing type_constructor array \<rightharpoonup> (Haskell) "Heap.STArray/ Heap.RealWorld/ _"
code_printing constant Array \<rightharpoonup> (Haskell) "error/ \"bare Array\""
code_printing constant Array_Time.new' \<rightharpoonup> (Haskell) "Heap.newArray"
code_printing constant Array_Time.of_list \<rightharpoonup> (Haskell) "Heap.newListArray"
code_printing constant Array_Time.make' \<rightharpoonup> (Haskell) "Heap.newFunArray"
code_printing constant Array_Time.len' \<rightharpoonup> (Haskell) "Heap.lengthArray"
code_printing constant Array_Time.nth' \<rightharpoonup> (Haskell) "Heap.readArray"
code_printing constant Array_Time.upd' \<rightharpoonup> (Haskell) "Heap.writeArray"
code_printing constant "HOL.equal :: 'a array \<Rightarrow> 'a array \<Rightarrow> bool" \<rightharpoonup> (Haskell) infix 4 "=="
code_printing class_instance array :: HOL.equal \<rightharpoonup> (Haskell) -

text \<open>Scala\<close>

code_printing type_constructor array \<rightharpoonup> (Scala) "!Array.T[_]"
code_printing constant Array \<rightharpoonup> (Scala) "!sys.error(\"bare Array\")"
code_printing constant Array_Time.new' \<rightharpoonup> (Scala) "('_: Unit)/ => / Array.alloc((_))((_))"
code_printing constant Array_Time.make' \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Array.make((_))((_))"
code_printing constant Array_Time.len' \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Array.len((_))"
code_printing constant Array_Time.nth' \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Array.nth((_), (_))"
code_printing constant Array_Time.upd' \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Array.upd((_), (_), (_))"
code_printing constant Array_Time.freeze \<rightharpoonup> (Scala) "('_: Unit)/ =>/ Array.freeze((_))"
code_printing constant "HOL.equal :: 'a array \<Rightarrow> 'a array \<Rightarrow> bool" \<rightharpoonup> (Scala) infixl 5 "=="

end


(*
  File: RBTree_Impl.thy
  Author: Bohua Zhan
*)

section \<open>Implementation of red-black tree\<close>

theory RBTree_Impl
  imports SepAuto "../Functional/RBTree"
begin

text \<open>
  Verification of imperative red-black trees.
\<close>

subsection \<open>Tree nodes\<close>

datatype ('a, 'b) rbt_node =
  Node (lsub: "('a, 'b) rbt_node ref option") (cl: color) (key: 'a) (val: 'b) (rsub: "('a, 'b) rbt_node ref option")
setup \<open>fold add_rewrite_rule @{thms rbt_node.sel}\<close>

fun color_encode :: "color \<Rightarrow> nat" where
  "color_encode B = 0"
| "color_encode R = 1"

instance color :: heap
  apply (rule heap_class.intro)
  apply (rule countable_classI [of "color_encode"])
  apply (metis color_encode.simps(1) color_encode.simps(2) not_B zero_neq_one)
  ..

fun rbt_node_encode :: "('a::heap, 'b::heap) rbt_node \<Rightarrow> nat" where
  "rbt_node_encode (Node l c k v r) = to_nat (l, c, k, v, r)"

instance rbt_node :: (heap, heap) heap
  apply (rule heap_class.intro)
  apply (rule countable_classI [of "rbt_node_encode"])
  apply (case_tac x, simp_all, case_tac y, simp_all)
  ..

fun btree :: "('a::heap, 'b::heap) rbt \<Rightarrow> ('a, 'b) rbt_node ref option \<Rightarrow> assn" where
  "btree Leaf p = \<up>(p = None)"
| "btree (rbt.Node lt c k v rt) (Some p) = (\<exists>\<^sub>Alp rp. p \<mapsto>\<^sub>r Node lp c k v rp * btree lt lp * btree rt rp)"
| "btree (rbt.Node lt c k v rt) None = false"
setup \<open>fold add_rewrite_ent_rule @{thms btree.simps}\<close>

lemma btree_Leaf [forward_ent]: "btree Leaf p \<Longrightarrow>\<^sub>A \<up>(p = None)" by auto2

lemma btree_Node [forward_ent]:
  "btree (rbt.Node lt c k v rt) p \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Alp rp. the p \<mapsto>\<^sub>r Node lp c k v rp * btree lt lp * btree rt rp * \<up>(p \<noteq> None))"
@proof @case "p = None" @qed

lemma btree_none: "emp \<Longrightarrow>\<^sub>A btree Leaf None" by auto2

lemma btree_constr_ent:
  "p \<mapsto>\<^sub>r Node lp c k v rp * btree lt lp * btree rt rp \<Longrightarrow>\<^sub>A btree (rbt.Node lt c k v rt) (Some p)" by auto2

setup \<open>fold add_entail_matcher [@{thm btree_none}, @{thm btree_constr_ent}]\<close>
setup \<open>fold del_prfstep_thm @{thms btree.simps}\<close>

type_synonym ('a, 'b) btree = "('a, 'b) rbt_node ref option"

subsection \<open>Operations\<close>

subsubsection \<open>Basic operations\<close>

definition tree_empty :: "('a, 'b) btree Heap" where
  "tree_empty = return None"

lemma tree_empty_rule [hoare_triple]:
  "<emp> tree_empty <btree Leaf>" by auto2

definition tree_is_empty :: "('a, 'b) btree \<Rightarrow> bool Heap" where
  "tree_is_empty b = return (b = None)"

definition btree_constr ::
  "('a::heap, 'b::heap) btree \<Rightarrow> color \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_constr lp c k v rp = do { p \<leftarrow> ref (Node lp c k v rp); return (Some p) }"

lemma btree_constr_rule [hoare_triple]:
  "<btree lt lp * btree rt rp>
   btree_constr lp c k v rp
   <btree (rbt.Node lt c k v rt)>" by auto2

definition set_color :: "color \<Rightarrow> ('a::heap, 'b::heap) btree \<Rightarrow> unit Heap" where
  "set_color c p = (case p of
    None \<Rightarrow> raise STR ''set_color''
  | Some pp \<Rightarrow> do {
      t \<leftarrow> !pp;
      pp := Node (lsub t) c (key t) (val t) (rsub t)
    })"

lemma set_color_rule [hoare_triple]:
  "<btree (rbt.Node a c x v b) p>
   set_color c' p
   <\<lambda>_. btree (rbt.Node a c' x v b) p>" by auto2

definition get_color :: "('a::heap, 'b::heap) btree \<Rightarrow> color Heap" where
  "get_color p = (case p of
     None \<Rightarrow> return B
   | Some pp \<Rightarrow> do {
       t \<leftarrow> !pp;
       return (cl t)
     })"

definition paint :: "color \<Rightarrow> ('a::heap, 'b::heap) btree \<Rightarrow> unit Heap" where
  "paint c p = (case p of
    None \<Rightarrow> return ()
  | Some pp \<Rightarrow> do {
     t \<leftarrow> !pp;
     pp := Node (lsub t) c (key t) (val t) (rsub t)
   })"

lemma paint_rule [hoare_triple]:
  "<btree t p>
   paint c p
   <\<lambda>_. btree (RBTree.paint c t) p>"
@proof @case "t = Leaf" @qed

subsubsection \<open>Rotation\<close>

definition btree_rotate_l :: "('a::heap, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_rotate_l p = (case p of
    None \<Rightarrow> raise STR ''Empty btree''
  | Some pp \<Rightarrow> do {
     t \<leftarrow> !pp;
     (case rsub t of
        None \<Rightarrow> raise STR ''Empty rsub''
      | Some rp \<Rightarrow> do {
          rt \<leftarrow> !rp;
          pp := Node (lsub t) (cl t) (key t) (val t) (lsub rt);
          rp := Node p (cl rt) (key rt) (val rt) (rsub rt);
          return (rsub t) })})"

lemma btree_rotate_l_rule [hoare_triple]:
  "<btree (rbt.Node a c1 x v (rbt.Node b c2 y w c)) p>
   btree_rotate_l p
   <btree (rbt.Node (rbt.Node a c1 x v b) c2 y w c)>" by auto2

definition btree_rotate_r :: "('a::heap, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_rotate_r p = (case p of
    None \<Rightarrow> raise STR ''Empty btree''
  | Some pp \<Rightarrow> do {
     t \<leftarrow> !pp;
     (case lsub t of
        None \<Rightarrow> raise STR ''Empty lsub''
      | Some lp \<Rightarrow> do {
          lt \<leftarrow> !lp;
          pp := Node (rsub lt) (cl t) (key t) (val t) (rsub t);
          lp := Node (lsub lt) (cl lt) (key lt) (val lt) p;
          return (lsub t) })})"

lemma btree_rotate_r_rule [hoare_triple]:
  "<btree (rbt.Node (rbt.Node a c1 x v b) c2 y w c) p>
   btree_rotate_r p
   <btree (rbt.Node a c1 x v (rbt.Node b c2 y w c))>" by auto2

subsubsection \<open>Balance\<close>

definition btree_balanceR :: "('a::heap, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_balanceR p = (case p of None \<Rightarrow> return None | Some pp \<Rightarrow> do {
     t \<leftarrow> !pp;
     cl_r \<leftarrow> get_color (rsub t);
     if cl_r = R then do {
       rt \<leftarrow> !(the (rsub t));
       cl_lr \<leftarrow> get_color (lsub rt);
       cl_rr \<leftarrow> get_color (rsub rt);
       if cl_lr = R then do {
         rp' \<leftarrow> btree_rotate_r (rsub t);
         pp := Node (lsub t) (cl t) (key t) (val t) rp';
         p' \<leftarrow> btree_rotate_l p;
         t' \<leftarrow> !(the p');
         set_color B (rsub t');
         return p'
       } else if cl_rr = R then do {
         p' \<leftarrow> btree_rotate_l p;
         t' \<leftarrow> !(the p');
         set_color B (rsub t');
         return p'
        } else return p }
     else return p})"

lemma balanceR_to_fun [hoare_triple]:
  "<btree (rbt.Node l B k v r) p>
   btree_balanceR p
   <btree (balanceR l k v r)>"
@proof @unfold "balanceR l k v r" @qed

definition btree_balance :: "('a::heap, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_balance p = (case p of None \<Rightarrow> return None | Some pp \<Rightarrow> do {
     t \<leftarrow> !pp;
     cl_l \<leftarrow> get_color (lsub t);
     if cl_l = R then do {
       lt \<leftarrow> !(the (lsub t));
       cl_rl \<leftarrow> get_color (rsub lt);
       cl_ll \<leftarrow> get_color (lsub lt);
       if cl_ll = R then do {
         p' \<leftarrow> btree_rotate_r p;
         t' \<leftarrow> !(the p');
         set_color B (lsub t');
         return p' }
       else if cl_rl = R then do {
         lp' \<leftarrow> btree_rotate_l (lsub t);
         pp := Node lp' (cl t) (key t) (val t) (rsub t);
         p' \<leftarrow> btree_rotate_r p;
         t' \<leftarrow> !(the p');
         set_color B (lsub t');
         return p'
       } else btree_balanceR p }
     else do {
       p' \<leftarrow> btree_balanceR p;
       return p'}})"

subsubsection \<open>Insertion\<close>

partial_function (heap) rbt_ins ::
  "'a::{heap,ord} \<Rightarrow> 'b::heap \<Rightarrow> ('a, 'b) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "rbt_ins k v p = (case p of
     None \<Rightarrow> btree_constr None R k v None
   | Some pp \<Rightarrow> do {
      t \<leftarrow> !pp;
      (if cl t = B then
        (if k = key t then do {
           pp := Node (lsub t) (cl t) k v (rsub t);
           return (Some pp) }
         else if k < key t then do {
           q \<leftarrow> rbt_ins k v (lsub t);
           pp := Node q (cl t) (key t) (val t) (rsub t);
           btree_balance p }
         else do {
           q \<leftarrow> rbt_ins k v (rsub t);
           pp := Node (lsub t) (cl t) (key t) (val t) q;
           btree_balance p })
       else
        (if k = key t then do {
           pp := Node (lsub t) (cl t) k v (rsub t);
           return (Some pp) }
         else if k < key t then do {
           q \<leftarrow> rbt_ins k v (lsub t);
           pp := Node q (cl t) (key t) (val t) (rsub t);
           return (Some pp) }
         else do {
           q \<leftarrow> rbt_ins k v (rsub t);
           pp := Node (lsub t) (cl t) (key t) (val t) q;
           return (Some pp) }))})"

lemma rbt_ins_to_fun [hoare_triple]:
  "<btree t p>
   rbt_ins k v p
   <btree (ins k v t)>"
@proof @induct t arbitrary p @qed

definition rbt_insert ::
  "'a::{heap,ord} \<Rightarrow> 'b::heap \<Rightarrow> ('a, 'b) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "rbt_insert k v p = do {
    p' \<leftarrow> rbt_ins k v p;
    paint B p';
    return p' }"

lemma rbt_insert_to_fun [hoare_triple]:
  "<btree t p>
   rbt_insert k v p
   <btree (RBTree.rbt_insert k v t)>" by auto2

subsubsection \<open>Search\<close>

partial_function (heap) rbt_search ::
  "'a::{heap,linorder} \<Rightarrow> ('a, 'b::heap) btree \<Rightarrow> 'b option Heap" where
  "rbt_search x b = (case b of
     None \<Rightarrow> return None
   | Some p \<Rightarrow> do {
      t \<leftarrow> !p;
      (if x = key t then return (Some (val t))
       else if x < key t then rbt_search x (lsub t)
       else rbt_search x (rsub t)) })"

lemma btree_search_correct [hoare_triple]:
  "<btree t b * \<up>(rbt_sorted t)>
   rbt_search x b
   <\<lambda>r. btree t b * \<up>(r = RBTree.rbt_search t x)>"
@proof @induct t arbitrary b @qed

subsubsection \<open>Delete\<close>

definition btree_balL :: "('a::heap, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_balL p = (case p of
     None \<Rightarrow> return None
   | Some pp \<Rightarrow> do {
      t \<leftarrow> !pp;
      cl_l \<leftarrow> get_color (lsub t);
      if cl_l = R then do {
        set_color B (lsub t);  \<comment> \<open>Case 1\<close>
        return p}
      else case rsub t of
        None \<Rightarrow> return p  \<comment> \<open>Case 2\<close>
      | Some rp \<Rightarrow> do {
         rt \<leftarrow> !rp;
         if cl rt = B then do {
           set_color R (rsub t);  \<comment> \<open>Case 3\<close>
           set_color B p;
           btree_balance p}
         else case lsub rt of
           None \<Rightarrow> return p  \<comment> \<open>Case 4\<close>
         | Some lrp \<Rightarrow> do {
            lrt \<leftarrow> !lrp;
            if cl lrt = B then do {
              set_color R (lsub rt);  \<comment> \<open>Case 5\<close>
              paint R (rsub rt);
              set_color B (rsub t);
              rp' \<leftarrow> btree_rotate_r (rsub t);
              pp := Node (lsub t) (cl t) (key t) (val t) rp';
              p' \<leftarrow> btree_rotate_l p;
              t' \<leftarrow> !(the p');
              set_color B (lsub t');
              rp'' \<leftarrow> btree_balance (rsub t');
              the p' := Node (lsub t') (cl t') (key t') (val t') rp'';
              return p'}
            else return p}}})"

lemma balL_to_fun [hoare_triple]:
  "<btree (rbt.Node l R k v r) p>
   btree_balL p
   <btree (balL l k v r)>"
@proof @unfold "balL l k v r" @qed

definition btree_balR :: "('a::heap, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_balR p = (case p of
     None \<Rightarrow> return None
   | Some pp \<Rightarrow> do {
      t \<leftarrow> !pp;
      cl_r \<leftarrow> get_color (rsub t);
      if cl_r = R then do {
        set_color B (rsub t);  \<comment> \<open>Case 1\<close>
        return p}
      else case lsub t of
        None \<Rightarrow> return p  \<comment> \<open>Case 2\<close>
      | Some lp \<Rightarrow> do {
         lt \<leftarrow> !lp;
         if cl lt = B then do {
           set_color R (lsub t);  \<comment> \<open>Case 3\<close>
           set_color B p;
           btree_balance p}
         else case rsub lt of
           None \<Rightarrow> return p  \<comment> \<open>Case 4\<close>
         | Some rlp \<Rightarrow> do {
            rlt \<leftarrow> !rlp;
            if cl rlt = B then do {
              set_color R (rsub lt);  \<comment> \<open>Case 5\<close>
              paint R (lsub lt);
              set_color B (lsub t);
              lp' \<leftarrow> btree_rotate_l (lsub t);
              pp := Node lp' (cl t) (key t) (val t) (rsub t);
              p' \<leftarrow> btree_rotate_r p;
              t' \<leftarrow> !(the p');
              set_color B (rsub t');
              lp'' \<leftarrow> btree_balance (lsub t');
              the p' := Node lp'' (cl t') (key t') (val t') (rsub t');
              return p'}
            else return p}}})"

lemma balR_to_fun [hoare_triple]:
  "<btree (rbt.Node l R k v r) p>
   btree_balR p
   <btree (balR l k v r)>"
@proof @unfold "balR l k v r" @qed

partial_function (heap) btree_combine ::
  "('a::heap, 'b::heap) btree \<Rightarrow> ('a, 'b) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "btree_combine lp rp =
   (if lp = None then return rp
    else if rp = None then return lp
    else do {
      lt \<leftarrow> !(the lp);
      rt \<leftarrow> !(the rp);
      if cl lt = R then
        if cl rt = R then do {
          tmp \<leftarrow> btree_combine (rsub lt) (lsub rt);
          cl_tm \<leftarrow> get_color tmp;
          if cl_tm = R then do {
            tmt \<leftarrow> !(the tmp);
            the lp := Node (lsub lt) R (key lt) (val lt) (lsub tmt);
            the rp := Node (rsub tmt) R (key rt) (val rt) (rsub rt);
            the tmp := Node lp R (key tmt) (val tmt) rp;
            return tmp}
          else do {
            the rp := Node tmp R (key rt) (val rt) (rsub rt);
            the lp := Node (lsub lt) R (key lt) (val lt) rp;
            return lp}}
        else do {
          tmp \<leftarrow> btree_combine (rsub lt) rp;
          the lp := Node (lsub lt) R (key lt) (val lt) tmp;
          return lp}
      else if cl rt = B then do {
        tmp \<leftarrow> btree_combine (rsub lt) (lsub rt);
        cl_tm \<leftarrow> get_color tmp;
        if cl_tm = R then do {
          tmt \<leftarrow> !(the tmp);
          the lp := Node (lsub lt) B (key lt) (val lt) (lsub tmt);
          the rp := Node (rsub tmt) B (key rt) (val rt) (rsub rt);
          the tmp := Node lp R (key tmt) (val tmt) rp;
          return tmp}
        else do {
          the rp := Node tmp B (key rt) (val rt) (rsub rt);
          the lp := Node (lsub lt) R (key lt) (val lt) rp;
          btree_balL lp}}
      else do {
        tmp \<leftarrow> btree_combine lp (lsub rt);
        the rp := Node tmp R (key rt) (val rt) (rsub rt);
        return rp}})"

lemma combine_to_fun [hoare_triple]:
  "<btree lt lp * btree rt rp>
   btree_combine lp rp
   <btree (combine lt rt)>"
@proof @fun_induct "combine lt rt" arbitrary lp rp @with
  @subgoal "(lt = rbt.Node l1 c1 k1 v1 r1, rt = rbt.Node l2 c2 k2 v2 r2)"
    @unfold "combine (rbt.Node l1 c1 k1 v1 r1) (rbt.Node l2 c2 k2 v2 r2)"
  @endgoal @end
@qed

partial_function (heap) rbt_del ::
  "'a::{heap,linorder} \<Rightarrow> ('a, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "rbt_del x p = (case p of
     None \<Rightarrow> return None
   | Some pp \<Rightarrow> do {
      t \<leftarrow> !pp;
      (if x = key t then btree_combine (lsub t) (rsub t)
       else if x < key t then case lsub t of
         None \<Rightarrow> do {
           set_color R p;
           return p}
       | Some lp \<Rightarrow> do {
           lt \<leftarrow> !lp;
           if cl lt = B then do {
             q \<leftarrow> rbt_del x (lsub t);
             pp := Node q R (key t) (val t) (rsub t);
             btree_balL p }
           else do {
             q \<leftarrow> rbt_del x (lsub t);
             pp := Node q R (key t) (val t) (rsub t);
             return p }}
       else case rsub t of
         None \<Rightarrow> do {
           set_color R p;
           return p}
       | Some rp \<Rightarrow> do {
           rt \<leftarrow> !rp;
           if cl rt = B then do {
             q \<leftarrow> rbt_del x (rsub t);
             pp := Node (lsub t) R (key t) (val t) q;
             btree_balR p }
           else do {
             q \<leftarrow> rbt_del x (rsub t);
             pp := Node (lsub t) R (key t) (val t) q;
             return p }})})"

lemma rbt_del_to_fun [hoare_triple]:
  "<btree t p>
   rbt_del x p
   <btree (del x t)>\<^sub>t"
@proof @induct t arbitrary p @with
  @subgoal "t = rbt.Node l c k v r"
    @unfold "del x (rbt.Node l c k v r)"
  @endgoal @end
@qed

definition rbt_delete ::
  "'a::{heap,linorder} \<Rightarrow> ('a, 'b::heap) btree \<Rightarrow> ('a, 'b) btree Heap" where
  "rbt_delete k p = do {
    p' \<leftarrow> rbt_del k p;
    paint B p';
    return p'}"

lemma rbt_delete_to_fun [hoare_triple]:
  "<btree t p>
   rbt_delete k p
   <btree (RBTree.delete k t)>\<^sub>t" by auto2

subsection \<open>Outer interface\<close>

text \<open>Express Hoare triples for operations on red-black tree in terms of
  the mapping represented by the tree.\<close>
definition rbt_map_assn :: "('a, 'b) map \<Rightarrow> ('a::{heap,linorder}, 'b::heap) rbt_node ref option \<Rightarrow> assn" where
  "rbt_map_assn M p = (\<exists>\<^sub>At. btree t p * \<up>(is_rbt t) * \<up>(rbt_sorted t) * \<up>(M = rbt_map t))"
setup \<open>add_rewrite_ent_rule @{thm rbt_map_assn_def}\<close>

theorem rbt_insert_rule [hoare_triple]:
  "<rbt_map_assn M b> rbt_insert k v b <rbt_map_assn (M {k \<rightarrow> v})>" by auto2

theorem rbt_search [hoare_triple]:
  "<rbt_map_assn M b> rbt_search x b <\<lambda>r. rbt_map_assn M b * \<up>(r = M\<langle>x\<rangle>)>" by auto2

theorem rbt_delete_rule [hoare_triple]:
  "<rbt_map_assn M b> rbt_delete k b <rbt_map_assn (delete_map k M)>\<^sub>t" by auto2

end