(*  Title:      HOL/Library/Old_Datatype.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Author:     Stefan Berghofer and Markus Wenzel, TU Muenchen
*)

section \<open>Old Datatype package: constructing datatypes from Cartesian Products and Disjoint Sums\<close>

theory Old_Datatype
imports Main
keywords "old_datatype" :: thy_decl
begin

subsection \<open>The datatype universe\<close>

definition "Node = {p. \<exists>f x k. p = (f :: nat => 'b + nat, x ::'a + nat) \<and> f k = Inr 0}"

typedef ('a, 'b) node = "Node :: ((nat => 'b + nat) * ('a + nat)) set"
  morphisms Rep_Node Abs_Node
  unfolding Node_def by auto

text\<open>Datatypes will be represented by sets of type \<open>node\<close>\<close>

type_synonym 'a item        = "('a, unit) node set"
type_synonym ('a, 'b) dtree = "('a, 'b) node set"

definition Push :: "[('b + nat), nat => ('b + nat)] => (nat => ('b + nat))"
  (*crude "lists" of nats -- needed for the constructions*)
  where "Push == (%b h. case_nat b h)"

definition Push_Node :: "[('b + nat), ('a, 'b) node] => ('a, 'b) node"
  where "Push_Node == (%n x. Abs_Node (apfst (Push n) (Rep_Node x)))"

(** operations on S-expressions -- sets of nodes **)

(*S-expression constructors*)
definition Atom :: "('a + nat) => ('a, 'b) dtree"
  where "Atom == (%x. {Abs_Node((%k. Inr 0, x))})"
definition Scons :: "[('a, 'b) dtree, ('a, 'b) dtree] => ('a, 'b) dtree"
  where "Scons M N == (Push_Node (Inr 1) ` M) Un (Push_Node (Inr (Suc 1)) ` N)"

(*Leaf nodes, with arbitrary or nat labels*)
definition Leaf :: "'a => ('a, 'b) dtree"
  where "Leaf == Atom \<circ> Inl"
definition Numb :: "nat => ('a, 'b) dtree"
  where "Numb == Atom \<circ> Inr"

(*Injections of the "disjoint sum"*)
definition In0 :: "('a, 'b) dtree => ('a, 'b) dtree"
  where "In0(M) == Scons (Numb 0) M"
definition In1 :: "('a, 'b) dtree => ('a, 'b) dtree"
  where "In1(M) == Scons (Numb 1) M"

(*Function spaces*)
definition Lim :: "('b => ('a, 'b) dtree) => ('a, 'b) dtree"
  where "Lim f == \<Union>{z. \<exists>x. z = Push_Node (Inl x) ` (f x)}"

(*the set of nodes with depth less than k*)
definition ndepth :: "('a, 'b) node => nat"
  where "ndepth(n) == (%(f,x). LEAST k. f k = Inr 0) (Rep_Node n)"
definition ntrunc :: "[nat, ('a, 'b) dtree] => ('a, 'b) dtree"
  where "ntrunc k N == {n. n\<in>N \<and> ndepth(n)<k}"

(*products and sums for the "universe"*)
definition uprod :: "[('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set"
  where "uprod A B == UN x:A. UN y:B. { Scons x y }"
definition usum :: "[('a, 'b) dtree set, ('a, 'b) dtree set]=> ('a, 'b) dtree set"
  where "usum A B == In0`A Un In1`B"

(*the corresponding eliminators*)
definition Split :: "[[('a, 'b) dtree, ('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c"
  where "Split c M == THE u. \<exists>x y. M = Scons x y \<and> u = c x y"

definition Case :: "[[('a, 'b) dtree]=>'c, [('a, 'b) dtree]=>'c, ('a, 'b) dtree] => 'c"
  where "Case c d M == THE u. (\<exists>x . M = In0(x) \<and> u = c(x)) \<or> (\<exists>y . M = In1(y) \<and> u = d(y))"

(** equality for the "universe" **)

definition dprod :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set]
      => (('a, 'b) dtree * ('a, 'b) dtree)set"
  where "dprod r s == UN (x,x'):r. UN (y,y'):s. {(Scons x y, Scons x' y')}"

definition dsum :: "[(('a, 'b) dtree * ('a, 'b) dtree)set, (('a, 'b) dtree * ('a, 'b) dtree)set]
      => (('a, 'b) dtree * ('a, 'b) dtree)set"
  where "dsum r s == (UN (x,x'):r. {(In0(x),In0(x'))}) Un (UN (y,y'):s. {(In1(y),In1(y'))})"

lemma apfst_convE:
    "[| q = apfst f p;  !!x y. [| p = (x,y);  q = (f(x),y) |] ==> R
     |] ==> R"
by (force simp add: apfst_def)

(** Push -- an injection, analogous to Cons on lists **)

lemma Push_inject1: "Push i f = Push j g  ==> i=j"
apply (simp add: Push_def fun_eq_iff)
apply (drule_tac x=0 in spec, simp)
done

lemma Push_inject2: "Push i f = Push j g  ==> f=g"
apply (auto simp add: Push_def fun_eq_iff)
apply (drule_tac x="Suc x" in spec, simp)
done

lemma Push_inject:
    "[| Push i f =Push j g;  [| i=j;  f=g |] ==> P |] ==> P"
by (blast dest: Push_inject1 Push_inject2)

lemma Push_neq_K0: "Push (Inr (Suc k)) f = (%z. Inr 0) ==> P"
by (auto simp add: Push_def fun_eq_iff split: nat.split_asm)

lemmas Abs_Node_inj = Abs_Node_inject [THEN [2] rev_iffD1]

(*** Introduction rules for Node ***)

lemma Node_K0_I: "(\<lambda>k. Inr 0, a) \<in> Node"
by (simp add: Node_def)

lemma Node_Push_I: "p \<in> Node \<Longrightarrow> apfst (Push i) p \<in> Node"
apply (simp add: Node_def Push_def)
apply (fast intro!: apfst_conv nat.case(2)[THEN trans])
done

subsection\<open>Freeness: Distinctness of Constructors\<close>

(** Scons vs Atom **)

lemma Scons_not_Atom [iff]: "Scons M N \<noteq> Atom(a)"
unfolding Atom_def Scons_def Push_Node_def One_nat_def
by (blast intro: Node_K0_I Rep_Node [THEN Node_Push_I]
         dest!: Abs_Node_inj
         elim!: apfst_convE sym [THEN Push_neq_K0])

lemmas Atom_not_Scons [iff] = Scons_not_Atom [THEN not_sym]

(*** Injectiveness ***)

(** Atomic nodes **)

lemma inj_Atom: "inj(Atom)"
apply (simp add: Atom_def)
apply (blast intro!: inj_onI Node_K0_I dest!: Abs_Node_inj)
done
lemmas Atom_inject = inj_Atom [THEN injD]

lemma Atom_Atom_eq [iff]: "(Atom(a)=Atom(b)) = (a=b)"
by (blast dest!: Atom_inject)

lemma inj_Leaf: "inj(Leaf)"
apply (simp add: Leaf_def o_def)
apply (rule inj_onI)
apply (erule Atom_inject [THEN Inl_inject])
done

lemmas Leaf_inject [dest!] = inj_Leaf [THEN injD]

lemma inj_Numb: "inj(Numb)"
apply (simp add: Numb_def o_def)
apply (rule inj_onI)
apply (erule Atom_inject [THEN Inr_inject])
done

lemmas Numb_inject [dest!] = inj_Numb [THEN injD]

(** Injectiveness of Push_Node **)

lemma Push_Node_inject:
    "[| Push_Node i m =Push_Node j n;  [| i=j;  m=n |] ==> P
     |] ==> P"
apply (simp add: Push_Node_def)
apply (erule Abs_Node_inj [THEN apfst_convE])
apply (rule Rep_Node [THEN Node_Push_I])+
apply (erule sym [THEN apfst_convE])
apply (blast intro: Rep_Node_inject [THEN iffD1] trans sym elim!: Push_inject)
done

(** Injectiveness of Scons **)

lemma Scons_inject_lemma1: "Scons M N <= Scons M' N' ==> M<=M'"
unfolding Scons_def One_nat_def
by (blast dest!: Push_Node_inject)

lemma Scons_inject_lemma2: "Scons M N <= Scons M' N' ==> N<=N'"
unfolding Scons_def One_nat_def
by (blast dest!: Push_Node_inject)

lemma Scons_inject1: "Scons M N = Scons M' N' ==> M=M'"
apply (erule equalityE)
apply (iprover intro: equalityI Scons_inject_lemma1)
done

lemma Scons_inject2: "Scons M N = Scons M' N' ==> N=N'"
apply (erule equalityE)
apply (iprover intro: equalityI Scons_inject_lemma2)
done

lemma Scons_inject:
    "[| Scons M N = Scons M' N';  [| M=M';  N=N' |] ==> P |] ==> P"
by (iprover dest: Scons_inject1 Scons_inject2)

lemma Scons_Scons_eq [iff]: "(Scons M N = Scons M' N') = (M=M' \<and> N=N')"
by (blast elim!: Scons_inject)

(*** Distinctness involving Leaf and Numb ***)

(** Scons vs Leaf **)

lemma Scons_not_Leaf [iff]: "Scons M N \<noteq> Leaf(a)"
unfolding Leaf_def o_def by (rule Scons_not_Atom)

lemmas Leaf_not_Scons  [iff] = Scons_not_Leaf [THEN not_sym]

(** Scons vs Numb **)

lemma Scons_not_Numb [iff]: "Scons M N \<noteq> Numb(k)"
unfolding Numb_def o_def by (rule Scons_not_Atom)

lemmas Numb_not_Scons [iff] = Scons_not_Numb [THEN not_sym]

(** Leaf vs Numb **)

lemma Leaf_not_Numb [iff]: "Leaf(a) \<noteq> Numb(k)"
by (simp add: Leaf_def Numb_def)

lemmas Numb_not_Leaf [iff] = Leaf_not_Numb [THEN not_sym]

(*** ndepth -- the depth of a node ***)

lemma ndepth_K0: "ndepth (Abs_Node(%k. Inr 0, x)) = 0"
by (simp add: ndepth_def  Node_K0_I [THEN Abs_Node_inverse] Least_equality)

lemma ndepth_Push_Node_aux:
     "case_nat (Inr (Suc i)) f k = Inr 0 \<longrightarrow> Suc(LEAST x. f x = Inr 0) \<le> k"
apply (induct_tac "k", auto)
apply (erule Least_le)
done

lemma ndepth_Push_Node:
    "ndepth (Push_Node (Inr (Suc i)) n) = Suc(ndepth(n))"
apply (insert Rep_Node [of n, unfolded Node_def])
apply (auto simp add: ndepth_def Push_Node_def
                 Rep_Node [THEN Node_Push_I, THEN Abs_Node_inverse])
apply (rule Least_equality)
apply (auto simp add: Push_def ndepth_Push_Node_aux)
apply (erule LeastI)
done

(*** ntrunc applied to the various node sets ***)

lemma ntrunc_0 [simp]: "ntrunc 0 M = {}"
by (simp add: ntrunc_def)

