(*  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 "MainRLT"
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>

(* the type "node" has a wide definition *)

(* *)
definition "isNode \<equiv> \<lambda>p. \<exists>f x k. p = (f :: nat => 'b + nat, x ::'a + nat) \<and> f k = Inr 0"

lemma isNode_alt: "isNode p \<longleftrightarrow> (\<exists>k. fst p k = Inr 0)"
unfolding isNode_def by (metis eq_fst_iff)

find_theorems name: node name: type_def
lemmas type_definition_isNode = node.type_definition_node[unfolded Node_def isNode_def[symmetric]]

(* *)
lemma isNode_aux: "isNode = isNode" ..
local_setup \<open>RLTHM @{binding isNode_rlt_neper_param} @{thm isNode_aux}\<close>
thm isNode_rlt_neper_param

(* *)
local_setup \<open>RLTHM @{binding isNode_rlt_alt} @{thm isNode_alt}\<close>
thm isNode_rlt_alt

(* *)
lemma isNode_Node: "isNode = (\<lambda>x. x \<in> Old_Datatype.Node)"
unfolding isNode_def Old_Datatype.Node_def by auto
local_setup \<open>RLTHM @{binding isNode_rlt_Node_rlt} @{thm isNode_Node}\<close>
thm isNode_rlt_Node_rlt
(* *)

(* *)
lemma isNode_rlt_simp:
"neper R1 \<Longrightarrow> neper R2 \<Longrightarrow> rel_prod (rel_fun (=) (rel_sum R1 (=))) (rel_sum R2 (=)) p p
\<Longrightarrow> isNode_rlt R1 R2 p = isNode p"
unfolding isNode_rlt_alt fun_eq_iff isNode_alt apply (simp add: sum.rrel_neper rlt_eq rlt_param)
by (smt (verit, best) rel_sum.cases rel_sum_simps(4) sum.simps(4))

(* *)

lemma bij_upto_node:
assumes R: "neper R1" "neper R2"
shows
"bij_upto
 (restr (rel_prod (rel_fun (=) (rel_sum R1 (=))) (rel_sum R2 (=))) isNode)
 (restr (rel_prod (rel_fun (=) (rel_sum R1 (=))) (rel_sum R2 (=))) (isNode_rlt R1 R2)) id"
apply(rule bij_upto_id')
  subgoal apply(rule neper_restr)
    subgoal by (simp add: R prod.rrel_neper sum.rrel_neper)
    subgoal apply(rule exI[of _ "(\<lambda>x. Inr 0, Inr 0)"])
    unfolding isNode_alt by auto .
  subgoal unfolding restr_def fun_eq_iff apply(intro allI antisym)
    subgoal for x xa apply(rule le_boolI) apply(subst isNode_rlt_simp[OF R])
      subgoal using R
        apply(subgoal_tac "neper (rel_prod (rel_fun (=) (rel_sum R1 (=))) (rel_sum R2 (=)))")
        unfolding neper_def per_def apply blast
        unfolding neper_def[symmetric] per_def[symmetric]
        by (simp add: prod.rrel_neper sum.rrel_neper)
      subgoal apply(subst isNode_rlt_simp[OF R])
        subgoal using R apply(subgoal_tac "neper (rel_prod (rel_fun (=) (rel_sum R1 (=))) (rel_sum R2 (=)))")
          unfolding neper_def per_def apply blast
          unfolding neper_def[symmetric] per_def[symmetric]
          by (simp add: prod.rrel_neper sum.rrel_neper)
        subgoal by simp . .
    subgoal for x xa apply(rule le_boolI) apply(subst isNode_rlt_simp[OF R, symmetric])
      subgoal using R
        apply(subgoal_tac "neper (rel_prod (rel_fun (=) (rel_sum R1 (=))) (rel_sum R2 (=)))")
        unfolding neper_def per_def apply blast
        unfolding neper_def[symmetric] per_def[symmetric]
        by (simp add: prod.rrel_neper sum.rrel_neper)
      subgoal apply(subst isNode_rlt_simp[OF R, symmetric])
        subgoal using R apply(subgoal_tac "neper (rel_prod (rel_fun (=) (rel_sum R1 (=))) (rel_sum R2 (=)))")
          unfolding neper_def per_def apply blast
          unfolding neper_def[symmetric] per_def[symmetric]
          by (simp add: prod.rrel_neper sum.rrel_neper)
        subgoal by simp . . . .

definition rel_node where
"rel_node R1 R2 = inv_imagep (rel_prod (rel_fun (=) (rel_sum R2 (=))) (rel_sum R1 (=))) Rep_Node"

thm bij_upto_transportFromRaw[OF type_definition_isNode rel_node_def bij_upto_node]

thm isNode_rlt_Node_rlt

lemma node_auxx:
assumes R: "neper R1" "neper R2"
and p: "rel_prod (rel_fun (=) (rel_sum R1 (=))) (rel_sum R2 (=)) p p"
shows "isNode_rlt R1 R2 p \<longleftrightarrow>
       member_rlt (rel_prod (rel_fun (=) (rel_sum R1 (=))) (rel_sum R2 (=)))
         p
         (Node_rlt R1 R2)"
unfolding isNode_rlt_Node_rlt[OF R(2,1), unfolded rel_fun_def, rule_format, OF
p[unfolded rel_fun_def]] using R by (simp add: rel_fun_eq_rel)

lemma node_aux:
assumes R: "neper R1" "neper R2"
shows
"(restr (rel_prod (rel_fun (=) (rel_sum R1 (=))) (rel_sum R2 (=)))
   (\<lambda>x. member_rlt (rel_prod (rel_fun (=) (rel_sum R1 (=))) (rel_sum R2 (=))) x (Node_rlt R1 R2)))
=
(restr (rel_prod (rel_fun (=) (rel_sum R1 (=))) (rel_sum R2 (=)))
   (isNode_rlt R1 R2))
"
unfolding restr_def fun_eq_iff using node_auxx[OF R]
apply(intro allI conjI antisym le_boolI)
  subgoal by simp
  subgoal apply(subst node_auxx[OF R])
  by auto (metis R mem_Collect_eq neper_classes_eq neper_eq neper_rel_fun prod.rrel_neper
    sum.rrel_neper)
  subgoal apply(subst node_auxx[OF R])
  by auto (metis R mem_Collect_eq neper_classes_eq neper_eq neper_rel_fun prod.rrel_neper
    sum.rrel_neper)
  subgoal by simp
  subgoal apply(subst node_auxx[OF R, symmetric]) apply auto
  apply(subgoal_tac "neper (rel_prod (rel_fun (=) (rel_sum R1 (=))) (rel_sum R2 (=)))")
    unfolding neper_def per_def apply blast
    unfolding neper_def[symmetric] per_def[symmetric]
    using R by (simp add: prod.rrel_neper sum.rrel_neper)
  subgoal apply(subst node_auxx[OF R, symmetric]) apply auto
  apply(subgoal_tac "neper (rel_prod (rel_fun (=) (rel_sum R1 (=))) (rel_sum R2 (=)))")
    unfolding neper_def per_def apply blast
    unfolding neper_def[symmetric] per_def[symmetric]
    using R by (simp add: prod.rrel_neper sum.rrel_neper) .

wide_typedef Old_Datatype.node rel: rel_node rep: "\<lambda>R1 R2. Rep_Node"
  subgoal for R1 R2 unfolding rel_node_def
  apply(rule neper_inv_imagep[of _ _ "Abs_Node (\<lambda>x. Inr 0, Inr 0)"])
     subgoal by (simp add: prod.rrel_neper sum.rrel_neper)
     subgoal unfolding rel_fun_def by (simp add: Abs_Node_inverse Node_K0_I) .
  subgoal unfolding rel_node_def unfolding inv_imagep_def fun_eq_iff
    by (simp add: Rep_Node_inject prod.rel_eq sum.rel_eq)
  subgoal for R1 R2 using bij_upto_transportFromRaw[OF type_definition_isNode rel_node_def bij_upto_node,simped]
     unfolding node_aux[of] .
  subgoal .. .

end


theory Syntactic_Criteria
  imports Compositionality
begin

context PL_Indis
begin

(* Table: Compositionality of during-execution noninterferences *)

lemma noWhile[intro]:
  "noWhile (Atm atm)"
  "noWhile c1 \<Longrightarrow> noWhile c2 \<Longrightarrow> noWhile (Seq c1 c2)"
  "noWhile c1 \<Longrightarrow> noWhile c2 \<Longrightarrow> noWhile (If tst c1 c2)"
  "noWhile c1 \<Longrightarrow> noWhile c2 \<Longrightarrow> noWhile (Par c1 c2)"
  by auto

lemma discr[intro]:
  "presAtm atm \<Longrightarrow> discr (Atm atm)"
  "discr c1 \<Longrightarrow> discr c2 \<Longrightarrow> discr (Seq c1 c2)"
  "discr c1 \<Longrightarrow> discr c2 \<Longrightarrow> discr (If tst c1 c2)"
  "discr c \<Longrightarrow> discr (While tst c)"
  "discr c1 \<Longrightarrow> discr c2 \<Longrightarrow> discr (Par c1 c2)"
  by auto

lemma siso[intro]:
  "compatAtm atm \<Longrightarrow> siso (Atm atm)"
  "siso c1 \<Longrightarrow> siso c2 \<Longrightarrow> siso (Seq c1 c2)"
  "compatTst tst \<Longrightarrow> siso c1 \<Longrightarrow> siso c2 \<Longrightarrow> siso (If tst c1 c2)"
  "compatTst tst \<Longrightarrow> siso c \<Longrightarrow> siso (While tst c)"
  "siso c1 \<Longrightarrow> siso c2 \<Longrightarrow> siso (Par c1 c2)"
  by auto

lemma Sbis[intro]:
  "compatAtm atm \<Longrightarrow> Atm atm \<approx>s Atm atm"
  "c1 \<approx>s c1 \<Longrightarrow> c2 \<approx>s c2 \<Longrightarrow> Seq c1 c2 \<approx>s Seq c1 c2"
  "compatTst tst \<Longrightarrow> c1 \<approx>s c1 \<Longrightarrow> c2 \<approx>s c2 \<Longrightarrow> If tst c1 c2 \<approx>s If tst c1 c2"
  "compatTst tst \<Longrightarrow> c \<approx>s c \<Longrightarrow> While tst c \<approx>s While tst c"
  "c1 \<approx>s c1 \<Longrightarrow> c2 \<approx>s c2 \<Longrightarrow> Par c1 c2 \<approx>s Par c1 c2"
  by auto

lemma ZObisT[intro]:
  "compatAtm atm \<Longrightarrow> Atm atm \<approx>01T Atm atm"
  "c1 \<approx>01T c1 \<Longrightarrow> c2 \<approx>01T c2 \<Longrightarrow> Seq c1 c2 \<approx>01T Seq c1 c2"
  "compatTst tst \<Longrightarrow> c1 \<approx>01T c1 \<Longrightarrow> c2 \<approx>01T c2 \<Longrightarrow> If tst c1 c2 \<approx>01T If tst c1 c2"
  "compatTst tst \<Longrightarrow> c \<approx>01T c \<Longrightarrow> While tst c \<approx>01T While tst c"
  "c1 \<approx>01T c1 \<Longrightarrow> c2 \<approx>01T c2 \<Longrightarrow> Par c1 c2 \<approx>01T Par c1 c2"
  by auto

lemma BisT[intro]:
  "compatAtm atm \<Longrightarrow> Atm atm \<approx>T Atm atm"
  "c1 \<approx>T c1 \<Longrightarrow> c2 \<approx>T c2 \<Longrightarrow> Seq c1 c2 \<approx>T Seq c1 c2"
  "compatTst tst \<Longrightarrow> c1 \<approx>T c1 \<Longrightarrow> c2 \<approx>T c2 \<Longrightarrow> If tst c1 c2 \<approx>T If tst c1 c2"
  "compatTst tst \<Longrightarrow> c \<approx>T c \<Longrightarrow> While tst c \<approx>T While tst c"
  "c1 \<approx>T c1 \<Longrightarrow> c2 \<approx>T c2 \<Longrightarrow> Par c1 c2 \<approx>T Par c1 c2"
  by auto

lemma WbisT[intro]:
  "compatAtm atm \<Longrightarrow> Atm atm \<approx>wT Atm atm"
  "c1 \<approx>wT c1 \<Longrightarrow> c2 \<approx>wT c2 \<Longrightarrow> Seq c1 c2 \<approx>wT Seq c1 c2"
  "compatTst tst \<Longrightarrow> c1 \<approx>wT c1 \<Longrightarrow> c2 \<approx>wT c2 \<Longrightarrow> If tst c1 c2 \<approx>wT If tst c1 c2"
  "compatTst tst \<Longrightarrow> c \<approx>wT c \<Longrightarrow> While tst c \<approx>wT While tst c"
  "c1 \<approx>wT c1 \<Longrightarrow> c2 \<approx>wT c2 \<Longrightarrow> Par c1 c2 \<approx>wT Par c1 c2"
  by auto

lemma ZObis[intro]:
  "compatAtm atm \<Longrightarrow> Atm atm \<approx>01 Atm atm"
  "c1 \<approx>01T c1 \<Longrightarrow> c2 \<approx>01 c2 \<Longrightarrow> Seq c1 c2 \<approx>01 Seq c1 c2"
  "c1 \<approx>01 c1 \<Longrightarrow> discr c2 \<Longrightarrow> Seq c1 c2 \<approx>01 Seq c1 c2"
  "compatTst tst \<Longrightarrow> c1 \<approx>01 c1 \<Longrightarrow> c2 \<approx>01 c2 \<Longrightarrow> If tst c1 c2 \<approx>01 If tst c1 c2"
  "c1 \<approx>01 c1 \<Longrightarrow> c2 \<approx>01 c2 \<Longrightarrow> Par c1 c2 \<approx>01 Par c1 c2"
  by auto

lemma Wbis[intro]:
  "compatAtm atm \<Longrightarrow> Atm atm \<approx>w Atm atm"
  "c1 \<approx>wT c1 \<Longrightarrow> c2 \<approx>w c2 \<Longrightarrow> Seq c1 c2 \<approx>w Seq c1 c2"
  "c1 \<approx>w c1 \<Longrightarrow> discr c2 \<Longrightarrow> Seq c1 c2 \<approx>w Seq c1 c2"
  "compatTst tst \<Longrightarrow> c1 \<approx>w c1 \<Longrightarrow> c2 \<approx>w c2 \<Longrightarrow> If tst c1 c2 \<approx>w If tst c1 c2"
  "c1 \<approx>w c1 \<Longrightarrow> c2 \<approx>w c2 \<Longrightarrow> Par c1 c2 \<approx>w Par c1 c2"
  by auto

(* Graph: The cleaned-up graph of implcations between security notions *)

lemma discr_noWhile_WbisT[intro]: "discr c \<Longrightarrow> noWhile c \<Longrightarrow> c \<approx>wT c"
  by auto

lemma siso_ZObis[intro]: "siso c \<Longrightarrow> c \<approx>01 c"
  by auto

lemma WbisT_Wbis[intro]: "c \<approx>wT c \<Longrightarrow> c \<approx>w c"
  by auto

lemma ZObis_Wbis[intro]: "c \<approx>01 c \<Longrightarrow> c \<approx>w c"
  by auto

lemma discr_BisT[intro]: "discr c \<Longrightarrow> c \<approx>T c"
  by auto

lemma WbisT_BisT[intro]: "c \<approx>wT c \<Longrightarrow> c \<approx>T c"
  using bis_incl by auto

lemma ZObisT_ZObis[intro]: "c \<approx>01T c \<Longrightarrow> c \<approx>01 c"
  by auto

lemma siso_ZObisT[intro]: "siso c \<Longrightarrow> c \<approx>01T c"
  by auto

primrec SC_discr where
  "SC_discr (Atm atm)      \<longleftrightarrow> presAtm atm"
| "SC_discr (Seq c1 c2)    \<longleftrightarrow> SC_discr c1 \<and> SC_discr c2"
| "SC_discr (If tst c1 c2) \<longleftrightarrow> SC_discr c1 \<and> SC_discr c2"
| "SC_discr (While tst c)  \<longleftrightarrow> SC_discr c"
| "SC_discr (Par c1 c2)    \<longleftrightarrow> SC_discr c1 \<and> SC_discr c2"

primrec SC_siso where
  "SC_siso (Atm atm)      \<longleftrightarrow> compatAtm atm"
| "SC_siso (Seq c1 c2)    \<longleftrightarrow> SC_siso c1 \<and> SC_siso c2"
| "SC_siso (If tst c1 c2) \<longleftrightarrow> compatTst tst \<and> SC_siso c1 \<and> SC_siso c2"
| "SC_siso (While tst c)  \<longleftrightarrow> compatTst tst \<and> SC_siso c"
| "SC_siso (Par c1 c2)    \<longleftrightarrow> SC_siso c1 \<and> SC_siso c2"

primrec SC_WbisT where
  "SC_WbisT (Atm atm)      \<longleftrightarrow> compatAtm atm"
| "SC_WbisT (Seq c1 c2)    \<longleftrightarrow> (SC_WbisT c1 \<and> SC_WbisT c2) \<or>
                              (noWhile (Seq c1 c2) \<and> SC_discr (Seq c1 c2)) \<or>
                              SC_siso (Seq c1 c2)"
| "SC_WbisT (If tst c1 c2) \<longleftrightarrow> (if compatTst tst
                              then (SC_WbisT c1 \<and> SC_WbisT c2)
                              else ((noWhile (If tst c1 c2) \<and> SC_discr (If tst c1 c2)) \<or>
                                    SC_siso (If tst c1 c2)))"
