theory temp

imports Main

begin

datatype 'a tree = Tip
  | Node "'a tree" 'a "'a tree"

primrec revtree :: "'a tree \<Rightarrow> 'a tree"
  where
"revtree Tip = Tip" |
"revtree (Node xs x ys) = (Node (revtree ys) x (revtree xs))"

lemma reverse:
  shows "revtree(revtree(t)) = t"
  apply (induct_tac t)
  by auto

lemma reverse2:
  shows "revtree(revtree(revtree(t))) = revtree(t)"
  using reverse apply auto

(*
     a
   /    \
atree   atree

*)


theory prop_02
imports Main
        "../../TestTheories/Listi"
        "../../TestTheories/Naturals"
        "$HIPSTER_HOME/IsaHipster"

begin

(*hipster init app*)
lemma lemma_a [thy_expl]: "app x2 Nil = x2"
by (hipster_induct_schemes init.simps app.simps)

lemma lemma_aa [thy_expl]: "app (app x1 y1) z1 = app x1 (app y1 z1)"
by (hipster_induct_schemes init.simps app.simps)

lemma unknown [thy_expl]: "init (app x x) = app x (init x)"
oops

(*
hipster_cond notNil init*)

theorem initApp: "notNil ts \<Longrightarrow> init (app rs ts) = app rs (init ts)"
by (hipster_induct_schemes notNil.simps init.simps app.simps NL.exhaust)

end


theory nat_alt_mul_assoc
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S n) y = S (plus n y)"

fun altmul :: "Nat => Nat => Nat" where
"altmul (Z) y = Z"
| "altmul (S z) (Z) = Z"
| "altmul (S z) (S x2) = S (plus (plus (altmul z x2) z) x2)"

(*hipster plus altmul *)

theorem x0 :
  "!! (x :: Nat) (y :: Nat) (z :: Nat) .
     (altmul x (altmul y z)) = (altmul (altmul x y) z)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory prop_36
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Nat = Z | S "Nat"
  fun equal2 :: "Nat => Nat => bool" where
  "equal2 (Z) (Z) = True"
  | "equal2 (Z) (S z) = False"
  | "equal2 (S x2) (Z) = False"
  | "equal2 (S x2) (S y2) = equal2 x2 y2"
  fun elem :: "Nat => Nat list => bool" where
  "elem x (Nil2) = False"
  | "elem x (Cons2 z xs) = (if equal2 x z then True else elem x xs)"
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  (*hipster equal2 elem append *)

  theorem x0 :
    "(elem x y) ==> (elem x (append y z))"
    by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)
end


theory Insert_Opt_Ext
  imports
    Insert_Opt
    Balance_Opt_Ext
    "../../Utilities_Ext"
    "../../Assertion_Tree_Lookup"
begin

context rbt_impl
begin

lemma pure_assn_prem_from_prem: "(P1 \<Longrightarrow> P2 \<Longrightarrow> htriple P3 c Q) \<Longrightarrow> htriple (\<up>P1 ** \<up>P2 ** P3) c Q"
  by (metis (mono_tags) htriple_realizable_preI n1 pure_true_conv realizable_extract_pure)

lemma less_key_not_in_value_graph [dest]: "(k, vi) \<in> graph (value_of_key t) \<Longrightarrow> (rbt_of t) |\<guillemotleft> k \<Longrightarrow> False"
  unfolding graph_def
  by (simp add: value_of_key_less_none)+

lemma greater_key_not_in_value_graph [dest]: "(k, vi) \<in> graph (value_of_key t) \<Longrightarrow> k \<guillemotleft>| (rbt_of t) \<Longrightarrow> False"
  unfolding graph_def
  by (simp add: value_of_key_greater_none)+