lemma ntrunc_Atom [simp]: "ntrunc (Suc k) (Atom a) = Atom(a)"
by (auto simp add: Atom_def ntrunc_def ndepth_K0)

lemma ntrunc_Leaf [simp]: "ntrunc (Suc k) (Leaf a) = Leaf(a)"
unfolding Leaf_def o_def by (rule ntrunc_Atom)

lemma ntrunc_Numb [simp]: "ntrunc (Suc k) (Numb i) = Numb(i)"
unfolding Numb_def o_def by (rule ntrunc_Atom)

lemma ntrunc_Scons [simp]:
    "ntrunc (Suc k) (Scons M N) = Scons (ntrunc k M) (ntrunc k N)"
unfolding Scons_def ntrunc_def One_nat_def
by (auto simp add: ndepth_Push_Node)

(** Injection nodes **)

lemma ntrunc_one_In0 [simp]: "ntrunc (Suc 0) (In0 M) = {}"
apply (simp add: In0_def)
apply (simp add: Scons_def)
done

lemma ntrunc_In0 [simp]: "ntrunc (Suc(Suc k)) (In0 M) = In0 (ntrunc (Suc k) M)"
by (simp add: In0_def)

lemma ntrunc_one_In1 [simp]: "ntrunc (Suc 0) (In1 M) = {}"
apply (simp add: In1_def)
apply (simp add: Scons_def)
done

lemma ntrunc_In1 [simp]: "ntrunc (Suc(Suc k)) (In1 M) = In1 (ntrunc (Suc k) M)"
by (simp add: In1_def)

subsection\<open>Set Constructions\<close>

(*** Cartesian Product ***)

lemma uprodI [intro!]: "\<lbrakk>M\<in>A; N\<in>B\<rbrakk> \<Longrightarrow> Scons M N \<in> uprod A B"
by (simp add: uprod_def)

(*The general elimination rule*)
lemma uprodE [elim!]:
    "\<lbrakk>c \<in> uprod A B;
        \<And>x y. \<lbrakk>x \<in> A; y \<in> B; c = Scons x y\<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
by (auto simp add: uprod_def)

(*Elimination of a pair -- introduces no eigenvariables*)
lemma uprodE2: "\<lbrakk>Scons M N \<in> uprod A B; \<lbrakk>M \<in> A; N \<in> B\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
by (auto simp add: uprod_def)

(*** Disjoint Sum ***)

lemma usum_In0I [intro]: "M \<in> A \<Longrightarrow> In0(M) \<in> usum A B"
by (simp add: usum_def)

lemma usum_In1I [intro]: "N \<in> B \<Longrightarrow> In1(N) \<in> usum A B"
by (simp add: usum_def)

lemma usumE [elim!]:
    "\<lbrakk>u \<in> usum A B;
        \<And>x. \<lbrakk>x \<in> A; u=In0(x)\<rbrakk> \<Longrightarrow> P;
        \<And>y. \<lbrakk>y \<in> B; u=In1(y)\<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
by (auto simp add: usum_def)

(** Injection **)

lemma In0_not_In1 [iff]: "In0(M) \<noteq> In1(N)"
unfolding In0_def In1_def One_nat_def by auto

lemmas In1_not_In0 [iff] = In0_not_In1 [THEN not_sym]

lemma In0_inject: "In0(M) = In0(N) ==>  M=N"
by (simp add: In0_def)

lemma In1_inject: "In1(M) = In1(N) ==>  M=N"
by (simp add: In1_def)

lemma In0_eq [iff]: "(In0 M = In0 N) = (M=N)"
by (blast dest!: In0_inject)

lemma In1_eq [iff]: "(In1 M = In1 N) = (M=N)"
by (blast dest!: In1_inject)

lemma inj_In0: "inj In0"
by (blast intro!: inj_onI)

lemma inj_In1: "inj In1"
by (blast intro!: inj_onI)

(*** Function spaces ***)

lemma Lim_inject: "Lim f = Lim g ==> f = g"
apply (simp add: Lim_def)
apply (rule ext)
apply (blast elim!: Push_Node_inject)
done

(*** proving equality of sets and functions using ntrunc ***)

lemma ntrunc_subsetI: "ntrunc k M <= M"
by (auto simp add: ntrunc_def)

lemma ntrunc_subsetD: "(!!k. ntrunc k M <= N) ==> M<=N"
by (auto simp add: ntrunc_def)

(*A generalized form of the take-lemma*)
lemma ntrunc_equality: "(!!k. ntrunc k M = ntrunc k N) ==> M=N"
apply (rule equalityI)
apply (rule_tac [!] ntrunc_subsetD)
apply (rule_tac [!] ntrunc_subsetI [THEN [2] subset_trans], auto)
done

lemma ntrunc_o_equality:
    "[| !!k. (ntrunc(k) \<circ> h1) = (ntrunc(k) \<circ> h2) |] ==> h1=h2"
apply (rule ntrunc_equality [THEN ext])
apply (simp add: fun_eq_iff)
done

(*** Monotonicity ***)

lemma uprod_mono: "[| A<=A';  B<=B' |] ==> uprod A B <= uprod A' B'"
by (simp add: uprod_def, blast)

lemma usum_mono: "[| A<=A';  B<=B' |] ==> usum A B <= usum A' B'"
by (simp add: usum_def, blast)

lemma Scons_mono: "[| M<=M';  N<=N' |] ==> Scons M N <= Scons M' N'"
by (simp add: Scons_def, blast)

lemma In0_mono: "M<=N ==> In0(M) <= In0(N)"
by (simp add: In0_def Scons_mono)

lemma In1_mono: "M<=N ==> In1(M) <= In1(N)"
by (simp add: In1_def Scons_mono)

(*** Split and Case ***)

lemma Split [simp]: "Split c (Scons M N) = c M N"
by (simp add: Split_def)

lemma Case_In0 [simp]: "Case c d (In0 M) = c(M)"
by (simp add: Case_def)

lemma Case_In1 [simp]: "Case c d (In1 N) = d(N)"
by (simp add: Case_def)

(**** UN x. B(x) rules ****)

lemma ntrunc_UN1: "ntrunc k (UN x. f(x)) = (UN x. ntrunc k (f x))"
by (simp add: ntrunc_def, blast)

lemma Scons_UN1_x: "Scons (UN x. f x) M = (UN x. Scons (f x) M)"
by (simp add: Scons_def, blast)

lemma Scons_UN1_y: "Scons M (UN x. f x) = (UN x. Scons M (f x))"
by (simp add: Scons_def, blast)

lemma In0_UN1: "In0(UN x. f(x)) = (UN x. In0(f(x)))"
by (simp add: In0_def Scons_UN1_y)

lemma In1_UN1: "In1(UN x. f(x)) = (UN x. In1(f(x)))"
by (simp add: In1_def Scons_UN1_y)

(*** Equality for Cartesian Product ***)

lemma dprodI [intro!]:
    "\<lbrakk>(M,M') \<in> r; (N,N') \<in> s\<rbrakk> \<Longrightarrow> (Scons M N, Scons M' N') \<in> dprod r s"
by (auto simp add: dprod_def)

(*The general elimination rule*)
lemma dprodE [elim!]:
    "\<lbrakk>c \<in> dprod r s;
        \<And>x y x' y'. \<lbrakk>(x,x') \<in> r; (y,y') \<in> s;
                        c = (Scons x y, Scons x' y')\<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
by (auto simp add: dprod_def)

(*** Equality for Disjoint Sum ***)

lemma dsum_In0I [intro]: "(M,M') \<in> r \<Longrightarrow> (In0(M), In0(M')) \<in> dsum r s"
by (auto simp add: dsum_def)

lemma dsum_In1I [intro]: "(N,N') \<in> s \<Longrightarrow> (In1(N), In1(N')) \<in> dsum r s"
by (auto simp add: dsum_def)