| "SC_WbisT (While tst c)  \<longleftrightarrow> (if compatTst tst
                              then SC_WbisT c
                              else ((noWhile (While tst c) \<and> SC_discr (While tst c)) \<or>
                                    SC_siso (While tst c)))"
| "SC_WbisT (Par c1 c2)    \<longleftrightarrow> (SC_WbisT c1 \<and> SC_WbisT c2) \<or>
                              (noWhile (Par c1 c2) \<and> SC_discr (Par c1 c2)) \<or>
                              SC_siso (Par c1 c2)"

primrec SC_ZObis where
  "SC_ZObis (Atm atm)      \<longleftrightarrow> compatAtm atm"
| "SC_ZObis (Seq c1 c2)    \<longleftrightarrow> (SC_siso c1 \<and> SC_ZObis c2) \<or>
                              (SC_ZObis c1 \<and> SC_discr c2) \<or>
                              SC_discr (Seq c1 c2) \<or>
                              SC_siso (Seq c1 c2)"
| "SC_ZObis (If tst c1 c2) \<longleftrightarrow> (if compatTst tst
                              then (SC_ZObis c1 \<and> SC_ZObis c2)
                              else (SC_discr (If tst c1 c2) \<or>
                                    SC_siso (If tst c1 c2)))"
| "SC_ZObis (While tst c)  \<longleftrightarrow> SC_discr (While tst c) \<or>
                              SC_siso (While tst c)"
| "SC_ZObis (Par c1 c2)    \<longleftrightarrow> (SC_ZObis c1 \<and> SC_ZObis c2) \<or>
                              SC_discr (Par c1 c2) \<or>
                              SC_siso (Par c1 c2)"

primrec SC_Wbis where
  "SC_Wbis (Atm atm)      \<longleftrightarrow> compatAtm atm"
| "SC_Wbis (Seq c1 c2)    \<longleftrightarrow> (SC_WbisT c1 \<and> SC_Wbis c2) \<or>
                             (SC_Wbis c1 \<and> SC_discr c2) \<or>
                             SC_ZObis (Seq c1 c2) \<or>
                             SC_WbisT (Seq c1 c2)"
| "SC_Wbis (If tst c1 c2) \<longleftrightarrow> (if compatTst tst
                             then (SC_Wbis c1 \<and> SC_Wbis c2)
                             else (SC_ZObis (If tst c1 c2) \<or>
                                   SC_WbisT (If tst c1 c2)))"
| "SC_Wbis (While tst c)  \<longleftrightarrow> SC_ZObis (While tst c) \<or>
                             SC_WbisT (While tst c)"
| "SC_Wbis (Par c1 c2)    \<longleftrightarrow> (SC_Wbis c1 \<and> SC_Wbis c2) \<or>
                             SC_ZObis (Par c1 c2) \<or>
                             SC_WbisT (Par c1 c2)"

primrec SC_BisT where
  "SC_BisT (Atm atm)      \<longleftrightarrow> compatAtm atm"
| "SC_BisT (Seq c1 c2)    \<longleftrightarrow> (SC_BisT c1 \<and> SC_BisT c2) \<or>
                             SC_discr (Seq c1 c2) \<or>
                             SC_WbisT (Seq c1 c2)"
| "SC_BisT (If tst c1 c2) \<longleftrightarrow> (if compatTst tst
                             then (SC_BisT c1 \<and> SC_BisT c2)
                             else (SC_discr (If tst c1 c2) \<or>
                                   SC_WbisT (If tst c1 c2)))"
| "SC_BisT (While tst c)  \<longleftrightarrow> (if compatTst tst
                             then SC_BisT c
                             else (SC_discr (While tst c) \<or>
                                   SC_WbisT (While tst c)))"
| "SC_BisT (Par c1 c2)    \<longleftrightarrow> (SC_BisT c1 \<and> SC_BisT c2) \<or>
                             SC_discr (Par c1 c2) \<or>
                             SC_WbisT (Par c1 c2)"

theorem SC_discr[intro]: "SC_discr c \<Longrightarrow> discr c"
  by (induct c) auto

theorem SC_siso[intro]: "SC_siso c \<Longrightarrow> siso c"
  by (induct c) auto

theorem SC_siso_imp_SC_WbisT[intro]: "SC_siso c \<Longrightarrow> SC_WbisT c"
  by (induct c) auto

theorem SC_discr_imp_SC_WbisT[intro]: "noWhile c \<Longrightarrow> SC_discr c \<Longrightarrow> SC_WbisT c"
  by (induct c) (auto simp: presAtm_compatAtm)

theorem SC_WbisT[intro]: "SC_WbisT c \<Longrightarrow> c \<approx>wT c"
  by (induct c) (auto split: if_split_asm)

theorem SC_discr_imp_SC_ZObis[intro]: "SC_discr c \<Longrightarrow> SC_ZObis c"
  by (induct c) (auto simp: presAtm_compatAtm)