lemma insert'_opt_correct_ext:
  "
    llvm_htriple
    (rbt_assn_ext t {} ti ** \<upharpoonleft>key_assn k ki ** \<upharpoonleft>value_assn v vi ** \<up>(rbt_sorted (rbt_of t)))
    (insert'_opt ki vi ti)
    (\<lambda>res. EXS t_res. rbt_assn_ext t_res {} res **
      \<up>(rbt_of t_res = (rbt_ins (\<lambda>_ _ v. v)) k v (rbt_of t)) **
      \<up>(rbt_sorted (rbt_of t_res)) **
      \<up>(ptr_of_key t ti \<subseteq>\<^sub>m ptr_of_key t_res res) **
      \<up>(value_of_key t_res = (value_of_key t)(k \<mapsto> vi))
    )
  "
proof (induction k v "rbt_of t" arbitrary: t ti rule: rbt_insert_ad'.induct )
  case (1 k\<^sub>n v\<^sub>n)
  then show ?case
    apply (subst insert'_opt.simps)
    apply vcg_vok
    done
next
  case (2 k\<^sub>n v\<^sub>n l k v r)

  have []:
    "llvm_htriple (\<up>(k\<^sub>n < k \<and> l = rbt_of t) ** rbt_assn_ext t {} ti \<and>* \<upharpoonleft>key_assn k\<^sub>n ki \<and>* \<upharpoonleft>value_assn v\<^sub>n vi \<and>* \<up>rbt_sorted (rbt_of t))
          (insert'_opt ki vi ti)
          (\<lambda>res s.
              \<exists>x. (rbt_assn_ext x {} res \<and>*
                   \<up>(rbt_of x = rbt_ins (\<lambda>_ _ v. v) k\<^sub>n v\<^sub>n (rbt_of t)) \<and>*
                   \<up>rbt_sorted (rbt_of x) \<and>*
                   \<up>(ptr_of_key t ti \<subseteq>\<^sub>m ptr_of_key x res) \<and>*
                   \<up>(value_of_key x = value_of_key t(k\<^sub>n \<mapsto> vi)))
                   s)" for t ti supply 2(1)[vcg_rules] by vcg

  have []:
      "llvm_htriple (\<up>(\<not> k\<^sub>n < k \<and> k < k\<^sub>n \<and> r = rbt_of t) ** rbt_assn_ext t {} ti \<and>* \<upharpoonleft>key_assn k\<^sub>n ki \<and>* \<upharpoonleft>value_assn v\<^sub>n vi \<and>* \<up>rbt_sorted (rbt_of t))
          (insert'_opt ki vi ti)
          (\<lambda>res s.
              \<exists>x. (rbt_assn_ext x {} res \<and>*
                   \<up>(rbt_of x = rbt_ins (\<lambda>_ _ v. v) k\<^sub>n v\<^sub>n (rbt_of t)) \<and>*
                   \<up>rbt_sorted (rbt_of x) \<and>*
                   \<up>(ptr_of_key t ti \<subseteq>\<^sub>m ptr_of_key x res) \<and>*
                   \<up>(value_of_key x = value_of_key t (k\<^sub>n \<mapsto> vi)))
                   s)" for t ti supply 2(2)[vcg_rules] by vcg

  from 2(3) show ?case
    apply (subst insert'_opt.simps)
    unfolding balance_black_def
    supply
      rbt_greater_trans[intro]
      rbt_less_trans[intro]

    supply 2(1-2)[vcg_rules]
    by (vcg_vok;fail)
next
  case (3 k\<^sub>n v\<^sub>n l k v r)

  note [vcg_rules] = 3(1-2)

  from 3(3) show ?case
    apply (subst insert'_opt.simps)
    unfolding balance_black_def
    supply
      rbt_greater_trans[intro]
      rbt_less_trans[intro]
    by (vcg_vok;fail)
qed

lemma insert_opt_correct_ext':
  "
    llvm_htriple
    (rbt_assn_ext t {} ti ** \<upharpoonleft>key_assn k ki ** \<upharpoonleft>value_assn v vi ** \<up>(is_rbt (rbt_of t)))
    (insert_opt ki vi ti)
    (\<lambda>ti_res. EXS t_res.
      rbt_assn_ext t_res {} ti_res **
      \<up>(rbt_of t_res = rbt_insert k v (rbt_of t)) **
      ctx(is_rbt (rbt_of t_res)) **
      \<up>(ptr_of_key t ti \<subseteq>\<^sub>m ptr_of_key t_res ti_res) **
      \<up>(value_of_key t_res = (value_of_key t)(k \<mapsto> vi))
    )
  "
  unfolding insert_opt_def rbt_insert_def rbt_insert_with_key_def paint_def is_rbt_def
  supply insert'_opt_correct_ext[vcg_rules]
  apply vcg
  apply (cases "rbt_ins (\<lambda>_ _ v. v) k v (rbt_of t)")
  subgoal using rbt_ins_non_empty by fast
  apply vcg
  apply vcg_compat
  apply (sepEwith \<open>(solves auto)?\<close>)
  subgoal
    by (metis color_of.simps(2) ins_inv1_inv2(1) ins_inv1_inv2(3) ins_rbt_sorted inv1.simps(2) inv2.simps(2) rbt_of_branchI rbt_sorted.simps(2))
  apply (sepwith \<open>solves pok_solver | solves vok_solver\<close>)
  apply simp
  apply sep
  done

lemmas insert_opt_correct_ext[vcg_rules] = insert_opt_correct_ext'[simplified ctx_def]

end

end


theory SquareProof
  imports
  "Square_Shallow_Normal"
begin

(* Our cogent function is available for us to use *)
value "square 5"

(* reasoning about our function *)
lemma square_correct: "square n = n^2"
  apply (induct n)
  using square_def apply simp
  using square_def apply simp
  by (simp add: power2_eq_square)

end


chapter "Shallow IMP"
section{*Commands*}
text{*Instead of using a deep-embedding for the abstract syntax we use shallow embedding.
      To do so we need an explicit notion of substitution and variables.
      We use abbreviation in order that we do not hide the core theory behind
      another definition layer. Which makes it more suited for exploitation by simp, auto, etc*}

theory utp_rel
imports "utp_pred" "utp_alphabet" "utp_urel_setup"

begin

type_synonym '\<alpha> cond      = "'\<alpha> upred"
type_synonym ('\<alpha>, '\<beta>) rel = "('\<alpha> \<times> '\<beta>) upred"
type_synonym '\<alpha> hrel      = "('\<alpha> \<times> '\<alpha>) upred"
type_synonym ('a, '\<alpha>) hexpr = "('a, '\<alpha> \<times> '\<alpha>) uexpr"

translations
  (type) "('\<alpha>, '\<beta>) rel" <= (type) "('\<alpha> \<times> '\<beta>) upred"

text {* We set up some overloaded constants for sequential composition and the identity in case
  we want to overload their definitions later. *}

consts
  useq     :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infixr ";;" 71)
  uassigns :: "'a usubst \<Rightarrow> 'b" ("\<langle>_\<rangle>\<^sub>a")
  uskip    :: "'a" ("II")

subsection \<open>Conditional\<close>

abbreviation rcond::"('\<alpha>, '\<beta>) rel \<Rightarrow> '\<alpha> cond \<Rightarrow> ('\<alpha>, '\<beta>) rel \<Rightarrow> ('\<alpha>, '\<beta>) rel"
                                                          ("(3_ \<triangleleft> _ \<triangleright>\<^sub>r/ _)" [52,0,53] 52)
where "(P \<triangleleft> b \<triangleright>\<^sub>r Q) \<equiv> (P \<triangleleft> \<lceil>b\<rceil>\<^sub>< \<triangleright> Q)"

subsection \<open>Sequential composition\<close>

lift_definition seqr::"('\<alpha>, '\<beta>) rel \<Rightarrow> ('\<beta>, '\<gamma>) rel \<Rightarrow> ('\<alpha>, '\<gamma>) rel"  is
  "\<lambda> P Q r. r \<in> ({p. P p} O {q. Q q})" .

 adhoc_overloading
  useq seqr

text {* We also set up a homogeneous sequential composition operator, and versions of @{term true}
  and @{term false} that are explicitly typed by a homogeneous alphabet. *}

abbreviation seqh :: "'\<alpha> hrel \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" (infixr ";;\<^sub>h" 71) where
"seqh P Q \<equiv> (P ;; Q)"

lift_definition assigns_r :: "'\<alpha> usubst \<Rightarrow> '\<alpha> hrel"
  is "\<lambda> \<sigma> (A, A'). A' = \<sigma>(A)" .

adhoc_overloading
  uassigns assigns_r

subsection \<open>SKIP\<close>

definition skip_ra :: "('\<beta>, '\<alpha>) lens \<Rightarrow>'\<alpha> hrel" where
[urel_defs]: "skip_ra v = ($v\<acute> =\<^sub>u $v)"

syntax
  "_skip_ra" :: "salpha \<Rightarrow> logic" ("II\<^bsub>_\<^esub>")

translations
  "_skip_ra v" == "CONST skip_ra v"

definition skip_r :: "'\<alpha> hrel" where
[urel_defs]:"skip_r = assigns_r id"

adhoc_overloading
  uskip skip_r

subsection \<open>Assign\<close>

definition assigns_ra :: "'\<alpha> usubst \<Rightarrow> ('\<beta>, '\<alpha>) lens \<Rightarrow> '\<alpha> hrel" ("\<langle>_\<rangle>\<^bsub>_\<^esub>") where
"\<langle>\<sigma>\<rangle>\<^bsub>a\<^esub> = (\<lceil>\<sigma>\<rceil>\<^sub>s \<dagger> II\<^bsub>a\<^esub>)"

abbreviation assign_r :: "('t \<Longrightarrow> '\<alpha>) \<Rightarrow> ('t, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel"  where
  "assign_r v expr \<equiv> assigns_r [v \<mapsto>\<^sub>s expr]"

abbreviation assign_2_r ::
  "('t1 \<Longrightarrow> '\<alpha>) \<Rightarrow> ('t2 \<Longrightarrow> '\<alpha>) \<Rightarrow> ('t1, '\<alpha>) uexpr \<Rightarrow> ('t2, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel" where
  "assign_2_r x y u v \<equiv> assigns_r [x \<mapsto>\<^sub>s u, y \<mapsto>\<^sub>s v]"

text \<open> We set up iterated sequential composition which iterates an indexed predicate over the
       elements of a list. \<close>

definition seqr_iter :: "'a list \<Rightarrow> ('a \<Rightarrow> 'b hrel) \<Rightarrow> 'b hrel" where
[urel_defs]: "seqr_iter xs P = foldr (\<lambda> i Q. P(i) ;; Q) xs II"

abbreviation conv_r :: "('a, '\<alpha> \<times> '\<beta>) uexpr \<Rightarrow> ('a, '\<beta> \<times> '\<alpha>) uexpr" ("_\<^sup>-" [999] 999)
where "conv_r e \<equiv> e \<oplus>\<^sub>p swap\<^sub>L"

subsection{*assert and assume*}

definition rassume :: "'\<alpha> upred \<Rightarrow> '\<alpha> hrel" ("_\<^sup>\<top>" [999] 999) where
[urel_defs]: "rassume c = II \<triangleleft> c \<triangleright>\<^sub>r false"

definition rassert :: "'\<alpha> upred \<Rightarrow> '\<alpha> hrel" ("_\<^sub>\<bottom>" [999] 999) where
[urel_defs]: "rassert c = II \<triangleleft> c \<triangleright>\<^sub>r true"

text {* Homogeneous relations form a quantale. This allows us to import a large number of laws
        from Struth and Armstrong's Kleene Algebra theory~\cite{Armstrong2015}. *}

abbreviation truer :: "'\<alpha> hrel" ("true\<^sub>h") where
"truer \<equiv> true"

abbreviation falser :: "'\<alpha> hrel" ("false\<^sub>h") where
"falser \<equiv> false"

text {* We next describe frames and antiframes with the help of lenses. A frame states that $P$
  defines the behaviour of all variables not in $a$, and all those in $a$ remain the same. An
  antiframe describes the converse: all variables in $a$ are specified by $P$, and all other
  variables remain the same. For more information please see \cite{Morgan90a}.*}

definition frame :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "frame a P = (\<^bold>\<exists> st \<bullet> P\<lbrakk>\<guillemotleft>st\<guillemotright>/$\<Sigma>\<acute>\<rbrakk> \<and> $\<Sigma>\<acute> =\<^sub>u \<guillemotleft>st\<guillemotright> \<oplus> $\<Sigma> on &a)"

definition antiframe :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "antiframe a P = (\<^bold>\<exists> st \<bullet> P\<lbrakk>\<guillemotleft>st\<guillemotright>/$\<Sigma>\<acute>\<rbrakk> \<and> $\<Sigma>\<acute> =\<^sub>u $\<Sigma> \<oplus> \<guillemotleft>st\<guillemotright> on &a)"

text {* The nameset operator can be used to hide a portion of the after-state that lies outside
  the lens $a$. It can be useful to partition a relation's variables in order to conjoin it
  with another relation. *}

definition nameset :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel \<Rightarrow> '\<alpha> hrel" where
[urel_defs]: "nameset a P = (P \<restriction>\<^sub>v {$\<Sigma>,$a\<acute>})"

subsection {* Syntax Translations *}

syntax
  -- {* Alternative traditional conditional syntax *}
  "_utp_if" :: "logic \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("(if\<^sub>u (_)/ then (_)/ else (_))" [0, 0, 71] 71)
  -- {* Iterated sequential composition *}
  "_seqr_iter" :: "pttrn \<Rightarrow> 'a list \<Rightarrow> '\<sigma> hrel \<Rightarrow> '\<sigma> hrel" ("(3;; _ : _ \<bullet>/ _)" [0, 0, 10] 10)
  -- {* Single and multiple assignement *}
  "_assignment"     :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> hrel"  ("'(_') :== '(_')")
  "_assignment"     :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> hrel"  (infixr ":==" 72)
  -- {* Indexed assignment *}
  "_assignment_upd" :: "svid \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("(_[_] :==/ _)" [73, 0, 0] 72)
  -- {* Substitution constructor *}
  "_mk_usubst"      :: "svids \<Rightarrow> uexprs \<Rightarrow> '\<alpha> usubst"
  -- {* Alphabetised skip *}
  "_skip_ra"        :: "salpha \<Rightarrow> logic" ("II\<^bsub>_\<^esub>")
  -- {* Frame *}
  "_frame"          :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_:\<lbrakk>_\<rbrakk>" [79,0] 80)
  -- {* Antiframe *}
  "_antiframe"      :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("_:[_]" [99,0] 100)
  -- {* Nameset *}
  "_nameset"        :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("ns _ \<bullet> _" [0,999] 999)

translations
  "_utp_if b P Q" => "P \<triangleleft> b \<triangleright>\<^sub>r Q"
  ";; x : l \<bullet> P" \<rightleftharpoons> "(CONST seqr_iter) l (\<lambda>x. P)"
  "_mk_usubst \<sigma> (_svid_unit x) v" \<rightleftharpoons> "\<sigma>(&x \<mapsto>\<^sub>s v)"
  "_mk_usubst \<sigma> (_svid_list x xs) (_uexprs v vs)" \<rightleftharpoons> "(_mk_usubst (\<sigma>(&x \<mapsto>\<^sub>s v)) xs vs)"
  "_assignment xs vs" => "CONST uassigns (_mk_usubst (CONST id) xs vs)"
  "x :== v" <= "CONST uassigns (CONST subst_upd (CONST id) (CONST svar x) v)"
  "x :== v" <= "CONST uassigns (CONST subst_upd (CONST id) x v)"
  "x,y :== u,v" <= "CONST uassigns (CONST subst_upd (CONST subst_upd (CONST id) (CONST svar x) u) (CONST svar y) v)"
  -- {* Indexed assignment uses the overloaded collection update function \emph{uupd}. *}
  "x [k] :== v" => "x :== &x(k \<mapsto> v)\<^sub>u"
  "_skip_ra v" \<rightleftharpoons> "CONST skip_ra v"
  "_frame x P" => "CONST frame x P"
  "_frame (_salphaset (_salphamk x)) P" <= "CONST frame x P"
  "_antiframe x P" => "CONST antiframe x P"
  "_antiframe (_salphaset (_salphamk x)) P" <= "CONST antiframe x P"
  "_nameset x P" == "CONST nameset x P"

text {* The following code sets up pretty-printing for homogeneous relational expressions. We cannot
  do this via the ``translations'' command as we only want the rule to apply when the input and output
  alphabet types are the same. The code has to deconstruct a @{typ "('a, '\<alpha>) uexpr"} type, determine
  that it is relational (product alphabet), and then checks if the types \emph{alpha} and \emph{beta}
  are the same. If they are, the type is printed as a \emph{hexpr}. Otherwise, we have no match.
  We then set up a regular translation for the \emph{hrel} type that uses this. *}

print_translation {*
let
fun tr' ctx [ a
            , Const (@{type_syntax "prod"},_) $ alpha $ beta ] =
  if (alpha = beta)
    then Syntax.const @{type_syntax "hexpr"} $ a $ alpha
    else raise Match;
in [(@{type_syntax "uexpr"},tr')]
end
*}

translations
  (type) "'\<alpha> hrel" <= (type) "(bool, '\<alpha>) hexpr"

subsection {* Program values *}

abbreviation prog_val :: "'\<alpha> hrel \<Rightarrow> ('\<alpha> hrel, '\<alpha>) uexpr" ("\<lbrace>|_|\<rbrace>\<^sub>u")
where "\<lbrace>|P|\<rbrace>\<^sub>u \<equiv> \<guillemotleft>P\<guillemotright>"

lift_definition call :: "('\<alpha> hrel, '\<alpha>) uexpr \<Rightarrow> '\<alpha> hrel"
is "\<lambda> P b. P (fst b) b" .

lemma call_prog_val: "call \<lbrace>|P|\<rbrace>\<^sub>u = P"
  by (simp add: call_def urel_defs lit.rep_eq Rep_uexpr_inverse)

(*notation (latex)
  skip_r  ("\<SKIP>") and
  cond  ("\<IF> _ \<THEN> _ \<ELSE> _"  60) and
  while  ("\<WHILE> _ \<DO> _ \<OD>"  60)*)

subsection {*Props *}

text {* We describe some properties of relations, including functional and injective relations. *}

definition ufunctional :: "('a, 'b) rel \<Rightarrow> bool"
where [urel_defs]: "ufunctional R \<longleftrightarrow> II \<sqsubseteq> R\<^sup>- ;; R"

definition uinj :: "('a, 'b) rel \<Rightarrow> bool"
where [urel_defs]: "uinj R \<longleftrightarrow> II \<sqsubseteq> R ;; R\<^sup>-"

-- {* Configuration for UTP tactics (see @{theory utp_tactics}). *}

update_uexpr_rep_eq_thms -- {* Reread @{text rep_eq} theorems. *}
text {* A test is like a precondition, except that it identifies to the postcondition. It
        forms the basis for Kleene Algebra with Tests (KAT). *}

definition lift_test :: "'\<alpha> cond \<Rightarrow> '\<alpha> hrel" ("\<lceil>_\<rceil>\<^sub>t")
where "\<lceil>b\<rceil>\<^sub>t = (\<lceil>b\<rceil>\<^sub>< \<and> II)"

declare cond_def [urel_defs]
declare skip_r_def [urel_defs]

text {* We implement a poor man's version of alphabet restriction that hides a variable within a relation *}

definition rel_var_res :: "'\<alpha> hrel \<Rightarrow> ('a \<Longrightarrow> '\<alpha>)  \<Rightarrow> '\<alpha> hrel" (infix "\<restriction>\<^sub>\<alpha>" 80) where
[urel_defs]:"P \<restriction>\<^sub>\<alpha> x = (\<exists> $x \<bullet> \<exists> $x\<acute> \<bullet> P)"

lemma Rep_inverse[code]:"Rep_uexpr (Abs_uexpr x) = x"
by rel_auto

subsection {* Relational alphabet extension *}

lift_definition rel_alpha_ext :: "'\<beta> hrel \<Rightarrow> ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> hrel" (infix "\<oplus>\<^sub>R" 65)
is "\<lambda> P x (b1, b2). P ((get\<^bsub>x\<^esub> b1), (get\<^bsub>x\<^esub> b2)) \<and>
                     (\<forall> b. b1 \<oplus>\<^sub>L b on x = b2 \<oplus>\<^sub>L b on x)" .

lemma rel_alpha_ext_alt_def:
  assumes "vwb_lens y" "x +\<^sub>L y \<approx>\<^sub>L 1\<^sub>L" "x \<bowtie> y"
  shows "P \<oplus>\<^sub>R x = (P \<oplus>\<^sub>p (x \<times>\<^sub>L x) \<and> $y\<acute> =\<^sub>u $y)"
  using assms
  apply (rel_auto robust, simp_all add: lens_override_def)
  apply (metis lens_indep_get lens_indep_sym)
  apply (metis vwb_lens_def wb_lens.get_put wb_lens_def weak_lens.put_get)
done
end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory factorial
imports "CParser.CTranslation" MachineWords
begin

declare hrs_simps [simp add]
declare sep_conj_ac [simp add]

consts free_pool :: "nat \<Rightarrow> heap_assert"

primrec
  fac :: "nat \<Rightarrow> machine_word"
where
  "fac 0 = 1"
| "fac (Suc n) = of_nat (Suc n) * fac n"

lemma fac_unfold:
  "unat n \<noteq> 0 \<Longrightarrow> fac (unat n) = n * fac (unat (n - 1))"
  apply(case_tac "unat n")
   apply simp
  apply(subst unat_minus_one)
   apply(simp only: unat_simps)
   apply(clarify)
   apply simp
  apply clarsimp
  apply(simp only: unat_simps)
  apply(subst mod_less)
   apply (fold len_of_addr_card)
   apply unat_arith
  apply (clarsimp simp: distrib_right split: unat_splits)
  done

primrec
  fac_list :: "nat \<Rightarrow> machine_word list"
where
  "fac_list 0 = [1]"
| "fac_list (Suc n) = fac (Suc n) # fac_list n"

lemma fac_list_length [simp]:
  "length (fac_list n) = n + 1"
  by (induct n) auto

lemma fac_list_unfold:
  "unat n \<noteq> 0 \<Longrightarrow> fac_list (unat n) = fac (unat n) # fac_list (unat (n - 1))"
  by (metis Suc_unat_minus_one fac_list.simps(2) unat_eq_zero)

primrec
  sep_list :: "machine_word list \<Rightarrow> machine_word ptr \<Rightarrow> heap_assert"
where
  "sep_list [] p = (\<lambda>s. p=NULL \<and> \<box> s)"
| "sep_list (x#xs) p = (\<lambda>s. \<exists>j. ((p \<mapsto> x) \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> j \<and>\<^sup>*
      sep_list xs (Ptr j)) s)"

lemma sep_list_NULL [simp]:
  "sep_list xs NULL = (\<lambda>s. xs = [] \<and> \<box> s)"
  by (case_tac xs) auto

definition
  sep_fac_list :: "machine_word \<Rightarrow> machine_word ptr \<Rightarrow> heap_assert"
where
  "sep_fac_list n p \<equiv> sep_list (fac_list (unat n)) p"

lemma sep_fac_list_unfold:
  "((\<lambda>s. unat n \<noteq> 0 \<and> (\<exists>q. (p \<mapsto> fac (unat n) \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> q \<and>\<^sup>*
      sep_fac_list (n - 1) (Ptr q)) s)) \<and>\<^sup>* R) s \<Longrightarrow>
      (sep_fac_list n p \<and>\<^sup>* R) s"
  apply (erule sep_globalise)
  apply (simp add: sep_fac_list_def fac_list_unfold)
  done

lemma sep_fac_list_points:
  "sep_points (sep_fac_list n p) s \<Longrightarrow> (p \<hookrightarrow> fac (unat n)) s"
  apply(unfold sep_points_def)
  apply(subst sep_map'_unfold)
  apply(erule sep_conj_impl)
   apply(unfold sep_fac_list_def)
   apply(case_tac "unat n")
    apply simp
    apply(unfold sep_map'_old)
    apply(erule (1) sep_conj_impl)
    apply simp
   apply clarsimp
   apply(subst (asm) sep_conj_assoc [symmetric])+
   apply(erule sep_conj_impl)
    apply simp+
  done

external_file "factorial.c"
install_C_file memsafe "factorial.c"

thm factorial_global_addresses.factorial_body_def

lemma (in factorial_global_addresses) mem_safe_alloc:
  "mem_safe (\<acute>ret__ptr_to_unsigned_long :== PROC alloc()) \<Gamma>"
  apply(insert alloc_impl)
  apply(unfold alloc_body_def)
  apply(subst mem_safe_restrict)
  apply(rule intra_mem_safe)
   apply(simp_all add: restrict_map_def split: if_split_asm)
  apply(auto simp: whileAnno_def comp_def hrs_comm split_def mono_guard_def)
  done

lemma (in factorial_global_addresses) sep_frame_alloc:
  "\<lbrakk> \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace> \<acute>ret__ptr_to_unsigned_long :== PROC alloc() \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>;
      htd_ind f; htd_ind g; \<forall>s. htd_ind (g s) \<rbrakk> \<Longrightarrow>
      \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
              \<acute>ret__ptr_to_unsigned_long :== PROC alloc()
              \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  unfolding sep_app_def
  by (rule sep_frame, auto intro!: mem_safe_alloc)

lemma (in alloc_spec) alloc_spec':
  shows "\<forall>\<sigma> k R f. factorial_global_addresses.\<Gamma> \<turnstile>
    \<lbrace>\<sigma>. ((\<lambda>x. free_pool k) ((\<lambda>x. undefined) \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
    \<acute>ret__ptr_to_unsigned_long :== PROC alloc()
    \<lbrace> ((\<lambda>p s. if k > 0 then (\<turnstile>\<^sub>s p \<and>\<^sup>* \<turnstile>\<^sub>s (p +\<^sub>p 1) \<and>\<^sup>*
        free_pool (k - 1)) s else (free_pool k) s \<and> p = NULL) \<acute>ret__ptr_to_unsigned_long
        \<and>\<^sup>* R (f \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  apply clarify
  apply(insert alloc_spec)
  apply(rule_tac x=\<sigma> in spec)
  apply(rule sep_frame_alloc)
     apply(clarsimp simp: sep_app_def split: if_split_asm)
    apply simp+
  done

lemma (in factorial_global_addresses) mem_safe_free:
  "mem_safe (PROC free(\<acute>p)) \<Gamma>"
  apply(insert free_impl)
  apply(unfold free_body_def)
  apply(subst mem_safe_restrict)
  apply(auto simp: whileAnno_def)
  apply(rule intra_mem_safe)
   apply(auto simp: restrict_map_def split: if_split_asm)
  done

lemma (in factorial_global_addresses) sep_frame_free:
  "\<lbrakk> \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace> PROC free(\<acute>p) \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>;
      htd_ind f; htd_ind g; \<forall>s. htd_ind (g s) \<rbrakk> \<Longrightarrow>
      \<forall>\<sigma>. \<Gamma> \<turnstile> \<lbrace>\<sigma>. (P (f \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
              PROC free(\<acute>p)
              \<lbrace> (Q (g \<sigma> \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (h \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  apply(simp only: sep_app_def)
  apply(rule sep_frame, auto intro!: mem_safe_free)
  done

lemma (in free_spec) free_spec':
  shows "\<forall>\<sigma> k R f. factorial_global_addresses.\<Gamma> \<turnstile>
    \<lbrace>\<sigma>. ((\<lambda>p. sep_cut' (ptr_val p) (2 * size_of TYPE(machine_word)) \<and>\<^sup>* free_pool k) \<acute>p  \<and>\<^sup>* R (f \<acute>(\<lambda>x. x)))\<^bsup>sep\<^esup> \<rbrace>
    PROC free(\<acute>p)
    \<lbrace> ((\<lambda>x. free_pool (k + 1)) ((\<lambda>x. ()) \<acute>(\<lambda>x. x)) \<and>\<^sup>* R (f \<sigma>))\<^bsup>sep\<^esup> \<rbrace>"
  apply clarify
  apply(insert free_spec)
  apply(rule_tac x=\<sigma> in spec)
  apply(rule sep_frame_free)
     apply(clarsimp simp: sep_app_def split: if_split_asm)
    apply simp+
  done

lemma double_word_sep_cut':
  "(p \<mapsto> x \<and>\<^sup>* (p +\<^sub>p 1) \<mapsto> y) s \<Longrightarrow> sep_cut' (ptr_val (p::machine_word ptr)) (2*machine_word_bytes) s"
apply(clarsimp simp: sep_conj_def sep_cut'_def dest!: sep_map_dom)
apply(subgoal_tac "{ptr_val p..+machine_word_bytes} \<subseteq> {ptr_val p..+(2*machine_word_bytes)}")
 apply(subgoal_tac "{ptr_val p+(of_nat machine_word_bytes)..+machine_word_bytes} \<subseteq> {ptr_val p..+(2*machine_word_bytes)}")
  apply rule
   apply (fastforce simp: ptr_add_def)
  apply clarsimp
  apply(drule intvlD)
  apply clarsimp
  apply(case_tac "k < machine_word_bytes")
   apply(erule intvlI)
  apply(erule notE)
  apply(clarsimp simp: intvl_def)
  apply(rule_tac x="k - machine_word_bytes" in exI)
  apply rule
   apply(simp only: unat_simps)
   apply(subst mod_less)
    apply(simp add: addr_card)
   apply (simp add: ptr_add_def addr_card)
  apply simp
 apply(clarsimp simp: intvl_def)
 apply(rule_tac x="machine_word_bytes+k" in exI)
 apply simp
apply(rule intvl_start_le)
apply simp
done

locale specs = factorial_global_addresses + alloc_spec + free_spec

lemma (in specs) factorial_spec:
  shows "factorial_spec"
  apply unfold_locales
  apply(hoare_rule HoarePartial.ProcRec1)
  apply (hoare_rule anno = "factorial_invs_body k" in HoarePartial.annotateI)
   prefer 2
   apply (simp add: whileAnno_def factorial_invs_body_def)
  apply(subst factorial_invs_body_def)
  apply(unfold sep_app_def)
  apply (vcg exspec=alloc_spec' exspec=free_spec')
    apply (fold lift_def)
    apply(clarsimp simp: sep_app_def)
    apply (rule conjI)
     apply clarsimp
     apply(rule_tac x=k in exI)
     apply(rule_tac x="\<lambda>p. \<box>" in exI)
     apply(rule_tac x="\<lambda>s. undefined" in exI)
     apply clarsimp
     apply (rule conjI)
      apply clarsimp
     apply clarsimp
     apply (rename_tac a b ret__ptr_to_unsigned_long)
     apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>* sep_true) (lift_state (a,b))")
      prefer 2
      apply(drule sep_conj_sep_true_right)
      apply simp
     apply(subgoal_tac "(\<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>* sep_true) (lift_state (a,b))")
      prefer 2
      apply(drule sep_conj_sep_true_left)
      apply simp
      apply(subst (asm) sep_conj_assoc [symmetric])+
      apply(drule_tac Q="free_pool (k - Suc 0)" in sep_conj_sep_true_right)
      apply simp
     apply(simp add: tagd_ptr_safe tagd_g c_guard_ptr_aligned c_guard_NULL)
     apply(simp add: sep_fac_list_def)
     apply(sep_select_tac "(_ +\<^sub>p _) \<mapsto> _")
     apply(rule sep_heap_update_global')
     apply simp
     apply(rule sep_heap_update_global')
     apply simp
    apply clarsimp
    apply(rule_tac x=k in exI)
    apply clarsimp
    apply(rule_tac x="k - Suc (unat (n - 1))" in exI)
    apply clarsimp
    apply(rule_tac x="\<lambda>(n,p). sep_fac_list (n - 1) p" in exI)
    apply(rule_tac x="\<lambda>s. (n_' s,q_' s)" in exI)
    apply (rule conjI, clarsimp)
    apply clarsimp
    apply (rule conjI)
     apply clarsimp
     apply(simp add: sep_fac_list_def)
     apply(rule_tac x="fac_list (unat (n - 1))" in exI)
     apply clarsimp
    apply clarsimp
    apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>* sep_true) (lift_state (ab,bb))")
     prefer 2
     apply(erule (1) sep_conj_impl)
     apply simp
    apply(subgoal_tac "(\<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>* sep_true) (lift_state (ab,bb))")
     prefer 2
     apply(subgoal_tac "(\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>*
                         \<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>*
                         sep_fac_list (n - 1) ret__ptr_to_unsigned_longa \<and>\<^sup>*
                         free_pool (k - Suc (unat n))) =
                         (\<turnstile>\<^sub>s (ret__ptr_to_unsigned_long +\<^sub>p 1) \<and>\<^sup>* (\<turnstile>\<^sub>s ret__ptr_to_unsigned_long \<and>\<^sup>*
                         sep_fac_list (n - 1) ret__ptr_to_unsigned_longa \<and>\<^sup>*
                         free_pool (k - Suc (unat n))))")
      prefer 2
      apply simp
     apply (simp only:)
     apply(erule (1) sep_conj_impl)
     apply simp
    apply(sep_point_tac sep_fac_list_points)
    apply(simp add: tagd_ptr_safe tagd_g sep_map'_g c_guard_ptr_aligned c_guard_NULL sep_map'_lift)
    apply(rule sep_fac_list_unfold)
    apply clarsimp
    apply (rule conjI, unat_arith)
    apply sep_exists_tac
    apply(rule_tac x="ptr_val ret__ptr_to_unsigned_longa" in exI)
    apply clarsimp
    apply(subst fac_unfold)
     apply unat_arith
    apply clarsimp
    apply(sep_select_tac "(_ +\<^sub>p _) \<mapsto> _")
    apply(rule sep_heap_update_global')
    apply(sep_select_tac "_ \<mapsto> _")
      apply(rule sep_heap_update_global')
      apply(erule (1) sep_conj_impl)+
      apply clarsimp
   apply clarsimp
   apply(case_tac xs)
    apply simp
   apply clarsimp
   apply sep_exists_tac
   apply clarsimp
   apply sep_point_tac
   apply(simp add: sep_map'_g c_guard_ptr_aligned c_guard_NULL sep_map'_lift)
   apply(rule_tac x="k - Suc (length list)" in exI)
   apply(rule_tac x="\<lambda>p. sep_list list (Ptr j)" in exI)
   apply(rule_tac x="\<lambda>x. ()" in exI)
   apply(clarsimp simp: sep_app_def)
   apply (rule conjI)
    apply(subgoal_tac "(q \<mapsto> aa \<and>\<^sup>* sep_list list (Ptr j) \<and>\<^sup>*
                         (q +\<^sub>p 1) \<mapsto> j \<and>\<^sup>* free_pool (k - Suc (length list))) =
                       (sep_list list (Ptr j) \<and>\<^sup>* (q \<mapsto> aa \<and>\<^sup>*
                         (q +\<^sub>p 1) \<mapsto> j \<and>\<^sup>* free_pool (k - Suc (length list))))")
     apply(simp only:)
     apply(erule (1) sep_conj_impl)
     apply simp
     apply(subst sep_conj_com)
     apply(subst (asm) sep_conj_assoc [symmetric])+
     apply(erule sep_conj_impl)
      apply simp
      apply(erule double_word_sep_cut'[simplified])
     apply assumption
    apply simp
   apply clarsimp
   apply(subgoal_tac "Suc (k - Suc (length list)) = k - length list")
    apply force
   apply arith
  apply clarsimp
  done

declare hrs_simps [simp del]

lemma (in factorial_global_addresses) mem_safe_factorial:
  shows "mem_safe (\<acute>ret__ptr_to_unsigned_long :== PROC factorial(\<acute>n)) \<Gamma>"
  apply(subst mem_safe_restrict)
  apply(rule intra_mem_safe)
   apply (insert factorial_impl free_impl alloc_impl)
   apply(drule_tac t="Some C" in sym)
   apply(simp_all add: restrict_map_def call_def block_def whileAnno_def
                       free_body_def alloc_body_def factorial_body_def creturn_def
                split: if_split_asm option.splits)
  by (force simp: intra_sc)

end