lemma dsumE [elim!]:
    "\<lbrakk>w \<in> dsum r s;
        \<And>x x'. \<lbrakk> (x,x') \<in> r;  w = (In0(x), In0(x')) \<rbrakk> \<Longrightarrow> P;
        \<And>y y'. \<lbrakk> (y,y') \<in> s;  w = (In1(y), In1(y')) \<rbrakk> \<Longrightarrow> P
     \<rbrakk> \<Longrightarrow> P"
by (auto simp add: dsum_def)

(*** Monotonicity ***)

lemma dprod_mono: "[| r<=r';  s<=s' |] ==> dprod r s <= dprod r' s'"
by blast

lemma dsum_mono: "[| r<=r';  s<=s' |] ==> dsum r s <= dsum r' s'"
by blast

(*** Bounding theorems ***)

lemma dprod_Sigma: "(dprod (A \<times> B) (C \<times> D)) <= (uprod A C) \<times> (uprod B D)"
by blast

lemmas dprod_subset_Sigma = subset_trans [OF dprod_mono dprod_Sigma]

(*Dependent version*)
lemma dprod_subset_Sigma2:
    "(dprod (Sigma A B) (Sigma C D)) <= Sigma (uprod A C) (Split (%x y. uprod (B x) (D y)))"
by auto

lemma dsum_Sigma: "(dsum (A \<times> B) (C \<times> D)) <= (usum A C) \<times> (usum B D)"
by blast

lemmas dsum_subset_Sigma = subset_trans [OF dsum_mono dsum_Sigma]

(*** Domain theorems ***)

lemma Domain_dprod [simp]: "Domain (dprod r s) = uprod (Domain r) (Domain s)"
  by auto

lemma Domain_dsum [simp]: "Domain (dsum r s) = usum (Domain r) (Domain s)"
  by auto

text \<open>hides popular names\<close>
hide_type (open) node item
hide_const (open) Push Node Atom Leaf Numb Lim Split Case

ML_file \<open>~~/src/HOL/Tools/Old_Datatype/old_datatype.ML\<close>

end


theory "HashMap"

imports  "lem/Evm" "Hoare"
 "HoareTripleForInstructions"
 "HoareTripleForStorage"
 "HoareTripleForMemory"

begin

declare memory_as_set_def [simp add]

fun storage_array :: "w256 \<Rightarrow> w256 list \<Rightarrow> set_pred" where
"storage_array ind [] = emp"
| "storage_array ind (a#b) = storage ind a ** storage_array (ind+1) b"

fun assoc :: "(w256*w256) list \<Rightarrow> set_pred" where
  "assoc [] = emp"
| "assoc ((key,a)#xs) = storage key a ** assoc xs"

definition hash_pair :: "w256 \<Rightarrow> w256*w256 \<Rightarrow> w256*w256" where
"hash_pair table p = (hash2 table (fst p), snd p)"

definition hash_pair_z :: "w256 \<Rightarrow> w256*w256 \<Rightarrow> w256*w256" where
"hash_pair_z table p = (hash2 table (fst p), 0)"

definition mapping :: "w256 \<Rightarrow> (w256*w256) list \<Rightarrow> set_pred" where
"mapping ind lst = assoc (map (hash_pair ind) lst)"

fun get :: "w256 \<Rightarrow> (w256*w256) list \<Rightarrow> w256" where
  "get k [] = 0"
| "get k ((ok,ov)#xs) = (if k = ok then ov else get k xs)"

fun mem :: "w256 \<Rightarrow> (w256*w256) list \<Rightarrow> bool" where
  "mem k [] = False"
| "mem k ((ok,ov)#xs) = (k = ok \<or> mem k xs)"

fun remove :: "w256 \<Rightarrow> (w256*w256) list \<Rightarrow> (w256*w256) list" where
  "remove k [] = []"
| "remove k ((ok,ov)#xs) =
   (if k = ok then xs else (ok,ov)#remove k xs)"

fun add :: "w256 \<Rightarrow> w256 \<Rightarrow> (w256*w256) list \<Rightarrow> (w256*w256) list" where
"add k v lst = (k,v)#remove k lst"

lemma add_not_mem : "\<not> (mem k lst) \<Longrightarrow> add k v lst = (k,v)#lst"
apply (induction lst)
apply(auto)
done

lemma stored :
   "mem k mp \<Longrightarrow>
    assoc mp = assoc (remove k mp) ** storage k (get k mp)"
apply (induction mp)
apply(auto)
done

lemma stored_hash_from_mapping :
   "mem k mp \<Longrightarrow>
    mapping ind mp =
    mapping ind (remove k mp) ** storage (hash2 ind k) (get k mp)"
apply (induction mp)
apply(auto simp:mapping_def hash_pair_def)
done

lemma minus_test : "a - {x} - {y} = a - {y} - {x}"
apply auto
done

lemma mapping_cons :
   "mapping ind ((k,v)#mp) = storage (hash2 ind k) v ** mapping ind mp"
apply (induction mp)
apply(auto simp:mapping_def minus_test hash_pair_def)
done

lemma set_storage1 :
  assumes a:"mem key m"
  shows "triple {OutOfGas}
    (\<langle> h \<le> 1024 \<rangle> **
     stack (h+1) (hash2 table key) **
     stack h v **
     stack_height (h+2) **
     mapping table m **
     program_counter k **
     gas_pred g **
     continuing)
    {(k, Storage SSTORE)}
    (mapping table (add key v m) **
     program_counter (k+1) **
     gas_pred (g - Csstore (get key m) v) **
     stack_height h **
     continuing)" (is "triple _ ?pre _ ?post")
proof -
  from a have good_pre: "?pre =
     (\<langle> h \<le> 1024 \<rangle> **
     stack_height (h+2) **
     stack (h+1) (hash2 table key) **
     stack h v **
     program_counter k **
     storage (hash2 table key) (get key m) **
     gas_pred g **
     continuing) **
     mapping table (remove key m)"
     (is "?pre = ?presmall ** _")
     by (auto simp:stored_hash_from_mapping)
  have good_post: "?post = (
     stack_height h **
     program_counter (k+1) **
     storage (hash2 table key) v **
     gas_pred (g - Csstore (get key m) v) **
     continuing) **
     mapping table (remove key m)" (is "_ = ?postsmall ** _")

     by (auto simp:mapping_cons)
  have "triple {OutOfGas} ?presmall {(k, Storage SSTORE)} ?postsmall"
    by (rule sstore_gas_triple)
  then have "triple {OutOfGas} (?presmall ** mapping table (remove key m))
      {(k, Storage SSTORE)} (?postsmall ** mapping table (remove key m))"
    by (rule frame)
  then show ?thesis using good_pre and good_post by simp
qed

lemma set_storage2 :
  assumes a:"\<not> (mem key m)"
  shows "triple {OutOfGas}
    (\<langle> h \<le> 1024 \<rangle> **
     stack (h+1) (hash2 table key) **
     stack h v **
     stack_height (h+2) **
     mapping table m **
     storage (hash2 table key) 0 **
     program_counter k **
     gas_pred g **
     continuing)
    {(k, Storage SSTORE)}
    (mapping table (add key v m) **
     program_counter (k+1) **
     gas_pred (g - Csstore 0 v) **
     stack_height h **
     continuing)" (is "triple _ ?pre _ ?post")
proof -
  have good_pre: "?pre =
     (\<langle> h \<le> 1024 \<rangle> **
     stack_height (h+2) **
     stack (h+1) (hash2 table key) **
     stack h v **
     program_counter k **
     storage (hash2 table key) 0 **
     gas_pred g **
     continuing) **
     mapping table m"
     (is "?pre = ?presmall ** _")
     by (auto simp:stored_hash_from_mapping)
  from a have good_post: "?post = (
     stack_height h **
     program_counter (k+1) **
     storage (hash2 table key) v **
     gas_pred (g - Csstore 0 v) **
     continuing) **
     mapping table m" (is "_ = ?postsmall ** _")
     by (subst add_not_mem) (auto simp:mapping_cons)
  have "triple {OutOfGas} ?presmall {(k, Storage SSTORE)} ?postsmall"
    by (rule sstore_gas_triple)
  then have "triple {OutOfGas} (?presmall ** mapping table m)
      {(k, Storage SSTORE)} (?postsmall ** mapping table m)"
    by (rule frame)
  then show ?thesis using good_pre and good_post by simp
qed

definition perhaps_alloc ::
   "w256 \<Rightarrow> w256 \<Rightarrow> (w256*w256) list \<Rightarrow> set_pred" where
"perhaps_alloc ind k lst =
    (if mem k lst then emp else storage (hash2 ind k) 0)"

lemma mem_perhaps :
  "mem key m \<Longrightarrow>
   mapping table m ** perhaps_alloc table key m =
   mapping table m"
apply(auto simp:perhaps_alloc_def)
done

lemma mem_perhaps_not :
  "\<not>mem key m \<Longrightarrow>
   mapping table m ** perhaps_alloc table key m =
   mapping table m ** storage (hash2 table key) 0"
apply(auto simp:perhaps_alloc_def)
done

lemma not_mem_get_zero : "\<not>mem key m \<Longrightarrow> get key m = 0"
apply (induction m)
apply (auto)
done

lemma set_storage :
  "triple {OutOfGas}
    (\<langle> h \<le> 1024 \<rangle> **
     stack (h+1) (hash2 table key) **
     stack h v **
     stack_height (h+2) **
     (mapping table m ** perhaps_alloc table key m) **
     program_counter k **
     gas_pred g **
     continuing)
    {(k, Storage SSTORE)}
    (mapping table (add key v m) **
     program_counter (k+1) **
     gas_pred (g - Csstore (get key m) v) **
     stack_height h **
     continuing)"
apply (cases "mem key m")
apply(subst mem_perhaps)
apply(simp)
using set_storage1
apply(simp)
apply(subst mem_perhaps_not)
apply(simp)
apply(subst not_mem_get_zero)
apply(simp)
using set_storage2
apply(auto)
done

lemma get_storage1 :
  assumes a:"mem key m"
  shows
  "triple {OutOfGas}
    (\<langle>h \<le> 1023 \<and> unat bn \<ge> 2463000 \<rangle> **
     stack_height (h+1) **
     stack h (hash2 table key) **
     mapping table m **
     block_number_pred bn **
     program_counter k **
     gas_pred g **
     continuing)
    {(k, Storage SLOAD)}
    (stack h (get key m) **
     mapping table m **
     program_counter (k+1) **
     block_number_pred bn **
     gas_pred (g - Gsload (unat bn)) **
     stack_height (h+1) **
     continuing)"
 (is "triple _ ?pre _ ?post")
proof -
  from a have good_pre: "?pre =
     (\<langle>h \<le> 1023 \<and> unat bn \<ge> 2463000 \<rangle> **
     block_number_pred bn ** stack_height (h + 1) **
     stack h (hash2 table key) **
     program_counter k **
     storage (hash2 table key) (get key m) **
     gas_pred g ** continuing) **
     mapping table (remove key m)"
     (is "?pre = ?presmall ** _")
     by (auto simp:stored_hash_from_mapping)
  have good_post: "?post = (
     block_number_pred bn ** stack_height (h + 1) **
     stack h (get key m) **
     program_counter (k + 1) **
     storage (hash2 table key) (get key m) **
     gas_pred (g - Gsload (unat bn)) ** continuing ) **
     mapping table (remove key m)" (is "_ = ?postsmall ** _")
     by (subst stored_hash_from_mapping) (auto simp:a)
  have "triple {OutOfGas} ?presmall {(k, Storage SLOAD)} ?postsmall"
    by (rule sload_gas_triple)
  then have "triple {OutOfGas} (?presmall ** mapping table (remove key m))
      {(k, Storage SLOAD)} (?postsmall ** mapping table (remove key m))"
    by (rule frame)
  then show ?thesis using good_pre and good_post by simp
qed

lemma get_storage2 :
  assumes a:"\<not>mem key m"
  shows
  "triple {OutOfGas}
    (\<langle>h \<le> 1023 \<and> unat bn \<ge> 2463000 \<rangle> **
     stack_height (h+1) **
     stack h (hash2 table key) **
     mapping table m **
     storage (hash2 table key) (get key m) **
     block_number_pred bn **
     program_counter k **
     gas_pred g **
     continuing)
    {(k, Storage SLOAD)}
    (stack h (get key m) **
     mapping table m **
     storage (hash2 table key) (get key m) **
     program_counter (k+1) **
     block_number_pred bn **
     gas_pred (g - Gsload (unat bn)) **
     stack_height (h+1) **
     continuing)"
 (is "triple _ ?pre _ ?post")
proof -
  from a have good_pre: "?pre =
     (\<langle>h \<le> 1023 \<and> unat bn \<ge> 2463000 \<rangle> **
     block_number_pred bn ** stack_height (h + 1) **
     stack h (hash2 table key) **
     program_counter k **
     storage (hash2 table key) 0 **
     gas_pred g ** continuing) **
     mapping table m"
     (is "?pre = ?presmall ** _")
     by (simp add:not_mem_get_zero)
  from a have good_post: "?post = (
     block_number_pred bn ** stack_height (h + 1) **
     stack h 0 **
     program_counter (k + 1) **
     storage (hash2 table key) 0 **
     gas_pred (g - Gsload (unat bn)) ** continuing ) **
     mapping table m" (is "_ = ?postsmall ** _")
     by (simp add:not_mem_get_zero)
  have "triple {OutOfGas} ?presmall {(k, Storage SLOAD)} ?postsmall"
    by (rule sload_gas_triple)
  then have "triple {OutOfGas} (?presmall ** mapping table m)
      {(k, Storage SLOAD)} (?postsmall ** mapping table m)"
    by (rule frame)
  then show ?thesis using good_pre and good_post by simp
qed

lemma get_storage :
  "triple {OutOfGas}
    (\<langle>h \<le> 1023 \<and> unat bn \<ge> 2463000 \<rangle> **
     stack_height (h+1) **
     stack h (hash2 table key) **
     ( mapping table m ** perhaps_alloc table key m ) **
     block_number_pred bn **
     program_counter k **
     gas_pred g **
     continuing)
    {(k, Storage SLOAD)}
    (stack h (get key m) **
     ( mapping table m ** perhaps_alloc table key m ) **
     program_counter (k+1) **
     block_number_pred bn **
     gas_pred (g - Gsload (unat bn)) **
     stack_height (h+1) **
     continuing)"
apply (cases "mem key m")
apply(subst mem_perhaps)
apply(simp)
apply(subst mem_perhaps)
apply(simp)
using get_storage1
apply(simp)
apply(subst mem_perhaps_not)
apply(simp)
apply(subst mem_perhaps_not)
apply(simp)
using get_storage2
apply(auto simp:not_mem_get_zero)
done