theorem SC_siso_imp_SC_ZObis[intro]: "SC_siso c \<Longrightarrow> SC_ZObis c"
  by (induct c) auto

theorem SC_ZObis[intro]: "SC_ZObis c \<Longrightarrow> c \<approx>01 c"
  by (induct c) (auto split: if_split_asm intro: discr_ZObis)

theorem SC_ZObis_imp_SC_Wbis[intro]: "SC_ZObis c \<Longrightarrow> SC_Wbis c"
  by (induct c) auto

theorem SC_WbisT_imp_SC_Wbis[intro]: "SC_WbisT c \<Longrightarrow> SC_Wbis c"
  by (induct c) auto

theorem SC_Wbis[intro]: "SC_Wbis c \<Longrightarrow> c \<approx>w c"
  by (induct c) (auto split: if_split_asm intro: discr_ZObis)

theorem SC_discr_imp_SC_BisT[intro]: "SC_discr c \<Longrightarrow> SC_BisT c"
  by (induct c) (auto simp: presAtm_compatAtm)

theorem SC_WbisT_imp_SC_BisT[intro]: "SC_WbisT c \<Longrightarrow> SC_BisT c"
  by (induct c) auto

theorem SC_ZObis_imp_SC_BisT[intro]: "SC_ZObis c \<Longrightarrow> SC_BisT c"
  by (induct c) auto

theorem SC_Wbis_imp_SC_BisT[intro]: "SC_Wbis c \<Longrightarrow> SC_BisT c"
  by (induct c) (auto split: if_split_asm)

theorem SC_BisT[intro]: "SC_BisT c \<Longrightarrow> c \<approx>T c"
  by (induct c) (auto split: if_split_asm)

(* reductions *)

theorem SC_WbisT_While: "SC_WbisT (While tst c) \<longleftrightarrow> SC_WbisT c \<and> compatTst tst"
  by simp

theorem SC_ZObis_While: "SC_ZObis (While tst c) \<longleftrightarrow> (compatTst tst \<and> SC_siso c) \<or> SC_discr c"
  by auto

theorem SC_ZObis_If: "SC_ZObis (If tst c1 c2) \<longleftrightarrow> (if compatTst tst then SC_ZObis c1 \<and> SC_ZObis c2 else SC_discr c1 \<and> SC_discr c2)"
  by simp

theorem SC_WbisT_Seq: "SC_WbisT (Seq c1 c2)  \<longleftrightarrow> (SC_WbisT c1 \<and> SC_WbisT c2)"
  by auto

theorem SC_ZObis_Seq: "SC_ZObis (Seq c1 c2) \<longleftrightarrow> (SC_siso c1 \<and> SC_ZObis c2) \<or>
                              (SC_ZObis c1 \<and> SC_discr c2)"
  by auto

theorem SC_Wbis_Seq: "SC_Wbis (Seq c1 c2) \<longleftrightarrow> (SC_WbisT c1 \<and> SC_Wbis c2) \<or> (SC_Wbis c1 \<and> SC_discr c2)"
  by auto

theorem SC_BisT_Par:
  "SC_BisT (Par c1 c2)    \<longleftrightarrow> (SC_BisT c1 \<and> SC_BisT c2)"
  by auto

end

end


theory "HeapToEnv"
  imports "DistinctVars" "Nominal-Utils" "FMap-Nominal-HOLCF"
begin

default_sort type

subsubsection {* Conversion from heaps to environments *}

function heapToEnv :: "('var \<times> 'exp) list \<Rightarrow> ('exp \<Rightarrow> 'value) \<Rightarrow> 'var f\<rightharpoonup> 'value"
where
  "heapToEnv [] _ = fempty"
| "heapToEnv ((x,e)#h) eval = (heapToEnv h eval) (x f\<mapsto> eval e)"
by (pat_completeness, auto)
termination by lexicographic_order

lemma cont2cont_heapToEnv[simp, cont2cont]:
  "(\<And> e . e \<in> snd ` set h \<Longrightarrow> cont (\<lambda>\<rho>. eval \<rho> e)) \<Longrightarrow> cont (\<lambda> \<rho>. heapToEnv h (eval \<rho>))"
  by(induct h, auto)

lemma heapToEnv_eqvt[eqvt]:
  "\<pi> \<bullet> heapToEnv h eval = heapToEnv (\<pi> \<bullet> h) (\<pi> \<bullet> eval)"
  by (induct h eval rule:heapToEnv.induct, auto simp add: fmap_upd_eqvt)

lemma heapToEnv_fdom[simp]:"fdom (heapToEnv h eval) = heapVars h"
  by (induct h eval rule:heapToEnv.induct, auto)

lemma heapToEnv_cong[fundef_cong]:
  "\<lbrakk> heap1 = heap2 ;  (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> eval1 e = eval2 e) \<rbrakk>
    \<Longrightarrow>  heapToEnv heap1 eval1 = heapToEnv heap2 eval2"
 by (induct heap2 eval2 arbitrary:heap1 rule:heapToEnv.induct, auto)

lemma lookupHeapToEnv:
  assumes "v \<in> heapVars h"
  shows "(heapToEnv h f) f! v = f (the (map_of h v))"
  using assms
  apply (induct h)
  apply simp
  apply (case_tac a)
  apply auto
  done

lemma lookupHeapToEnvNotAppend[simp]:
  assumes "x \<notin> heapVars \<Gamma>"
  shows "heapToEnv (\<Gamma>@h) f f! x = heapToEnv h f f! x"
  using assms by (induct \<Gamma>, auto)

lemma heapToEnv_remove_Cons_fmap_expand:
  "finite S \<Longrightarrow> x \<notin> S \<Longrightarrow> heapToEnv ((x, e) # \<Gamma>) eval\<^bsub>[S]\<^esub> = heapToEnv \<Gamma> eval\<^bsub>[S]\<^esub>"
  apply (rule fmap_eqI)
  apply simp
  apply (subgoal_tac "xa \<noteq> x")
  apply (case_tac "xa \<in> heapVars \<Gamma>")
  apply simp
  apply simp
  apply auto
  done

