theory NonFree
imports "SetoidIsotrans" "~~/src/HOL/Library/FuncSet" Equiv_Relation2
begin

section{* Combinators *}

term list_all2

definition map2 where
"map2 f xl yl \<equiv> map (split f) (zip xl yl)"

lemma list_all2_Nil_iff:
assumes "list_all2 R xs ys"
shows "xs = [] \<longleftrightarrow> ys = []"
using assms by (cases xs, cases ys) auto

lemma list_all2_NilL[simp]:
"list_all2 R [] ys \<longleftrightarrow> ys = []"
using list_all2_Nil_iff by auto

lemma list_all2_NilR[simp]:
"list_all2 R xs [] \<longleftrightarrow> xs = []"
using list_all2_Nil_iff by auto

lemma list_all2_ConsL:
assumes "list_all2 R (x # xs') ys"
shows "\<exists> y ys'. ys = y # ys' \<and> R x y \<and> list_all2 R xs' ys'"
using assms by(cases ys) auto

lemma list_all2_elimL[elim, consumes 2, case_names Cons]:
assumes xs: "xs = x # xs'" and h: "list_all2 R xs ys"
and Cons: "\<And> y ys'. \<lbrakk>ys = y # ys'; R x y; list_all2 R xs' ys'\<rbrakk> \<Longrightarrow> phi"
shows phi
using list_all2_ConsL assms by metis

lemma list_all2_elimL2[elim, consumes 1, case_names Cons]:
assumes h: "list_all2 R (x # xs') ys"
and Cons: "\<And> y ys'. \<lbrakk>ys = y # ys'; R x y; list_all2 R xs' ys'\<rbrakk> \<Longrightarrow> phi"
shows phi
using list_all2_ConsL assms by metis

lemma list_all2_ConsR:
assumes "list_all2 R xs (y # ys')"
shows "\<exists> x xs'. xs = x # xs' \<and> R x y \<and> list_all2 R xs' ys'"
using assms by(cases xs) auto

lemma list_all2_elimR[elim, consumes 2, case_names Cons]:
assumes ys: "ys = y # ys'" and h: "list_all2 R xs ys"
and Cons: "\<And> x xs'. \<lbrakk>xs = x # xs'; R x y; list_all2 R xs' ys'\<rbrakk> \<Longrightarrow> phi"
shows phi
using list_all2_ConsR assms by metis

lemma list_all2_elimR2[elim, consumes 1, case_names Cons]:
assumes h: "list_all2 R xs (y # ys')"
and Cons: "\<And> x xs'. \<lbrakk>xs = x # xs'; R x y; list_all2 R xs' ys'\<rbrakk> \<Longrightarrow> phi"
shows phi
using list_all2_ConsR assms by metis

lemma ex_list_all2:
assumes "\<And>x. x \<in> set xs \<Longrightarrow> \<exists>y. f x y"
shows "\<exists> ys. list_all2 f xs ys"
using assms apply(induct xs)
apply fastforce
by (metis set.simps insertCI list_all2_Cons)

lemma list_all2_cong[fundef_cong]:
assumes "xs1 = ys1" and "xs2 = ys2"
and "\<And> i . i < length xs2 \<Longrightarrow> R (xs1!i) (xs2!i) \<longleftrightarrow> R' (ys1!i) (ys2!i)"
shows "list_all2 R xs1 xs2 \<longleftrightarrow> list_all2 R' ys1 ys2"
by (metis assms list_all2_conv_all_nth)