definition zero_table :: "w256 \<Rightarrow> state_element set" where
"zero_table table = {StorageElm (hash2 table key,0) | key.
  hash2 table key \<noteq> 0}"

(* set with exactly correct elems *)
definition alloc_zero_table :: "w256 \<Rightarrow> set_pred" where
"alloc_zero_table table = (\<lambda>st. st = zero_table table)"

definition alloc_zero_tables :: "w256 \<Rightarrow> w256 \<Rightarrow> set_pred" where
"alloc_zero_tables t1 t2 = (\<lambda>st. st = zero_table t1 \<union> zero_table t2)"

lemma separate_table :
  "a \<noteq> b \<Longrightarrow> zero_table a \<inter> zero_table b = {}"
apply (auto simp:zero_table_def)
using hash_inj
apply force
done

lemma separate_table2 :
  "a \<noteq> b \<Longrightarrow>
  alloc_zero_tables a b = alloc_zero_table a ** alloc_zero_table b"
apply(auto simp:alloc_zero_table_def alloc_zero_tables_def
   sep_def separate_table)
done

definition assoc_set ::
  "(w256*w256) list \<Rightarrow> state_element set" where
"assoc_set m = {StorageElm (a,b) | a b. (a,b) \<in> set m}"

definition mapping_set ::
  "w256 \<Rightarrow> (w256*w256) list \<Rightarrow> state_element set" where
"mapping_set table m = assoc_set (map (hash_pair table) m)"

definition mapping_set_z ::
  "w256 \<Rightarrow> (w256*w256) list \<Rightarrow> state_element set" where
"mapping_set_z table m = assoc_set (map (hash_pair_z table) m)"

definition mapping_zero ::
   "w256 \<Rightarrow> (w256*w256) list \<Rightarrow> state_element set" where
"mapping_zero table m = zero_table table - mapping_set_z table m"

definition alloc_zero ::
   "w256 \<Rightarrow> (w256*w256) list \<Rightarrow> set_pred" where
"alloc_zero table m = (\<lambda>st. st = mapping_zero table m)"

lemma start_table :
   "alloc_zero_table t = alloc_zero t [] ** mapping t []"
apply(auto simp:alloc_zero_table_def alloc_zero_def sep_def
  mapping_def mapping_zero_def mapping_set_def emp_def
  assoc_set_def mapping_set_z_def)
done

lemma easy : "p \<in> set m \<Longrightarrow> f p \<in> set (map f m)"
apply (induction m)
apply auto
done

lemma hp_simp : "fst \<circ> hash_pair t = hash2 t \<circ> fst"
apply(auto simp:hash_pair_def)
done

lemma hp_simp2 : "fst (hash_pair t (a, b)) = hash2 t a"
apply(auto simp:hash_pair_def)
done

lemma easy2 : "aa \<notin> fst ` set m \<Longrightarrow> (aa, b) \<in> set m \<Longrightarrow> False"
  by (simp add: rev_image_eqI)

lemma add_mapping_set :
  "mem a m \<Longrightarrow> fst ` (set m) = fst ` (set (add a b m))"
apply (induction m)
apply (simp)
apply (auto)
apply force
defer
apply force
subgoal for aa b m aaa ba
apply (cases "a = aa")
apply force
apply force
done
subgoal for aa b m aaa ba
apply (cases "a = aa")
apply force
apply force
done
done

lemma hp_unfold : "(hash2 t key, b) = hash_pair t (key,b)"
apply (simp add:hash_pair_def)
done

lemma hp_z_unfold : "(hash2 t key, 0) = hash_pair_z t (key,b)"
apply (simp add:hash_pair_z_def)
done