lemma heapToEnv_mono:
  "finite d1 \<Longrightarrow>
   d1 = d2 \<Longrightarrow>
   x \<notin> heapVars \<Gamma> \<Longrightarrow>
  heapToEnv \<Gamma> eval\<^bsub>[d1]\<^esub> \<sqsubseteq> heapToEnv ((x, e) # \<Gamma>) eval\<^bsub>[d2]\<^esub>"
   apply (erule subst)
   apply (rule fmap_expand_belowI)
   apply simp
   apply (rule eq_imp_below)
   apply simp
   apply (metis the_lookup_fmap_upd_other[symmetric])
   done

subsubsection {* Reordering lemmas *}

lemma heapToEnv_reorder_head:
  assumes "x \<noteq> y"
  shows "heapToEnv ((x,e1)#(y,e2)#\<Gamma>) eval = heapToEnv ((y,e2)#(x,e1)#\<Gamma>) eval"
  by (simp add: fmap_upd_twist[OF assms])

lemma heapToEnv_reorder_head_append:
  assumes "x \<notin> heapVars \<Gamma>"
  shows "heapToEnv ((x,e)#\<Gamma>@\<Delta>) eval = heapToEnv (\<Gamma> @ ((x,e)#\<Delta>)) eval"
  using assms
  apply (induct \<Gamma>)
  apply simp
  apply (case_tac a)
  apply (auto simp del: heapToEnv.simps simp add: heapToEnv_reorder_head)
  apply simp
  done

lemma heapToEnv_delete_insert:
  assumes "distinctVars \<Gamma>"
  assumes "(x,e) \<in> set \<Gamma>"
  shows "heapToEnv \<Gamma> eval = heapToEnv ((x,e) # delete x \<Gamma>) eval"
using assms
proof (induct \<Gamma> rule:distinctVars.induct)
  case goal1 thus ?case by simp
next
  case (goal2 y \<Gamma> e2)
  show ?case
  proof(cases "(x,e) = (y,e2)")
  case True
    from `y \<notin> heapVars \<Gamma>`
    have "x \<notin> heapVars \<Gamma>" using True by simp
    hence "delete x \<Gamma> = \<Gamma>" by (rule delete_no_there)
    with True show ?thesis by simp
  next
  case False
    hence "x \<noteq> y" by (metis goal2(1) goal2(4) heapVars_from_set set_ConsD)
    hence "(x, e) \<in> set \<Gamma>" by (metis False goal2(4) set_ConsD)
    note hyp = goal2(3)[OF this]

    have "heapToEnv ((x, e) # delete x ((y, e2) # \<Gamma>)) eval
      = heapToEnv ((x, e) # ((y, e2) # delete x \<Gamma>)) eval"
      using False by simp
    also have "... = heapToEnv ((y, e2) # ((x, e) # delete x \<Gamma>)) eval"
      by (rule heapToEnv_reorder_head[OF `x \<noteq> y`])
    also have "... = heapToEnv ((y, e2) # \<Gamma>) eval"
      using hyp
      by simp
    finally
    show ?thesis by (rule sym)
  qed
qed

lemma heapToEnv_reorder:
  assumes "distinctVars \<Gamma>"
  assumes "distinctVars \<Delta>"
  assumes "set \<Gamma> = set \<Delta>"
  shows "heapToEnv \<Gamma> eval = heapToEnv \<Delta> eval"
using assms
proof (induct \<Gamma> arbitrary: \<Delta> rule:distinctVars.induct)
case goal1 thus ?case by simp
next
case (goal2 x \<Gamma> e \<Delta>)
  hence "(x,e) \<in> set \<Delta>"
    by (metis ListMem_iff elem)
  note Delta' = heapToEnv_delete_insert[OF `distinctVars \<Delta>` this]

  have "distinctVars (delete x \<Delta>)"
    by (rule distinctVars_delete[OF goal2(4)])
  moreover
  from `set ((x, e) # \<Gamma>) = set \<Delta>`
  have "set (delete x ((x, e) # \<Gamma>)) = set (delete x \<Delta>)"
    by (metis filter_set delete_eq)
  hence "set \<Gamma> = set (delete x \<Delta>)"
    by (simp add: delete_no_there[OF `x \<notin> heapVars \<Gamma>`])
  ultimately
  have "heapToEnv \<Gamma> eval = heapToEnv (delete x \<Delta>) eval"
    by (rule goal2(3))
  thus ?case
    by (simp add: Delta')
qed

lemma heapToEnv_subst_exp:
  assumes "eval e = eval e'"
  shows "heapToEnv ((x,e)#\<Gamma>) eval = heapToEnv ((x,e')#\<Gamma>) eval"
  by (simp add: assms)
end


(*  Title:      HOL/MicroJava/BV/JVM.thy

    Author:     Gerwin Klein
    Copyright   2000 TUM

*)

header {* \isaheader{The JVM Type System as Semilattice} *}

theory JVM_SemiType imports SemiType begin

type_synonym ty\<^sub>l = "ty err list"
type_synonym ty\<^sub>s = "ty list"
type_synonym ty\<^sub>i = "ty\<^sub>s \<times> ty\<^sub>l"
type_synonym ty\<^sub>i' = "ty\<^sub>i option"
type_synonym ty\<^sub>m = "ty\<^sub>i' list"
type_synonym ty\<^sub>P = "mname \<Rightarrow> cname \<Rightarrow> ty\<^sub>m"

definition stk_esl :: "'c prog \<Rightarrow> nat \<Rightarrow> ty\<^sub>s esl"
where
  "stk_esl P mxs \<equiv> upto_esl mxs (SemiType.esl P)"

definition loc_sl :: "'c prog \<Rightarrow> nat \<Rightarrow> ty\<^sub>l sl"
where
  "loc_sl P mxl \<equiv> Listn.sl mxl (Err.sl (SemiType.esl P))"

definition sl :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err sl"
where
  "sl P mxs mxl \<equiv>
  Err.sl(Opt.esl(Product.esl (stk_esl P mxs) (Err.esl(loc_sl P mxl))))"

definition states :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err set"
where "states P mxs mxl \<equiv> fst(sl P mxs mxl)"

definition le :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err ord"
where
  "le P mxs mxl \<equiv> fst(snd(sl P mxs mxl))"

definition sup :: "'c prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> ty\<^sub>i' err binop"
where
  "sup P mxs mxl \<equiv> snd(snd(sl P mxs mxl))"

definition sup_ty_opt :: "['c prog,ty err,ty err] \<Rightarrow> bool"
                 ("_ |- _ <=T _" [71,71,71] 70)
where
  "sup_ty_opt P \<equiv> Err.le (subtype P)"

definition sup_state :: "['c prog,ty\<^sub>i,ty\<^sub>i] \<Rightarrow> bool"
                 ("_ |- _ <=i _"  [71,71,71] 70)
where
  "sup_state P \<equiv> Product.le (Listn.le (subtype P)) (Listn.le (sup_ty_opt P))"

definition sup_state_opt :: "['c prog,ty\<^sub>i',ty\<^sub>i'] \<Rightarrow> bool"
                 ("_ |- _ <=' _"  [71,71,71] 70)
where
  "sup_state_opt P \<equiv> Opt.le (sup_state P)"

abbreviation
  sup_loc :: "['c prog,ty\<^sub>l,ty\<^sub>l] \<Rightarrow> bool"  ("_ |- _ [<=T] _"  [71,71,71] 70)
  where "P |- LT [<=T] LT' \<equiv> list_all2 (sup_ty_opt P) LT LT'"

notation (xsymbols)
  sup_ty_opt  ("_ \<turnstile> _ \<le>\<^sub>\<top> _" [71,71,71] 70) and
  sup_state  ("_ \<turnstile> _ \<le>\<^sub>i _" [71,71,71] 70) and
  sup_state_opt  ("_ \<turnstile> _ \<le>' _" [71,71,71] 70) and
  sup_loc  ("_ \<turnstile> _ [\<le>\<^sub>\<top>] _"  [71,71,71] 70)

section "Unfolding"

lemma JVM_states_unfold:
  "states P mxs mxl \<equiv> err(opt((Union {list n (types P) |n. n <= mxs}) <*>
                                 list mxl (err(types P))))"
(*<*)
  apply (unfold states_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def loc_sl_def Product.esl_def
         Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
  apply simp
  done
(*>*)

lemma JVM_le_unfold:
 "le P m n \<equiv>
  Err.le(Opt.le(Product.le(Listn.le(subtype P))(Listn.le(Err.le(subtype P)))))"
(*<*)
  apply (unfold le_def sl_def Opt.esl_def Err.sl_def
         stk_esl_def loc_sl_def Product.esl_def
         Listn.sl_def upto_esl_def SemiType.esl_def Err.esl_def)
  apply simp
  done
(*>*)

lemma sl_def2:
  "JVM_SemiType.sl P mxs mxl \<equiv>
  (states P mxs mxl, JVM_SemiType.le P mxs mxl, JVM_SemiType.sup P mxs mxl)"
(*<*) by (unfold JVM_SemiType.sup_def states_def JVM_SemiType.le_def) simp (*>*)

lemma JVM_le_conv:
  "le P m n (OK t1) (OK t2) = P \<turnstile> t1 \<le>' t2"
(*<*) by (simp add: JVM_le_unfold Err.le_def lesub_def sup_state_opt_def
                sup_state_def sup_ty_opt_def) (*>*)

lemma JVM_le_Err_conv:
  "le P m n = Err.le (sup_state_opt P)"
(*<*) by (unfold sup_state_opt_def sup_state_def
             sup_ty_opt_def JVM_le_unfold) simp (*>*)

lemma err_le_unfold [iff]:
  "Err.le r (OK a) (OK b) = r a b"
(*<*) by (simp add: Err.le_def lesub_def) (*>*)

section {* Semilattice *}

lemma order_sup_state_opt [intro, simp]:
  "wf_prog wf_mb P \<Longrightarrow> order (sup_state_opt P)"
(*<*) by (unfold sup_state_opt_def sup_state_def sup_ty_opt_def) blast (*>*)

lemma semilat_JVM [intro?]:
  "wf_prog wf_mb P \<Longrightarrow> semilat (JVM_SemiType.sl P mxs mxl)"
(*<*)
  apply (unfold JVM_SemiType.sl_def stk_esl_def loc_sl_def)
  apply (blast intro: err_semilat_Product_esl err_semilat_upto_esl
                      Listn_sl err_semilat_JType_esl)
  done
(*>*)

lemma acc_JVM [intro]:
  "wf_prog wf_mb P \<Longrightarrow> acc (JVM_SemiType.le P mxs mxl)"
(*<*) by (unfold JVM_le_unfold) blast (*>*)

section {* Widening with @{text "\<top>"} *}

lemma subtype_refl[iff]: "subtype P t t" (*<*) by (simp add: fun_of_def) (*>*)

lemma sup_ty_opt_refl [iff]: "P \<turnstile> T \<le>\<^sub>\<top> T"
(*<*)
  apply (unfold sup_ty_opt_def)
  apply (fold lesub_def)
  apply (rule le_err_refl)
  apply (simp add: lesub_def)
  done
(*>*)

lemma Err_any_conv [iff]: "P \<turnstile> Err \<le>\<^sub>\<top> T = (T = Err)"
(*<*) by (unfold sup_ty_opt_def) (rule Err_le_conv [simplified lesub_def]) (*>*)

lemma any_Err [iff]: "P \<turnstile> T \<le>\<^sub>\<top> Err"
(*<*) by (unfold sup_ty_opt_def) (rule le_Err [simplified lesub_def]) (*>*)

lemma OK_OK_conv [iff]:
  "P \<turnstile> OK T \<le>\<^sub>\<top> OK T' = P \<turnstile> T \<le> T'"
(*<*) by (simp add: sup_ty_opt_def fun_of_def) (*>*)

lemma any_OK_conv [iff]:
  "P \<turnstile> X \<le>\<^sub>\<top> OK T' = (\<exists>T. X = OK T \<and> P \<turnstile> T \<le> T')"
(*<*)
  apply (unfold sup_ty_opt_def)
  apply (rule le_OK_conv [simplified lesub_def])
  done
(*>*)

lemma OK_any_conv:
 "P \<turnstile> OK T \<le>\<^sub>\<top> X = (X = Err \<or> (\<exists>T'. X = OK T' \<and> P \<turnstile> T \<le> T'))"
(*<*)
  apply (unfold sup_ty_opt_def)
  apply (rule OK_le_conv [simplified lesub_def])
  done
(*>*)

lemma sup_ty_opt_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a \<le>\<^sub>\<top> b; P \<turnstile> b \<le>\<^sub>\<top> c\<rbrakk> \<Longrightarrow> P \<turnstile> a \<le>\<^sub>\<top> c"
(*<*) by (auto intro: widen_trans
           simp add: sup_ty_opt_def Err.le_def lesub_def fun_of_def
           split: err.splits) (*>*)

section "Stack and Registers"

lemma stk_convert:
  "P \<turnstile> ST [\<le>] ST' = Listn.le (subtype P) ST ST'"
(*<*) by (simp add: Listn.le_def lesub_def) (*>*)

lemma sup_loc_refl [iff]: "P \<turnstile> LT [\<le>\<^sub>\<top>] LT"
(*<*) by (rule list_all2_refl) simp (*>*)

lemmas sup_loc_Cons1 [iff] = list_all2_Cons1 [of "sup_ty_opt P"] for P

lemma sup_loc_def:
  "P \<turnstile> LT [\<le>\<^sub>\<top>] LT' \<equiv> Listn.le (sup_ty_opt P) LT LT'"
(*<*) by (simp add: Listn.le_def lesub_def) (*>*)

lemma sup_loc_widens_conv [iff]:
  "P \<turnstile> map OK Ts [\<le>\<^sub>\<top>] map OK Ts' = P \<turnstile> Ts [\<le>] Ts'"
(*<*)
  by (simp add: list_all2_map1 list_all2_map2)
(*>*)

lemma sup_loc_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a [\<le>\<^sub>\<top>] b; P \<turnstile> b [\<le>\<^sub>\<top>] c\<rbrakk> \<Longrightarrow> P \<turnstile> a [\<le>\<^sub>\<top>] c"
(*<*) by (rule list_all2_trans, rule sup_ty_opt_trans) (*>*)

section "State Type"

lemma sup_state_conv [iff]:
  "P \<turnstile> (ST,LT) \<le>\<^sub>i (ST',LT') = (P \<turnstile> ST [\<le>] ST' \<and> P \<turnstile> LT [\<le>\<^sub>\<top>] LT')"
(*<*) by (auto simp add: sup_state_def stk_convert lesub_def Product.le_def sup_loc_def) (*>*)

lemma sup_state_conv2:
  "P \<turnstile> s1 \<le>\<^sub>i s2 = (P \<turnstile> fst s1 [\<le>] fst s2 \<and> P \<turnstile> snd s1 [\<le>\<^sub>\<top>] snd s2)"
(*<*) by (cases s1, cases s2) simp (*>*)

lemma sup_state_refl [iff]: "P \<turnstile> s \<le>\<^sub>i s"
(*<*) by (auto simp add: sup_state_conv2) (*>*)

lemma sup_state_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a \<le>\<^sub>i b; P \<turnstile> b \<le>\<^sub>i c\<rbrakk> \<Longrightarrow> P \<turnstile> a \<le>\<^sub>i c"
(*<*) by (auto intro: sup_loc_trans widens_trans simp add: sup_state_conv2) (*>*)

lemma sup_state_opt_None_any [iff]:
  "P \<turnstile> None \<le>' s"
(*<*) by (simp add: sup_state_opt_def Opt.le_def) (*>*)

lemma sup_state_opt_any_None [iff]:
  "P \<turnstile> s \<le>' None = (s = None)"
(*<*) by (simp add: sup_state_opt_def Opt.le_def) (*>*)

lemma sup_state_opt_Some_Some [iff]:
  "P \<turnstile> Some a \<le>' Some b = P \<turnstile> a \<le>\<^sub>i b"
(*<*) by (simp add: sup_state_opt_def Opt.le_def lesub_def) (*>*)

lemma sup_state_opt_any_Some:
  "P \<turnstile> (Some s) \<le>' X = (\<exists>s'. X = Some s' \<and> P \<turnstile> s \<le>\<^sub>i s')"
(*<*) by (simp add: sup_state_opt_def Opt.le_def lesub_def) (*>*)

lemma sup_state_opt_refl [iff]: "P \<turnstile> s \<le>' s"
(*<*) by (simp add: sup_state_opt_def Opt.le_def lesub_def) (*>*)

lemma sup_state_opt_trans [intro?, trans]:
  "\<lbrakk>P \<turnstile> a \<le>' b; P \<turnstile> b \<le>' c\<rbrakk> \<Longrightarrow> P \<turnstile> a \<le>' c"
(*<*)
  apply (unfold sup_state_opt_def Opt.le_def lesub_def)
  apply (simp del: split_paired_All)
  apply (rule sup_state_trans, assumption+)
  done
(*>*)

end


(*  Title:    HOL/Prolog/Test.thy
    Author:   David von Oheimb (based on a lecture on Lambda Prolog by Nadathur)
*)

section {* Basic examples *}

theory Test
imports HOHH
begin

typedecl nat

typedecl 'a list

consts
  Nil   :: "'a list"                                  ("[]")
  Cons  :: "'a => 'a list => 'a list"                 (infixr "#"  65)

syntax
  (* list Enumeration *)
  "_list"     :: "args => 'a list"                          ("[(_)]")

translations
  "[x, xs]"     == "x#[xs]"
  "[x]"         == "x#[]"

typedecl person

axiomatization
  append  :: "['a list, 'a list, 'a list]            => bool" and
  reverse :: "['a list, 'a list]                     => bool" and

  mappred :: "[('a => 'b => bool), 'a list, 'b list] => bool" and
  mapfun  :: "[('a => 'b), 'a list, 'b list]         => bool" and

  bob     :: person and
  sue     :: person and
  ned     :: person and

  nat23   :: nat          ("23") and
  nat24   :: nat          ("24") and
  nat25   :: nat          ("25") and

  age     :: "[person, nat]                          => bool" and

  eq      :: "['a, 'a]                               => bool" and

  empty   :: "['b]                                   => bool" and
  add     :: "['a, 'b, 'b]                           => bool" and
  remove  :: "['a, 'b, 'b]                           => bool" and
  bag_appl:: "['a, 'a, 'a, 'a]                       => bool"
where
        append:  "\<And>x xs ys zs. append  []    xs  xs    ..
                  append (x#xs) ys (x#zs) :- append xs ys zs" and
        reverse: "\<And>L1 L2. reverse L1 L2 :- (!rev_aux.
                  (!L.          rev_aux  []    L  L )..
                  (!X L1 L2 L3. rev_aux (X#L1) L2 L3 :- rev_aux L1 L2 (X#L3))
                  => rev_aux L1 L2 [])" and

        mappred: "\<And>x xs y ys P. mappred P  []     []    ..
                  mappred P (x#xs) (y#ys) :- P x y  &  mappred P xs ys" and
        mapfun:  "\<And>x xs ys f. mapfun f  []     []      ..
                  mapfun f (x#xs) (f x#ys) :- mapfun f xs ys" and

        age:     "age bob 24 ..
                  age sue 23 ..
                  age ned 23" and

        eq:      "\<And>x. eq x x" and

(* actual definitions of empty and add is hidden -> yields abstract data type *)

        bag_appl: "\<And>A B X Y. bag_appl A B X Y:- (? S1 S2 S3 S4 S5.
                                empty    S1    &
                                add A    S1 S2 &
                                add B    S2 S3 &
                                remove X S3 S4 &
                                remove Y S4 S5 &
                                empty    S5)"

lemmas prog_Test = append reverse mappred mapfun age eq bag_appl

schematic_lemma "append ?x ?y [a,b,c,d]"
  apply (prolog prog_Test)
  back
  back
  back
  back
  done

schematic_lemma "append [a,b] y ?L"
  apply (prolog prog_Test)
  done

schematic_lemma "!y. append [a,b] y (?L y)"
  apply (prolog prog_Test)
  done

schematic_lemma "reverse [] ?L"
  apply (prolog prog_Test)
  done

schematic_lemma "reverse [23] ?L"
  apply (prolog prog_Test)
  done

schematic_lemma "reverse [23,24,?x] ?L"
  apply (prolog prog_Test)
  done

schematic_lemma "reverse ?L [23,24,?x]"
  apply (prolog prog_Test)
  done

schematic_lemma "mappred age ?x [23,24]"
  apply (prolog prog_Test)
  back
  done

schematic_lemma "mappred (%x y. ? z. age z y) ?x [23,24]"
  apply (prolog prog_Test)
  done

schematic_lemma "mappred ?P [bob,sue] [24,23]"
  apply (prolog prog_Test)
  done

schematic_lemma "mapfun f [bob,bob,sue] [?x,?y,?z]"
  apply (prolog prog_Test)
  done

schematic_lemma "mapfun (%x. h x 25) [bob,sue] ?L"
  apply (prolog prog_Test)
  done

schematic_lemma "mapfun ?F [24,25] [h bob 24,h bob 25]"
  apply (prolog prog_Test)
  done

schematic_lemma "mapfun ?F [24] [h 24 24]"
  apply (prolog prog_Test)
  back
  back
  back
  done

lemma "True"
  apply (prolog prog_Test)
  done

schematic_lemma "age ?x 24 & age ?y 23"
  apply (prolog prog_Test)
  back
  done

schematic_lemma "age ?x 24 | age ?x 23"
  apply (prolog prog_Test)
  back
  back
  done

lemma "? x y. age x y"
  apply (prolog prog_Test)
  done

lemma "!x y. append [] x x"
  apply (prolog prog_Test)
  done

schematic_lemma "age sue 24 .. age bob 23 => age ?x ?y"
  apply (prolog prog_Test)
  back
  back
  back
  back
  done

(*set trace_DEPTH_FIRST;*)
lemma "age bob 25 :- age bob 24 => age bob 25"
  apply (prolog prog_Test)
  done
(*reset trace_DEPTH_FIRST;*)

schematic_lemma "(!x. age x 25 :- age x 23) => age ?x 25 & age ?y 25"
  apply (prolog prog_Test)
  back
  back
  back
  done

lemma "!x. ? y. eq x y"
  apply (prolog prog_Test)
  done

schematic_lemma "? P. P & eq P ?x"
  apply (prolog prog_Test)
(*
  back
  back
  back
  back
  back
  back
  back
  back
*)
  done

lemma "? P. eq P (True & True) & P"
  apply (prolog prog_Test)
  done

lemma "? P. eq P op | & P k True"
  apply (prolog prog_Test)
  done

lemma "? P. eq P (Q => True) & P"
  apply (prolog prog_Test)
  done

(* P flexible: *)
lemma "(!P k l. P k l :- eq P Q) => Q a b"
  apply (prolog prog_Test)
  done
(*
loops:
lemma "(!P k l. P k l :- eq P (%x y. x | y)) => a | b"
*)

(* implication and disjunction in atom: *)
lemma "? Q. (!p q. R(q :- p) => R(Q p q)) & Q (t | s) (s | t)"
  by fast

(* disjunction in atom: *)
lemma "(!P. g P :- (P => b | a)) => g(a | b)"
  apply (tactic "step_tac (put_claset HOL_cs @{context}) 1")
  apply (tactic "step_tac (put_claset HOL_cs @{context}) 1")
  apply (tactic "step_tac (put_claset HOL_cs @{context}) 1")
   prefer 2
   apply fast
  apply fast
  done

(*
hangs:
lemma "(!P. g P :- (P => b | a)) => g(a | b)"
  by fast
*)

schematic_lemma "!Emp Stk.(
                       empty    (Emp::'b) ..
         (!(X::nat) S. add    X (S::'b)         (Stk X S)) ..
         (!(X::nat) S. remove X ((Stk X S)::'b) S))
 => bag_appl 23 24 ?X ?Y"
  oops

schematic_lemma "!Qu. (
          (!L.            empty    (Qu L L)) ..
          (!(X::nat) L K. add    X (Qu L (X#K)) (Qu L K)) ..
          (!(X::nat) L K. remove X (Qu (X#L) K) (Qu L K)))
 => bag_appl 23 24 ?X ?Y"
  oops

lemma "D & (!y. E) :- (!x. True & True) :- True => D"
  apply (prolog prog_Test)
  done

schematic_lemma "P x .. P y => P ?X"
  apply (prolog prog_Test)
  back
  done

end


theory Prelude_Either
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"NotFalse\", \"NotTrue\", \"AndFalse\", \"AndTrue\", \"AndSym\",
     \"OrDef\", \"OtherwiseDef\", \"NotFalse1\", \"NotTrue1\",
     \"notNot1\", \"notNot2\", \"EqualTDef\", \"EqualSymDef\",
     \"EqualReflex\", \"EqualTransT\", \"DiffDef\", \"EqualPrefixDef\",
     \"DiffPrefixDef\", \"DiffSymDef\", \"DiffTDef\", \"DiffFDef\",
     \"TE1\", \"TE2\", \"TE3\", \"TE4\", \"IBE1\", \"IBE2\", \"IBE3\",
     \"IBE4\", \"IBE5\", \"IBE6\", \"IBE7\", \"IBE8\", \"IUE1\",
     \"IUE2\", \"IOE01\", \"IOE02\", \"IOE03\", \"IOE04\", \"IOE05\",
     \"IOE06\", \"IOE07\", \"IOE08\", \"IOE09\", \"LeIrreflexivity\",
     \"LeTAsymmetry\", \"LeTTransitive\", \"LeTTotal\", \"GeDef\",
     \"GeIrreflexivity\", \"GeTAsymmetry\", \"GeTTransitive\",
     \"GeTTotal\", \"LeqDef\", \"LeqReflexivity\", \"LeqTTransitive\",
     \"LeqTTotal\", \"GeqDef\", \"GeqReflexivity\", \"GeqTTransitive\",
     \"GeqTTotal\", \"EqTSOrdRel\", \"EqFSOrdRel\", \"EqTOrdRel\",
     \"EqFOrdRel\", \"EqTOrdTSubstE\", \"EqTOrdFSubstE\",
     \"EqTOrdTSubstD\", \"EqTOrdFSubstD\", \"LeTGeFEqFRel\",
     \"LeFGeTEqTRel\", \"LeTGeTRel\", \"LeFGeFRel\", \"LeqTGetTRel\",
     \"LeqFGetFRel\", \"GeTLeTRel\", \"GeFLeFRel\", \"GeqTLeqTRel\",
     \"GeqFLeqFRel\", \"LeqTGeFRel\", \"LeqFGeTRel\", \"GeTLeFEqFRel\",
     \"GeFLeTEqTRel\", \"GeqTLeFRel\", \"GeqFLeTRel\",
     \"LeqTLeTEqTRel\", \"LeqFLeFEqFRel\", \"GeqTGeTEqTRel\",
     \"GeqFGeFEqFRel\", \"LeTGeqFRel\", \"GeTLeqFRel\", \"LeLeqDiff\",
     \"LePrefixDef\", \"LeqPrefixDef\", \"GePrefixDef\",
     \"GeqPrefixDef\", \"CmpLTDef\", \"CmpEQDef\", \"CmpGTDef\",
     \"MaxYDef\", \"MaxXDef\", \"MinXDef\", \"MinYDef\", \"MaxSym\",
     \"MinSym\", \"TO1\", \"TO2\", \"TO3\", \"TO4\", \"TO5\", \"TO6\",
     \"TO7\", \"IOO13\", \"IOO14\", \"IOO15\", \"IOO16\", \"IOO17\",
     \"IOO18\", \"IOO19\", \"IOO20\", \"IOO21\", \"IOO22\", \"IOO23\",
     \"IOO24\", \"IOO25\", \"IOO26\", \"IOO27\", \"IOO28\", \"IOO29\",
     \"IOO30\", \"IOO31\", \"IOO32\", \"IOO33\", \"IBO5\", \"IBO6\",
     \"IBO7\", \"IBO8\", \"IBO9\", \"IBO10\", \"IBO11\", \"IBO12\",
     \"IUO01\", \"IUO02\", \"IUO03\", \"IUO04\", \"IUO05\", \"IUO06\",
     \"IUO07\", \"EitherLeftDef\", \"EitherRightDef\", \"IEE01\",
     \"IEE02\", \"IEE03\", \"IEO01\", \"IEO02\", \"IEO03\", \"IEO04\",
     \"IEO05\", \"IEO06\", \"IEO07\", \"IEO08\", \"IEO09\", \"IEO10\",
     \"IEO11\", \"IEO12\", \"IEO13\"]"

typedecl Unit
typedecl X_Nat

datatype Bool = X_False ("False''") | X_True ("True''")
datatype Ordering = EQ | GT | LT
datatype ('a, 'b) Either = X_Left 'a ("Left''/'(_')" [3] 999) | X_Right 'b ("Right''/'(_')" [3] 999)

consts
Not__X :: "Bool => Bool" ("(Not''/ _)" [56] 56)
XLtXEqXEqXGt :: "'a => 'a => Bool"
XLtXGtXEqXGt :: "'a => 'a => Bool"
XLtXGtXGt :: "'a => 'a => Bool"
XLtXLtXEqXGt :: "'a => 'a => Bool"
XLtXLtXGt :: "'a => 'a => Bool"
XLtXSlashXEqXGt :: "'a => 'a => Bool"
X__XAmpXAmp__X :: "Bool => Bool => Bool" ("(_/ &&/ _)" [54,54] 52)
X__XEqXEq__X :: "'a => 'a => Bool" ("(_/ ==''/ _)" [54,54] 52)
X__XGtXEq__X :: "'a => 'a => Bool" ("(_/ >=''/ _)" [54,54] 52)
X__XGt__X :: "'a => 'a => Bool" ("(_/ >''/ _)" [54,54] 52)
X__XLtXEq__X :: "'a => 'a => Bool" ("(_/ <=''/ _)" [54,54] 52)
X__XLt__X :: "'a => 'a => Bool" ("(_/ <''/ _)" [54,54] 52)
X__XSlashXEq__X :: "'a => 'a => Bool" ("(_/ '/=/ _)" [54,54] 52)
X__XVBarXVBar__X :: "Bool => Bool => Bool" ("(_/ ||/ _)" [54,54] 52)
X_max :: "'a => 'a => 'a"
X_min :: "'a => 'a => 'a"
compare :: "'a => 'a => Ordering"
either :: "('a => 'c) => ('b => 'c) => ('a, 'b) Either => 'c"
otherwiseH :: "Bool"

axioms
NotFalse [rule_format] : "Not' False' = True'"

NotTrue [rule_format] : "Not' True' = False'"

AndFalse [rule_format] : "ALL x. False' && x = False'"

AndTrue [rule_format] : "ALL x. True' && x = x"

AndSym [rule_format] : "ALL x. ALL y. x && y = y && x"

OrDef [rule_format] :
"ALL x. ALL y. x || y = Not' (Not' x && Not' y)"

OtherwiseDef [rule_format] : "otherwiseH = True'"

NotFalse1 [rule_format] : "ALL x. Not' x = True' = (x = False')"

NotTrue1 [rule_format] : "ALL x. Not' x = False' = (x = True')"

notNot1 [rule_format] : "ALL x. (~ x = True') = (Not' x = True')"

notNot2 [rule_format] : "ALL x. (~ x = False') = (Not' x = False')"

EqualTDef [rule_format] : "ALL x. ALL y. x = y --> x ==' y = True'"

EqualSymDef [rule_format] : "ALL x. ALL y. x ==' y = y ==' x"

EqualReflex [rule_format] : "ALL x. x ==' x = True'"

EqualTransT [rule_format] :
"ALL x.
 ALL y.
 ALL z. x ==' y = True' & y ==' z = True' --> x ==' z = True'"

DiffDef [rule_format] : "ALL x. ALL y. x /= y = Not' (x ==' y)"

EqualPrefixDef [rule_format] :
"ALL x. ALL y. XLtXEqXEqXGt x y = x ==' y"

DiffPrefixDef [rule_format] :
"ALL x. ALL y. XLtXSlashXEqXGt x y = x /= y"

DiffSymDef [rule_format] : "ALL x. ALL y. x /= y = y /= x"

DiffTDef [rule_format] :
"ALL x. ALL y. x /= y = True' = (Not' (x ==' y) = True')"

DiffFDef [rule_format] :
"ALL x. ALL y. x /= y = False' = (x ==' y = True')"

TE1 [rule_format] : "ALL x. ALL y. x ==' y = False' --> ~ x = y"

TE2 [rule_format] :
"ALL x. ALL y. Not' (x ==' y) = True' = (x ==' y = False')"

TE3 [rule_format] :
"ALL x. ALL y. Not' (x ==' y) = False' = (x ==' y = True')"

TE4 [rule_format] :
"ALL x. ALL y. (~ x ==' y = True') = (x ==' y = False')"

IBE1 [rule_format] : "True' ==' True' = True'"

IBE2 [rule_format] : "False' ==' False' = True'"

IBE3 [rule_format] : "False' ==' True' = False'"

IBE4 [rule_format] : "True' ==' False' = False'"

IBE5 [rule_format] : "True' /= False' = True'"

IBE6 [rule_format] : "False' /= True' = True'"

IBE7 [rule_format] : "Not' (True' ==' False') = True'"

IBE8 [rule_format] : "Not' Not' (True' ==' False') = False'"

IUE1 [rule_format] : "() ==' () = True'"

IUE2 [rule_format] : "() /= () = False'"

IOE01 [rule_format] : "LT ==' LT = True'"

IOE02 [rule_format] : "EQ ==' EQ = True'"

IOE03 [rule_format] : "GT ==' GT = True'"

IOE04 [rule_format] : "LT ==' EQ = False'"

IOE05 [rule_format] : "LT ==' GT = False'"

IOE06 [rule_format] : "EQ ==' GT = False'"

IOE07 [rule_format] : "LT /= EQ = True'"

IOE08 [rule_format] : "LT /= GT = True'"

IOE09 [rule_format] : "EQ /= GT = True'"

LeIrreflexivity [rule_format] :
"ALL x. ALL y. x ==' y = True' --> x <' y = False'"

LeTAsymmetry [rule_format] :
"ALL x. ALL y. x <' y = True' --> y <' x = False'"

LeTTransitive [rule_format] :
"ALL x.
 ALL y. ALL z. x <' y = True' & y <' z = True' --> x <' z = True'"

LeTTotal [rule_format] :
"ALL x. ALL y. (x <' y = True' | y <' x = True') | x ==' y = True'"

GeDef [rule_format] : "ALL x. ALL y. x >' y = y <' x"

GeIrreflexivity [rule_format] :
"ALL x. ALL y. x ==' y = True' --> x >' y = False'"

GeTAsymmetry [rule_format] :
"ALL x. ALL y. x >' y = True' --> y >' x = False'"

GeTTransitive [rule_format] :
"ALL x.
 ALL y. ALL z. (x >' y) && (y >' z) = True' --> x >' z = True'"

GeTTotal [rule_format] :
"ALL x. ALL y. ((x >' y) || (y >' x)) || (x ==' y) = True'"

LeqDef [rule_format] :
"ALL x. ALL y. x <=' y = (x <' y) || (x ==' y)"

LeqReflexivity [rule_format] : "ALL x. x <=' x = True'"

LeqTTransitive [rule_format] :
"ALL x.
 ALL y. ALL z. (x <=' y) && (y <=' z) = True' --> x <=' z = True'"

LeqTTotal [rule_format] :
"ALL x. ALL y. (x <=' y) && (y <=' x) = x ==' y"

GeqDef [rule_format] :
"ALL x. ALL y. x >=' y = (x >' y) || (x ==' y)"

GeqReflexivity [rule_format] : "ALL x. x >=' x = True'"

GeqTTransitive [rule_format] :
"ALL x.
 ALL y. ALL z. (x >=' y) && (y >=' z) = True' --> x >=' z = True'"

GeqTTotal [rule_format] :
"ALL x. ALL y. (x >=' y) && (y >=' x) = x ==' y"

EqTSOrdRel [rule_format] :
"ALL x.
 ALL y. x ==' y = True' = (x <' y = False' & x >' y = False')"

EqFSOrdRel [rule_format] :
"ALL x.
 ALL y. x ==' y = False' = (x <' y = True' | x >' y = True')"

EqTOrdRel [rule_format] :
"ALL x.
 ALL y. x ==' y = True' = (x <=' y = True' & x >=' y = True')"

EqFOrdRel [rule_format] :
"ALL x.
 ALL y. x ==' y = False' = (x <=' y = True' | x >=' y = True')"

EqTOrdTSubstE [rule_format] :
"ALL x.
 ALL y. ALL z. x ==' y = True' & y <' z = True' --> x <' z = True'"

EqTOrdFSubstE [rule_format] :
"ALL x.
 ALL y.
 ALL z. x ==' y = True' & y <' z = False' --> x <' z = False'"

EqTOrdTSubstD [rule_format] :
"ALL x.
 ALL y. ALL z. x ==' y = True' & z <' y = True' --> z <' x = True'"

EqTOrdFSubstD [rule_format] :
"ALL x.
 ALL y.
 ALL z. x ==' y = True' & z <' y = False' --> z <' x = False'"

LeTGeFEqFRel [rule_format] :
"ALL x.
 ALL y. x <' y = True' = (x >' y = False' & x ==' y = False')"

LeFGeTEqTRel [rule_format] :
"ALL x.
 ALL y. x <' y = False' = (x >' y = True' | x ==' y = True')"

LeTGeTRel [rule_format] :
"ALL x. ALL y. x <' y = True' = (y >' x = True')"

LeFGeFRel [rule_format] :
"ALL x. ALL y. x <' y = False' = (y >' x = False')"

LeqTGetTRel [rule_format] :
"ALL x. ALL y. x <=' y = True' = (y >=' x = True')"

LeqFGetFRel [rule_format] :
"ALL x. ALL y. x <=' y = False' = (y >=' x = False')"

GeTLeTRel [rule_format] :
"ALL x. ALL y. x >' y = True' = (y <' x = True')"

GeFLeFRel [rule_format] :
"ALL x. ALL y. x >' y = False' = (y <' x = False')"

GeqTLeqTRel [rule_format] :
"ALL x. ALL y. x >=' y = True' = (y <=' x = True')"

GeqFLeqFRel [rule_format] :
"ALL x. ALL y. x >=' y = False' = (y <=' x = False')"

LeqTGeFRel [rule_format] :
"ALL x. ALL y. x <=' y = True' = (x >' y = False')"

LeqFGeTRel [rule_format] :
"ALL x. ALL y. x <=' y = False' = (x >' y = True')"

GeTLeFEqFRel [rule_format] :
"ALL x.
 ALL y. x >' y = True' = (x <' y = False' & x ==' y = False')"

GeFLeTEqTRel [rule_format] :
"ALL x.
 ALL y. x >' y = False' = (x <' y = True' | x ==' y = True')"

GeqTLeFRel [rule_format] :
"ALL x. ALL y. x >=' y = True' = (x <' y = False')"

GeqFLeTRel [rule_format] :
"ALL x. ALL y. x >=' y = False' = (x <' y = True')"

LeqTLeTEqTRel [rule_format] :
"ALL x.
 ALL y. x <=' y = True' = (x <' y = True' | x ==' y = True')"

LeqFLeFEqFRel [rule_format] :
"ALL x.
 ALL y. x <=' y = False' = (x <' y = False' & x ==' y = False')"

GeqTGeTEqTRel [rule_format] :
"ALL x.
 ALL y. x >=' y = True' = (x >' y = True' | x ==' y = True')"

GeqFGeFEqFRel [rule_format] :
"ALL x.
 ALL y. x >=' y = False' = (x >' y = False' & x ==' y = False')"

LeTGeqFRel [rule_format] :
"ALL x. ALL y. x <' y = True' = (x >=' y = False')"

GeTLeqFRel [rule_format] :
"ALL x. ALL y. x >' y = True' = (x <=' y = False')"

LeLeqDiff [rule_format] :
"ALL x. ALL y. x <' y = (x <=' y) && (x /= y)"

LePrefixDef [rule_format] : "ALL x. ALL y. XLtXLtXGt x y = x <' y"

LeqPrefixDef [rule_format] :
"ALL x. ALL y. XLtXLtXEqXGt x y = x <=' y"

GePrefixDef [rule_format] : "ALL x. ALL y. XLtXGtXGt x y = x >' y"

GeqPrefixDef [rule_format] :
"ALL x. ALL y. XLtXGtXEqXGt x y = x >=' y"

CmpLTDef [rule_format] :
"ALL x. ALL y. compare x y ==' LT = x <' y"

CmpEQDef [rule_format] :
"ALL x. ALL y. compare x y ==' EQ = x ==' y"

CmpGTDef [rule_format] :
"ALL x. ALL y. compare x y ==' GT = x >' y"

MaxYDef [rule_format] : "ALL x. ALL y. X_max x y ==' y = x <=' y"

MaxXDef [rule_format] : "ALL x. ALL y. X_max x y ==' x = y <=' x"

MinXDef [rule_format] : "ALL x. ALL y. X_min x y ==' x = x <=' y"

MinYDef [rule_format] : "ALL x. ALL y. X_min x y ==' y = y <=' x"

MaxSym [rule_format] :
"ALL x. ALL y. X_max x y ==' y = X_max y x ==' y"

MinSym [rule_format] :
"ALL x. ALL y. X_min x y ==' y = X_min y x ==' y"

TO1 [rule_format] :
"ALL x.
 ALL y. (x ==' y = True' | x <' y = True') = (x <=' y = True')"

TO2 [rule_format] :
"ALL x. ALL y. x ==' y = True' --> x <' y = False'"

TO3 [rule_format] :
"ALL x. ALL y. Not' Not' (x <' y) = True' | Not' (x <' y) = True'"

TO4 [rule_format] :
"ALL x. ALL y. x <' y = True' --> Not' (x ==' y) = True'"

TO5 [rule_format] :
"ALL w.
 ALL x.
 ALL y.
 ALL z.
 (x <' y = True' & y <' z = True') & z <' w = True' -->
 x <' w = True'"

TO6 [rule_format] :
"ALL x. ALL z. z <' x = True' --> Not' (x <' z) = True'"

TO7 [rule_format] :
"ALL x. ALL y. x <' y = True' = (y >' x = True')"

IOO13 [rule_format] : "LT <' EQ = True'"

IOO14 [rule_format] : "EQ <' GT = True'"

IOO15 [rule_format] : "LT <' GT = True'"

IOO16 [rule_format] : "LT <=' EQ = True'"

IOO17 [rule_format] : "EQ <=' GT = True'"

IOO18 [rule_format] : "LT <=' GT = True'"

IOO19 [rule_format] : "EQ >=' LT = True'"

IOO20 [rule_format] : "GT >=' EQ = True'"

IOO21 [rule_format] : "GT >=' LT = True'"

IOO22 [rule_format] : "EQ >' LT = True'"

IOO23 [rule_format] : "GT >' EQ = True'"

IOO24 [rule_format] : "GT >' LT = True'"

IOO25 [rule_format] : "X_max LT EQ ==' EQ = True'"

IOO26 [rule_format] : "X_max EQ GT ==' GT = True'"

IOO27 [rule_format] : "X_max LT GT ==' GT = True'"

IOO28 [rule_format] : "X_min LT EQ ==' LT = True'"

IOO29 [rule_format] : "X_min EQ GT ==' EQ = True'"

IOO30 [rule_format] : "X_min LT GT ==' LT = True'"

IOO31 [rule_format] : "compare LT LT ==' EQ = True'"

IOO32 [rule_format] : "compare EQ EQ ==' EQ = True'"

IOO33 [rule_format] : "compare GT GT ==' EQ = True'"

IBO5 [rule_format] : "False' <' True' = True'"

IBO6 [rule_format] : "False' >=' True' = False'"

IBO7 [rule_format] : "True' >=' False' = True'"

IBO8 [rule_format] : "True' <' False' = False'"

IBO9 [rule_format] : "X_max False' True' ==' True' = True'"

IBO10 [rule_format] : "X_min False' True' ==' False' = True'"

IBO11 [rule_format] : "compare True' True' ==' EQ = True'"

IBO12 [rule_format] : "compare False' False' ==' EQ = True'"

IUO01 [rule_format] : "() <=' () = True'"

IUO02 [rule_format] : "() <' () = False'"

IUO03 [rule_format] : "() >=' () = True'"

IUO04 [rule_format] : "() >' () = False'"

IUO05 [rule_format] : "X_max () () ==' () = True'"

IUO06 [rule_format] : "X_min () () ==' () = True'"

IUO07 [rule_format] : "compare () () ==' EQ = True'"

EitherLeftDef [rule_format] :
"ALL f. ALL g. ALL x. either f g (Left'(x)) = f x"

EitherRightDef [rule_format] :
"ALL f. ALL g. ALL y. either f g (Right'(y)) = g y"

IEE01 [rule_format] :
"ALL x. ALL y. Left'(x) ==' Left'(y) = x ==' y"

IEE02 [rule_format] :
"ALL w. ALL z. Right'(z) ==' Right'(w) = z ==' w"

IEE03 [rule_format] :
"ALL x. ALL z. Left'(x) ==' Right'(z) = False'"

IEO01 [rule_format] : "ALL x. ALL z. Left'(x) <' Right'(z) = True'"

IEO02 [rule_format] : "ALL x. ALL y. Left'(x) <' Left'(y) = x <' y"

IEO03 [rule_format] :
"ALL w. ALL z. Right'(z) <' Right'(w) = z <' w"

declare NotFalse [simp]
declare NotTrue [simp]
declare AndFalse [simp]
declare AndTrue [simp]
declare EqualReflex [simp]
declare IBE1 [simp]
declare IBE2 [simp]
declare IBE3 [simp]
declare IBE4 [simp]
declare IBE5 [simp]
declare IBE6 [simp]
declare IBE7 [simp]
declare IBE8 [simp]
declare IOE01 [simp]
declare IOE02 [simp]
declare IOE03 [simp]
declare IOE04 [simp]
declare IOE05 [simp]
declare IOE06 [simp]
declare IOE07 [simp]
declare IOE08 [simp]
declare IOE09 [simp]
declare LeIrreflexivity [simp]
declare LeTAsymmetry [simp]
declare GeIrreflexivity [simp]
declare GeTAsymmetry [simp]
declare GeTTransitive [simp]
declare GeTTotal [simp]
declare LeqReflexivity [simp]
declare LeqTTransitive [simp]
declare LeqTTotal [simp]
declare GeqReflexivity [simp]
declare GeqTTransitive [simp]
declare GeqTTotal [simp]
declare CmpLTDef [simp]
declare CmpEQDef [simp]
declare CmpGTDef [simp]
declare MaxYDef [simp]
declare MaxXDef [simp]
declare MinXDef [simp]
declare MinYDef [simp]
declare TO2 [simp]
declare TO4 [simp]
declare TO6 [simp]
declare IOO13 [simp]
declare IOO14 [simp]
declare IOO15 [simp]
declare IOO16 [simp]
declare IOO17 [simp]
declare IOO18 [simp]
declare IOO19 [simp]
declare IOO20 [simp]
declare IOO21 [simp]
declare IOO22 [simp]
declare IOO23 [simp]
declare IOO24 [simp]
declare IOO25 [simp]
declare IOO26 [simp]
declare IOO27 [simp]
declare IOO28 [simp]
declare IOO29 [simp]
declare IOO30 [simp]
declare IOO31 [simp]
declare IOO32 [simp]
declare IOO33 [simp]
declare IBO5 [simp]
declare IBO6 [simp]
declare IBO7 [simp]
declare IBO8 [simp]
declare IBO9 [simp]
declare IBO10 [simp]
declare IBO11 [simp]
declare IBO12 [simp]
declare IUO05 [simp]
declare IUO06 [simp]
declare IUO07 [simp]
declare EitherLeftDef [simp]
declare EitherRightDef [simp]
declare IEE01 [simp]
declare IEE02 [simp]
declare IEE03 [simp]
declare IEO01 [simp]
declare IEO02 [simp]
declare IEO03 [simp]

theorem IEO04 : "ALL x. ALL z. Left'(x) >=' Right'(z) = False'"
apply(rule allI)
apply(simp only: GeqDef)
apply(simp only: GeDef OrDef)
apply(case_tac "Right'(y) <' Left'(x)")
apply(auto)
done

ML "Header.record \"IEO04\""

theorem IEO05 : "ALL x. ALL z. Right'(z) >=' Left'(x) = True'"
apply(rule allI)
apply(simp only: GeqDef)
apply(simp only: GeDef OrDef)
apply(case_tac "Left'(x) <' Right'(y)")
apply(auto)
done

ML "Header.record \"IEO05\""

theorem IEO06 : "ALL x. ALL z. Right'(z) <' Left'(x) = False'"
apply(rule allI)
apply(case_tac "Right'(y) <' Left'(x)")
apply(auto)
done

ML "Header.record \"IEO06\""

theorem IEO07 :
"ALL x.
 ALL z.
 compare (Left'(x)) (Right'(z)) ==' EQ = Left'(x) ==' Right'(z)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IEO07\""

theorem IEO08 :
"ALL x.
 ALL z.
 compare (Left'(x)) (Right'(z)) ==' LT = Left'(x) <' Right'(z)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IEO08\""

theorem IEO09 :
"ALL x.
 ALL z.
 compare (Left'(x)) (Right'(z)) ==' GT = Left'(x) >' Right'(z)"
apply(rule allI)+
apply(simp add: GeDef)
done

ML "Header.record \"IEO09\""

theorem IEO10 :
"ALL x.
 ALL z.
 Left'(x) <=' Right'(z) =
 X_max (Left'(x)) (Right'(z)) ==' Right'(z)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IEO10\""

theorem IEO11 :
"ALL x.
 ALL z.
 Right'(z) <=' Left'(x) = X_max (Left'(x)) (Right'(z)) ==' Left'(x)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IEO11\""

theorem IEO12 :
"ALL x.
 ALL z.
 Left'(x) <=' Right'(z) = X_min (Left'(x)) (Right'(z)) ==' Left'(x)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IEO12\""

theorem IEO13 :
"ALL x.
 ALL z.
 Right'(z) <=' Left'(x) =
 X_min (Left'(x)) (Right'(z)) ==' Right'(z)"
apply(rule allI)+
apply(simp add: LeqDef)
done

ML "Header.record \"IEO13\""

end


theory CallFutures
imports Vars "Nominal-Utils" "Set-Cpo"
begin

type_synonym future = "var \<Rightarrow> nat"

definition no_future :: future where [simp]: "no_future v = 0"

definition possible :: "var \<Rightarrow> future \<Rightarrow> bool"
  where "possible v f = (f v > 0)"

inductive_set domF :: "future \<Rightarrow> var set" for f
  where "possible v f \<Longrightarrow> v \<in> domF f"

lemma possible_eqvt[eqvt]: "\<pi> \<bullet> possible v f = possible (\<pi> \<bullet> v) (\<pi> \<bullet> f)"
  unfolding possible_def by simp

definition after :: "var \<Rightarrow> future \<Rightarrow> future"
  where "after v f = (f(v := f v - 1))"

lemma after_eqvt[eqvt]: "\<pi> \<bullet> after v f = after (\<pi> \<bullet> v) (\<pi> \<bullet> f)"
  unfolding after_def by simp

lemma after_swap: "after x (after y f) = after y (after x f)"
  unfolding after_def by auto

definition without :: "var \<Rightarrow> future \<Rightarrow> future"
  where "without v f = (f(v := 0))"

lemma without_eqvt[eqvt]: "\<pi> \<bullet> without v f = without (\<pi> \<bullet> v) (\<pi> \<bullet> f)"
  unfolding without_def by simp

type_synonym futures = "var \<Rightarrow> future set"

definition combine :: "future \<Rightarrow> future \<Rightarrow> future"
  where [simp]: "combine f1 f2 v = f1 v + f2 v"

lemma combine_nofuture[simp]: "combine no_future f = f" by auto
lemma combine_nofuture2[simp]: "combine f no_future = f" by auto

definition future_add :: "future set \<Rightarrow> future set \<Rightarrow> future set"
  where "future_add fs fs' = fs \<union> fs' \<union> {f . \<exists> f1 \<in> fs. \<exists> f2 \<in> fs'. f = combine f1 f2}"

lemma future_add_subset1:
  "fs \<subseteq> future_add fs fs'"
    unfolding future_add_def by auto
lemma future_add_subset2:
  "fs' \<subseteq> future_add fs fs'"
    unfolding future_add_def by auto

lemma future_addE:
  assumes "f \<in> future_add fs fs'"
  obtains "f \<in> fs" | "f \<in> fs'" | f' f'' where "f = combine f' f''" "f' \<in> fs" "f'' \<in> fs'"
  using assms
  unfolding future_add_def by auto

lemma combine_comm: "combine f f' = combine f' f"
  by (auto simp add: combine_def)

lemma combine_assoc[simp]: "combine f (combine f' f'') = combine (combine f f') f''"
  by (auto simp add: combine_def)

lemma combine_mem_add_subset[intro]:
  "f \<in> fs \<Longrightarrow> f' \<in> fs' \<Longrightarrow> combine f f' \<in> future_add fs fs'"
  unfolding future_add_def
  by auto

lemma future_add_assoc:
  "future_add fs (future_add fs' fs'') = future_add (future_add fs fs') fs''"
  apply (auto elim!: future_addE
           intro: set_mp[OF future_add_subset1] set_mp[OF future_add_subset2])
  apply auto
  apply (auto simp add: combine_assoc[symmetric] simp del: combine_assoc)
  done

lemma future_add_comm:
  "future_add fs fs' = future_add fs' fs"
  unfolding future_add_def
  apply (auto elim!: future_addE)
  apply (subst combine_comm, auto)+
  done

lemma future_add_twist:
  "future_add fs (future_add fs' fs'') = future_add (future_add fs' fs) fs''"
  by (metis future_add_assoc future_add_comm)

(*
definition may_call :: "var \<Rightarrow> future set \<Rightarrow> future set"
  where "may_call v fs = {f . \<exists> f' \<in> fs. \<forall> x. x \<noteq> v \<longrightarrow> f x = f' x}"
*)

definition many_calls :: "var set \<Rightarrow> future set"
  where "many_calls S = {f . \<forall> x. x \<notin> S \<longrightarrow> f x = 0}"

lemma not_future_many_calls[simp]:
  "no_future \<in> many_calls S" by (simp add: many_calls_def)

lemma not_future_upd_many_calls[simp, intro]:
  "x \<in> S \<Longrightarrow> f \<in> many_calls S \<Longrightarrow> f(x := n) \<in> many_calls S" by (simp add: many_calls_def)

definition may_call :: "var \<Rightarrow> future set \<Rightarrow> future set"
  where "may_call v fs = future_add (many_calls {v}) fs"

lemma may_call_multiple_calls: "(\<exists>f\<in>may_call x fs. Suc 0 < f x') \<longleftrightarrow> x' = x \<or> (\<exists>f\<in>fs. 1 < f x')"
  unfolding may_call_def
  apply rule
  apply (auto elim!: future_addE simp add: many_calls_def  intro: set_mp[OF future_add_subset1] set_mp[OF future_add_subset2])
  apply (rule bexI[where x = "no_future(x:=2)"])
  apply (auto intro: set_mp[OF future_add_subset1] set_mp[OF future_add_subset2])
  done

lemma future_add_may_call_twist:
  "future_add fs (may_call x fs') = future_add (may_call x fs) fs'"
  unfolding may_call_def by (metis future_add_assoc future_add_comm)

(* http://stackoverflow.com/questions/16603886/inductive-set-with-non-fixed-parameters *)

inductive paths' :: "futures \<Rightarrow> future set \<Rightarrow> var list \<Rightarrow> bool" for G
  where "paths' G current []"
  | "f \<in> current \<Longrightarrow> possible x f \<Longrightarrow> paths' G (future_add {after x f} (G x)) path \<Longrightarrow> paths' G current (x#path)"

definition paths  :: "futures \<Rightarrow> future set \<Rightarrow> var list set"
  where "paths G current = Collect (paths' G current)"
lemma elim_paths'[pred_set_conv]: "paths' G f p \<longleftrightarrow> p \<in> paths G f" unfolding paths_def by simp

lemmas paths_intros[intro?] = paths'.intros[unfolded elim_paths']
lemmas paths_induct[consumes 1, induct set: paths] = paths'.induct[to_set]
lemmas paths_cases[consumes 1, cases set: paths] = paths'.cases[to_set]
lemmas paths_simpss = paths'.simps[to_set]

lemma possible_no_future[simp]: "possible xa no_future \<longleftrightarrow> False"
  by (auto simp add: possible_def no_future_def)

lemma possible_upd[simp]: "possible x' (f(x := n)) \<longleftrightarrow> (x = x' \<and> n > 0) \<or> (possible x' f \<and> x' \<noteq> x)"
  by (auto simp add: possible_def no_future_def)

lemma after_upd[simp]: "after x (f(x := n)) = f(x := n - 1)"
  by (auto simp add: after_def)

lemma no_future_upd0[simp]: "no_future(x := 0) = no_future"
  by (auto simp add: no_future_def)

(*
lemma may_call_cont: "cont (may_call v)" sorry
lemmas may_call_cont[cont2cont, simp]
*)

definition restrict_future :: "var set \<Rightarrow> future \<Rightarrow> future"
  where "restrict_future S f x = (if x \<in> S then f x else 0)"

text {* Some tests *}

lemma cons_eq_replicate[simp]: "x'#xs = replicate n x \<longleftrightarrow> x' = x \<and> n > 0 \<and> xs = replicate (n - 1) x"
  by (cases n) auto

lemma snoc_eq_replicate[simp]: "xs @ [x'] = replicate n x  \<longleftrightarrow> x' = x \<and> n > 0 \<and> xs = replicate (n - 1) x"
proof-
  have "xs @ [x'] = replicate n x \<longleftrightarrow> rev (xs @ [x']) = rev (replicate n x)" by (metis rev_rev_ident)
  also have "\<dots> \<longleftrightarrow> rev (xs @ [x']) = replicate n x" by (metis rev_replicate)
  also have "\<dots> \<longleftrightarrow> x'# (rev xs)  = replicate n x" by (metis rev.simps(2) rev_rev_ident)
  also have "\<dots> \<longleftrightarrow> x' = x \<and> n > 0 \<and> rev xs = replicate (n - 1) x" by (rule cons_eq_replicate)
  also have "\<dots> \<longleftrightarrow> x' = x \<and> n > 0 \<and> xs = replicate (n - 1) x" by (metis rev_rev_ident rev_replicate)
  finally show ?thesis.
qed

lemma [simp]: "replicate n x @ [x'] = replicate n' x \<longleftrightarrow> n' = Suc n \<and> x' = x"
  by auto
(*

lemma
  fixes G current
  assumes [simp]:"G = ((\<lambda> _. {})(x := current))"
  assumes [simp]:"current = {no_future(x := 1)}"
  shows "paths G current = {replicate n x | n. True}"
proof(rule set_eqI, rule)
  fix p
  assume "p \<in> paths G current"
  from  this `current = _`
  show "p \<in> {replicate n x |n. True}" by (induction) auto
next
  fix p
  assume "p \<in> {replicate n x |n. True}"
  then obtain n where "p = replicate n x" by auto
  thus "p \<in> paths G current"
  by (induction p arbitrary: n)(auto intro: paths_intros)
qed

lemma
  assumes [simp]: "x\<noteq>y"
  assumes [simp]:"G = ((\<lambda> _. {})(x := current, y := {no_future}))"
  assumes [simp]:"current = {no_future(x := 1), no_future(y := 1)}"
  shows "paths G current = {replicate n x | n. True} \<union> {replicate n x @ [y]| n. True}"
proof(rule set_eqI, rule)
  fix p
  assume "p \<in> paths G current"
  hence "(current = {no_future} \<Longrightarrow> p = [])" and "current = {no_future(x := 1), no_future(y := 1)} \<Longrightarrow> p \<in> {replicate n x | n. True} \<union>  {replicate n x @ [y]| n. True}"
    by induction (auto, arith+)
  with `current = _`
  show "p \<in> {replicate n x | n. True} \<union>  {replicate n x @ [y]| n. True}" by blast
next
  fix p
  {
  fix n
  have "replicate n x \<in> paths G current"
    by (induction n) (auto intro: paths_intros (1) paths_intros(2)[where f = "no_future(x := Suc 0)"])
  moreover
  have "replicate n x @ [y] \<in> paths G current"
    by (induction n) (auto intro: paths_intros(1) paths_intros(2)[where f = "no_future(x := Suc 0)"]  paths_intros(2)[where f = "no_future(y := Suc 0)"])
  moreover
  note calculation
  }
  moreover
  assume  "p \<in> {replicate n x | n. True} \<union>  {replicate n x @ [y]| n. True}"
  ultimately
  show "p \<in> paths G current" by blast
qed
*)

end