lemma set_list_size:
assumes "x \<in> set xs"
shows "f x \<le> list_size f xs"
by (metis assms list_size_estimation' order_eq_refl)

lemma nth_list_size:
assumes "i < length xs"
shows "f (xs!i) \<le> list_size f xs"
by (metis assms nth_mem set_list_size)

lemma list_all2_list_all[simp]:
"list_all2 (\<lambda> x y. f y) xs ys \<longleftrightarrow>
 length xs = length ys \<and> list_all f ys"
by (metis list_all2_conv_all_nth list_all_length)

lemma list_all2_list_all_2[simp]:
"list_all2 f xs xs \<longleftrightarrow> list_all (\<lambda> x. f x x) xs"
unfolding list_all2_def list_all_iff
by (metis splitD splitI2 zip_same)

lemma length_map2[simp]:
assumes "length ys = length xs"
shows "length (map2 f xs ys) = length xs"
using assms unfolding map2_def by auto

lemma listAll2_map2I[intro?]:
assumes "length xs = length ys" and "\<And> x y. R x (f x y)"
shows "list_all2 R xs (map2 f xs ys)"
apply(rule list_all2I) using assms unfolding set_zip map2_def by auto

term "(product,list_all2)"

lemma product_length:
assumes "as \<in> product As"
shows "length as = length As"
using assms apply(induct As arbitrary: as) by auto

lemma list_all2_product:
"list_all2 f xs ys \<longleftrightarrow> ys \<in> product (map (\<lambda> x. {y. f x y}) xs)"
proof-
  {assume "length xs = length ys"
   hence ?thesis
   apply(induct rule: list_induct2) by auto
  }
  thus ?thesis
  using product_length list_all2_lengthD
  by (metis length_map)
qed

abbreviation
  setf_to_predf where
 "setf_to_predf f \<equiv> (% x y. y \<in> f x)"

lemma setf_to_predf_Collect:
  "setf_to_predf Collect f = f" by auto

lemma in_product_list_all2[simp]:
"ys \<in> product (map f xs) \<longleftrightarrow> list_all2 (setf_to_predf f) xs ys"
unfolding list_all2_product by simp

lemma product_list_all2:
"product (map f xs) = Collect (list_all2 (setf_to_predf f) xs)"
by auto

section {* Horn theory *}

datatype var = var nat
datatype pvar = pvar nat
  (* terms are either variables or term operations (Op) applied to terms: *)
  (* parameter variablen seien so gesorted wie von arOfP vorgeschrieben *)
  (* Sortierung ist Teil der Identitaet von Variablen *)
datatype ('sort,'opsym) trm =
  Var 'sort var | Op 'opsym "pvar list" "('sort,'opsym) trm list"

  (* atomic formulas (atoms) are either equational or relational atoms: *)
  (* die Sorten der pvars werden durch die psorts beschrieben
     und die Interpretation der parameter condition ist fix, steht also gleich als
     Praedikat auf Parametern drin *)
  (* Pconds are relations on parameters with a fixed semantic interpretation;
     they are not characterized via Horn clauses *)
datatype ('sort,'opsym,'rlsym,'psort,'param) atm =
  Pcond "'param list \<Rightarrow> bool" "'psort list" "pvar list" |
  Eq 'sort "('sort,'opsym) trm" "('sort,'opsym) trm" |
  Rl 'rlsym "pvar list" "('sort,'opsym) trm list"

(* Horn clauses: *)
datatype ('sort,'opsym,'rlsym,'psort,'param) hcl =
Horn "('sort,'opsym,'rlsym,'psort,'param) atm list"
     "('sort,'opsym,'rlsym,'psort,'param) atm"

locale Signature =
  fixes stOf :: "'opsym \<Rightarrow> 'sort"
    and arOfP :: "'opsym \<Rightarrow> 'psort list"
    and arOf :: "'opsym \<Rightarrow> 'sort list"
    and rarOf :: "'rlsym \<Rightarrow> 'sort list"
    and rarOfP :: "'rlsym \<Rightarrow> 'psort list"
    and params :: "'psort \<Rightarrow> 'param \<Rightarrow> bool"
    and prels :: "(('param list \<Rightarrow> bool) * 'psort list) set"
begin

function trms :: "'sort \<Rightarrow> ('sort,'opsym) trm \<Rightarrow> bool"
where
"trms s (Var s' x) \<longleftrightarrow> s' = s"
|
"trms s (Op \<sigma> pxl Tl) \<longleftrightarrow>
 stOf \<sigma> = s \<and>
 length pxl = length (arOfP \<sigma>) \<and>
 list_all2 trms (arOf \<sigma>) Tl"
by(pat_completeness) auto
termination apply (relation "measure (size o snd)")
apply force
apply simp by (smt nth_list_size)

lemma trms_induct[induct pred: trms, consumes 1, case_names Var Op]:
assumes 0: "trms s T"
and Var: "\<And> s x. phi s (Var s x)"
and Op:
"\<And> \<sigma> pxl Tl.
  \<lbrakk>length pxl = length (arOfP \<sigma>);
   list_all2 trms (arOf \<sigma>) Tl; list_all2 phi (arOf \<sigma>) Tl\<rbrakk>
  \<Longrightarrow> phi (stOf \<sigma>) (Op \<sigma> pxl Tl)"
shows "phi s T"
proof-
  have "\<forall>s. trms s T \<longrightarrow> phi s T"
  apply(induct T rule:
        trm.inducts(1)[of "\<lambda> T. \<forall> s. trms s T \<longrightarrow> phi s T"
                          "\<lambda> Tl. \<forall> sl. list_all2 trms sl Tl \<longrightarrow> list_all2 phi sl Tl"])
  using Var Op by auto
  thus ?thesis using 0 by auto
qed

inductive inhab :: "'sort \<Rightarrow> bool"
where
inhabI: "\<lbrakk>stOf \<sigma> = s; \<And> s2. s2 \<in> set (arOf \<sigma>) \<Longrightarrow> inhab s2\<rbrakk> \<Longrightarrow> inhab s"

lemma inhabI2:
"\<lbrakk>stOf \<sigma> = s; list_all inhab (arOf \<sigma>)\<rbrakk> \<Longrightarrow> inhab s"
by (simp add: list_all_iff inhabI)

definition compat where
"compat intSt intOp \<equiv>
 \<forall> \<sigma> pl al.
   list_all2 params (arOfP \<sigma>) pl \<and>
   list_all2 intSt (arOf \<sigma>) al \<longrightarrow>
   intSt (stOf \<sigma>) (intOp \<sigma> pl al)"

lemma compat_elim[elim?]:
assumes "compat intSt intOp"
and "list_all2 params (arOfP \<sigma>) pl"
and "list_all2 intSt (arOf \<sigma>) al"
shows "intSt (stOf \<sigma>) (intOp \<sigma> pl al)"
using assms unfolding compat_def by auto

(* A model is a triple (intSt, intOp, intRl) where compat intSt intOp holds *)

(* interpretation of terms in a model, parameterized by an interpretation of
variables *)
fun intTrm ::
"('opsym \<Rightarrow> 'param list \<Rightarrow> 'a list \<Rightarrow> 'a)
  \<Rightarrow> ('psort \<Rightarrow> pvar \<Rightarrow> 'param) \<Rightarrow> ('sort \<Rightarrow> var \<Rightarrow> 'a)
  \<Rightarrow> ('sort,'opsym) trm \<Rightarrow> 'a"
where
"intTrm intOp intPvar intVar (Var s x) = intVar s x"
|
"intTrm intOp intPvar intVar (Op \<sigma> pxl ts) =
 intOp \<sigma>
   (map2 intPvar (arOfP \<sigma>) pxl)
   (map (intTrm intOp intPvar intVar) ts)"

lemma intTrm_intSt:
assumes PVAR: "\<And> ps px. params ps (intPvar ps px)" and
VAR: "\<And> s x. intSt s (intVar s x)"
and OP: "compat intSt intOp" and 0: "trms s T"
shows "intSt s (intTrm intOp intPvar intVar T)"
using 0 proof (induct)
  fix \<sigma> Tl and pxl :: "pvar list"
  let ?intTrm = "intTrm intOp intPvar intVar"
  let ?ar = "arOf \<sigma>"  let ?arP = "arOfP \<sigma>" let ?s = "stOf \<sigma>"
  assume l: "length pxl = length (arOfP \<sigma>)"
  and IH: "list_all2 (\<lambda>s T. intSt s (?intTrm T)) ?ar Tl"
  show "intSt ?s (?intTrm (Op \<sigma> pxl Tl))"
  unfolding intTrm.simps using OP proof
    show "list_all2 params ?arP (map2 intPvar ?arP pxl)"
    apply default using PVAR l by auto
  next
    show "list_all2 intSt ?ar (map ?intTrm Tl)"
    using IH unfolding list_all2_map2 .
  qed
qed(insert VAR, auto)

(* satisfaction of an equational atom by a model under a variable interpretation *)
definition satPcond where
"satPcond intPvar R psl pxl \<equiv> R (map2 intPvar psl pxl)
 ::bool"

definition satEq where
"satEq intOp intEq intPvar intVar T1 T2 \<equiv>
 intEq (intTrm intOp intPvar intVar T1) (intTrm intOp intPvar intVar T2)
 ::bool"

(* satisfaction of an relational atom by a model *)
definition satRl where
"satRl intOp intRl intPvar intVar \<pi> pxl Tl \<equiv>
 intRl \<pi>
   (map2 intPvar (rarOfP \<pi>) pxl)
   (map (intTrm intOp intPvar intVar) Tl)
 ::bool"

(* satisfaction of an atom by a model: *)
definition satAtm where
"satAtm intOp intEq intRl intPvar intVar atm \<equiv>
 case atm of
   Pcond R psl pxl \<Rightarrow> satPcond intPvar R psl pxl
 | Eq s T1 T2 \<Rightarrow> satEq intOp intEq intPvar intVar T1 T2
 | Rl \<pi> pxl Tl \<Rightarrow> satRl intOp intRl intPvar intVar \<pi> pxl Tl"

(* satisfaction of a Horn clause by a model: *)
definition satHcl where
"satHcl intSt intOp intEq intRl hcl \<equiv>
 case hcl of Horn atml atm \<Rightarrow>
 \<forall> intPvar intVar.
    (\<forall> ps px. params ps (intPvar ps px)) \<and> (\<forall> s x. intSt s (intVar s x)) \<longrightarrow>
    list_all (satAtm intOp intEq intRl intPvar intVar) atml \<longrightarrow>
    satAtm intOp intEq intRl intPvar intVar atm"
  (* vermutlich besser in der Form:
     ALL intPvar : compatPvar. ALL intVar : compatVar intST.
        list_all (satAtm intSt ...) atml --> satAtm intST ... atm *)

definition compatAtm where
  "compatAtm atm \<equiv>
 case atm of
   Pcond R psl pxl \<Rightarrow> (R, psl) \<in> prels \<and> length psl = length pxl
 | Eq s T1 T2 \<Rightarrow> trms s T1 \<and> trms s T2
 | Rl \<pi> pxl ts \<Rightarrow>
     length pxl = length (rarOfP \<pi>) \<and>
     list_all2 trms (rarOf \<pi>) ts"

definition compatHcl where
"compatHcl hcl \<equiv>
 case hcl of Horn atml atm \<Rightarrow>
   (\<forall> R psl pxl. atm \<noteq> Pcond R psl pxl) \<and>
   list_all compatAtm atml \<and> compatAtm atm"

end (* context Signature *)
(**************************)

datatype ('sort,'opsym,'param) gtrm =
Gop 'opsym "'param list" "('sort,'opsym,'param) gtrm list"

(* the factored type will consists of equiv. classes, i.e., of sets: *)
type_synonym ('sort,'opsym,'param) trmHCL = "(('sort,'opsym,'param) gtrm) set"

(* NB: HOL types have to be nonempty, so we might have to invent
   dummy psorts, rlsyms. (sorts, opsyms can be assumed) *)
locale HornTheory = Signature stOf arOfP arOf rarOf rarOfP params prels
  for stOf :: "'opsym \<Rightarrow> 'sort"
  and arOfP :: "'opsym \<Rightarrow> 'psort list"
  and arOf :: "'opsym \<Rightarrow> 'sort list"
  and rarOf :: "'rlsym \<Rightarrow> 'sort list"
  and rarOfP :: "'rlsym \<Rightarrow> 'psort list"
  and params :: "'psort \<Rightarrow> 'param \<Rightarrow> bool"
  and prels :: "(('param list \<Rightarrow> bool) * 'psort list) set" +
  fixes HCL :: "('sort,'opsym,'rlsym,'psort,'param) hcl set"
  assumes compatHCL: "\<And> hcl. hcl \<in> HCL \<Longrightarrow> compatHcl hcl"
      and inhab_assm: "\<And> s. inhab s"
      and ex_params: "\<And> ps. \<exists> p. params ps p"
begin

lemma ex_list_all2_params:
"\<exists> pl. list_all2 params psl pl"
by (metis ex_list_all2 ex_params)

subsection {* Ground terms *}

function gtrms :: "'sort \<Rightarrow> ('sort,'opsym,'param) gtrm \<Rightarrow> bool"
where
"gtrms s (Gop \<sigma> pl Gl) \<longleftrightarrow>
 stOf \<sigma> = s \<and>
 list_all2 params (arOfP \<sigma>) pl \<and>
 list_all2 gtrms (arOf \<sigma>) Gl"
by(pat_completeness) auto
termination apply (relation "measure (size o snd)")
apply force
apply simp by (smt nth_list_size)

lemma gtrms_induct[induct pred: gtrms, consumes 1, case_names Gop]:
assumes 0: "gtrms s G"
and Gop:
"\<And> \<sigma> pl Gl.
  \<lbrakk>list_all2 params (arOfP \<sigma>) pl;
   list_all2 gtrms (arOf \<sigma>) Gl;
   list_all2 phi (arOf \<sigma>) Gl\<rbrakk>
  \<Longrightarrow> phi (stOf \<sigma>) (Gop \<sigma> pl Gl)"
shows "phi s G"
proof-
  have "\<forall>s. gtrms s G \<longrightarrow> phi s G"
  apply(induct G rule:
        gtrm.inducts(1)[of "\<lambda> Gl. \<forall> sl. list_all2 gtrms sl Gl \<longrightarrow> list_all2 phi sl Gl"
                           "\<lambda> G. \<forall> s. gtrms s G \<longrightarrow> phi s G"])
  using Gop by auto
  thus ?thesis using 0 by auto
qed

lemma gtrms_disj:
assumes "gtrms s G" and "s \<noteq> s'"
shows "\<not> gtrms s' G"
using assms by (induct arbitrary: s') auto

lemma inhab_imp_ex_gtrms:
assumes "inhab s" shows "\<exists> G. gtrms s G"
using assms proof induct
  fix \<sigma> s let ?ar = "arOf \<sigma>" let ?arP = "arOfP \<sigma>"
  assume s: "stOf \<sigma> = s" and
  IH: "\<And>s2. s2 \<in> set ?ar \<Longrightarrow> \<exists>G. gtrms s2 G"
  obtain Gl where Gl: "list_all2 gtrms ?ar Gl"
  using ex_list_all2[of ?ar gtrms, OF IH] by blast
  obtain pl where pl: "list_all2 params (arOfP \<sigma>) pl"
  using ex_list_all2_params by blast
  show "\<exists>G. gtrms s G"
  apply(rule exI[of _ "Gop \<sigma> pl Gl"]) using pl Gl s by simp
qed

lemma ex_gtrms: "\<exists> G. gtrms s G"
using inhab_assm inhab_imp_ex_gtrms by auto

lemma compat_gtrms:
"compat gtrms Gop"
unfolding compat_def by auto

subsection {* The HCL-induced relations *}

lemma set_incl_pred:
"A \<le> B \<longleftrightarrow> (\<forall> a. A a \<longrightarrow> B a)"
by (metis predicate1D predicate1I)

lemma set_incl_pred2:
"A \<le> B \<longleftrightarrow> (\<forall> a1 a2. A a1 a2 \<longrightarrow> B a1 a2)"
by (metis predicate2I rev_predicate2D)

lemma set_incl_pred3:
"A \<le> B \<longleftrightarrow> (\<forall> a1 a2 a3. A a1 a2 a3 \<longrightarrow> B a1 a2 a3)" (is "_ \<longleftrightarrow> ?R")
proof-
  have "A \<le> B \<longleftrightarrow> (\<forall> a1. A a1 \<le> B a1)" by (metis le_funD le_funI)
  also have "... \<longleftrightarrow> ?R" apply(rule iff_allI)
  unfolding set_incl_pred2 ..
  finally show ?thesis .
qed

lemma set_incl_pred4:
"A \<le> B \<longleftrightarrow> (\<forall> a1 a2 a3 a4. A a1 a2 a3 a4 \<longrightarrow> B a1 a2 a3 a4)" (is "_ \<longleftrightarrow> ?R")
proof-
  have "A \<le> B \<longleftrightarrow> (\<forall> a1. A a1 \<le> B a1)" by (metis le_funD le_funI)
  also have "... \<longleftrightarrow> ?R" apply(rule iff_allI)
  unfolding set_incl_pred3 ..
  finally show ?thesis .
qed

lemma list_all_mono:
assumes "phi \<le> chi"
shows "list_all phi \<le> list_all chi"
using assms unfolding set_incl_pred list_all_iff by auto

lemma list_all2_mono:
assumes "phi \<le> chi"
shows "list_all2 phi \<le> list_all2 chi"
using assms by (metis (full_types) list_all2_mono set_incl_pred2)

lemma satEq_mono:
assumes "Geq \<le> Geq2"
shows "satEq Gop Geq intPvar intVar \<le>
       satEq Gop Geq2 intPvar intVar"
using assms unfolding set_incl_pred2 satEq_def by auto

lemma satRl_mono:
assumes "Grel \<le> Grel2"
shows "satRl Gop Grel intPvar intVar \<le>
       satRl Gop Grel2 intPvar intVar"
using assms unfolding set_incl_pred3 satRl_def by auto

lemma satAtm_mono:
assumes e: "Geq \<le> Geq2" and r: "Grel \<le> Grel2"
shows "satAtm Gop Geq Grel intPvar intVar \<le>
       satAtm Gop Geq2 Grel2 intPvar intVar"
using satEq_mono[OF e] satRl_mono[OF r]
unfolding set_incl_pred set_incl_pred2 set_incl_pred3 satAtm_def
apply clarify by (case_tac a, auto)

subsection{* The Horn-determined relations on ground terms *}

inductive
Geq :: "('sort,'opsym,'param) gtrm \<Rightarrow> ('sort,'opsym,'param) gtrm \<Rightarrow> bool"
and
Grel :: "'rlsym \<Rightarrow> 'param list \<Rightarrow> ('sort,'opsym,'param) gtrm list \<Rightarrow> bool"
where
Refl[simp,intro]:
"Geq G G"
|
Sym:
"Geq G1 G2 \<Longrightarrow> Geq G2 G1"
|
Trans:
"\<lbrakk>Geq G1 G2; Geq G2 G3\<rbrakk> \<Longrightarrow> Geq G1 G3"
|
GeqGop:
"\<lbrakk>list_all2 params (arOfP \<sigma>) pl;
  list_all2 gtrms (arOf \<sigma>) Gl; list_all2 gtrms (arOf \<sigma>) Gl';
  list_all2 Geq Gl Gl'\<rbrakk> \<Longrightarrow>
  Geq (Gop \<sigma> pl Gl) (Gop \<sigma> pl Gl')"|
GeqGrel:
"\<lbrakk>list_all2 Geq Gl Gl'; Grel \<pi> pl Gl\<rbrakk> \<Longrightarrow>
  Grel \<pi> pl Gl'"
|Eq:
"\<lbrakk>Horn atml (Eq s T1 T2) \<in> HCL;
  \<And> ps px. params ps (intPvar ps px); \<And>s x. gtrms s (intVar s x);
  list_all (satAtm Gop Geq Grel intPvar intVar) atml\<rbrakk> \<Longrightarrow>
  Geq (intTrm Gop intPvar intVar T1) (intTrm Gop intPvar intVar T2)"
|Rel:
"\<lbrakk>Horn atml (Rl \<pi> pxl Tl) \<in> HCL;
  \<And> ps px. params ps (intPvar ps px); \<And>s x. gtrms s (intVar s x);
  list_all (satAtm Gop Geq Grel intPvar intVar) atml\<rbrakk> \<Longrightarrow>
  Grel \<pi>
   (map2 intPvar (rarOfP \<pi>) pxl)
   (map (intTrm Gop intPvar intVar) Tl)"
monos list_all_mono list_all2_mono satAtm_mono

lemma GeqGrel2:
assumes l: "list_all2 Geq Gl Gl'"
shows "Grel \<pi> pl Gl \<longleftrightarrow> Grel \<pi> pl Gl'"
proof-
  have l': "list_all2 Geq Gl' Gl"
  using assms unfolding list_all2_def set_zip apply simp
  by (metis Sym)
  show ?thesis using GeqGrel l l' by auto
qed

lemma satEq_Gop:
assumes "Horn atml (Eq s T1 T2) \<in> HCL" and
Pvar: "\<And> ps px. params ps (intPvar ps px)" and
Var: "\<And>s x. gtrms s (intVar s x)" and
atml: "list_all (satAtm Gop Geq Grel intPvar intVar) atml"
shows "satEq Gop Geq intPvar intVar T1 T2"
unfolding satEq_def using Eq[OF assms] .

lemma satRel_Gop:
assumes "Horn atml (Rl \<pi> pxl Tl) \<in> HCL" and
Pvar: "\<And> ps px. params ps (intPvar ps px)" and
Var: "\<And>s x. gtrms s (intVar s x)" and
atml: "list_all (satAtm Gop Geq Grel intPvar intVar) atml"
shows "satRl Gop Grel intPvar intVar \<pi> pxl Tl"
unfolding satRl_def using Rel[OF assms] .

abbreviation "GGeq \<equiv> {(G1,G2) . Geq G1 G2}"

lemma equiv_GGeq:
"equiv UNIV GGeq"
using Refl Sym Trans unfolding equiv_def refl_on_def sym_def trans_def by blast

lemma Geq_Grel_well:
"(Geq G1 G2 \<longrightarrow> ((\<exists> s. gtrms s G1 \<and> gtrms s G2) \<or> G1 = G2))
 \<and>
 (Grel \<pi> pl Gl \<longrightarrow> list_all2 params (rarOfP \<pi>) pl \<and> list_all2 gtrms (rarOf \<pi>) Gl)"
apply(induct rule: Geq_Grel.induct)
  apply force
  apply force
  apply (metis gtrms_disj)
  apply force
proof-
  fix Gl Gl' \<pi> pl
  let ?rar = "rarOf \<pi>" let ?rarP = "rarOfP \<pi>"
  assume IH:
  "list_all2 (\<lambda>G1 G2. Geq G1 G2 \<and> ((\<exists>s. gtrms s G1 \<and> gtrms s G2) \<or> G1 = G2)) Gl Gl'"
  and Gl: "Grel \<pi> pl Gl"
  and 0: "list_all2 params ?rarP pl \<and> list_all2 gtrms ?rar Gl"
  {fix i assume i: "i < length ?rar"
   have "gtrms (?rar!i) (Gl!i)" by (metis 0 i list_all2_nthD)
   moreover have "(\<exists>s. gtrms s (Gl!i) \<and> gtrms s (Gl'!i)) \<or> Gl!i = Gl'!i"
   by (smt 0 IH i list_all2_conv_all_nth)
   ultimately have "gtrms (?rar!i) (Gl'!i)" by (metis gtrms_disj)
  }
  thus "list_all2 params ?rarP pl \<and> list_all2 gtrms ?rar Gl'"
  using 0[THEN conjunct1]
  by (smt 0 IH list_all2_all_nthI list_all2_lengthD)
next
  case (Eq atml s T1 T2 intPvar intVar)
  have "gtrms s (intTrm Gop intPvar intVar T1)"
  apply(rule intTrm_intSt)
    apply (rule Eq(2), rule Eq(3), rule compat_gtrms)
    using compatHCL[OF Eq(1)] unfolding compatHcl_def compatAtm_def by auto
  moreover have "gtrms s (intTrm Gop intPvar intVar T2)"
  apply(rule intTrm_intSt)
    apply (rule Eq(2), rule Eq(3), rule compat_gtrms)
    using compatHCL[OF Eq(1)] unfolding compatHcl_def compatAtm_def by auto
  ultimately show ?case by blast
next
  case (Rel atml \<pi> pxl Tl intPvar intVar)
  show ?case
  apply default
    apply default
      using compatHCL[OF Rel(1)] unfolding compatHcl_def compatAtm_def apply fastforce
      apply (rule Rel(2))
    unfolding list_all2_map2
    using compatHCL[OF Rel(1)] unfolding compatHcl_def compatAtm_def apply simp
    using intTrm_intSt[of intPvar gtrms intVar Gop,
                       OF Rel(2) Rel(3) compat_gtrms]
  by (smt list_all2_cong list_all2_nthD2)
qed

lemma Geq_gtrms:
assumes "Geq G1 G2"
shows "(\<exists> s. gtrms s G1 \<and> gtrms s G2) \<or> G1 = G2"
using assms Geq_Grel_well by blast

lemma Grel_params:
assumes "Grel \<pi> pl Gl"
shows "list_all2 params (rarOfP \<pi>) pl"
using assms Geq_Grel_well by blast

lemma Grel_gtrms:
assumes "Grel \<pi> pl Gl"
shows "list_all2 gtrms (rarOf \<pi>) Gl"
using assms Geq_Grel_well by blast

subsection {* Transition from ground terms to Horn terms (Horn classes of ground terms) *}

definition "clsOf \<equiv> proj GGeq"
definition "htrms s H \<longleftrightarrow> H \<in> UNIV // GGeq \<and> gtrms s (EpsSet H)"
definition "Hop \<sigma> pl Hl = clsOf (Gop \<sigma> pl (map EpsSet Hl))"
definition "Hrel \<pi> pl Hl \<longleftrightarrow> Grel \<pi> pl (map EpsSet Hl)"

(* Pointwise facts: *)
lemma Geq_Eps_clsOf[simp]:
"Geq (EpsSet (clsOf G)) G"
using assms unfolding clsOf_def
using Eps_proj[OF equiv_GGeq] by simp

lemma Geq_Eps_clsOf2[simp]:
"Geq G (EpsSet (clsOf G))"
by (metis Geq_Eps_clsOf Sym)

lemma clsOf:
assumes "gtrms s G"
shows "htrms s (clsOf G)"
unfolding htrms_def apply default
  unfolding clsOf_def proj_in_iff[OF equiv_GGeq] apply fastforce
  using Geq_gtrms[OF Geq_Eps_clsOf, of G] assms
  by (metis (full_types) clsOf_def gtrms_disj)

lemma ex_htrms: "EX H. htrms s H"
  apply rule apply (rule clsOf)
  by (rule someI_ex[OF ex_gtrms])

lemma htrms_clsOf[simp]:
"htrms s (clsOf G) \<longleftrightarrow> gtrms s G"
apply default
unfolding htrms_def using Geq_gtrms[OF Geq_Eps_clsOf, of G]
  apply (metis gtrms_disj)
  by (metis (full_types) clsOf htrms_def)

lemma Eps[simp]:
assumes "htrms s H"
shows "gtrms s (EpsSet H)"
using assms unfolding htrms_def by auto

lemma htrms_in[simp]:
assumes "htrms s H"
shows "H \<in> UNIV // GGeq"
using assms unfolding htrms_def by auto

lemma clsOf_Eps[simp]:
assumes "htrms s H"
shows "clsOf (EpsSet H) = H"
unfolding clsOf_def apply(rule proj_Eps[OF equiv_GGeq]) using htrms_in[OF assms] .

lemma clsOf_surj:
assumes "htrms s H"
shows "\<exists> G. gtrms s G \<and> clsOf G = H"
apply(rule exI[of _ "EpsSet H"]) using assms by auto

lemma clsOf_Geq[simp]:
"clsOf G1 = clsOf G2 \<longleftrightarrow> Geq G1 G2"
unfolding clsOf_def using proj_iff[OF equiv_GGeq] by auto

lemma Geq_Eps[simp]:
assumes "htrms s H1" and "htrms s H2"
shows "Geq (EpsSet H1) (EpsSet H2) \<longleftrightarrow> H1 = H2"
by (metis assms clsOf_Eps clsOf_Geq)

lemma Geq_inj[simp]:
assumes "htrms s H1" and "htrms s H2"
shows "EpsSet H1 = EpsSet H2 \<longleftrightarrow> H1 = H2"
proof-
  have "EpsSet H1 = EpsSet H2 \<Longrightarrow> Geq (EpsSet H1) (EpsSet H2)"
  by (metis Geq_Eps assms)
  hence "EpsSet H1 = EpsSet H2 \<Longrightarrow> H1 = H2" using Geq_Eps[OF assms] by blast
  thus ?thesis by blast
qed

lemma Eps_Geq_surj:
assumes "gtrms s G"
shows "\<exists> H. htrms s H \<and> Geq (EpsSet H) G"
apply(rule exI[of _ "clsOf G"]) using assms by auto

lemma Eps_Geq_surj2:
assumes "gtrms s G"
shows "\<exists> H. htrms s H \<and> Geq G (EpsSet H)"
using Eps_Geq_surj[OF assms] by (metis Sym)

(* List facts: *)
lemmas map_map = "map.compositionality"
declare zip_same[simp]

lemma Geq_Eps_clsOfL[simp]:
"list_all2 Geq (map EpsSet (map clsOf Gl)) Gl"
unfolding map_map list_all2_map1 apply(rule list_all2I) by auto

lemma Geq_Eps_clsOfL_comp[simp]:
"list_all2 Geq (map (EpsSet o clsOf) Gl) Gl"
by (metis Geq_Eps_clsOfL List.map_map)

lemma Geq_Eps_clsOf2L[simp]:
"list_all2 Geq Gl (map EpsSet (map clsOf Gl))"
unfolding map_map list_all2_map2 apply(rule list_all2I) by auto

lemma Geq_Eps_clsOf2L_comp[simp]:
"list_all2 Geq Gl (map (EpsSet o clsOf) Gl)"
by (metis Geq_Eps_clsOf2L List.map_map)

lemma htrms_clsOfL[simp]:
"list_all2 htrms sl (map clsOf Gl) \<longleftrightarrow> list_all2 gtrms sl Gl"
unfolding list_all2_def set_zip apply simp apply safe
apply (metis htrms_clsOf nth_map) by auto

lemma EpsL[simp]:
assumes "list_all2 htrms sl Hl"
shows "list_all2 gtrms sl (map EpsSet Hl)"
using assms unfolding list_all2_def set_zip apply simp apply safe
by (metis Eps nth_map)

lemma htrms_inL[simp]:
assumes "list_all2 htrms sl Hl"
shows "list_all (\<lambda> H. H \<in> UNIV // GGeq) Hl"
unfolding list_all_iff set_conv_nth proof safe
  fix H i assume "i < length Hl"
  hence "htrms (sl!i) (Hl!i)" unfolding list_all2_def set_zip
  by (metis assms list_all2_nthD2)
  thus "Hl ! i \<in> UNIV // GGeq" by simp
qed

lemma clsOf_EpsL[simp]:
assumes "list_all2 htrms sl Hl"
shows "map clsOf (map EpsSet Hl) = Hl"
using assms unfolding map_map list_all2_def set_zip
apply(intro nth_equalityI, simp)
by (smt map_map assms clsOf_Eps length_map list_all2_conv_all_nth nth_map)

lemma clsOf_EpsL_comp[simp]:
assumes "list_all2 htrms sl Hl"
shows "map (clsOf o EpsSet) Hl = Hl"
by (smt List.map_map assms clsOf_EpsL)

lemma clsOf_surjL:
assumes "list_all2 htrms sl Hl"
shows "\<exists> Gl. list_all2 gtrms sl Gl \<and> map clsOf Gl = Hl"
apply(rule exI[of _ "map EpsSet Hl"]) using assms by auto

lemma clsOf_GeqL[simp]:
"map clsOf Gl1 = map clsOf Gl2 \<longleftrightarrow> list_all2 Geq Gl1 Gl2"
unfolding list_eq_iff_nth_eq list_all2_def set_zip apply simp
apply(rule conj_cong)
  apply fastforce
  by (metis clsOf_Geq nth_map)

lemma Geq_EpsL[simp]:
assumes "list_all2 htrms sl Hl1" and "list_all2 htrms sl Hl2"
shows "list_all2 Geq (map EpsSet Hl1) (map EpsSet Hl2) \<longleftrightarrow> Hl1 = Hl2"
by (metis assms clsOf_EpsL clsOf_GeqL)

lemma Geq_injL[simp]:
assumes "list_all2 htrms sl Hl1" and "list_all2 htrms sl Hl2"
shows "map EpsSet Hl1 = map EpsSet Hl2 \<longleftrightarrow> Hl1 = Hl2"
proof-
  have "map EpsSet Hl1 = map EpsSet Hl2 \<Longrightarrow> list_all2 Geq (map EpsSet Hl1) (map EpsSet Hl2)"
  by (metis Geq_EpsL assms)
  hence "map EpsSet Hl1 = map EpsSet Hl2 \<Longrightarrow> Hl1 = Hl2" using Geq_EpsL[OF assms] by blast
  thus ?thesis by blast
qed

lemma Eps_Geq_surjL:
assumes "list_all2 gtrms sl Gl"
shows "\<exists> Hl. list_all2 htrms sl Hl \<and> list_all2 Geq (map EpsSet Hl) Gl"
apply(rule exI[of _ "map clsOf Gl"]) using assms by auto

lemma Eps_Geq_surj2L:
assumes "list_all2 gtrms sl Gl"
shows "\<exists> Hl. list_all2 htrms sl Hl \<and> list_all2 Geq Gl (map EpsSet Hl)"
apply(rule exI[of _ "map clsOf Gl"]) using assms by auto

(* Operations:  *)
lemma clsOf_Gop:
assumes pl: "list_all2 params (arOfP \<sigma>) pl" and Gl: "list_all2 gtrms (arOf \<sigma>) Gl"
shows "clsOf (Gop \<sigma> pl Gl) = Hop \<sigma> pl (map clsOf Gl)"
unfolding Hop_def unfolding clsOf_Geq proof (rule GeqGop)
  show "list_all2 gtrms (arOf \<sigma>) (map EpsSet (map clsOf Gl))"
  unfolding map_map list_all2_map2
  proof (rule list_all2_all_nthI)
    fix i assume i: "i < length (arOf \<sigma>)" let ?ar = "arOf \<sigma>"
    have "gtrms (?ar ! i) (Gl ! i)" by (metis Gl i list_all2_nthD)
    moreover have "Geq (Gl ! i) (EpsSet (clsOf (Gl ! i)))" by (metis Geq_Eps_clsOf2)
    ultimately show "gtrms (?ar ! i) (EpsSet (clsOf (Gl ! i)))" by (metis Eps clsOf)
  qed (metis Gl list_all2_conv_all_nth)
qed (insert assms, auto)

lemma Geq_Eps_Hop:
"Geq (EpsSet (Hop \<sigma> pl Hl)) (Gop \<sigma> pl (map EpsSet Hl))"
unfolding Hop_def by simp

lemma Geq_Eps_Hop2:
"Geq (Gop \<sigma> pl (map EpsSet Hl)) (EpsSet (Hop \<sigma> pl Hl))"
unfolding Hop_def by simp

(* Relations: *)
lemma Hrel_clsOf[simp]:
"Hrel \<pi> pl (map clsOf Gl) \<longleftrightarrow> Grel \<pi> pl Gl"
unfolding Hrel_def apply(rule GeqGrel2) by simp

lemma Grel_Eps[simp]:
"Grel \<pi> pl (map EpsSet Hl) \<longleftrightarrow> Hrel \<pi> pl Hl"
unfolding Hrel_def by simp

lemma inhab_imp_ex_htrms:
assumes "inhab s" shows "\<exists> H. htrms s H"
using inhab_imp_ex_gtrms[OF assms]
by (metis Eps_Geq_surj2)

subsection{* The Horn initial model *}

(* Equational atoms: *)
lemma intTrm_Gop_Geq:
assumes Pvar: "\<And> ps px. params ps (intPvar ps px)"
and Var1: "\<And>s x. gtrms s (intVar1 s x)"
and Var: "\<And>s x. Geq (intVar1 s x) (intVar2 s x)"
and T: "trms s T"
shows "Geq (intTrm Gop intPvar intVar1 T) (intTrm Gop intPvar intVar2 T)"
using T proof (induct rule: trms_induct)
  case (Op \<sigma> pxl Tl)
  let ?arP = "arOfP \<sigma>"  let ?ar = "arOf \<sigma>"
  let ?iT1 = "intTrm Gop intPvar intVar1"
  let ?iT2 = "intTrm Gop intPvar intVar2"
  have Var2: "\<And>s x. gtrms s (intVar2 s x)"
  by (metis Var Var1 clsOf_Geq htrms_clsOf)
  show ?case unfolding intTrm.simps apply(rule GeqGop)
    apply (metis Op(1) Pvar listAll2_map2I)
    apply (metis Op(1) Op(2) Pvar Signature.intTrm.simps(2) Signature.trms.simps(2)
                 Var1 compat_gtrms gtrms.simps intTrm_intSt)
    apply (metis Op(1) Op(2) Pvar Signature.intTrm.simps(2) Signature.trms.simps(2)
                 Var2 compat_gtrms gtrms.simps intTrm_intSt)
    using Op(3) unfolding list_all2_map1 list_all2_map2
    list_all2_list_all list_all2_list_all_2 by simp
qed (metis Var intTrm.simps)

lemma map_nth_factor: "j < length xs ==> map f (map g xs) ! j = f (map g xs ! j)"
 by (metis length_map nth_map)

lemma intTrm_Hop:
assumes Pvar: "\<And> ps px. params ps (intPvar ps px)" and
Var: "\<And>s x. htrms s (intVar s x)" and T: "trms s T"
shows
"intTrm Hop intPvar intVar T =
 clsOf (intTrm Gop intPvar (\<lambda> xs x. EpsSet (intVar xs x)) T)"
using T proof (induct rule: trms_induct)
  case (Op \<sigma> pxl Tl)
  let ?arP = "arOfP \<sigma>"  let ?ar = "arOf \<sigma>"
  let ?iV = "\<lambda> xs x. EpsSet (intVar xs x)"
  let ?hiT = "intTrm Hop intPvar intVar" let ?giT = "intTrm Gop intPvar ?iV"
  have l: "length pxl = length ?arP" and Tl: "list_all2 trms ?ar Tl"
  and IH: "list_all (\<lambda>T. ?hiT T = clsOf (?giT T)) Tl"
  using Op unfolding list_all2_list_all by auto
  have 0: "map (intTrm Hop intPvar intVar) Tl = map clsOf (map ?giT Tl)"
  using IH unfolding list_all_iff by simp
  have "?hiT (Op \<sigma> pxl Tl) = clsOf (Gop \<sigma> (map2 intPvar ?arP pxl) (map ?giT Tl))"
  unfolding intTrm.simps 0 apply(rule clsOf_Gop[symmetric])
    apply (metis Pvar l listAll2_map2I)
    unfolding list_all2_map2 proof (rule list_all2_all_nthI)
      fix i assume i: "i < length ?ar"
      have i': "i < length Tl" by (metis (full_types) Tl i list_all2_lengthD)
      have hiT_mapunfold: "?hiT (Tl!i) = (map ?hiT Tl) ! i" by (metis i' nth_map)
      have giT_mapunfold: "?giT (Tl!i) = (map ?giT Tl) ! i" by (metis i' nth_map)
      have 1: "?hiT (Tl!i) = clsOf (?giT (Tl!i))" by (metis (mono_tags) IH i' list_all_length)
      hence "Geq (EpsSet (?hiT (Tl!i))) (?giT (Tl!i))" by (metis Geq_Eps_clsOf)
      moreover
      {have "gtrms (?ar!i) (?giT (Tl!i))"
       apply(rule intTrm_intSt[OF Pvar])
       by(metis Eps Var compat_gtrms Tl i list_all2_conv_all_nth)+
       hence "gtrms (?ar!i) (EpsSet (?hiT (Tl!i)))"
       using Eps 1 htrms_clsOf by auto
      }
      ultimately show "gtrms (?ar!i) (?giT (Tl!i))"
      by (metis clsOf_Geq htrms_clsOf)
    qed (metis Tl list_all2_conv_all_nth)
  also have "... = clsOf (?giT (Op \<sigma> pxl Tl))" by simp
  finally show ?case .
qed(metis Var clsOf_Eps intTrm.simps)

lemma intTrm_Hop_clsOf:
assumes Pvar: "\<And> ps px. params ps (intPvar ps px)" and
Var: "\<And>s x. gtrms s (intVar s x)" and T: "trms s T"
shows
"intTrm Hop intPvar (\<lambda> xs x. clsOf (intVar xs x)) T =
 clsOf (intTrm Gop intPvar intVar T)"
proof-
  def iV \<equiv> "\<lambda> xs x. clsOf (intVar xs x)"
  have VVar: "\<And>s x. htrms s (iV s x)" unfolding iV_def using Var by (metis clsOf)
  show ?thesis
  unfolding intTrm_Hop[of intPvar, OF Pvar VVar T, unfolded iV_def] clsOf_Geq
  apply(rule intTrm_Gop_Geq)
  using Pvar Geq_Eps_clsOf Eps VVar iV_def T by auto
qed

(* Relational atoms: *)
lemma Grel_intTrm_Gop:
assumes Pvar: "\<And> ps px. params ps (intPvar ps px)"
and Var1: "\<And>s x. gtrms s (intVar1 s x)"
and Var: "\<And>s x. Geq (intVar1 s x) (intVar2 s x)"
and Tl: "list_all2 trms (rarOf \<pi>) Tl"
shows "Grel \<pi> pl (map (intTrm Gop intPvar intVar1) Tl) \<longleftrightarrow>
       Grel \<pi> pl (map (intTrm Gop intPvar intVar2) Tl)"
apply(rule GeqGrel2) proof(rule list_all2_all_nthI, simp_all)
  fix i assume i: "i < length Tl"
  let ?giT1 = "intTrm Gop intPvar intVar1"
  let ?giT2 = "intTrm Gop intPvar intVar2"
  show "Geq (?giT1 (Tl!i)) (?giT2 (Tl!i))"
  apply(rule intTrm_Gop_Geq[OF Pvar Var1 Var, of "rarOf \<pi>!i"])
  by (metis Tl i list_all2_nthD2)
qed

lemma Hrel_intTrm_Hop:
assumes Pvar: "\<And> ps px. params ps (intPvar ps px)" and
Var: "\<And>s x. htrms s (intVar s x)" and Tl: "list_all2 trms (rarOf \<pi>) Tl"
shows
"Hrel \<pi> pl (map (intTrm Hop intPvar intVar) Tl) \<longleftrightarrow>
 Grel \<pi> pl (map (intTrm Gop intPvar (\<lambda> xs x. EpsSet (intVar xs x))) Tl)"
unfolding Hrel_def map_map
apply(rule GeqGrel2) proof(rule list_all2_all_nthI, simp_all)
  fix i assume i: "i < length Tl"
  let ?hiT = "intTrm Hop intPvar intVar"
  let ?giT = "intTrm Gop intPvar (\<lambda>xs x. EpsSet (intVar xs x))"
  have "?hiT (Tl!i) = clsOf (?giT (Tl!i))"
  apply(rule intTrm_Hop[OF Pvar Var, of "rarOf \<pi>!i"])
  by (metis Tl i list_all2_nthD2)
  thus "Geq (EpsSet (?hiT (Tl!i))) (?giT (Tl!i))" by (metis Geq_Eps_clsOf2 Sym)
qed

lemma Hrel_intTrm_Hop_clsOf:
assumes Pvar: "\<And> ps px. params ps (intPvar ps px)" and
Var: "\<And>s x. gtrms s (intVar s x)" and Tl: "list_all2 trms (rarOf \<pi>) Tl"
shows
"Hrel \<pi> pl (map (intTrm Hop intPvar (\<lambda> xs x. clsOf (intVar xs x))) Tl) \<longleftrightarrow>
 Grel \<pi> pl (map (intTrm Gop intPvar intVar) Tl)"  (is "?L \<longleftrightarrow> ?R")
proof-
  def iV \<equiv> "\<lambda> xs x. clsOf (intVar xs x)"
  have VVar: "\<And>s x. htrms s (iV s x)" unfolding iV_def using Var by (metis clsOf)
  have 0: "\<And> xs x. Geq (EpsSet (iV xs x)) (intVar xs x)"
  by (metis Geq_Eps_clsOf2 Sym iV_def)
  have "?L \<longleftrightarrow> Grel \<pi> pl (map (intTrm Gop intPvar (\<lambda> xs x. EpsSet (iV xs x))) Tl)"
  unfolding iV_def[symmetric] by(rule Hrel_intTrm_Hop[OF Pvar VVar Tl])
  also have "... \<longleftrightarrow> ?R"
  apply(rule Grel_intTrm_Gop[OF Pvar _ 0 Tl]) by (metis Eps VVar)
  finally show ?thesis .
qed

lemma satEq_Hop:
assumes Pvar: "\<And> ps px. params ps (intPvar ps px)" and
Var: "\<And>s x. htrms s (intVar s x)"
and T1: "trms s T1" and T2: "trms s T2"
shows
"satEq Hop (op=) intPvar intVar T1 T2 \<longleftrightarrow>
 satEq Gop Geq intPvar (\<lambda> xs x. EpsSet (intVar xs x)) T1 T2"
unfolding satEq_def intTrm_Hop[OF Pvar Var T1] intTrm_Hop[OF Pvar Var T2] by simp

lemma satRl_Hop:
assumes Pvar: "\<And> ps px. params ps (intPvar ps px)" and
Var: "\<And>s x. htrms s (intVar s x)" and Tl: "list_all2 trms (rarOf \<pi>) Tl"
shows
"satRl Hop Hrel intPvar intVar \<pi> pxl Tl \<longleftrightarrow>
 satRl Gop Grel intPvar (\<lambda> xs x. EpsSet (intVar xs x)) \<pi> pxl Tl"
unfolding satRl_def Hrel_intTrm_Hop[OF assms]
apply(rule Grel_intTrm_Gop)
using Pvar Eps Var Tl by auto

lemma satAtm_Hop:
assumes Pvar: "\<And> ps px. params ps (intPvar ps px)" and
Var: "\<And>s x. htrms s (intVar s x)" and
c: "compatAtm atm"
shows
"satAtm Hop (op=) Hrel intPvar intVar atm \<longleftrightarrow>
 satAtm Gop Geq Grel intPvar (\<lambda> xs x. EpsSet (intVar xs x)) atm"
using satEq_Hop[of intPvar intVar, OF Pvar Var]
      satRl_Hop[of intPvar intVar, OF Pvar Var]
using c unfolding compatAtm_def satAtm_def satPcond_def
apply(cases atm) by auto

theorem sat_HCL:
assumes "hcl \<in> HCL"
shows "satHcl htrms Hop (op=) Hrel hcl"
using assms proof(cases hcl, unfold satHcl_def, clarsimp)
  fix atml atm intPvar intVar
  assume H: "Horn atml atm \<in> HCL"
  and Pvar: "\<forall>ps px. params ps (intPvar ps px)"
  and Var: "\<forall>s x. htrms s (intVar s x)"
  and atml: "list_all (satAtm Hop (op =) Hrel intPvar intVar) atml"
  let ?iV = "\<lambda> xs x. EpsSet (intVar xs x)"
  have 0: "list_all (satAtm Gop Geq Grel intPvar ?iV) atml"
  unfolding list_all_iff proof safe
    fix atm' assume atm': "atm' \<in> set atml"
    have c: "compatAtm atm'" using compatHCL[OF assms] H unfolding compatHcl_def
    by (smt Ball_set_list_all atm' compatHCL compatHcl_def hcl.simps(2))
    have "satAtm Hop (op =) Hrel intPvar intVar atm'"
    by (metis Ball_set_list_all atm' atml)
    thus "satAtm Gop Geq Grel intPvar ?iV atm'"
    using Pvar Var satAtm_Hop[OF _ _ c] by auto
  qed
  show "satAtm Hop (op =) Hrel intPvar intVar atm"
  proof(cases atm)
    case Pcond
    hence False using compatHCL[OF H] unfolding compatHcl_def by auto
    thus ?thesis by simp
  next
    case (Eq s T1 T2)
    have T: "trms s T1" "trms s T2"
    using compatHCL[OF assms] H unfolding compatHcl_def Eq compatAtm_def
    by (smt atm.simps(11) compatAtm_def compatHCL compatHcl_def hcl.simps)+
    have "satEq Gop Geq intPvar ?iV T1 T2"
    apply(rule satEq_Gop) using H Pvar Var 0 unfolding Eq by auto
    hence "satEq Hop (op =) intPvar intVar T1 T2" by (metis Pvar T Var satEq_Hop)
    thus ?thesis unfolding H Eq satAtm_def by simp
  next
    case (Rl \<pi> pxl Tl)
    have pxl: "length pxl = length (rarOfP \<pi>)"
    and Tl: "list_all2 trms (rarOf \<pi>) Tl"
    using compatHCL[OF assms] H unfolding compatHcl_def Rl compatAtm_def
    by (smt atm.simps(12) compatAtm_def compatHCL compatHcl_def hcl.simps)+
    have "satRl Gop Grel intPvar ?iV \<pi> pxl Tl"
    apply(rule satRel_Gop) using H Pvar Var 0 unfolding Rl by auto
    hence "satRl Hop Hrel intPvar intVar \<pi> pxl Tl" by (metis Pvar Tl Var satRl_Hop)
    thus ?thesis unfolding H Rl satAtm_def by simp
  qed
qed

theorem induct_HCL[induct pred: htrms, consumes 1, case_names Hop]:
assumes 0: "htrms s H"
and Hop:
"\<And> \<sigma> pl Hl.
  \<lbrakk>list_all2 params (arOfP \<sigma>) pl;
   list_all2 htrms (arOf \<sigma>) Hl;
   list_all2 phi (arOf \<sigma>) Hl\<rbrakk>
  \<Longrightarrow> phi (stOf \<sigma>) (Hop \<sigma> pl Hl)"
shows "phi s H"
proof-
  {fix G
   assume "gtrms s G"
   hence "phi s (clsOf G)"
   proof (induct rule: gtrms_induct)
     case (Gop \<sigma> pl Gl)
     show ?case
     unfolding clsOf_Gop[OF Gop(1) Gop(2)] proof(rule Hop[OF Gop(1)])
       let ?ar = "arOf \<sigma>"
       show "list_all2 phi ?ar (map clsOf Gl)"
       proof (rule list_all2_all_nthI)
         fix i assume i: "i < length ?ar"
         hence "phi (?ar!i) (clsOf (Gl!i))" using Gop(3) by (metis list_all2_conv_all_nth)
         thus "phi (?ar!i) (map clsOf Gl ! i)"
         by (metis Gop(2) i list_all2_lengthD nth_map)
       qed (metis Gop(2) length_map list_all2_lengthD)
     qed(insert Gop(2), simp)
   qed
  }
  thus ?thesis using 0 by (metis Eps clsOf_Eps)
qed

theorem cases_HCL[consumes 1, case_names Hop]:
assumes 0: "htrms s H"
and Hop:
"\<And> \<sigma> pl Hl.
  \<lbrakk>  stOf \<sigma> = s ;
     list_all2 params (arOfP \<sigma>) pl ;
     list_all2 htrms (arOf \<sigma>) Hl ;
     H = Hop \<sigma> pl Hl  \<rbrakk>
  \<Longrightarrow> phi"
shows "phi"
using 0 Hop by induct auto

subsection{* Iteration *}

(* pre-iterator for ground terms: *)
fun giter where
"giter intOp (Gop \<sigma> pl Gl) = intOp \<sigma> pl (map (giter intOp) Gl)"

lemma gtrms_giter:
assumes c: "compat intSt intOp" and 0: "gtrms s G"
shows "intSt s (giter intOp G)"
using 0 apply(induct rule: gtrms_induct)
using c unfolding compat_def apply simp
by (metis list_all2_map2)

lemma intTrm_giter:
assumes Pvar: "\<And> ps px. params ps (intPvar ps px)" and
Var: "\<And>s x. gtrms s (intVar s x)"
and T: "trms s T"
shows
"intTrm intOp intPvar (\<lambda>s x. giter intOp (intVar s x)) T =
 giter intOp (intTrm Gop intPvar intVar T)"
using T apply (induct rule: trms_induct)
apply simp_all
by (smt Ball_set_list_all map_eq_conv o_eq_dest_lhs)

lemma map_intTrm_giter:
assumes Pvar: "\<And> ps px. params ps (intPvar ps px)" and
Var: "\<And>s x. gtrms s (intVar s x)"
and Tl: "list_all2 trms sl Tl"
shows
"map (intTrm intOp intPvar (\<lambda>s x. giter intOp (intVar s x))) Tl =
 map (giter intOp o intTrm Gop intPvar intVar) Tl"
proof-
  have l: "length sl = length Tl" using Tl unfolding list_all2_def by simp
  show ?thesis
  apply(rule nth_equalityI)
  using intTrm_giter[of intPvar intVar _ _ intOp, OF Pvar Var]
      list_all2_nthD[OF Tl] l by auto
qed

lemma satAtm_giter:
assumes Pvar: "\<And> ps px. params ps (intPvar ps px)" and
Var: "\<And>s x. gtrms s (intVar s x)" and
c: "compatAtm atm"
and 0:
"satAtm Gop
       (\<lambda>T1 T2. Geq T1 T2 \<and> giter intOp T1 = giter intOp T2)
       (\<lambda>\<pi> pl Tl. Grel \<pi> pl Tl \<and> intRl \<pi> pl (map (giter intOp) Tl))
       intPvar intVar atm"
shows "satAtm intOp (op =) intRl intPvar (\<lambda> s x. giter intOp (intVar s x)) atm"
proof(cases atm)
  case Pcond
  thus ?thesis using 0 unfolding satAtm_def by auto
next
  case (Eq s T1 T2)
  have T1: "trms s T1" and T2: "trms s T2"
  using c unfolding Eq compatHcl_def compatAtm_def by auto
  show ?thesis unfolding Eq satAtm_def satEq_def apply simp
  unfolding intTrm_giter[OF Pvar Var T1] intTrm_giter[OF Pvar Var T2]
  using 0 unfolding satAtm_def Eq satEq_def by simp
next
  case (Rl \<pi> pxl Tl)
  have pxl: "length pxl = length (rarOfP \<pi>)"
  and Tl: "list_all2 trms (rarOf \<pi>) Tl"
  using c unfolding Rl compatHcl_def compatAtm_def by auto
  show ?thesis unfolding Rl satAtm_def satRl_def apply simp
  unfolding map_intTrm_giter[OF Pvar Var Tl]
  using 0 unfolding satAtm_def Rl satRl_def by simp
qed

lemma Geq_Grel_giter:
assumes c: "compat intSt intOp"
and sat: "\<And> hcl. hcl \<in> HCL \<Longrightarrow> satHcl intSt intOp (op=) intRl hcl"
shows
"(Geq G1 G2 \<longrightarrow> (giter intOp G1 = giter intOp G2))
 \<and>
 (Grel \<pi> pl Gl \<longrightarrow> intRl \<pi> pl (map (giter intOp) Gl))"
proof(induct rule: Geq_Grel.induct)
  case (GeqGop \<sigma> pl Gl1 Gl2)
  hence "length Gl1 = length Gl2" by (metis list_all2_lengthD)
  hence ?case
  unfolding giter.simps using list_all2_nthD[OF GeqGop(4)]
  by (metis (no_types) length_map list_eq_iff_nth_eq nth_map)
next
  case (Eq atml s T1 T2 intPvar intVar)
  let ?iT = "intTrm Gop intPvar intVar"
  let ?iV = "\<lambda> s x. giter intOp (intVar s x)"
  have T1: "trms s T1" and T2: "trms s T2" using compatHCL[OF Eq(1)]
  unfolding compatHcl_def compatAtm_def by auto
  have ssat: "list_all (satAtm intOp (op=) intRl intPvar ?iV) atml"
  unfolding list_all_length proof safe
    fix i assume i: "i < length atml"
    have c: "compatAtm (atml!i)"
    using i compatHCL[OF Eq(1)] unfolding compatHcl_def list_all_length by auto
    have 0:
    "satAtm Gop
       (\<lambda>T1 T2. Geq T1 T2 \<and> giter intOp T1 = giter intOp T2)
       (\<lambda>\<pi> pl Tl. Grel \<pi> pl Tl \<and> intRl \<pi> pl (map (giter intOp) Tl))
       intPvar intVar (atml!i)"
    using i Eq(4) unfolding list_all_length by simp
    show "satAtm intOp (op =) intRl intPvar ?iV (atml!i)"
    using satAtm_giter[OF Eq(2) Eq(3) c 0] .
  qed
  have "\<And> s x. intSt s (?iV s x)" using gtrms_giter[OF c Eq(3)] .
  hence "satAtm intOp (op=) intRl intPvar ?iV (Eq s T1 T2)"
  using ssat sat[OF Eq(1)] Eq(2) unfolding satHcl_def by simp
  hence "satEq intOp (op=) intPvar (\<lambda> s x. giter intOp (intVar s x)) T1 T2"
  unfolding satAtm_def by simp
  thus ?case unfolding satEq_def
  unfolding intTrm_giter[OF Eq(2) Eq(3) T1] intTrm_giter[OF Eq(2) Eq(3) T2] .
next
  case (Rel atml \<pi> pxl Tl intPvar intVar)
  let ?iT = "intTrm Gop intPvar intVar"
  let ?iV = "\<lambda> s x. giter intOp (intVar s x)"
  have pxl: "length pxl = length (rarOfP \<pi>)"
  and Tl: "list_all2 trms (rarOf \<pi>) Tl"
  using compatHCL[OF Rel(1)] unfolding compatHcl_def compatAtm_def by auto
  have ssat: "list_all (satAtm intOp (op=) intRl intPvar ?iV) atml"
  unfolding list_all_length proof safe
    fix i assume i: "i < length atml"
    have c: "compatAtm (atml!i)"
    using i compatHCL[OF Rel(1)] unfolding compatHcl_def list_all_length by auto
    have 0:
    "satAtm Gop
       (\<lambda>T1 T2. Geq T1 T2 \<and> giter intOp T1 = giter intOp T2)
       (\<lambda>\<pi> pl Tl. Grel \<pi> pl Tl \<and> intRl \<pi> pl (map (giter intOp) Tl))
       intPvar intVar (atml!i)"
    using i Rel(4) unfolding list_all_length by simp
    show "satAtm intOp (op =) intRl intPvar ?iV (atml!i)"
    using satAtm_giter[OF Rel(2) Rel(3) c 0] .
  qed
  have "\<And> s x. intSt s (?iV s x)" using gtrms_giter[OF c Rel(3)] .
  hence "satAtm intOp (op=) intRl intPvar ?iV (Rl \<pi> pxl Tl)"
  using ssat sat[OF Rel(1)] Rel(2) unfolding satHcl_def by simp
  hence "satRl intOp intRl intPvar (\<lambda> s x. giter intOp (intVar s x)) \<pi> pxl Tl"
  unfolding satAtm_def by simp
  thus ?case unfolding satRl_def
  unfolding map_intTrm_giter[OF Rel(2) Rel(3) Tl] by simp
next
  case (GeqGop \<sigma> pl Gl1 Gl2)
  have "map (giter intOp) Gl1 = map (giter intOp) Gl2"
  apply(rule nth_equalityI)
    using GeqGop(2,3) unfolding list_all2_def apply fastforce
    using GeqGop(4) unfolding list_all2_conv_all_nth by simp
  thus ?case by simp
next
  case (GeqGrel Gl1 Gl2 \<pi> pl)
  have "map (giter intOp) Gl1 = map (giter intOp) Gl2"
  apply(rule nth_equalityI)
    using GeqGrel unfolding list_all2_def apply fastforce
    using GeqGrel unfolding list_all2_conv_all_nth by simp
  thus ?case using GeqGrel by simp
qed auto

lemma Geq_giter:
assumes c: "compat intSt intOp"
and sat: "\<And> hcl. hcl \<in> HCL \<Longrightarrow> satHcl intSt intOp (op=) intRl hcl"
and 0: "Geq G1 G2"
shows "giter intOp G1 = giter intOp G2"
using Geq_Grel_giter[OF c sat] 0 by auto

lemma Grel_giter:
assumes c: "compat intSt intOp"
and sat: "\<And> hcl. hcl \<in> HCL \<Longrightarrow> satHcl intSt intOp (op=) intRl hcl"
and 0: "Grel \<pi> pl Gl"
shows "intRl \<pi> pl (map (giter intOp) Gl)"
using Geq_Grel_giter[OF c sat] 0 by auto

lemma giter_respects_GGeq:
assumes c: "compat intSt intOp"
and sat: "\<And> hcl. hcl \<in> HCL \<Longrightarrow> satHcl intSt intOp (op=) intRl hcl"
shows "(giter intOp) respects GGeq"
using Geq_giter[OF c sat] unfolding congruent_def by auto

(*   *)
definition "iter intOp = univ (giter intOp)"

lemma iter_clsOf:
assumes c: "compat intSt intOp"
and sat: "\<And> hcl. hcl \<in> HCL \<Longrightarrow> satHcl intSt intOp (op=) intRl hcl"
shows "iter intOp (clsOf G) = giter intOp G"
unfolding iter_def clsOf_def apply(rule univ_commute[OF equiv_GGeq])
using giter_respects_GGeq[OF assms] by simp_all

lemma giter_Eps:
assumes c: "compat intSt intOp"
and sat: "\<And> hcl. hcl \<in> HCL \<Longrightarrow> satHcl intSt intOp (op=) intRl hcl"
shows "giter intOp (EpsSet H) = iter intOp H"
using iter_clsOf[OF c sat] by (metis iter_def univ_def)

lemma map_iter_clsOf:
assumes c: "compat intSt intOp"
and sat: "\<And> hcl. hcl \<in> HCL \<Longrightarrow> satHcl intSt intOp (op=) intRl hcl"
shows "map ((iter intOp) o clsOf) Gl = map (giter intOp) Gl"
using iter_clsOf[OF assms]
by (metis map_ext o_eq_dest_lhs splitE)

lemma map_giter_Eps:
assumes c: "compat intSt intOp"
and sat: "\<And> hcl. hcl \<in> HCL \<Longrightarrow> satHcl intSt intOp (op=) intRl hcl"
shows "map ((giter intOp) o EpsSet) Hl = map (iter intOp) Hl"
using giter_Eps[OF assms]
by (metis map_ext o_eq_dest_lhs splitE)

lemma iter_intSt:
assumes c: "compat intSt intOp"
and sat: "\<And> hcl. hcl \<in> HCL \<Longrightarrow> satHcl intSt intOp (op=) intRl hcl"
and H: "htrms s H"
shows "intSt s (iter intOp H)"
using gtrms_giter[OF c] sat H by (metis Eps iter_def univ_def)

lemma compat_Hop:
"compat htrms Hop"
unfolding compat_def
by (metis EpsL Hop_def clsOf gtrms.simps)

theorem iter_Hop:
assumes c: "compat intSt intOp"
and sat: "\<And> hcl. hcl \<in> HCL \<Longrightarrow> satHcl intSt intOp (op=) intRl hcl"
shows "iter intOp (Hop \<sigma> pl Hl) = intOp \<sigma> pl (map (iter intOp) Hl)"
using map_giter_Eps[OF c sat]
by (metis (no_types) Hop_def List.map_map c giter.simps iter_clsOf sat)

theorem iter_Hrel:
assumes c: "compat intSt intOp"
and sat: "\<And> hcl. hcl \<in> HCL \<Longrightarrow> satHcl intSt intOp (op=) intRl hcl"
and Hrel: "Hrel \<pi> pl Hl"
shows "intRl \<pi> pl (map (iter intOp) Hl)"
proof-
  let ?Gl = "map EpsSet Hl"
  have 0: "Grel \<pi> pl ?Gl" unfolding Grel_Eps using Hrel .
  show ?thesis using Grel_giter[OF c sat 0] map_giter_Eps[OF c sat, of Hl] by auto
qed

thm sat_HCL
thm induct_HCL
thm iter_intSt
thm iter_Hop
thm iter_Hrel
thm cases_HCL

end (* context HornTheory *)

end


section \<open> Alphabet Manipulation \<close>

theory utp_alphabet
  imports
    utp_pred utp_usedby
begin

subsection \<open> Preliminaries \<close>

text \<open> Alphabets are simply types that characterise the state-space of an expression. Thus
  the Isabelle type system ensures that predicates cannot refer to variables not in the alphabet
  as this would be a type error. Often one would like to add or remove additional variables, for
  example if we wish to have a predicate which ranges only a smaller state-space, and then
  lift it into a predicate over a larger one. This is useful, for example, when dealing with
  relations which refer only to undashed variables (conditions) since we can use the type system
  to ensure well-formedness.

  In this theory we will set up operators for extending and contracting and alphabet.
  We first set up a theorem attribute for alphabet laws and a tactic. \<close>

named_theorems alpha

method alpha_tac = (simp add: alpha unrest)?

subsection \<open> Alphabet Extrusion \<close>

text \<open> Alter an alphabet by application of a lens that demonstrates how the smaller alphabet
  ($\beta$) injects into the larger alphabet ($\alpha$). This changes the type of the expression
  so it is parametrised over the large alphabet. We do this by using the lens \emph{get}
  function to extract the smaller state binding, and then apply this to the expression.

  We call this "extrusion" rather than "extension" because if the extension lens is bijective
  then it does not extend the alphabet. Nevertheless, it does have an effect because the type
  will be different which can be useful when converting predicates with equivalent alphabets. \<close>

lift_definition aext :: "('a, '\<beta>) uexpr \<Rightarrow> ('\<beta>, '\<alpha>) lens \<Rightarrow> ('a, '\<alpha>) uexpr" (infixr "\<oplus>\<^sub>p" 95)
is "\<lambda> P x b. P (get\<^bsub>x\<^esub> b)" .

update_uexpr_rep_eq_thms

text \<open> Next we prove some of the key laws. Extending an alphabet twice is equivalent to extending
  by the composition of the two lenses. \<close>

lemma aext_twice: "(P \<oplus>\<^sub>p a) \<oplus>\<^sub>p b = P \<oplus>\<^sub>p (a ;\<^sub>L b)"
  by (pred_auto)

text \<open> The bijective @{term "1\<^sub>L"} lens identifies the source and view types. Thus an alphabet
  extension using this has no effect. \<close>

lemma aext_id [simp]: "P \<oplus>\<^sub>p 1\<^sub>L = P"
  by (pred_auto)

text \<open> Literals do not depend on any variables, and thus applying an alphabet extension only
  alters the predicate's type, and not its valuation .\<close>

lemma aext_lit [simp]: "\<guillemotleft>v\<guillemotright> \<oplus>\<^sub>p a = \<guillemotleft>v\<guillemotright>"
  by (pred_auto)

lemma aext_zero [simp]: "0 \<oplus>\<^sub>p a = 0"
  by (pred_auto)

lemma aext_one [simp]: "1 \<oplus>\<^sub>p a = 1"
  by (pred_auto)

lemma aext_numeral [simp]: "numeral n \<oplus>\<^sub>p a = numeral n"
  by (pred_auto)

lemma aext_true [simp]: "true \<oplus>\<^sub>p a = true"
  by (pred_auto)

lemma aext_false [simp]: "false \<oplus>\<^sub>p a = false"
  by (pred_auto)

lemma aext_not [alpha]: "(\<not> P) \<oplus>\<^sub>p x = (\<not> (P \<oplus>\<^sub>p x))"
  by (pred_auto)

lemma aext_and [alpha]: "(P \<and> Q) \<oplus>\<^sub>p x = (P \<oplus>\<^sub>p x \<and> Q \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma aext_or [alpha]: "(P \<or> Q) \<oplus>\<^sub>p x = (P \<oplus>\<^sub>p x \<or> Q \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma aext_imp [alpha]: "(P \<Rightarrow> Q) \<oplus>\<^sub>p x = (P \<oplus>\<^sub>p x \<Rightarrow> Q \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma aext_iff [alpha]: "(P \<Leftrightarrow> Q) \<oplus>\<^sub>p x = (P \<oplus>\<^sub>p x \<Leftrightarrow> Q \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma aext_shAll [alpha]: "(\<^bold>\<forall> x \<bullet> P(x)) \<oplus>\<^sub>p a = (\<^bold>\<forall> x \<bullet> P(x) \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_UINF_ind [alpha]: "(\<Sqinter> x \<bullet> P x) \<oplus>\<^sub>p a =(\<Sqinter> x \<bullet> (P x \<oplus>\<^sub>p a))"
  by (pred_auto)

lemma aext_UINF_mem [alpha]: "(\<Sqinter> x\<in>A \<bullet> P x) \<oplus>\<^sub>p a =(\<Sqinter> x\<in>A \<bullet> (P x \<oplus>\<^sub>p a))"
  by (pred_auto)

text \<open> Alphabet extension distributes through the function liftings. \<close>

lemma aext_uop [alpha]: "uop f u \<oplus>\<^sub>p a = uop f (u \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_bop [alpha]: "bop f u v \<oplus>\<^sub>p a = bop f (u \<oplus>\<^sub>p a) (v \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_trop [alpha]: "trop f u v w \<oplus>\<^sub>p a = trop f (u \<oplus>\<^sub>p a) (v \<oplus>\<^sub>p a) (w \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_qtop [alpha]: "qtop f u v w x \<oplus>\<^sub>p a = qtop f (u \<oplus>\<^sub>p a) (v \<oplus>\<^sub>p a) (w \<oplus>\<^sub>p a) (x \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_plus [alpha]:
  "(x + y) \<oplus>\<^sub>p a = (x \<oplus>\<^sub>p a) + (y \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_minus [alpha]:
  "(x - y) \<oplus>\<^sub>p a = (x \<oplus>\<^sub>p a) - (y \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_uminus [simp]:
  "(- x) \<oplus>\<^sub>p a = - (x \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_times [alpha]:
  "(x * y) \<oplus>\<^sub>p a = (x \<oplus>\<^sub>p a) * (y \<oplus>\<^sub>p a)"
  by (pred_auto)

lemma aext_divide [alpha]:
  "(x / y) \<oplus>\<^sub>p a = (x \<oplus>\<^sub>p a) / (y \<oplus>\<^sub>p a)"
  by (pred_auto)

text \<open> Extending a variable expression over $x$ is equivalent to composing $x$ with the alphabet,
  thus effectively yielding a variable whose source is the large alphabet. \<close>

lemma aext_var [alpha]:
  "var x \<oplus>\<^sub>p a = var (x ;\<^sub>L a)"
  by (pred_auto)

lemma aext_ulambda [alpha]: "((\<lambda> x \<bullet> P(x)) \<oplus>\<^sub>p a) = (\<lambda> x \<bullet> P(x) \<oplus>\<^sub>p a)"
  by (pred_auto)

text \<open> Alphabet extension is monotonic and continuous. \<close>

lemma aext_mono: "P \<sqsubseteq> Q \<Longrightarrow> P \<oplus>\<^sub>p a \<sqsubseteq> Q \<oplus>\<^sub>p a"
  by (pred_auto)

lemma aext_cont [alpha]: "vwb_lens a \<Longrightarrow> (\<Sqinter> A) \<oplus>\<^sub>p a = (\<Sqinter> P\<in>A.  P \<oplus>\<^sub>p a)"
  by (pred_simp)

text \<open> If a variable is unrestricted in a predicate, then the extended variable is unrestricted
  in the predicate with an alphabet extension. \<close>

lemma unrest_aext [unrest]:
  "\<lbrakk> mwb_lens a; x \<sharp> p \<rbrakk> \<Longrightarrow> unrest (x ;\<^sub>L a) (p \<oplus>\<^sub>p a)"
  by (transfer, simp add: lens_comp_def)

text \<open> If a given variable (or alphabet) $b$ is independent of the extension lens $a$, that is, it is
  outside the original state-space of $p$, then it follows that once $p$ is extended by $a$ then
  $b$ cannot be restricted. \<close>

lemma unrest_aext_indep [unrest]:
  "a \<bowtie> b \<Longrightarrow> b \<sharp> (p \<oplus>\<^sub>p a)"
  by pred_auto

subsection \<open> Expression Alphabet Restriction \<close>

text \<open> Restrict an alphabet by application of a lens that demonstrates how the smaller alphabet
  ($\beta$) injects into the larger alphabet ($\alpha$). Unlike extension, this operation
  can lose information if the expressions refers to variables in the larger alphabet. \<close>

lift_definition arestr :: "('a, '\<alpha>) uexpr \<Rightarrow> ('\<beta>, '\<alpha>) lens \<Rightarrow> ('a, '\<beta>) uexpr" (infixr "\<restriction>\<^sub>e" 90)
is "\<lambda> P x b. P (create\<^bsub>x\<^esub> b)" .

update_uexpr_rep_eq_thms

lemma arestr_id [simp]: "P \<restriction>\<^sub>e 1\<^sub>L = P"
  by (pred_auto)

lemma arestr_aext [simp]: "mwb_lens a \<Longrightarrow> (P \<oplus>\<^sub>p a) \<restriction>\<^sub>e a = P"
  by (pred_auto)

text \<open> If an expression's alphabet can be divided into two disjoint sections and the expression
  does not depend on the second half then restricting the expression to the first half is
  loss-less. \<close>

lemma aext_arestr [alpha]:
  assumes "mwb_lens a" "bij_lens (a +\<^sub>L b)" "a \<bowtie> b" "b \<sharp> P"
  shows "(P \<restriction>\<^sub>e a) \<oplus>\<^sub>p a = P"
proof -
  from assms(2) have "1\<^sub>L \<subseteq>\<^sub>L a +\<^sub>L b"
    by (simp add: bij_lens_equiv_id lens_equiv_def)
  with assms(1,3,4) show ?thesis
    apply (auto simp add: id_lens_def lens_plus_def sublens_def lens_comp_def prod.case_eq_if)
    apply (pred_simp)
    apply (metis lens_indep_comm mwb_lens_weak weak_lens.put_get)
    done
qed

text \<open> Alternative formulation of the above law using used-by instead of unrestriction. \<close>

lemma aext_arestr' [alpha]:
  assumes "a \<natural> P"
  shows "(P \<restriction>\<^sub>e a) \<oplus>\<^sub>p a = P"
  by (rel_simp, metis assms lens_override_def usedBy_uexpr.rep_eq)

lemma arestr_lit [simp]: "\<guillemotleft>v\<guillemotright> \<restriction>\<^sub>e a = \<guillemotleft>v\<guillemotright>"
  by (pred_auto)

lemma arestr_zero [simp]: "0 \<restriction>\<^sub>e a = 0"
  by (pred_auto)

lemma arestr_one [simp]: "1 \<restriction>\<^sub>e a = 1"
  by (pred_auto)

lemma arestr_numeral [simp]: "numeral n \<restriction>\<^sub>e a = numeral n"
  by (pred_auto)

lemma arestr_var [alpha]:
  "var x \<restriction>\<^sub>e a = var (x /\<^sub>L a)"
  by (pred_auto)

lemma arestr_true [simp]: "true \<restriction>\<^sub>e a = true"
  by (pred_auto)

lemma arestr_false [simp]: "false \<restriction>\<^sub>e a = false"
  by (pred_auto)

lemma arestr_not [alpha]: "(\<not> P)\<restriction>\<^sub>ea = (\<not> (P\<restriction>\<^sub>ea))"
  by (pred_auto)

lemma arestr_and [alpha]: "(P \<and> Q)\<restriction>\<^sub>ex = (P\<restriction>\<^sub>ex \<and> Q\<restriction>\<^sub>ex)"
  by (pred_auto)

lemma arestr_or [alpha]: "(P \<or> Q)\<restriction>\<^sub>ex = (P\<restriction>\<^sub>ex \<or> Q\<restriction>\<^sub>ex)"
  by (pred_auto)

lemma arestr_imp [alpha]: "(P \<Rightarrow> Q)\<restriction>\<^sub>ex = (P\<restriction>\<^sub>ex \<Rightarrow> Q\<restriction>\<^sub>ex)"
  by (pred_auto)

subsection \<open> Predicate Alphabet Restriction \<close>

text \<open> In order to restrict the variables of a predicate, we also need to existentially quantify
  away the other variables. We can't do this at the level of expressions, as quantifiers are not
  applicable here. Consequently, we need a specialised version of alphabet restriction for
  predicates. It both restricts the variables using quantification and then removes them
  from the alphabet type using expression restriction. \<close>

definition upred_ares :: "'\<alpha> upred \<Rightarrow> ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<beta> upred"
where [upred_defs]: "upred_ares P a = (P \<restriction>\<^sub>v a) \<restriction>\<^sub>e a"

syntax
  "_upred_ares" :: "logic \<Rightarrow> salpha \<Rightarrow> logic" (infixl "\<restriction>\<^sub>p" 90)

translations
  "_upred_ares P a" == "CONST upred_ares P a"

lemma upred_aext_ares [alpha]:
  "vwb_lens a \<Longrightarrow> P \<oplus>\<^sub>p a \<restriction>\<^sub>p a = P"
  by (pred_auto)

lemma upred_ares_aext [alpha]:
  "a \<natural> P \<Longrightarrow> (P \<restriction>\<^sub>p a) \<oplus>\<^sub>p a = P"
  by (pred_auto)

lemma upred_arestr_lit [simp]: "\<guillemotleft>v\<guillemotright> \<restriction>\<^sub>p a = \<guillemotleft>v\<guillemotright>"
  by (pred_auto)

lemma upred_arestr_true [simp]: "true \<restriction>\<^sub>p a = true"
  by (pred_auto)

lemma upred_arestr_false [simp]: "false \<restriction>\<^sub>p a = false"
  by (pred_auto)

lemma upred_arestr_or [alpha]: "(P \<or> Q)\<restriction>\<^sub>px = (P\<restriction>\<^sub>px \<or> Q\<restriction>\<^sub>px)"
  by (pred_auto)

subsection \<open> Alphabet Lens Laws \<close>

lemma alpha_in_var [alpha]: "x ;\<^sub>L fst\<^sub>L = in_var x"
  by (simp add: in_var_def)

lemma alpha_out_var [alpha]: "x ;\<^sub>L snd\<^sub>L = out_var x"
  by (simp add: out_var_def)

lemma in_var_prod_lens [alpha]:
  "wb_lens Y \<Longrightarrow> in_var x ;\<^sub>L (X \<times>\<^sub>L Y) = in_var (x ;\<^sub>L X)"
  by (simp add: in_var_def prod_as_plus lens_comp_assoc[THEN sym] fst_lens_plus)

lemma out_var_prod_lens [alpha]:
  "wb_lens X \<Longrightarrow> out_var x ;\<^sub>L (X \<times>\<^sub>L Y) = out_var (x ;\<^sub>L Y)"
  apply (simp add: out_var_def prod_as_plus lens_comp_assoc[THEN sym])
  apply (subst snd_lens_plus)
  using comp_wb_lens fst_vwb_lens vwb_lens_wb apply blast
   apply (simp add: alpha_in_var alpha_out_var)
  apply (simp)
  done

subsection \<open> Substitution Alphabet Extension \<close>

text \<open> This allows us to extend the alphabet of a substitution, in a similar way to expressions. \<close>

definition subst_ext :: "'\<alpha> usubst \<Rightarrow> ('\<alpha> \<Longrightarrow> '\<beta>) \<Rightarrow> '\<beta> usubst" (infix "\<oplus>\<^sub>s" 65) where
[upred_defs]: "\<sigma> \<oplus>\<^sub>s x = (\<lambda> s. put\<^bsub>x\<^esub> s (\<sigma> (get\<^bsub>x\<^esub> s)))"

lemma id_subst_ext [usubst]:
  "wb_lens x \<Longrightarrow> id \<oplus>\<^sub>s x = id"
  by pred_auto

lemma upd_subst_ext [alpha]:
  "vwb_lens x \<Longrightarrow> \<sigma>(y \<mapsto>\<^sub>s v) \<oplus>\<^sub>s x = (\<sigma> \<oplus>\<^sub>s x)(&x:y \<mapsto>\<^sub>s v \<oplus>\<^sub>p x)"
  by pred_auto

lemma apply_subst_ext [alpha]:
  "vwb_lens x \<Longrightarrow> (\<sigma> \<dagger> e) \<oplus>\<^sub>p x = (\<sigma> \<oplus>\<^sub>s x) \<dagger> (e \<oplus>\<^sub>p x)"
  by (pred_auto)

lemma aext_upred_eq [alpha]:
  "((e =\<^sub>u f) \<oplus>\<^sub>p a) = ((e \<oplus>\<^sub>p a) =\<^sub>u (f \<oplus>\<^sub>p a))"
  by (pred_auto)

lemma subst_aext_comp [usubst]:
  "vwb_lens a \<Longrightarrow> (\<sigma> \<oplus>\<^sub>s a) \<circ> (\<rho> \<oplus>\<^sub>s a) = (\<sigma> \<circ> \<rho>) \<oplus>\<^sub>s a"
  by pred_auto

subsection \<open> Substitution Alphabet Restriction \<close>

text \<open> This allows us to reduce the alphabet of a substitution, in a similar way to expressions. \<close>

definition subst_res :: "'\<alpha> usubst \<Rightarrow> ('\<beta> \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<beta> usubst" (infix "\<restriction>\<^sub>s" 65) where
[upred_defs]: "\<sigma> \<restriction>\<^sub>s x = (\<lambda> s. get\<^bsub>x\<^esub> (\<sigma> (create\<^bsub>x\<^esub> s)))"

lemma id_subst_res [usubst]:
  "mwb_lens x \<Longrightarrow> id \<restriction>\<^sub>s x = id"
  by pred_auto

lemma upd_subst_res [alpha]:
  "mwb_lens x \<Longrightarrow> \<sigma>(&x:y \<mapsto>\<^sub>s v) \<restriction>\<^sub>s x = (\<sigma> \<restriction>\<^sub>s x)(&y \<mapsto>\<^sub>s v \<restriction>\<^sub>e x)"
  by (pred_auto)

lemma subst_ext_res [usubst]:
  "mwb_lens x \<Longrightarrow> (\<sigma> \<oplus>\<^sub>s x) \<restriction>\<^sub>s x = \<sigma>"
  by (pred_auto)

lemma unrest_subst_alpha_ext [unrest]:
  "x \<bowtie> y \<Longrightarrow> x \<sharp> (P \<oplus>\<^sub>s y)"
  by (pred_simp robust, metis lens_indep_def)
end


(*  Title:       TLList_CCPO.thy
    Author:      Andreas Lochbihler, ETH Zurich
*)

section \<open>Ccpo structure for terminated lazy lists\<close>

theory TLList_CCPO imports TLList begin

lemma Set_is_empty_parametric [transfer_rule]:
  includes lifting_syntax
  shows "(rel_set A ===> (=)) Set.is_empty Set.is_empty"
by(auto simp add: rel_fun_def Set.is_empty_def dest: rel_setD1 rel_setD2)

lemma monotone_comp: "\<lbrakk> monotone orda ordb g; monotone ordb ordc f \<rbrakk> \<Longrightarrow> monotone orda ordc (f \<circ> g)"
by(rule monotoneI)(simp add: monotoneD)

lemma mcont_comp: "\<lbrakk> mcont luba orda lubb ordb g; mcont lubb ordb lubc ordc f \<rbrakk> \<Longrightarrow> mcont luba orda lubc ordc (f \<circ> g)"
by(auto simp add: mcont_def intro: cont_comp monotone_comp)

context includes lifting_syntax
begin

lemma monotone_parametric [transfer_rule]:
  assumes [transfer_rule]: "bi_total A"
  shows "((A ===> A ===> (=)) ===> (B ===> B ===> (=)) ===> (A ===> B) ===> (=)) monotone monotone"
unfolding monotone_def[abs_def] by transfer_prover

lemma cont_parametric [transfer_rule]:
  assumes [transfer_rule]: "bi_total A" "bi_unique B"
  shows "((rel_set A ===> A) ===> (A ===> A ===> (=)) ===> (rel_set B ===> B) ===> (B ===> B ===> (=)) ===> (A ===> B) ===> (=)) cont cont"
unfolding cont_def[abs_def] Set.is_empty_def[symmetric] by transfer_prover

lemma mcont_parametric [transfer_rule]:
  assumes [transfer_rule]: "bi_total A" "bi_unique B"
  shows "((rel_set A ===> A) ===> (A ===> A ===> (=)) ===> (rel_set B ===> B) ===> (B ===> B ===> (=)) ===> (A ===> B) ===> (=)) mcont mcont"
unfolding mcont_def[abs_def] by transfer_prover

end

lemma (in ccpo) Sup_Un_less:
  assumes chain: "Complete_Partial_Order.chain (\<le>) (A \<union> B)"
  and AB: "\<forall>x\<in>A. \<exists>y\<in>B. x \<le> y"
  shows "Sup (A \<union> B) = Sup B"
proof(rule order.antisym)
  from chain have chain': "Complete_Partial_Order.chain (\<le>) B"
    by(blast intro: chain_subset)
  show "Sup (A \<union> B) \<le> Sup B" using chain
  proof(rule ccpo_Sup_least)
    fix x
    assume "x \<in> A \<union> B"
    thus "x \<le> Sup B"
    proof
      assume "x \<in> A"
      then obtain y where "x \<le> y" "y \<in> B" using AB by blast
      note \<open>x \<le> y\<close>
      also from chain' \<open>y \<in> B\<close> have "y \<le> Sup B" by(rule ccpo_Sup_upper)
      finally show ?thesis .
    qed(rule ccpo_Sup_upper[OF chain'])
  qed
  show "Sup B \<le> Sup (A \<union> B)"
    using chain chain' by(blast intro: ccpo_Sup_least ccpo_Sup_upper)
qed

subsection \<open>The ccpo structure\<close>

context includes tllist.lifting fixes b :: 'b begin

lift_definition tllist_ord :: "('a, 'b) tllist \<Rightarrow> ('a, 'b) tllist \<Rightarrow> bool"
is "\<lambda>(xs1, b1) (xs2, b2). if lfinite xs1 then b1 = b \<and> lprefix xs1 xs2 \<or> xs1 = xs2 \<and> flat_ord b b1 b2 else xs1 = xs2"
by auto

lift_definition tSup :: "('a, 'b) tllist set \<Rightarrow> ('a, 'b) tllist"
is "\<lambda>A. (lSup (fst ` A), flat_lub b (snd ` (A \<inter> {(xs, _). lfinite xs})))"
proof goal_cases
  case (1 A1 A2)
  hence "fst ` A1 = fst ` A2" "snd ` (A1 \<inter> {(xs, _). lfinite xs}) = snd ` (A2 \<inter> {(xs, _). lfinite xs})"
    by(auto 4 3 simp add: rel_set_def intro: rev_image_eqI)
  thus ?case by simp
qed

lemma tllist_ord_simps [simp, code]: (* FIXME: does not work with transfer *)
  shows tllist_ord_TNil_TNil: "tllist_ord (TNil b1) (TNil b2) \<longleftrightarrow> flat_ord b b1 b2"
  and tllist_ord_TNil_TCons: "tllist_ord (TNil b1) (TCons y ys) \<longleftrightarrow> b1 = b"
  and tllist_ord_TCons_TNil: "tllist_ord (TCons x xs) (TNil b2) \<longleftrightarrow> False"
  and tllist_ord_TCons_TCons: "tllist_ord (TCons x xs) (TCons y ys) \<longleftrightarrow> x = y \<and> tllist_ord xs ys"
by(auto simp add: tllist_ord.rep_eq flat_ord_def)

lemma tllist_ord_refl [simp]: "tllist_ord xs xs"
by transfer(auto simp add: flat_ord_def)

lemma tllist_ord_antisym: "\<lbrakk> tllist_ord xs ys; tllist_ord ys xs \<rbrakk> \<Longrightarrow> xs = ys"
by transfer(auto simp add: flat_ord_def split: if_split_asm intro: lprefix_antisym)

lemma tllist_ord_trans [trans]: "\<lbrakk> tllist_ord xs ys; tllist_ord ys zs \<rbrakk> \<Longrightarrow> tllist_ord xs zs"
by transfer(auto simp add: flat_ord_def split: if_split_asm intro: lprefix_trans)

lemma chain_tllist_llist_of_tllist:
  assumes "Complete_Partial_Order.chain tllist_ord A"
  shows "Complete_Partial_Order.chain lprefix (llist_of_tllist ` A)"
by(rule chainI)(auto 4 3 simp add: tllist_ord.rep_eq split: if_split_asm dest: chainD[OF assms])

lemma chain_tllist_terminal:
  assumes "Complete_Partial_Order.chain tllist_ord A"
  shows "Complete_Partial_Order.chain (flat_ord b) {terminal xs|xs. xs \<in> A \<and> tfinite xs}"
by(rule chainI)(auto simp add: tllist_ord.rep_eq flat_ord_def dest: chainD[OF assms])

lemma flat_ord_chain_finite:
  assumes "Complete_Partial_Order.chain (flat_ord b) A"
  shows "finite A"
proof -
  from assms have "\<exists>z. \<forall>x\<in>A. x = b \<or> x = z"
    by(clarsimp simp add: chain_def flat_ord_def) metis
  then obtain z where "\<And>x. x \<in> A \<Longrightarrow> x = b \<or> x = z" by blast
  hence "A \<subseteq> {b, z}" by auto
  thus ?thesis by(rule finite_subset) simp
qed

lemma tSup_empty [simp]: "tSup {} = TNil b"
by(transfer)(simp add: flat_lub_def)

lemma is_TNil_tSup [simp]: "is_TNil (tSup A) \<longleftrightarrow> (\<forall>x\<in>A. is_TNil x)"
by transfer(simp add: split_beta)

lemma chain_tllist_ord_tSup:
  assumes chain: "Complete_Partial_Order.chain tllist_ord A"
  and A: "xs \<in> A"
  shows "tllist_ord xs (tSup A)"
proof(cases "tfinite xs")
  case True
  show ?thesis
  proof(cases "llist_of_tllist xs = llist_of_tllist (tSup A)")
    case True
    with \<open>tfinite xs\<close> have "lfinite (lSup (llist_of_tllist ` A))"
      by(simp add: tSup_def image_image)
    hence "terminal (tSup A) = flat_lub b {terminal xs|xs. xs \<in> A \<and> tfinite xs}" (is "_ = flat_lub _ ?A")
      by(simp add: tSup_def terminal_tllist_of_llist image_image)(auto intro: rev_image_eqI intro!: arg_cong[where f="flat_lub b"])
    moreover have "flat_ord b (terminal xs) (flat_lub b ?A)"
      by(rule ccpo.ccpo_Sup_upper[OF Partial_Function.ccpo[OF flat_interpretation]])(blast intro: chain_tllist_terminal[OF chain] A \<open>tfinite xs\<close>)+
    ultimately show ?thesis using True by(simp add: tllist_ord.rep_eq)
  next
    case False
    hence "\<exists>ys\<in>A. \<not> tllist_ord ys xs"
      by(rule contrapos_np)(auto intro!: lprefix_antisym chain_lSup_lprefix chain_lprefix_lSup simp add: tSup_def image_image A chain_tllist_llist_of_tllist[OF chain] tllist_ord.rep_eq split: if_split_asm)
    then obtain ys where "ys \<in> A" "\<not> tllist_ord ys xs" by blast
    with A have "tllist_ord xs ys" "xs \<noteq> ys" by(auto dest: chainD[OF chain])
    with True have "terminal xs = b" by transfer(auto simp add: flat_ord_def)
    with True False show ?thesis
      by(simp add: tllist_ord.rep_eq tSup_def image_image chain_lprefix_lSup chain_tllist_llist_of_tllist chain A)
  qed
next
  case False
  thus ?thesis using assms by(simp add: tllist_ord.rep_eq tSup_def image_image chain_lprefix_lSup chain_tllist_llist_of_tllist not_lfinite_lprefix_conv_eq[THEN iffD1] terminal_tllist_of_llist split: if_split_asm)
qed

lemma chain_tSup_tllist_ord:
  assumes chain: "Complete_Partial_Order.chain tllist_ord A"
  and lub: "\<And>xs'. xs' \<in> A \<Longrightarrow> tllist_ord xs' xs"
  shows "tllist_ord (tSup A) xs"
proof -
  have "\<And>xs'. xs' \<in> llist_of_tllist ` A \<Longrightarrow> lprefix xs' (llist_of_tllist xs)"
    by(auto dest!: lub simp add: tllist_ord.rep_eq split: if_split_asm)
  with chain_tllist_llist_of_tllist[OF chain]
  have prefix: "lprefix (lSup (llist_of_tllist ` A)) (llist_of_tllist xs)"
    by(rule chain_lSup_lprefix)

  show ?thesis
  proof(cases "tfinite (tSup A)")
    case False thus ?thesis using prefix
      by(simp add: tllist_ord.rep_eq tSup_def image_image not_lfinite_lprefix_conv_eq[THEN iffD1])
  next
    case True
    from True have fin: "lfinite (lSup (llist_of_tllist ` A))" by(simp add: tSup_def image_image)
    have eq: "terminal (tSup A) = flat_lub b {terminal xs|xs. xs \<in> A \<and> tfinite xs}" (is "_ = flat_lub _ ?A")
      by(simp add: tSup_def terminal_tllist_of_llist image_image fin)(auto intro: rev_image_eqI intro!: arg_cong[where f="flat_lub b"])

    show ?thesis
    proof(cases "lprefix (llist_of_tllist xs) (lSup (llist_of_tllist ` A))")
      case True
      with prefix have "lSup (llist_of_tllist ` A) = llist_of_tllist xs" by(rule lprefix_antisym)
      moreover have "flat_ord b (flat_lub b ?A) (terminal xs)"
        by(rule ccpo.ccpo_Sup_least[OF Partial_Function.ccpo[OF flat_interpretation]])(auto intro: chain_tllist_terminal[OF chain] dest: lub simp add: tllist_ord.rep_eq flat_ord_def)
      ultimately show ?thesis using eq by(simp add: tllist_ord.rep_eq tSup_def image_image)
    next
      case False
      { fix xs'
        assume "xs' \<in> A"
        with False have "\<not> lprefix (llist_of_tllist xs) (llist_of_tllist xs')"
          by-(erule contrapos_nn, auto 4 4 intro: lprefix_trans chain_lprefix_lSup chain_tllist_llist_of_tllist chain)
        with lub[OF \<open>xs' \<in> A\<close>] have "terminal xs' = b"
          by(auto simp add: tllist_ord.rep_eq split: if_split_asm) }
      with chain_tllist_terminal[OF chain] have "flat_ord b (flat_lub b ?A) b"
        by -(rule ccpo.ccpo_Sup_least[OF Partial_Function.ccpo[OF flat_interpretation]], auto simp add: flat_ord_def)
      hence "flat_lub b ?A = b" by(simp add: flat_ord_def)
      thus ?thesis using True eq prefix
        by(simp add: tSup_def terminal_tllist_of_llist tllist_ord.rep_eq image_image)
    qed
  qed
qed

lemma tllist_ord_ccpo [simp, cont_intro]:
  "class.ccpo tSup tllist_ord (mk_less tllist_ord)"
by unfold_locales(auto simp add: mk_less_def intro: tllist_ord_antisym tllist_ord_trans chain_tllist_ord_tSup chain_tSup_tllist_ord)

lemma tllist_ord_partial_function_definitions: "partial_function_definitions tllist_ord tSup"
by unfold_locales(auto simp add: mk_less_def intro: tllist_ord_antisym tllist_ord_trans chain_tllist_ord_tSup chain_tSup_tllist_ord)

interpretation tllist: partial_function_definitions "tllist_ord" "tSup"
by(rule tllist_ord_partial_function_definitions)

lemma admissible_mcont_is_TNil [THEN admissible_subst, cont_intro, simp]:
  shows admissible_is_TNil: "ccpo.admissible tSup tllist_ord is_TNil"
by(rule ccpo.admissibleI)(simp)

lemma terminal_tSup:
  "\<forall>xs\<in>Y. is_TNil xs \<Longrightarrow> terminal (tSup Y) = flat_lub b (terminal ` Y)"
  including tllist.lifting apply transfer
  apply (auto simp add: split_def)
  apply (rule arg_cong [where f = "flat_lub b"])
  apply force
  done

lemma thd_tSup:
  "\<exists>xs \<in> Y. \<not> is_TNil xs
  \<Longrightarrow> thd (tSup Y) = (THE x. x \<in> thd ` (Y \<inter> {xs. \<not> is_TNil xs}))"
apply(simp add: tSup_def image_image)
apply(rule arg_cong[where f=The])
apply(auto intro: rev_image_eqI intro!: ext)
done

lemma ex_TCons_raw_parametric:
  includes lifting_syntax
  shows "(rel_set (rel_prod (llist_all2 A) B) ===> (=)) (\<lambda>Y. \<exists>(xs, b) \<in> Y. \<not> lnull xs) (\<lambda>Y. \<exists>(xs, b) \<in> Y. \<not> lnull xs)"
by(auto 4 4 simp add: rel_fun_def dest: rel_setD1 rel_setD2 llist_all2_lnullD intro: rev_bexI)

lift_definition ex_TCons :: "('a, 'b) tllist set \<Rightarrow> bool"
is "\<lambda>Y. \<exists>(xs, b) \<in> Y. \<not> lnull xs" parametric ex_TCons_raw_parametric
by (blast dest: rel_setD1 rel_setD2)+

lemma ex_TCons_iff: "ex_TCons Y \<longleftrightarrow> (\<exists>xs \<in> Y. \<not> is_TNil xs)"
by transfer auto

lemma retain_TCons_raw_parametric:
  includes lifting_syntax
  shows "(rel_set (rel_prod (llist_all2 A) B) ===> rel_set (rel_prod (llist_all2 A) B))
    (\<lambda>A. A \<inter> {(xs, b). \<not> lnull xs}) (\<lambda>A. A \<inter> {(xs, b). \<not> lnull xs})"
by(rule rel_funI rel_setI)+(auto 4 4 dest: llist_all2_lnullD rel_setD2 rel_setD1 intro: rev_bexI)

lift_definition retain_TCons :: "('a, 'b) tllist set \<Rightarrow> ('a, 'b) tllist set"
is "\<lambda>A. A \<inter> {(xs, b). \<not> lnull xs}" parametric retain_TCons_raw_parametric
by(rule rel_setI)(fastforce dest: rel_setD1 rel_setD2)+

lemma retain_TCons_conv: "retain_TCons A = A \<inter> {xs. \<not> is_TNil xs}"
by(auto simp add: retain_TCons_def intro: rev_image_eqI)

lemma ttl_tSup:
  "\<lbrakk> Complete_Partial_Order.chain tllist_ord Y; \<exists>xs \<in> Y. \<not> is_TNil xs \<rbrakk>
  \<Longrightarrow> ttl (tSup Y) = tSup (ttl ` (Y \<inter> {xs. \<not> is_TNil xs}))"
unfolding ex_TCons_iff[symmetric] retain_TCons_conv[symmetric]
proof (transfer, goal_cases)
  case prems: (1 Y)
  then obtain xs b' where xsb: "(xs, b') \<in> Y" "\<not> lnull xs" by blast
  note chain = prems(1)

  have "flat_lub b (snd ` (Y \<inter> {(xs, _). lfinite xs})) = flat_lub b (insert b (snd ` (Y \<inter> {(xs, _). lfinite xs})))"
    by(auto simp add: flat_lub_def)
  also have "insert b (snd ` (Y \<inter> {(xs, _). lfinite xs})) = insert b (snd ` (apfst ltl ` (Y \<inter> {(xs, b). \<not> lnull xs}) \<inter> {(xs, _). lfinite xs}))"
    apply(auto intro: rev_image_eqI)
    apply(erule contrapos_np)
    apply(frule chainD[OF chain \<open>(xs, b') \<in> Y\<close>])
    using \<open>\<not> lnull xs\<close> xsb
    by(fastforce split: if_split_asm simp add: lprefix_lnull intro!: rev_image_eqI)
  also have "flat_lub b \<dots> = flat_lub b (snd ` (apfst ltl ` (Y \<inter> {(xs, b). \<not> lnull xs}) \<inter> {(xs, _). lfinite xs}))"
    by(auto simp add: flat_lub_def)
  also
  have "ltl ` (fst ` Y \<inter> {xs. \<not> lnull xs}) = fst ` apfst ltl ` (Y \<inter> {(xs, b). \<not> lnull xs})"
    by(auto simp add: image_image)
  ultimately show ?case using prems by clarsimp
qed

lemma tSup_TCons: "A \<noteq> {} \<Longrightarrow> tSup (TCons x ` A) = TCons x (tSup A)"
unfolding Set.is_empty_def[symmetric]
apply transfer
unfolding Set.is_empty_def
apply(clarsimp simp add: image_image lSup_LCons[symmetric])
apply(rule arg_cong[where f="flat_lub b"])
apply(auto 4 3 intro: rev_image_eqI)
done

lemma tllist_ord_terminalD:
  "\<lbrakk> tllist_ord xs ys; is_TNil ys \<rbrakk> \<Longrightarrow> flat_ord b (terminal xs) (terminal ys)"
by(cases xs)(auto simp add: is_TNil_def)

lemma tllist_ord_bot [simp]: "tllist_ord (TNil b) xs"
by(cases xs)(simp_all add: flat_ord_def)

lemma tllist_ord_ttlI:
  "tllist_ord xs ys \<Longrightarrow> tllist_ord (ttl xs) (ttl ys)"
by(cases xs ys rule: tllist.exhaust[case_product tllist.exhaust])(simp_all)

lemma not_is_TNil_conv: "\<not> is_TNil xs \<longleftrightarrow> (\<exists>x xs'. xs = TCons x xs')"
by(cases xs) simp_all

subsection \<open>Continuity of predefined constants\<close>

lemma mono_tllist_ord_case:
  fixes bot
  assumes mono: "\<And>x. monotone tllist_ord ord (\<lambda>xs. f x xs (TCons x xs))"
  and ord: "class.preorder ord (mk_less ord)"
  and bot: "\<And>x. ord (bot b) x"
  shows "monotone tllist_ord ord (\<lambda>xs. case xs of TNil b \<Rightarrow> bot b | TCons x xs' \<Rightarrow> f x xs' xs)"
proof -
  interpret preorder ord "mk_less ord" by (fact ord)
  show ?thesis by(rule monotoneI)(auto split: tllist.split dest: monotoneD[OF mono] simp add: flat_ord_def bot)
qed

lemma mcont_lprefix_case_aux:
  fixes f bot ord
  defines "g \<equiv> \<lambda>xs. f (thd xs) (ttl xs) (TCons (thd xs) (ttl xs))"
  assumes mcont: "\<And>x. mcont tSup tllist_ord lub ord (\<lambda>xs. f x xs (TCons x xs))"
  and ccpo: "class.ccpo lub ord (mk_less ord)"
  and bot: "\<And>x. ord (bot b) x"
  and cont_bot: "cont (flat_lub b) (flat_ord b) lub ord bot"
  shows "mcont tSup tllist_ord lub ord (\<lambda>xs. case xs of TNil b \<Rightarrow> bot b | TCons x xs' \<Rightarrow> f x xs' xs)"
  (is "mcont _ _ _ _ ?f")
proof(rule mcontI)
  interpret b: ccpo lub ord "mk_less ord" by(rule ccpo)

  show "cont tSup tllist_ord lub ord ?f"
  proof(rule contI)
    fix Y :: "('a, 'b) tllist set"
    assume chain: "Complete_Partial_Order.chain tllist_ord Y"
      and Y: "Y \<noteq> {}"
    from chain have chain': "Complete_Partial_Order.chain ord (?f ` Y)"
      by(rule chain_imageI)(auto split: tllist.split simp add: flat_ord_def intro!: bot mcont_monoD[OF mcont])

    show "?f (tSup Y) = lub (?f ` Y)"
    proof(cases "is_TNil (tSup Y)")
      case True
      hence "?f ` Y = bot ` terminal ` Y"
        by(auto 4 3 split: tllist.split intro: rev_image_eqI intro!: imageI)
      moreover from True have "tSup Y = TNil (flat_lub b (terminal ` Y))"
        by -(rule tllist.expand, simp_all add: terminal_tSup)
      moreover have "Complete_Partial_Order.chain (flat_ord b) (terminal ` Y)"
        using chain True by(auto intro: chain_imageI tllist_ord_terminalD)
      ultimately show ?thesis using Y
      by (simp add: contD [OF cont_bot] cong del: b.SUP_cong_simp)
    next
      case False
      hence eq: "tSup Y = TCons (thd (tSup Y)) (ttl (tSup Y))" by simp
      have eq':
        "?f ` Y =
         (\<lambda>x. bot (terminal x)) ` (Y \<inter> {xs. is_TNil xs}) \<union>
         (\<lambda>xs. f (thd xs) (ttl xs) xs) ` (Y \<inter> {xs. \<not> is_TNil xs})"
        by(auto 4 3 split: tllist.splits intro: rev_image_eqI)

      from False obtain xs where xs: "xs \<in> Y" "\<not> is_TNil xs" by auto
      { fix ys
        assume "ys \<in> Y" "is_TNil ys"
        hence "terminal ys = b" using xs
          by(cases xs ys rule: tllist.exhaust[case_product tllist.exhaust])(auto dest: chainD[OF chain]) }
      then have lub: "lub (?f ` Y) = lub ((\<lambda>xs. f (thd xs) (ttl xs) xs) ` (Y \<inter> {xs. \<not> is_TNil xs}))"
        using xs chain' unfolding eq'
        by -(erule ccpo.Sup_Un_less[OF ccpo], auto simp add: intro!: bot)
      { fix xs
        assume xs:  "xs \<in> Y \<inter> {xs. \<not> is_TNil xs}"
        hence "(THE x. x \<in> thd ` (Y \<inter> {xs. \<not> is_TNil xs})) = thd xs"
          by(auto dest: chainD[OF chain] simp add: not_is_TNil_conv intro!: the_equality)
        hence "f (THE x. x \<in> thd ` (Y \<inter> {xs. \<not> is_TNil xs})) (ttl xs) (TCons (THE x. x \<in> thd ` (Y \<inter> {xs. \<not> is_TNil xs})) (ttl xs)) = f (thd xs) (ttl xs) xs"
          using xs by simp }
      moreover have "Complete_Partial_Order.chain tllist_ord (ttl ` (Y \<inter> {xs. \<not> is_TNil xs}))"
        using chain by(rule chain_imageI[OF chain_subset])(auto simp add: tllist_ord_ttlI)
      moreover from False have "Y \<inter> {xs. \<not> is_TNil xs} \<noteq> {}" by auto
      ultimately show ?thesis
        apply(subst (1 2) eq)
        using False
        apply(simp add: thd_tSup ttl_tSup[OF chain] mcont_contD[OF mcont] image_image lub)
        done
    qed
  qed
  from mcont_mono[OF mcont] _ bot
  show "monotone tllist_ord ord ?f"
    by(rule mono_tllist_ord_case)(unfold_locales)
qed

lemma cont_TNil [simp, cont_intro]: "cont (flat_lub b) (flat_ord b) tSup tllist_ord TNil"
apply(rule contI)
apply transfer
apply(simp add: image_image image_constant_conv)
apply(rule arg_cong[where f="flat_lub b"])
apply(auto intro: rev_image_eqI)
done

lemma monotone_TCons: "monotone tllist_ord tllist_ord (TCons x)"
by(rule monotoneI) simp

lemmas mono2mono_TCons[cont_intro] = monotone_TCons[THEN tllist.mono2mono]

lemma mcont_TCons: "mcont tSup tllist_ord tSup tllist_ord (TCons x)"
apply(rule mcontI)
apply(rule monotone_TCons)
apply(rule contI)
apply(simp add: tSup_TCons)
done

lemmas mcont2mcont_TCons[cont_intro] = mcont_TCons[THEN tllist.mcont2mcont]

lemmas [transfer_rule del] = tllist_ord.transfer tSup.transfer

lifting_update tllist.lifting
lifting_forget tllist.lifting

lemmas [transfer_rule] = tllist_ord.transfer tSup.transfer

lemma mono2mono_tset[THEN lfp.mono2mono, cont_intro]:
  shows smonotone_tset: "monotone tllist_ord (\<subseteq>) tset"
including tllist.lifting
by transfer(rule monotone_comp[OF _ monotone_lset], auto intro: monotoneI)

lemma mcont2mcont_tset [THEN lfp.mcont2mcont, cont_intro]:
  shows mcont_tset: "mcont tSup tllist_ord Union (\<subseteq>) tset"
including tllist.lifting
apply transfer
apply(rule mcont_comp[OF _ mcont_lset])
unfolding mcont_def by(auto intro: monotoneI contI )

end

context includes lifting_syntax
begin

lemma rel_fun_lift:
  "(\<And>x. A (f x) (g x)) \<Longrightarrow> ((=) ===> A) f g"
by(simp add: rel_fun_def)

lemma tllist_ord_transfer [transfer_rule]:
  "((=) ===> pcr_tllist (=) (=) ===> pcr_tllist (=) (=) ===> (=))
     (\<lambda>b (xs1, b1) (xs2, b2). if lfinite xs1 then b1 = b \<and> lprefix xs1 xs2 \<or> xs1 = xs2 \<and> flat_ord b b1 b2 else xs1 = xs2)
     tllist_ord"
by(rule rel_fun_lift)(rule tllist_ord.transfer)

lemma tSup_transfer [transfer_rule]:
  "((=) ===> rel_set (pcr_tllist (=) (=)) ===> pcr_tllist (=) (=))
     (\<lambda>b A. (lSup (fst ` A), flat_lub b (snd ` (A \<inter> {(xs, _). lfinite xs}))))
     tSup"
by(rule rel_fun_lift)(rule tSup.transfer)

end

lifting_update tllist.lifting
lifting_forget tllist.lifting

interpretation tllist: partial_function_definitions "tllist_ord b" "tSup b" for b
by(rule tllist_ord_partial_function_definitions)

lemma tllist_case_mono [partial_function_mono, cont_intro]:
  assumes tnil: "\<And>b. monotone orda ordb (\<lambda>f. tnil f b)"
  and tcons: "\<And>x xs. monotone orda ordb (\<lambda>f. tcons f x xs)"
  shows "monotone orda ordb (\<lambda>f. case_tllist (tnil f) (tcons f) xs)"
by(rule monotoneI)(auto split: tllist.split dest: monotoneD[OF tnil] monotoneD[OF tcons])

subsection \<open>Definition of recursive functions\<close>

locale tllist_pf = fixes b :: 'b
begin

declaration \<open>Partial_Function.init "tllist" @{term "tllist.fixp_fun b"}
  @{term "tllist.mono_body b"} @{thm tllist.fixp_rule_uc[where b=b]} @{thm tllist.fixp_induct_uc[where b=b]} NONE\<close>

abbreviation mono_tllist where "mono_tllist \<equiv> monotone (fun_ord (tllist_ord b)) (tllist_ord b)"

lemma LCons_mono [partial_function_mono, cont_intro]:
  "mono_tllist A \<Longrightarrow> mono_tllist (\<lambda>f. TCons x (A f))"
by(rule monotoneI)(auto dest: monotoneD)

end

lemma mono_tllist_lappendt2 [partial_function_mono]:
  "tllist_pf.mono_tllist b A \<Longrightarrow> tllist_pf.mono_tllist b (\<lambda>f. lappendt xs (A f))"
apply(rule monotoneI)
apply(drule (1) monotoneD)
apply(simp add: tllist_ord.rep_eq split: if_split_asm)
apply(auto simp add: lappend_inf)
done

lemma mono_tllist_tappend2 [partial_function_mono]:
  assumes "\<And>y. tllist_pf.mono_tllist b (C y)"
  shows "tllist_pf.mono_tllist b (\<lambda>f. tappend xs (\<lambda>y. C y f))"
apply(cases "tfinite xs")
 apply(rule monotoneI)
 apply(drule monotoneD[OF assms[where y="terminal xs"]])
 including tllist.lifting
 apply transfer
 apply(fastforce split: if_split_asm)
apply(simp add: tappend_inf)
done

end


(* Title: Verification Component Based on KAD: Programs with Pointers
   Author: Victor Gomes, Georg Struth
   Maintainer: Victor Gomes <victor.gomes@cl.cam.ac.uk>
               Georg Struth <g.struth@sheffield.ac.uk>
*)

subsubsection\<open>KAD Component for Pointer Programs\<close>

theory Pointer_Examples
  imports VC_KAD_Examples2 "HOL-Hoare.Heap"

begin

text \<open>This component supports the verification of simple while programs
with pointers in a partial correctness setting.\<close>

text\<open>All we do here is integrating Nipkow's implementation of pointers and heaps.\<close>

type_synonym 'a state = "string  \<Rightarrow> ('a ref + ('a \<Rightarrow> 'a ref))"

lemma list_reversal:
  "PRE (\<lambda>s :: 'a state. List (projr (s ''h'')) (projl (s ''p'')) Ps
        \<and> List (projr (s ''h'')) (projl (s ''q'')) Qs
        \<and> set Ps \<inter> set Qs = {})
    (WHILE (\<lambda>s. projl (s ''p'') \<noteq> Null)
     INV (\<lambda>s. \<exists>ps qs. List (projr (s ''h'')) (projl (s ''p'')) ps
              \<and> List (projr (s ''h'')) (projl (s ''q'')) qs
              \<and> set ps \<inter> set qs = {} \<and> rev ps @ qs = rev Ps @ Qs)
     DO
      (''r'' ::= (\<lambda>s. s ''p''));
      (''p'' ::= (\<lambda>s. Inl (projr (s ''h'') (addr (projl (s ''p''))))) );
      (''h'' ::= (\<lambda>s. Inr ((projr (s ''h''))(addr (projl (s ''r'')) := projl (s ''q''))) ));
      (''q'' ::= (\<lambda>s. s ''r''))
     OD)
  POST (\<lambda>s. List (projr (s ''h'')) (projl (s ''q'')) (rev Ps @ Qs))"
  apply hoare
  apply auto[2]
  by (clarsimp, fastforce intro: notin_List_update[THEN iffD2])

end