lemma storage_simp :
 "hash2 t key \<noteq> 0 \<Longrightarrow>
  (StorageElm (hash2 t key, 0) \<in> mapping_set_z t m) =
  (key \<in> fst ` (set m))"
apply (auto simp:mapping_set_z_def assoc_set_def hash_pair_z_def)
using hash_inj2
apply force
subgoal for b
using Set.imageI [of "(key,b)" "set m" "hash_pair_z t"]
apply (subst hp_z_unfold)
apply force
done
done

declare add.simps [simp del]

lemma add_mapping_set2 :
  "mem a m \<Longrightarrow> fst ` (set (add a b m)) = fst ` (set m)"
using add_mapping_set
apply simp
done

lemma alloc_zero_mem :
  "mem a m \<Longrightarrow>
   mapping_zero t (add a b m) = mapping_zero t m"
apply(auto simp:alloc_zero_table_def alloc_zero_def sep_def
  emp_def zero_table_def mapping_zero_def)
apply (auto simp:storage_simp)
apply (auto simp:add_mapping_set2)
apply force
using add_mapping_set
apply force
done

lemma mem_as_set : "\<not> mem aa m \<Longrightarrow> (aa, b) \<in> set m \<Longrightarrow> False"
apply (induction m)
apply (auto)
done

(* alloc zero needs to carry the invariant *)
lemma alloc_zero_split :
  "hash2 t a \<noteq> 0 \<Longrightarrow>
  alloc_zero t m = alloc_zero t (add a b m) ** perhaps_alloc t a m"
apply(auto simp:alloc_zero_table_def alloc_zero_def sep_def
  emp_def zero_table_def perhaps_alloc_def)
apply(rule funext)
apply (simp add:alloc_zero_mem)
apply(auto)[1]
apply(rule funext)
apply (simp add:add_not_mem)
apply (auto)
apply (rule exI [of "_" "{StorageElm (hash2 t a, 0)}"])

apply (auto simp:mapping_zero_def mapping_set_z_def
   hash_pair_z_def assoc_set_def storage_def)
apply (simp add:zero_table_def)
apply auto
defer
apply (simp add:zero_table_def)
apply auto
subgoal for aa b
using hash_inj2 [of t a t aa]
apply auto
using mem_as_set
apply force
done
subgoal for aa b
using hash_inj2 [of t a t aa]
apply auto
using mem_as_set
apply force
done
done

lemma alloc_zero_split2 :
  "hash2 t a \<noteq> 0 \<Longrightarrow>
   alloc_zero t (add a b m) ** perhaps_alloc t a m = alloc_zero t m"
using alloc_zero_split
apply simp
done

lemma alloc_table :
   "hash2 t a \<noteq> 0 \<Longrightarrow>
    alloc_zero t m ** mapping t m =
    mapping t m ** (alloc_zero t (add a b m) ** perhaps_alloc t a m)"
apply (subst alloc_zero_split2)
apply auto
done

definition htable :: "w256 \<Rightarrow> (w256 * w256) list \<Rightarrow> set_pred" where
"htable t m = alloc_zero t m ** mapping t m"

lemma set_table :
    assumes a:"hash2 table key \<noteq> 0"
    shows "triple {OutOfGas}
    (\<langle> h \<le> 1024 \<rangle> **
     stack (h+1) (hash2 table key) **
     stack h v **
     stack_height (h+2) **
     htable table m **
     program_counter k **
     gas_pred g **
     continuing)
    {(k, Storage SSTORE)}
    (htable table (add key v m) **
     program_counter (k+1) **
     gas_pred (g - Csstore (get key m) v) **
     stack_height h **
     continuing)" (is "triple _ ?pre _ ?post")
proof -
  have good_pre: "?pre =
     (\<langle> h \<le> 1024 \<rangle> **
     stack (h+1) (hash2 table key) **
     stack h v **
     stack_height (h+2) **
     (mapping table m ** perhaps_alloc table key m) **
     program_counter k **
     gas_pred g **
     continuing) **
     alloc_zero table (add key v m)"
     (is "?pre = ?presmall ** _")
    using a
 apply (subst htable_def)
 apply (subst alloc_table)
 apply (auto)
 done
  have good_post: "?post = (
     mapping table (add key v m) **
     program_counter (k+1) **
     gas_pred (g - Csstore (get key m) v) **
     stack_height h **
     continuing) **
     alloc_zero table (add key v m)"
     (is "_ = ?postsmall ** _")
     apply (subst htable_def) apply (auto) done
  have "triple {OutOfGas} ?presmall {(k, Storage SSTORE)} ?postsmall"
   using set_storage by force
  then have "triple {OutOfGas} (?presmall ** alloc_zero table (add key v m))
      {(k, Storage SSTORE)} (?postsmall ** alloc_zero table (add key v m))"
    by (rule frame)
  then show ?thesis using good_pre and good_post by simp
qed

lemma get_table :
  assumes a:"hash2 table key \<noteq> 0"
  shows
    "triple {OutOfGas}
    (\<langle>h \<le> 1023 \<and> unat bn \<ge> 2463000 \<rangle> **
     stack_height (h+1) **
     stack h (hash2 table key) **
     htable table m **
     block_number_pred bn **
     program_counter k **
     gas_pred g **
     continuing)
    {(k, Storage SLOAD)}
    (stack h (get key m) **
     htable table m **
     program_counter (k+1) **
     block_number_pred bn **
     gas_pred (g - Gsload (unat bn)) **
     stack_height (h+1) **
     continuing)"
 (is "triple _ ?pre _ ?post")
proof -
  from a have good_pre: "?pre =
    (\<langle>h \<le> 1023 \<and> unat bn \<ge> 2463000 \<rangle> **
     stack_height (h+1) **
     stack h (hash2 table key) **
     ( mapping table m ** perhaps_alloc table key m ) **
     block_number_pred bn **
     program_counter k **
     gas_pred g **
     continuing) ** alloc_zero table (add key 0 m)"
     (is "?pre = ?presmall ** _")
      apply (subst htable_def)
      apply (subst alloc_table)
      apply (auto)
      done
  from a have good_post: "?post = (
     stack h (get key m) **
     ( mapping table m ** perhaps_alloc table key m ) **
     program_counter (k+1) **
     block_number_pred bn **
     gas_pred (g - Gsload (unat bn)) **
     stack_height (h+1) **
     continuing) **
     alloc_zero table (add key 0 m)" (is "_ = ?postsmall ** _")
      apply (subst htable_def)
      apply (subst alloc_table)
      apply (auto)
      done
  have "triple {OutOfGas} ?presmall {(k, Storage SLOAD)} ?postsmall"
    by (rule get_storage)
  then have "triple {OutOfGas} (?presmall ** alloc_zero table (add key 0 m))
      {(k, Storage SLOAD)} (?postsmall ** alloc_zero table (add key 0 m))"
    by (rule frame)
  then show ?thesis using good_pre and good_post by simp
qed

end


;;; \omega-ants agents for theory nd-rips

(in-package :omega)

(eval-when (compile)
           (error "This file should not be compiled."))

;;; STUFF

(defun 1st-subterm (a1)
  (first (data~appl-arguments  a1)))
(defun 2nd-subterm (a1)
  (second (data~appl-arguments  a1)))

; CONJUNCTIVE MODUS PONENS
;
; IF P AND Q THEN R
; P
; Q
; ------------------
; R
;
; (a) If a sentence of the form  IF P AND Q THEN R holds in some domain D
; (b) and P holds in D
; (c) and Q holds in D
; (d) and R does not yet hold in D (does it suffice to look into the supports?)
; (e) then add R to D
;
;

; tested for: first 3 arguments: OK
;
;

(agent~defmatrix rips-conj-modus-ponens ;;; no c-predicates since only used in forward direction
   (agents (s-predicate (for implication)
                        (uses )
                        (definition (pred-conj-impl implication)))
	   (s-predicate (for antecedent1)
                        (uses implication)
                        (definition (pred-match1 implication antecedent1)))
	   (s-predicate (for antecedent2)
			(uses implication antecedent1)
			(definition (pred-match2 implication antecedent1 antecedent2))))
   (predicates
    (pred-conj-impl (a1)
		    (and (logic~implication-p  a1)
		    	 (logic~conjunction-p (first (data~appl-arguments  a1)))))
		    (Pred-match1 (a1 a2)
		 (or (term~alpha-equal (first
					(data~appl-arguments
					 (first (data~appl-arguments a1)))) a2)
		     (term~alpha-equal (second
					(data~appl-arguments
					 (first (data~appl-arguments a1)))) a2 ) ))
    (pred-match2 (a1 a2 a3)
		 (let* ((conj (first (data~appl-arguments a1)))
			(a (first (data~appl-arguments conj)))
			(b (second (data~appl-arguments conj))))
		   (or (and (term~alpha-equal a2 a)
			     (term~alpha-equal a3 b))
		       (and (term~alpha-equal a2 b)
			     (term~alpha-equal a3 a)))))))

; MODUS PONENS - FORWARD IF ELIMINATION
;
; IF P THEN Q
; P
; ------------------
; Q
;
; (a) If a sentence of the form IF P THEN Q holds in some domain D,
; (b) and P holds in D,
; (c) and Q does not yet hold in D,
; (d) then add Q to D.

; MODUS PONENS - BACKWARD IF ELIMINATION
;
; IF P THEN Q
; P
; ------------------
; Q
;
; (a) Set D to domain of current goal
; (b) Set Q to current goal
; (c) If the sentence of the form IF P THEN Q holds in some domain D,
; (d) and D does not yet contain the subgoal P,
; (e) then add P to the list of subgoals
;

; tested for first 2 arguments: ok
;
;

(agent~defmatrix rips-modus-ponens
    (agents (s-predicate (for implication)
                         (uses )
                         (definition (pred-conj-impl implication))) ;; corresponds to (a) (forward)
            (s-predicate (for antecedent)
                         (uses implication)
                         (definition (pred-match1 implication antecedent)))
    	    (c-predicate (for succedent)
			 (uses implication)
                         (definition (pred-match2 implication succedent)))
	    (c-predicate (for succedent)
                         (uses implication antecedent)
                         (definition (pred-match3 implication antecedent succedent)))

	    )
    (predicates
     (pred-conj-impl (a1)
 		    (logic~implication-p a1))
     (pred-match1 (a1 a2)
 		 (term~alpha-equal (first (data~appl-arguments  a1)) a2))
     (pred-match2 (a1 a2)
 		 (term~alpha-equal (second (data~appl-arguments  a1)) a2))
     (pred-match3 (a1 a2 a3)
 		 (and (pred-match1 a1 a2)
 		      (pred-match2 a1 a3)))

    ))

; FORWARD DILEMMA
;
; P v Q
; IF P THEN R
; IF Q THEN R
; ------------------
; R
;
; (a) If a sentence of the form P v Q holds in some domain D,
; (b) and IF P THEN R holds in D,
; (c) and IF Q THEN R holds in D,
; (d) and R does not yet hold in D,
; (e) then add R to D.
;

;
; tested with first 3 arguments: ok
;

(Agent~defmatrix rips-dilemma
   (agents (s-predicate (for disjunction)
                        (uses )
                        (definition (pred-disj disjunction)))
	    (s-predicate (for implication1)
                        (uses disjunction)
                         (definition (pred-match1 disjunction implication1)))
            (s-predicate (for implication2)
                         (uses disjunction implication1)
                         (definition (pred-match2 disjunction implication1 implication2)))
 	   (c-predicate (for succedent)
                         (uses disjunction implication1 implication2)
                         (definition (pred-match3 disjunction implication1 implication2 succedent)))
	   )
   (predicates
    (pred-disj (a1)
		    (logic~disjunction-p a1))
    (pred-match1 (a1 a2)
		 (and (logic~implication-p a2)
		      (or (term~alpha-equal (1st-subterm a1) (1st-subterm a2))
			  (term~alpha-equal (2nd-subterm a1) (1st-subterm a2)))))
    (pred-match2 (a1 a2 a3)
		 (and (logic~implication-p a3)
		      (term~alpha-equal (2nd-subterm a2) (2nd-subterm a3))
		      (or (and  (term~alpha-equal (1st-subterm a1) (1st-subterm a2))
				(term~alpha-equal (2nd-subterm a1) (1st-subterm a3)))
			  (and  (term~alpha-equal (2nd-subterm a1) (1st-subterm a2))
			        (term~alpha-equal (1st-subterm a1) (1st-subterm a3))))))
    (pred-match3 (a1 a2 a3 a4)
		 (and  (term~alpha-equal (2nd-subterm a2) a4)
		       (term~alpha-equal (2nd-subterm a3) a4)))
    ))

; FORWARD DISJUNCTIVE-MODUS-PONENS
;
; (P v Q) => R
;  P
; ------------------
;  R
;
; (a) If a sentence of the form (P v Q) => R holds in some domain D,
; (b) and P or Q also holds in D,
; (c) and R does not yet hold in D,
; (d) then add R to D.

; BACKWARD DISJUNCTIVE-MODUS-PONENS
;
; (P v Q) => R
;  P
; ------------------
;  R
;
; (a) Set D to domain of current goal.
; (b) Set R to current goal
; (c) It the sentence (P v Q) => R holds in D,
; (d) and D does not yet contain the subgoal P,
; (e) then add P to the list of subgoals
; (f) If the subgoal in (e) fails,
; (g) and D does not yet contain the subgoal Q,
; (h) then add Q to the list of subgals.
;

; tested with: implication only (1st s-predicate)
;              implication and antecedent (2nd s-predicate)
;              all three agents
;

(Agent~defmatrix rips-disj-modus-ponens
   (agents (s-predicate (for implication)
                        (uses )
                        (definition (pred-impl-disj implication))) ;;; forward & backward direction
	    (s-predicate (for antecedent)
                        (uses implication)
                        (definition (pred-match1 implication antecedent))) ;forward direction
 	   (c-predicate (for succedent)
                         (uses implication)
                         (definition (pred-match3 implication succedent))) ;backward & forward direction
	   )
   (predicates
    (pred-impl-disj (a1)
		    (and (logic~implication-p a1)
			 (logic~disjunction-p (1st-subterm a1))))
    (pred-match1 (a1 a2)
		      (or (term~alpha-equal (1st-subterm (1st-subterm a1)) a2)
			  (term~alpha-equal (2nd-subterm (1st-subterm a1)) a2)))
    (pred-match3 (a1 a2)
		 (term~alpha-equal (2nd-subterm a1) a2))
    ))

; FORWARD DISJUNCTIVE SYLLOGISM
;
;  P OR Q
;  NOT Q
; ------------------
;  P
;
; (a) If a sentence of the form P OR Q holds in some domain D,
; (b) then if NOT P holds in D and Q does not yet hold in D,
; (c) then add Q to D
; (d) else if NOT Q holdds in D and P does not yet hold in D,
; (e) then add P to D.
;
; tested in forward direction

; BACKWARD DISJUNCTIVE SYLLOGISM
;
;  P OR Q
;  NOT Q
; ------------------
;  P
;
; (a) Set D to domain of current goal
; (b) Set Q to current goal
; (c) If a sentence of the form P OR Q or Q OR P holds in D,
; (d) and NOT P is a subformula of a sentence that holds in D,
; (e) and D does not yet contain the subgoal NOT P,              ;;;;;;; !!!!!!
; (f) then add NOT P to the list of subgoals.

(Agent~defmatrix rips-disj-syll
   (agents (s-predicate (for disjunction)
                        (uses )
                        (definition (pred-disj disjunction)))
	    (s-predicate (for antecedent)
                        (uses disjunction)
			(exclude succedent) ;;; does not seem to work?
                        (definition (pred-match1 disjunction antecedent)))
 	     (c-predicate (for succedent)
                         (uses disjunction)
			 (exclude antecedent)  ;;;does not seem to work???
                         (definition (pred-match3 disjunction succedent)))
	   )
   (predicates
    (pred-disj (a1)
	       (logic~disjunction-p a1))
    (pred-match1 (a1 a2)
		 (and (logic~negation-p a2)
		      (or (term~alpha-equal (1st-subterm a1) (1st-subterm a2))
			  (term~alpha-equal (2nd-subterm a1) (1st-subterm a2)))))
    (pred-match3 (a1 a2)
  		 (or (term~alpha-equal (1st-subterm a1) a2)
		     (term~alpha-equal (2nd-subterm a1) a2)))
    ))

; RIPS-DEMORGAN-1
;
; NOT (P AND Q)
; ------------------
; (NOT P) OR (NOT Q)
;
; (a) Set D to domain of current goal
; (b) If current goal is of the form (NOT P) OR (NOT Q),
; (c) and NOT (P AND Q) is a subformula of a sentence that holds in D,
; (d) then add NOT (P AND Q) to the list of subgoals.
;
; tested for all 2 arguments: ok.
;
;

(agent~defmatrix rips-demorgan-1
   (agents (s-predicate (for antecedent)
                        (uses )
                        (definition (pred-match1 antecedent)))
	   (s-predicate (for antecedent)
                        (uses succedent)
                        (definition (pred-match1a antecedent succedent)))
           (c-predicate (for succedent)
                        (uses antecedent)
                        (definition (pred-match1a antecedent succedent)))
	   (c-predicate (for succedent)
                        (uses )
                        (definition (pred-match2 succedent)))
	   )
   (predicates
    (pred-match1 (a1)
		 (and (logic~negation-p a1)
		      (logic~conjunction-p (1st-subterm a1))))
    (pred-match2 (a1)
		 (and (logic~disjunction-p a1)
		      (logic~negation-p (1st-subterm a1))
		      (logic~negation-p (2nd-subterm a1))))
    (pred-match1a (a1 a2)
		 (and (pred-match1 a1)   ;; this is a bit wasteful.
		      (pred-match2 a2)   ;;
		      (term~alpha-equal (1st-subterm (1st-subterm a1)) (1st-subterm (1st-subterm a2)))
		      (term~alpha-equal (2nd-subterm (1st-subterm a1)) (1st-subterm (2nd-subterm a2)))))
    ))

; RIPS-DEMORGAN-2
;
; NOT (P OR Q)
; ------------------
; (NOT P) AND (NOT Q)
;
; (a) Set D to domain of current goal
; (b) If current goal is of the form (NOT P) AND (NOT Q),
; (c) and NOT (P OR Q) is a subformula of a sentence that holds in D,
; (d) then add NOT (P OR Q) to the list of subgoals.
;
;
; not tested yet.
;

(agent~defmatrix rips-demorgan-2
   (agents (s-predicate (for antecedent)
                        (uses )
                        (definition (pred-match1 antecedent)))
	   (s-predicate (for antecedent)
                        (uses succedent)
                        (definition (pred-match1a antecedent succedent)))
           (c-predicate (for succedent)
                        (uses antecedent)
                        (definition (pred-match1a antecedent succedent)))
	   (c-predicate (for succedent)
                        (uses )
                        (definition (pred-match2 succedent)))
	   )
   (predicates
    (pred-match1 (a1)
		 (and (logic~negation-p a1)
		      (logic~disjunction-p (1st-subterm a1))))
    (pred-match2 (a1)
		 (and (logic~conjunction-p a1)
		      (logic~negation-p (1st-subterm a1))
		      (logic~negation-p (2nd-subterm a1))))
    (pred-match1a (a1 a2)
		 (and (pred-match1 a1)   ;; this is a bit wasteful.
		      (pred-match2 a2)   ;;
		      (term~alpha-equal (1st-subterm (1st-subterm a1)) (1st-subterm (1st-subterm a2)))
		      (term~alpha-equal (2nd-subterm (1st-subterm a1)) (1st-subterm (2nd-subterm a2)))))
    ))

; RIPS-ANDE (FORWARD)
;
; P AND Q
; ------------------
; P
;
; P AND Q
;
; ------------------
; Q
;
; (a) If a sentence of the form P AND Q holds in some domain D,
; (b) then if P does not yet hold in D,
; (c) then add P to D,
; (d) and if Q does not yet hold in D,
; (e) then add Q to D
;
;
; tested in forward direction.
;
;
; RIPS-ANDE (BACKWARD)
;
; BIG TODO: This doesn't yet correspond to Rips, even not the tactic.
;
; P AND Q
; ------------------
; P
;
; Q AND P
;
; ------------------
; P
;
; (a) Set D to domain of current goal,
; (b) Set P to current goal
; (c) If the sentence P AND Q is a subformula of a sentence that holds in D,
; (d) and D does not yet contain the subgoal P AND Q,
; (e) then add P AND Q to the list of subgoals.
; (f) If the subgoal in (e) fails,
; (g) and the sentence Q AND P is a subformula of a sentence that holds in D,
; (h) and D does not yet contain the subgoal Q AND P,
; (i) then add Q AND P to the list of subgoals.
;

(agent~defmatrix rips-ande
   (agents (s-predicate (for conjunction)
                        (uses )
			(exclude conjunct1 conjunct2)
                        (definition (pred-conj conjunction)))

	   )
   (predicates
    (pred-conj (a1)
		 (logic~conjunction-p a1))

    ))

;
; RIPS-NOTNOTE (FORWARD)
;
; NOT NOT P
; ------------------
; P
;
; (a) If a sentence of the form NOT NOT P holds in some domain D,
; (b) and P does not yet hold in D,
; (c) then add P to D.

;
; RIPS-NOTNOTE (BACKWARD)
;
; NOT NOT P
; ------------------
; P
;
; (a) Set D to domain of current goal
; (b) Set P to current goal.
; (c) If the sentence NOT NOT P is a subformula of a sentence that holds in D,
; (d) and D does not yet contain the subgoal NOT NOT P,
; (e) then add NOT NOT P to the list of subgoals.
;
;

(agent~defmatrix rips-notnote
   (agents (s-predicate (for negnegterm)
                        (uses )
			(exclude term)
                        (definition (pred-negneg negnegterm)))
	   (c-predicate (for term)
                        (uses )
			(exclude negnegterm)
                        (definition (pred-term term)))

	   )
   (predicates
    (pred-negneg (a1)
		 (and (logic~negation-p a1)
		      (logic~negation-p (1st-subterm a1))
		      ))
    (pred-term (a1)
		 T)

    ))

; RIPS-IMPI (BACKWARD)
;
; [P]
; .
; .
; .
; Q
; ------------------
; P => Q
;
; (a) Set D to domain of current goal
; (b) If the current goal is of the form  P => Q,
; (c) and neither D nor ist superdomains nor its immediate subdomains contain suppostitions P and subgoal Q,
; (d) and IR P THEN Q is a subformula of the premises or conclusion,  ;;; TODO !
; (e) then set up a subdomain of D, D', with supposition P.
; (f) add the subgoal of proving Q in D' to the list of subgoals.
;
; tested

(agent~defmatrix rips-impi
   (agents
    (c-predicate (for succedent)
		 (uses )
		 (definition (pred-impl succedent)))

	   )
   (predicates
    (pred-impl (a1)
		 (logic~implication-p a1))

    ))

; RIPS-ANDI
;
; P
; Q
; ------------------
; P AND Q
;
; (a) Set D to domain of current goal
; (b) If current goal is of the form P AND Q,
; (c) and D does not yet contain the subgoal P,
; (d) then add the subgoal of proving P in D to the list of subgoals.
; (e) If the subgoal in (d) succeeds,
; (f) and D does not yet contain subgoal Q,
; (g) then add the subgoal of proving Q in D to the list of subgoals.
;
;
; tested with all three arguments

(agent~defmatrix rips-andi
   (agents (s-predicate (for conjunct1) ; corresponds to (d)
                        (uses conjunction)
                        (definition (pred-match1 conjunction conjunct1)))
	   (s-predicate (for conjunct2) ; corresponds to (g)
                        (uses conjunction)
                        (definition (pred-match2 conjunction conjunct2)))
           (c-predicate (for conjunction)
                        (uses )
                        (definition (logic~conjunction-p conjunction)))  ; corresponds to (e)

	   )
   (predicates
    (pred-match1 (a1 a2)
		 (term~alpha-equal (1st-subterm a1) a2))
		; (and (term~alpha-equal (1st-subterm a1) a2)
		;      (notany #'(lambda (x) (term~alpha-equal a2
		;				       (node~formula x)))
		;		       (pds~node-supports (:node a1)))))
		;      ;(not (some #'(lambda (hyp-node)
		;		     (term~alpha-equal (node~formula hyp-node)
			;			       a2 ))
				; (pds~node-supports (:node a1))))
		     ; ))
    (pred-match2 (a1 a2)
		 (term~alpha-equal (2nd-subterm a1) a2))

    ))

;;; NOTE - TODO!

;;; NOTI - TODO!

;
; RIPS-ORE
;
; P v Q
; [P] ---> R
; [Q] ---> R
; ----------------
;  R
;
; (a) Set D to domain of current goal
; (b) Set R to current goal.
; (c) If a sentence of the form P OR Q holds in D,
; (d) and both P and Q are subformulas or negations of subformulas of the premises or conclusion,
; (e) and R is a subformula or negation of a subformula of the premises or conclusion,
; (f) and neither D nor its superdomains  nor its immediate subdomains contain supposition P and subgoal R,
; (g) and neither D nor its superdomains  nor its immediate subdomains contain supposition P and subgoal R,
; (h) then set up a subdomain of D, D', with supposition Q and subgoal R,
; (i) and add the subgoal of proving R in D' to the list of subgoals.
; (j) If the subgoal in (i) succeeds,
; (k) the set up another subdomain of D, D'', with supposition Q,
; (l) and add the subgoal of proving R in D'' to the list of subgoals.
;
; tested for two arguments
;

(agent~defmatrix rips-ore
   (agents (s-predicate (for disjunction) ;corresponds to (c)
                        (uses )
                        (definition (logic~disjunction-p disjunction)))
           (c-predicate (for conclusion)
                        (uses )
                        (definition (pred-conj conjunction)))

	   )
   (predicates
    (pred-conj (a1)
	       T)

    ))

;;;;;;;;;;;;;; backward if elimination ;;; TODO

(agent~defmatrix rips-bckw-if-elim
   (agents (s-predicate (for implication) ;corresponds to (c)
                        (uses )
                        (definition (logic~implication-p implication)))
           (c-predicate (for succedent)
                        (uses implication)
                        (definition (pred-bckw implication succedent)))

	   )
   (predicates
    (pred-bckw (implication succedent)
	       (format t "pred-bckw")
	       (nd-rips=backward-IF-elim-condition succedent implication))

    ))

(agent~defmatrix rips-bckw-if-intro
   (agents (c-predicate (for implication)
                        (uses )
                        (definition (logic~implication-p implication)))
	   )
   (predicates
    )
    )

(agent~defmatrix rips-bckw-andi
   (agents (c-predicate (for conjunction)
                        (uses )
                        (definition (logic~conjunction-p conjunction)))
	   )
   (predicates
    )
    )

(agent~defmatrix rips-matching
   (agents
           (s-predicate (for assertion)
                        (uses )
                        (definition 'T))
           (c-predicate (for subgoal)
                        (uses assertion)
                        (definition (nd-rips=isomorphic-p conjunction assertion)))
	   )
   (predicates
    )
    )

   (th~defagentdefault nd-rips
  	      (csm~set-considered-commands '(rips-conj-modus-ponens rips-modus-ponens rips-dilemma rips-demorgan-1 rips-demorgan-2 rips-andi rips-disj-modus-ponens rips-disj-syll rips-ande rips-notnote rips-impi rips-ore weaken rips-bckw-if-elim  rips-bckw-if-intro rips-bckw-andi rips-matching defn-expand))
  		    )

  (th~defagentdefault relation
   	      (csm~set-considered-commands '(rips-conj-modus-ponens rips-modus-ponens rips-dilemma rips-demorgan-1 rips-demorgan-2 rips-andi rips-disj-modus-ponens rips-disj-syll rips-ande rips-notnote rips-impi rips-ore weaken rips-bckw-if-elim))
  	 	    )

;; (defmethod bb~command-suggestion-leq-p
;;   ((sugg1 bb+command-suggestion) (sugg2 bb+command-suggestion) (indicator (eql :i-e-f)))
;;   (let ((com1 (mapcar #'keim~name (com~categories (bb~entry-command sugg1))))
;; 	(com2 (mapcar #'keim~name (com~categories (bb~entry-command sugg2)))))
;;     (flet ((in (cat list)
;; 	       (find cat list :test #'string-equal)))
;;       (or (in :elimination com2)
;; 	  (and (in :introduction com2) (not (in :elimination com1)))
;; 	  (and (in :false com2) (not (or (in :elimination com1)
;; 					 (in :introduction com1))))
;; 	  ))))

;; (defun pds~not-free-in-nodes-or-hyps-p (term &rest lines)
;;   (declare (edited  "23-SEP-1996" "09-FEB-1993 12:46")
;; 	   (authors Lassaad nesmith)
;; 	   (input   "A TERM and  as &rest argument a list of nodes.")
;; 	   (effect  "None.")
;; 	   (value   "T if TERM is not free in (occurs un-lambda-bound in)
;; LINES' formulas nor free in any of their hypotheses, otherwise nil."))
;;   (let ((hyps (delete-duplicates
;; 	       (mapcan #'copy-list (mapcar #'pdsn~hyps lines)))))
;;     (dolist (line
;; 	     (remove-duplicates (append lines hyps))
;; 	     t)
;;       (let ((unbound-symbols
;; 	     (data~all-unbound-symbols (node~formula line))))
;; 	(if (find term unbound-symbols :test #'data~equal-p)
;; 	    (return-from pds~not-free-in-nodes-or-hyps-p nil))))))

;;; TODOS: rips backward ande


theory poST_test
  imports "~~/poST/poSTVM/poSTVM_alt_inductive"
begin

value "fmempty :: (nat,nat) fmap"
definition test_process_state1 :: "process_state" where
"test_process_state1 =
  (fmap_of_list [(''var1'',stacked_proc_var.Var (stacked_var_init.Symbolic (basic_post_type.Nat 0) None))],
  ''state1'',
  ''state1'',
  [''state1''],
  proc_status.Active,
  time.Time 0 0 0 0 0)"
definition test_program_state1 :: "program_state" where
"test_program_state1 =
  (fmempty,
  (fmupd
    ''process1''
    test_process_state1
    fmempty),
  ''process1'')"
definition test_ms1 :: "model_state" where
"test_ms1 = model_state.ST
  fmempty
  (fmupd
    ''program1''
    test_program_state1
    fmempty)
  ''program1''
  []
  fmempty"

definition test_process_state2 :: "process_state" where
"test_process_state2 =
  (fmap_of_list [(''var1'',stacked_proc_var.Var (stacked_var_init.Symbolic (basic_post_type.Nat 1) None))],
  ''state1'',
  ''state1'',
  [''state1''],
  proc_status.Active,
  time.Time 0 0 0 0 0)"
definition test_program_state2 :: "program_state" where
"test_program_state2 =
  (fmempty,
  (fmupd
    ''process1''
    test_process_state2
    fmempty),
  ''process1'')"
definition test_ms2 :: "model_state" where
"test_ms2 = model_state.ST
  fmempty
  (fmupd
    ''program1''
    test_program_state2
    fmempty)
  ''program1''
  []
  fmempty"

definition test_statement1 :: "stmt" where
"test_statement1 = stmt.AssignSt (common_var.Symbolic ''var1'') (expr.Const (const.Nat 1))"

lemma "(statement_result.Continue,test_ms1)\<turnstile>test_statement1\<longrightarrow>(statement_result.Continue,test_ms2)"
  apply (auto simp add: test_statement1_def
                test_ms1_def
                test_ms2_def
                test_process_state1_def
                test_process_state2_def
                test_program_state1_def
                test_program_state2_def)
  apply (rule AssignS)
   apply (rule Const)
  apply auto
  done

definition test_process_state3 :: "process_state" where
"test_process_state3 =
  (fmap_of_list [(''var1'',stacked_proc_var.Var (stacked_var_init.Symbolic (basic_post_type.Nat 2) None))],
  ''state1'',
  ''state1'',
  [''state1''],
  proc_status.Active,
  time.Time 0 0 0 0 0)"
definition test_program_state3 :: "program_state" where
"test_program_state3 =
  (fmap_of_list [],
  (fmupd
    ''process1''
    test_process_state3
    fmempty),
  ''process1'')"
definition test_ms3 :: "model_state" where
"test_ms3 = model_state.ST
  fmempty
  (fmupd
    ''program1''
    test_program_state3
    fmempty)
  ''program1''
  []
  fmempty"

definition test_statement2 :: "stmt" where
"test_statement2 = stmt.AssignSt (common_var.Symbolic ''var1'')
  (expr.Binary (binary_op.Sum) (expr.SymbolicVar ''var1'') (expr.Const (const.Nat 2)))"

lemma "(statement_result.Continue,test_ms1)\<turnstile>test_statement2\<longrightarrow>(statement_result.Continue,test_ms3)"
  apply (simp add: test_statement2_def
                test_ms1_def
                test_ms3_def
                test_process_state1_def
                test_process_state3_def
                test_program_state1_def
                test_program_state3_def)
  apply (rule AssignS)
   apply (rule BinOp)
     apply (rule Var)
   apply (auto)
   apply (rule Const)
apply (auto)
done
(* Don't work now*)
definition test_process_state4 :: "process_state" where
"test_process_state4 =
  (fmap_of_list [(''var1'',stacked_proc_var.Var (stacked_var_init.Symbolic (basic_post_type.Nat 0) None)),
                 (''var2'',stacked_proc_var.Var (stacked_var_init.Symbolic (basic_post_type.Nat 0) None))],
  ''state1'',
  ''state1'',
  [''state1''],
  proc_status.Active,
  time.Time 0 0 0 0 0)"
definition test_program_state4 :: "program_state" where
"test_program_state4 =
  (fmap_of_list[],
  (fmupd
    ''process1''
    test_process_state4
    fmempty),
  ''process1'')"
definition test_ms4 :: "model_state" where
"test_ms4 = model_state.ST
  fmempty
  (fmupd
    ''program1''
    test_program_state4
    fmempty)
  ''program1''
  []
  fmempty"

definition test_process_state5 :: "process_state" where
"test_process_state5 =
  (fmap_of_list [(''var1'',stacked_proc_var.Var (stacked_var_init.Symbolic (basic_post_type.Nat 1) None)),
                 (''var2'',stacked_proc_var.Var (stacked_var_init.Symbolic (basic_post_type.Nat 2) None))],
  ''state1'',
  ''state1'',
  [''state1''],
  proc_status.Active,
  time.Time 0 0 0 0 0)"
definition test_program_state5 :: "program_state" where
"test_program_state5 =
  (fmap_of_list[],
  (fmupd
    ''process1''
    test_process_state5
    fmempty),
  ''process1'')"
definition test_ms5 :: "model_state" where
"test_ms5 = model_state.ST
  fmempty
  (fmupd
    ''program1''
    test_program_state5
    fmempty)
  ''program1''
  []
  fmempty"

definition test_statement3 :: "stmt" where
"test_statement3 = stmt.Comb
  (stmt.AssignSt (common_var.Symbolic ''var1'')(
    expr.Binary (binary_op.Sum) (expr.SymbolicVar ''var1'') (expr.Const (const.Nat 1))))
  (stmt.AssignSt (common_var.Symbolic ''var2'')(
    expr.Binary (binary_op.Sum) (expr.SymbolicVar ''var2'') (expr.Const (const.Nat 2))))"

find_theorems "Suc (Suc 0)"

lemma "(fmupd 2 3 (fmupd 1 2 fmempty)) = (fmupd 2 3 (fmupd 1 2 (fmupd 2 1 (fmupd 1 1 fmempty))))"
  apply (metis fmupd_idem fmupd_reorder_neq)
  done

lemma "(statement_result.Continue,test_ms4)\<turnstile>test_statement3\<longrightarrow>(statement_result.Continue,test_ms5)"
  apply (simp add: test_statement3_def
                test_ms4_def
                test_ms5_def
                test_process_state4_def
                test_process_state5_def
                test_program_state4_def
                test_program_state5_def)
  apply (rule Comb)
   apply (rule AssignS)
    apply (rule BinOp)
      apply (rule Var)
      apply (auto)
   apply (rule Const)
   apply (auto)
  apply (rule AssignS)
   apply (rule BinOp)
     apply (rule Var)
     apply (auto)
   apply (rule Const)
   apply (auto)
  done
(**)

find_theorems "(Suc 0)"

definition test_process_state6 :: "process_state" where
"test_process_state6 =
  (fmap_of_list [(''var1'',stacked_proc_var.Var (stacked_var_init.Symbolic (basic_post_type.Nat 1) None)),
                 (''var2'',stacked_proc_var.Var (stacked_var_init.Symbolic (basic_post_type.Nat 3) None))],
  ''state1'',
  ''state1'',
  [''state1''],
  proc_status.Active,
  time.Time 0 0 0 0 0)"
definition test_program_state6 :: "program_state" where
"test_program_state6 =
  (fmap_of_list [],
  (fmupd
    ''process1''
    test_process_state6
    fmempty),
  ''process1'')"
definition test_ms6 :: "model_state" where
"test_ms6 = model_state.ST
  fmempty
  (fmupd
    ''program1''
    test_program_state6
    fmempty)
  ''program1''
  []
  fmempty"

(*
var1 = var1 + 1;
IF var1 = 1
THEN
  var2 = var2 + 3;
ELSE
  var2 = var2 - 2;
*)
definition test_statement4 :: "stmt" where
"test_statement4 = stmt.Comb
  (stmt.AssignSt (common_var.Symbolic ''var1'')(
    expr.Binary (binary_op.Sum) (expr.SymbolicVar ''var1'') (expr.Const (const.Nat 1))))
  (stmt.IfSt
    (expr.Binary binary_op.Eq (expr.SymbolicVar ''var1'') (expr.Const (const.Nat 1)))
    (stmt.AssignSt (common_var.Symbolic ''var2'')(
      expr.Binary (binary_op.Sum) (expr.SymbolicVar ''var2'') (expr.Const (const.Nat 3))))
    (stmt.AssignSt (common_var.Symbolic ''var2'')(
      expr.Binary (binary_op.Sub) (expr.SymbolicVar ''var2'') (expr.Const (const.Nat 2)))))"

lemma "(statement_result.Continue,test_ms4)\<turnstile>test_statement4 \<longrightarrow> (statement_result.Continue,test_ms6)"
  apply (simp add:test_statement4_def
                test_ms4_def test_process_state4_def test_program_state4_def
                test_ms6_def test_process_state6_def test_program_state6_def)
  apply (rule Comb)
   apply (rule AssignS)
    apply (rule BinOp)
      apply (rule Var)
  apply (auto)
   apply (rule Const)
   apply (auto)
  apply (rule If)
   apply (rule BinOp)
     apply (rule Var)
     apply (auto)
   apply (rule Const)
   apply (auto)
  apply (rule AssignS)
   apply (rule BinOp)
     apply (rule Var)
     apply (auto)
   apply (rule Const)
  apply (auto)
  done

definition test_process_state7 :: "process_state" where
"test_process_state7 =
  (fmap_of_list [(''var1'',stacked_proc_var.Var (stacked_var_init.Symbolic (basic_post_type.Nat 6) None)),
                 (''var2'',stacked_proc_var.Var (stacked_var_init.Symbolic (basic_post_type.Nat 0) None))],
  ''state1'',
  ''state1'',
  [''state1''],
  proc_status.Active,
  time.Time 0 0 0 0 0)"
definition test_program_state7 :: "program_state" where
"test_program_state7 =
  (fmap_of_list [],
  (fmupd
    ''process1''
    test_process_state7
    fmempty),
  ''process1'')"
definition test_ms7 :: "model_state" where
"test_ms7 = model_state.ST
  fmempty
  (fmupd
    ''program1''
    test_program_state7
    fmempty)
  ''program1''
  []
  fmempty"

definition statement6 :: "statement" where
"statement6 = statement.IterSt (iter_statement.RepeatSt
  [(statement.AssignSt (common_var.Symbolic ''var1'')( (expr.Binary binary_op.Sum (expr.SymbolicVar ''var1'') (expr.Const (const.Nat 2)))))]
  (expr.Binary binary_op.Less (expr.SymbolicVar ''var1'') (expr.Const (const.Nat 5))))"
(*
definition test_statement6 :: "stmt" where
"test_statement6 = statement_to_stmt (statement5)"

value "test_statement6"
*)
definition test_statement6 :: "stmt" where
"test_statement6 =
Comb (Comb
  (Comb
    (stmt.AssignSt
      (common_var.Symbolic ''var1'')( expr.Binary binary_op.Sum (expr.SymbolicVar ''var1'') (expr.Const (const.Nat 2))))
    Blank)
  (stmt.WhileSt (expr.Binary Less (expr.SymbolicVar ''var1'') (expr.Const (const.Nat 4)))
    (Comb
      (stmt.AssignSt
        (common_var.Symbolic ''var1'')( expr.Binary binary_op.Sum (expr.SymbolicVar ''var1'') (expr.Const (const.Nat 2))))
      Blank)))
  (stmt.AssignSt
        (common_var.Symbolic ''var1'')( expr.Binary binary_op.Sum (expr.SymbolicVar ''var1'') (expr.Const (const.Nat 2))))"

lemma "(statement_result.Continue,test_ms4)\<turnstile> test_statement6 \<longrightarrow> (statement_result.Continue,test_ms7)"
  apply (auto simp add: test_statement6_def
                test_ms4_def test_process_state4_def test_program_state4_def
                test_ms7_def test_process_state7_def test_program_state7_def)
  apply (rule Comb)
  apply (rule Comb)
   apply (rule Comb)
    apply (rule AssignS)
     apply (rule BinOp)
       apply (rule Var)
       apply (auto)
    apply (rule Const)
    apply (auto)
   apply (rule Blank)
  apply (auto)

  apply (rule LoopT)
   apply (rule BinOp)
       apply (rule Var)
       apply (auto)
     apply (rule Const)
      apply (auto)
    apply (rule Comb)
  apply (rule AssignS)
     apply (rule BinOp)
       apply (rule Var)
       apply (auto)
    apply (rule Const)
     apply (auto)
    apply (rule Blank)

  apply (rule LoopF)
    apply (rule BinOp)
       apply (rule Var)
       apply (auto)
     apply (rule Const)
    apply (auto)
  apply (rule AssignS)
     apply (rule BinOp)
       apply (rule Var)
       apply (auto)
    apply (rule Const)
   apply (auto)
  done

end


header {* \subsection{The view-partitioning equivalence relation}*}

theory Step_vpeq
  imports Step Step_invariants
begin

text {* The view consists of
 \begin{enumerate}
 \item View of object values.
 \item View of subject-subject dynamic policy. The threads can discover the policy
       at runtime, e.g. by calling ipc() and observing success or failure.
 \item View of subject-object dynamic policy. The threads can discover the policy
       at runtime, e.g. by calling open() and observing success or failure.
 \end{enumerate}
*}

definition vpeq_obj :: "partition_id_t \<Rightarrow> state_t \<Rightarrow> state_t \<Rightarrow> bool" where
  "vpeq_obj u s t \<equiv> \<forall> obj_id . Policy.sp_spec_subj_obj u obj_id READ \<longrightarrow> (obj s) obj_id = (obj t) obj_id"

definition vpeq_subj_subj :: "partition_id_t \<Rightarrow> state_t \<Rightarrow> state_t \<Rightarrow> bool" where
  "vpeq_subj_subj u s t \<equiv>
    \<forall> v . ((Policy.sp_spec_subj_subj u v \<longrightarrow> sp_impl_subj_subj s u v = sp_impl_subj_subj t u v)
           \<and> (Policy.sp_spec_subj_subj v u \<longrightarrow> sp_impl_subj_subj s v u = sp_impl_subj_subj t v u))"

definition vpeq_subj_obj :: "partition_id_t \<Rightarrow> state_t \<Rightarrow> state_t \<Rightarrow> bool" where
  "vpeq_subj_obj u s t \<equiv>
   \<forall> ob m p1 .
     (Policy.sp_spec_subj_obj u ob m \<longrightarrow> sp_impl_subj_obj s u ob m = sp_impl_subj_obj t u ob m)
   \<and> (Policy.sp_spec_subj_obj p1 ob PROVIDE \<and> (Policy.sp_spec_subj_obj u ob READ \<or> Policy.sp_spec_subj_obj u ob WRITE) \<longrightarrow>
         sp_impl_subj_obj s p1 ob PROVIDE = sp_impl_subj_obj t p1 ob PROVIDE)"

definition vpeq_local :: "partition_id_t \<Rightarrow> state_t \<Rightarrow> state_t \<Rightarrow> bool" where
 "vpeq_local u s t \<equiv>
    \<forall> tid . (partition tid) = u \<longrightarrow> (thread s tid) = (thread t tid)"

definition "vpeq u s t \<equiv>
   vpeq_obj u s t \<and> vpeq_subj_subj u s t \<and> vpeq_subj_obj u s t \<and> vpeq_local u s t"

subsubsection {* Elementary properties *}

lemma vpeq_rel:
  shows vpeq_refl: "vpeq u s s"
    and vpeq_sym [sym]: "vpeq u s t \<Longrightarrow> vpeq u t s"
    and vpeq_trans [trans]: "\<lbrakk> vpeq u s1 s2 ; vpeq u s2 s3 \<rbrakk> \<Longrightarrow> vpeq u s1 s3"
  unfolding vpeq_def vpeq_obj_def vpeq_subj_subj_def vpeq_subj_obj_def vpeq_local_def
    by auto

text {* Auxiliary equivalence relation. *}

lemma set_object_value_ign:
  assumes eq_obs: "~ Policy.sp_spec_subj_obj u x READ"
    shows "vpeq u s (set_object_value x y s)"
proof -
  from assms show ?thesis
    unfolding vpeq_def vpeq_obj_def vpeq_subj_subj_def vpeq_subj_obj_def set_object_value_def
              vpeq_local_def
    by auto
qed

text {* Context-switch and fetch operations are also consistent with vpeq
        and locally respect everything. *}

theorem cswitch_consistency_and_respect:
  fixes u :: partition_id_t
    and s :: state_t
    and new_current :: thread_id_t
  assumes "atomic_step_invariant s"
  shows "vpeq u s (s \<lparr> current := new_current \<rparr>)"
proof -
  show ?thesis
    unfolding vpeq_def vpeq_obj_def vpeq_subj_subj_def vpeq_subj_obj_def vpeq_local_def
    by auto
qed

end


section \<open>Examples\<close>

subsection \<open>Misc\<close>

theory Example_Misc
  imports
    Main
    "HOL-Library.Extended"
    "../state_monad/State_Main"
begin

paragraph \<open>Lists\<close>

fun min_list :: "'a::ord list \<Rightarrow> 'a" where
  "min_list (x # xs) = (case xs of [] \<Rightarrow> x | _ \<Rightarrow> min x (min_list xs))"

lemma min_list_fold:
  "min_list (x # xs) = fold min xs x" for x :: "'a :: linorder"
  by (induction xs arbitrary: x; auto simp: fold_min_commute[symmetric]; metis min.commute)

(* FIXME mv List *)
lemma induct_list012:
  "\<lbrakk>P []; \<And>x. P [x]; \<And>x y zs. P (y # zs) \<Longrightarrow> P (x # y # zs)\<rbrakk> \<Longrightarrow> P xs"
by induction_schema (pat_completeness, lexicographic_order)

lemma min_list_Min: "xs \<noteq> [] \<Longrightarrow> min_list xs = Min (set xs)"
by (induction xs rule: induct_list012)(auto)

paragraph \<open>Extended Data Type\<close>

(* TODO: Move to distribution! *)
lemma Pinf_add_right[simp]:
  "\<infinity> + x = \<infinity>"
  by (cases x; simp)

paragraph \<open>Syntax\<close>

bundle app_syntax begin

notation App (infixl "$" 999)
notation Wrap ("\<llangle>_\<rrangle>")

end

(*
paragraph \<open>Code Setup\<close>

definition map1\<^sub>T' where
  "map1\<^sub>T' f xs \<equiv> \<langle>rec_list \<langle>[]\<rangle> (\<lambda>x xs a. \<langle>\<lambda>y. \<langle>\<lambda>ys. \<langle>y#ys\<rangle>\<rangle>\<rangle> . (f x) . a)\<rangle> . \<langle>xs\<rangle> "

lemma map1\<^sub>T_map1\<^sub>T':
  "map1\<^sub>T = \<langle>\<lambda>f. \<langle>\<lambda>xs. map1\<^sub>T' f xs\<rangle>\<rangle>"
  unfolding map1\<^sub>T_def map1\<^sub>T'_def ..

lemmas [code] =
  mem_defs.checkmem'_def

lemmas [code_unfold] =
  map\<^sub>T_def
  map1\<^sub>T_map1\<^sub>T'

paragraph \<open>Simplifying monad expressions\<close>

lemma app_return_right:
  "f . \<langle>g\<rangle> = do {f \<leftarrow> f; f g}"
  unfolding fun_app_lifted_def left_identity ..

lemma app_return_left:
  "\<langle>f\<rangle> . g = g \<bind> f"
  unfolding fun_app_lifted_def left_identity ..

lemma get_return:
  "(do {m \<leftarrow> get; \<langle>f m\<rangle>}) = State (\<lambda> mem. (f mem, mem))"
  unfolding get_def bind_def return_def by simp

lemma get_put:
  "do {m \<leftarrow> get; put (f m)} = State (\<lambda> mem. ((), f mem))"
  unfolding get_def put_def bind_def return_def by simp

lemma bind_return_assoc:
  "(do {
       x \<leftarrow> a;
       \<langle>f x\<rangle>
     }) \<bind>
    b =
    do {
      x \<leftarrow> a;
      b (f x)
    }"
  by (auto split: prod.split simp add: bind_def return_def)

lemma app_lifted_return_assoc:
  "(do {
       x \<leftarrow> a;
       \<langle>f x\<rangle>
     }) .
    b =
    do {
      x \<leftarrow> a;
      b \<bind> f x
    }"
  unfolding fun_app_lifted_def bind_return_assoc ..

(* There could be a simpproc for this pattern *)
lemma bind_return_assoc2:
  "(do {
       x \<leftarrow> a;
       y \<leftarrow> b;
       \<langle>f x y\<rangle>
     }) \<bind>
    c =
    do {
      x \<leftarrow> a;
      y \<leftarrow> b;
      c (f x y)
    }"
  by (auto split: prod.split simp add: bind_def return_def)

lemma bind_return_assoc3:
  "(do {
       x \<leftarrow> a;
       y \<leftarrow> b;
       z \<leftarrow> c;
       \<langle>f x y z\<rangle>
     }) \<bind>
    d =
    do {
      x \<leftarrow> a;
      y \<leftarrow> b;
      z \<leftarrow> c;
      d (f x y z)
    }"
  by (auto split: prod.split simp add: bind_def return_def)

lemma if\<^sub>T_return:
  "if\<^sub>T \<langle>b\<rangle> x\<^sub>T y\<^sub>T \<equiv> if b then x\<^sub>T else y\<^sub>T"
  unfolding if\<^sub>T_def return_def bind_def by simp

(* Would it be a good idea to just unfold fun_app_lifted? *)
lemmas monad_unfolds =
  app_return_right app_return_left Monad.left_identity Monad.right_identity
  app_lifted_return_assoc bind_return_assoc bind_return_assoc2 bind_return_assoc3
  get_return get_put
  map1\<^sub>T_map1\<^sub>T'
  if\<^sub>T_return
*)
end