\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Relators\<close>
theory Function_Relators
  imports
    Binary_Relation_Functions
    Functions_Base
    Predicates_Lattice
begin

paragraph \<open>Summary\<close>
text \<open>Introduces the concept of function relators. The slogan of function
relators is "related functions map related inputs to related outputs".\<close>

definition "Dep_Fun_Rel_rel R S f g \<equiv> \<forall>x y. R x y \<longrightarrow> S x y (f x) (g y)"

abbreviation "Fun_Rel_rel R S \<equiv> Dep_Fun_Rel_rel R (\<lambda>_ _. S)"

definition "Dep_Fun_Rel_pred P R f g \<equiv> \<forall>x. P x \<longrightarrow> R x (f x) (g x)"

abbreviation "Fun_Rel_pred P R \<equiv> Dep_Fun_Rel_pred P (\<lambda>_. R)"

bundle Dep_Fun_Rel_syntax begin
syntax
  "_Fun_Rel_rel" :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow>
    ('b \<Rightarrow> 'd) \<Rightarrow> bool" ("(_) \<Rrightarrow> (_)" [41, 40] 40)
  "_Dep_Fun_Rel_rel" :: "idt \<Rightarrow> idt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> bool" ("[_/ _/ \<Colon>/ _] \<Rrightarrow> (_)" [41, 41, 41, 40] 40)
  "_Dep_Fun_Rel_rel_if" :: "idt \<Rightarrow> idt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> bool" ("[_/ _/ \<Colon>/ _/ |/ _] \<Rrightarrow> (_)" [41, 41, 41, 41, 40] 40)
  "_Fun_Rel_pred" :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow>
    ('a \<Rightarrow> 'c) \<Rightarrow> bool" ("[_] \<Rrightarrow> (_)" [41, 40] 40)
  "_Dep_Fun_Rel_pred" :: "idt \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> bool" ("[_/ \<Colon>/ _] \<Rrightarrow> (_)" [41, 41, 40] 40)
  "_Dep_Fun_Rel_pred_if" :: "idt \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> bool" ("[_/ \<Colon>/ _/ |/ _] \<Rrightarrow> (_)" [41, 41, 41, 40] 40)
end
bundle no_Dep_Fun_Rel_syntax begin
no_syntax
  "_Fun_Rel_rel" :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow>
    ('b \<Rightarrow> 'd) \<Rightarrow> bool" ("(_) \<Rrightarrow> (_)" [41, 40] 40)
  "_Dep_Fun_Rel_rel" :: "idt \<Rightarrow> idt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> bool" ("[_/ _/ \<Colon>/ _] \<Rrightarrow> (_)" [41, 41, 41, 40] 40)
  "_Dep_Fun_Rel_rel_if" :: "idt \<Rightarrow> idt \<Rightarrow> ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'd) \<Rightarrow> bool" ("[_/ _/ \<Colon>/ _/ |/ _] \<Rrightarrow> (_)" [41, 41, 41, 41, 40] 40)
  "_Fun_Rel_pred" :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow>
    ('a \<Rightarrow> 'c) \<Rightarrow> bool" ("[_] \<Rrightarrow> (_)" [41, 40] 40)
  "_Dep_Fun_Rel_pred" :: "idt \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> bool" ("[_/ \<Colon>/ _] \<Rrightarrow> (_)" [41, 41, 40] 40)
  "_Dep_Fun_Rel_pred_if" :: "idt \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> bool \<Rightarrow> ('b \<Rightarrow> 'c \<Rightarrow> bool) \<Rightarrow>
    ('a \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'c) \<Rightarrow> bool" ("[_/ \<Colon>/ _/ |/ _] \<Rrightarrow> (_)" [41, 41, 41, 40] 40)
end
unbundle Dep_Fun_Rel_syntax
translations
  "R \<Rrightarrow> S" \<rightleftharpoons> "CONST Fun_Rel_rel R S"
  "[x y \<Colon> R] \<Rrightarrow> S" \<rightleftharpoons> "CONST Dep_Fun_Rel_rel R (\<lambda>x y. S)"
  "[x y \<Colon> R | B] \<Rrightarrow> S" \<rightleftharpoons> "CONST Dep_Fun_Rel_rel R (\<lambda>x y. CONST rel_if B S)"
  "[P] \<Rrightarrow> R" \<rightleftharpoons> "CONST Fun_Rel_pred P R"
  "[x \<Colon> P] \<Rrightarrow> R" \<rightleftharpoons> "CONST Dep_Fun_Rel_pred P (\<lambda>x. R)"
  "[x \<Colon> P | B] \<Rrightarrow> R" \<rightleftharpoons> "CONST Dep_Fun_Rel_pred P (\<lambda>x. CONST rel_if B R)"

lemma Dep_Fun_Rel_relI [intro]:
  assumes "\<And>x y. R x y \<Longrightarrow> S x y (f x) (g y)"
  shows "([x y \<Colon> R] \<Rrightarrow> S x y) f g"
  unfolding Dep_Fun_Rel_rel_def using assms by blast

lemma Dep_Fun_Rel_relD:
  assumes "([x y \<Colon> R] \<Rrightarrow> S x y) f g"
  and "R x y"
  shows "S x y (f x) (g y)"
  using assms unfolding Dep_Fun_Rel_rel_def by blast

lemma Dep_Fun_Rel_relE [elim]:
  assumes "([x y \<Colon> R] \<Rrightarrow> S x y) f g"
  and "R x y"
  obtains "S x y (f x) (g y)"
  using assms unfolding Dep_Fun_Rel_rel_def by blast

lemma Dep_Fun_Rel_predI [intro]:
  assumes "\<And>x. P x \<Longrightarrow> R x (f x) (g x)"
  shows "([x \<Colon> P] \<Rrightarrow> R x) f g"
  unfolding Dep_Fun_Rel_pred_def using assms by blast

lemma Dep_Fun_Rel_predD:
  assumes "([x \<Colon> P] \<Rrightarrow> R x) f g"
  and "P x"
  shows "R x (f x) (g x)"
  using assms unfolding Dep_Fun_Rel_pred_def by blast

lemma Dep_Fun_Rel_predE [elim]:
  assumes "([x \<Colon> P] \<Rrightarrow> R x) f g"
  and "P x"
  obtains "R x (f x) (g x)"
  using assms unfolding Dep_Fun_Rel_pred_def by blast

lemma rel_inv_Dep_Fun_Rel_rel_eq [simp]:
  "([x y \<Colon> R] \<Rrightarrow> S x y)\<inverse> = ([y x \<Colon> R\<inverse>] \<Rrightarrow> (S x y)\<inverse>)"
  by (intro ext) auto

lemma rel_inv_Dep_Fun_Rel_pred_eq [simp]:
  "([x \<Colon> P] \<Rrightarrow> R x)\<inverse> = ([x \<Colon> P] \<Rrightarrow> (R x)\<inverse>)"
  by (intro ext) auto

lemma Dep_Fun_Rel_pred_eq_Dep_Fun_Rel_rel:
  "([x \<Colon> P] \<Rrightarrow> R x) = ([x _ \<Colon> (((\<sqinter>) P) \<circ> (=))] \<Rrightarrow> R x)"
  by (intro ext) (auto intro!: Dep_Fun_Rel_predI Dep_Fun_Rel_relI)

lemma Fun_Rel_eq_eq_eq [simp]: "((=) \<Rrightarrow> (=)) = (=)"
  by (intro ext) auto

paragraph \<open>Composition\<close>

lemma Dep_Fun_Rel_rel_compI:
  assumes Dep_Fun_Rel1: "([x y \<Colon> R] \<Rrightarrow> S x y) f g"
  and Dep_Fun_Rel2: "\<And>x y. R x y \<Longrightarrow> ([x' y' \<Colon> T x y] \<Rrightarrow> U x y x' y') f' g'"
  and le: "\<And>x y. R x y \<Longrightarrow> S x y (f x) (g y) \<Longrightarrow> T x y (f x) (g y)"
  shows "([x y \<Colon> R] \<Rrightarrow> U x y (f x) (g y)) (f' \<circ> f) (g' \<circ> g)"
  using assms by (intro Dep_Fun_Rel_relI) (auto 6 0)

corollary Dep_Fun_Rel_rel_compI':
  assumes "([x y \<Colon> R] \<Rrightarrow> S x y) f g"
  and "\<And>x y. R x y \<Longrightarrow> ([x' y' \<Colon> S x y] \<Rrightarrow> T x y x' y') f' g'"
  shows "([x y \<Colon> R] \<Rrightarrow> T x y (f x) (g y)) (f' \<circ> f) (g' \<circ> g)"
  using assms by (intro Dep_Fun_Rel_rel_compI)

lemma Dep_Fun_Rel_pred_comp_Dep_Fun_Rel_rel_compI:
  assumes Dep_Fun_Rel1: "([x \<Colon> P] \<Rrightarrow> R x) f g"
  and Dep_Fun_Rel2: "\<And>x. P x \<Longrightarrow> ([x' y' \<Colon> S x] \<Rrightarrow> T x x' y') f' g'"
  and le: "\<And>x. P x \<Longrightarrow> R x (f x) (g x) \<Longrightarrow> S x (f x) (g x)"
  shows "([x \<Colon> P] \<Rrightarrow> T x (f x) (g x)) (f' \<circ> f) (g' \<circ> g)"
  using assms by (intro Dep_Fun_Rel_predI) (auto 6 0)

corollary Dep_Fun_Rel_pred_comp_Dep_Fun_Rel_rel_compI':
  assumes "([x \<Colon> P] \<Rrightarrow> R x) f g"
  and "\<And>x. P x \<Longrightarrow> ([x' y' \<Colon> R x] \<Rrightarrow> S x x' y') f' g'"
  shows "([x \<Colon> P] \<Rrightarrow> S x (f x) (g x)) (f' \<circ> f) (g' \<circ> g)"
  using assms by (intro Dep_Fun_Rel_pred_comp_Dep_Fun_Rel_rel_compI)

paragraph \<open>Restrictions\<close>

lemma restrict_left_Dep_Fun_Rel_rel_restrict_left_eq:
  fixes R :: "'a1 \<Rightarrow> 'a2 \<Rightarrow> bool"
  and S :: "'a1 \<Rightarrow> 'a2 \<Rightarrow> 'b1 \<Rightarrow> 'b2 \<Rightarrow> bool"
  and P :: "'a1 \<Rightarrow> 'a2 \<Rightarrow> 'b1 \<Rightarrow> bool"
  assumes "\<And>f x y. Q f \<Longrightarrow> R x y \<Longrightarrow> P x y (f x)"
  shows "([x y \<Colon> R] \<Rrightarrow> (S x y)\<restriction>\<^bsub>P x y\<^esub>)\<restriction>\<^bsub>Q\<^esub> = ([x y \<Colon> R] \<Rrightarrow> S x y)\<restriction>\<^bsub>Q\<^esub>"
  using assms by (intro ext iffI restrict_leftI Dep_Fun_Rel_relI)
  (auto dest!: Dep_Fun_Rel_relD)

lemma restrict_right_Dep_Fun_Rel_rel_restrict_right_eq:
  fixes R :: "'a1 \<Rightarrow> 'a2 \<Rightarrow> bool"
  and S :: "'a1 \<Rightarrow> 'a2 \<Rightarrow> 'b1 \<Rightarrow> 'b2 \<Rightarrow> bool"
  and P :: "'a1 \<Rightarrow> 'a2 \<Rightarrow> 'b2 \<Rightarrow> bool"
  assumes "\<And>f x y. Q f \<Longrightarrow> R x y \<Longrightarrow> P x y (f y)"
  shows "(([x y \<Colon> R] \<Rrightarrow> (S x y)\<upharpoonleft>\<^bsub>P x y\<^esub>)\<upharpoonleft>\<^bsub>Q\<^esub>) = (([x y \<Colon> R] \<Rrightarrow> S x y)\<upharpoonleft>\<^bsub>Q\<^esub>)"
  unfolding restrict_right_eq
  using assms restrict_left_Dep_Fun_Rel_rel_restrict_left_eq[where ?R="R\<inverse>"
    and ?S="\<lambda>y x. (S x y)\<inverse>"]
  by simp

end


section {* Interpretation of syntax in semantic domains *}

theory Semantic_Domains imports Iteration
begin

text {* In this section, we employ our iteration principle
to obtain interpretation of syntax in semantic domains via valuations.
A bonus from our Horn-theoretic approach is the built-in
commutation of the interpretation with substitution versus valuation update,
a property known in the literature as the ``substitution lemma". *}

subsection {* Semantic domains and valuations *}

text{*
Semantic domains are for binding signatures
what algebras are for standard algebraic signatures. They fix carrier sets for each sort,
and interpret each operation symbol as an operation on these sets
%
\footnote{
To match the Isabelle type system, we model (as usual) the family of carrier sets as a
``well-sortedness" predicate taking sorts and semantic items from a given
(initially unsorted) universe into booleans,
and require the operations, considered on the unsorted universe, to preserve well-sortedness.
}
%
of corresponding arity, where:
%
\\- non-binding arguments
are treated as usual (first-order) arguments;
%
\\- binding arguments are treated as second-order (functional) arguments.
%
\footnote{
In other words, syntactic bindings are captured semantically as functional bindings.}
%

In particular, for the untyped and simply-typed $\lambda$-calculi,
the semantic domains become the well-known (set-theoretic) Henkin models.

We use terminology and notation according to our general methodology employed so far:
the inhabitants of semantic domains are referred to as ``semantic items";
we prefix the reference to semantic items with an ``s": sX, sA, etc.
This convention also applies to the operations on semantic domains: ``sAbs", ``sOp", etc.

We eventually show that the function spaces consisting of maps
from valuations to semantic items form models;
in other words,
these maps can be viewed as ``generalized items"; we use for them
term-like notations ``X", ``A", etc.
(as we did in the theory that dealt with iteration).
*}

subsubsection {* Definitions: *}

datatype ('varSort,'sTerm)sAbs = sAbs 'varSort "'sTerm \<Rightarrow> 'sTerm"

record ('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom =
  sWls :: "'sort \<Rightarrow> 'sTerm \<Rightarrow> bool"
  sDummy :: "'sort \<Rightarrow> 'sTerm"
  sOp :: "'opSym \<Rightarrow> ('index,'sTerm)input \<Rightarrow> ('bindex,('varSort,'sTerm)sAbs)input \<Rightarrow>'sTerm"

text{* The type of valuations: *}

type_synonym ('varSort,'var,'sTerm)val = "'varSort \<Rightarrow> 'var \<Rightarrow> 'sTerm"

(* *************************************************** *)
context FixSyn
begin

(* A new type variable, corresponding to 'sTerm, is introduced in the context by
the following definitions and facts. *)

fun sWlsAbs where
"sWlsAbs SEM (xs,s) (sAbs xs' sF) =
 (isInBar (xs,s) \<and> xs = xs' \<and>
  (\<forall> sX. if sWls SEM (asSort xs) sX
           then sWls SEM s (sF sX)
           else sF sX = sDummy SEM s))"

definition sWlsInp where
"sWlsInp SEM delta sinp \<equiv>
 wlsOpS delta \<and> sameDom (arOf delta) sinp \<and> liftAll2 (sWls SEM) (arOf delta) sinp"

definition sWlsBinp where
"sWlsBinp SEM delta sbinp \<equiv>
 wlsOpS delta \<and> sameDom (barOf delta) sbinp \<and> liftAll2 (sWlsAbs SEM) (barOf delta) sbinp"

definition sWlsNE where
"sWlsNE SEM \<equiv>
 \<forall> s. \<exists> sX. sWls SEM s sX"

definition sWlsDisj where
"sWlsDisj SEM \<equiv>
 \<forall> s s' sX. sWls SEM s sX \<and> sWls SEM s' sX \<longrightarrow> s = s'"

definition sOpPrSWls where
"sOpPrSWls SEM \<equiv>
 \<forall> delta sinp sbinp.
   sWlsInp SEM delta sinp \<and> sWlsBinp SEM delta sbinp
   \<longrightarrow> sWls SEM (stOf delta) (sOp SEM delta sinp sbinp)"

text{* The notion of a ``well-sorted" (better read as ``well-structured")
semantic domain:
%
\footnote{
As usual in Isabelle, we first define the ``raw" version,
and then ``fix" it with a well-structuredness predicate.
}
%
*}
definition wlsSEM where
"wlsSEM SEM \<equiv>
 sWlsNE SEM \<and> sWlsDisj SEM \<and> sOpPrSWls SEM"

text{* The preperties described  in the next 4 definitions turn out to be
consequences of the well-structuredness of the semantic domain: *}

definition sWlsAbsNE where
"sWlsAbsNE SEM \<equiv>
 \<forall> us s. isInBar (us,s) \<longrightarrow> (\<exists> sA. sWlsAbs SEM (us,s) sA)"

definition sWlsAbsDisj where
"sWlsAbsDisj SEM \<equiv>
 \<forall> us s us' s' sA.
   isInBar (us,s) \<and> isInBar (us',s') \<and> sWlsAbs SEM (us,s) sA \<and> sWlsAbs SEM (us',s') sA
   \<longrightarrow> us = us' \<and> s = s'"

text{* The notion of two valuations being equal everywhere but on a given variable: *}

definition eqBut where
"eqBut val val' xs x \<equiv>
 \<forall> ys y. (ys = xs \<and> y = x) \<or> val ys y = val' ys y"

definition updVal ::
"('varSort,'var,'sTerm)val \<Rightarrow>
 'var \<Rightarrow> 'sTerm \<Rightarrow> 'varSort \<Rightarrow>
 ('varSort,'var,'sTerm)val" ("_ '(_ := _')'__" 200)
where
"(val (x := sX)_xs) \<equiv>
 \<lambda> ys y. (if ys = xs \<and> y = x then sX else val ys y)"

definition swapVal ::
"'varSort \<Rightarrow> 'var \<Rightarrow> 'var \<Rightarrow> ('varSort,'var,'sTerm)val \<Rightarrow>
 ('varSort,'var,'sTerm)val"
where
"swapVal zs z1 z2 val \<equiv> \<lambda>xs x. val xs (x @xs[z1 \<and> z2]_zs) "

abbreviation swapVal_abbrev ("_ ^[_ \<and> _]'__" 200) where
"val ^[z1 \<and> z2]_zs \<equiv> swapVal zs z1 z2 val"

definition sWlsVal where
"sWlsVal SEM val \<equiv>
 \<forall> ys y. sWls SEM (asSort ys) (val ys y)"

(* The last argument is a dummy argument identifying the type 'var --
it may be regarded as a type argument:  *)

definition sWlsValNE ::
"('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom \<Rightarrow> 'var \<Rightarrow> bool"
where
"sWlsValNE SEM x \<equiv> \<exists> (val :: ('varSort,'var,'sTerm)val). sWlsVal SEM val"

subsubsection {* Basic facts *}

lemma sWlsNE_imp_sWlsAbsNE:
assumes "sWlsNE SEM"
shows "sWlsAbsNE SEM"
unfolding sWlsAbsNE_def proof clarify
  fix xs s
  obtain sY where "sWls SEM s sY"
  using assms unfolding sWlsNE_def by auto
  moreover assume "isInBar (xs,s)"
  ultimately
  have "sWlsAbs SEM (xs,s) (sAbs xs (\<lambda>sX. if sWls SEM (asSort xs) sX
                                           then sY
                                           else sDummy SEM s))" by simp
  thus "\<exists>sA. sWlsAbs SEM (xs,s) sA" by blast
qed

lemma sWlsDisj_imp_sWlsAbsDisj:
"sWlsDisj SEM \<Longrightarrow> sWlsNE SEM \<Longrightarrow> sWlsAbsDisj SEM"
by (simp add: sWlsAbsDisj_def sWlsNE_def sWlsDisj_def)
   (smt prod.inject sAbs.inject sWlsAbs.elims(2))

lemma sWlsNE_imp_sWlsValNE:
"sWlsNE SEM \<Longrightarrow> sWlsValNE SEM x"
by (auto simp: sWlsNE_def  sWlsValNE_def sWlsVal_def
 intro!: exI someI_ex[of "(\<lambda> sY. sWls SEM (asSort _) sY)"])

theorem updVal_simp[simp]:
"(val (x := sX)_xs) ys y = (if ys = xs \<and> y = x then sX else val ys y)"
unfolding updVal_def by simp

theorem updVal_over[simp]:
"((val (x := sX)_xs) (x := sX')_xs) = (val (x := sX')_xs)"
unfolding updVal_def by fastforce

theorem updVal_commute:
assumes "xs \<noteq> ys \<or> x \<noteq> y"
shows "((val (x := sX)_xs) (y := sY)_ys) = ((val (y := sY)_ys) (x := sX)_xs)"
using assms unfolding updVal_def by fastforce

theorem updVal_preserves_sWls[simp]:
assumes "sWls SEM (asSort xs) sX" and "sWlsVal SEM val"
shows "sWlsVal SEM (val (x := sX)_xs)"
using assms unfolding sWlsVal_def by auto

lemmas updVal_simps = updVal_simp updVal_over updVal_preserves_sWls

theorem swapVal_ident[simp]: "(val ^[x \<and> x]_xs) = val"
unfolding swapVal_def by auto

theorem swapVal_compose:
"((val ^[x \<and> y]_zs) ^[x' \<and> y']_zs') =
 ((val ^[x' @zs'[x \<and> y]_zs \<and> y' @zs'[x \<and> y]_zs]_zs') ^[x \<and> y]_zs)"
unfolding swapVal_def by (metis sw_compose)

theorem swapVal_commute:
"zs \<noteq> zs' \<or> {x,y} \<inter> {x',y'} = {} \<Longrightarrow>
 ((val ^[x \<and> y]_zs) ^[x' \<and> y']_zs') = ((val ^[x' \<and> y']_zs') ^[x \<and> y]_zs)"
using swapVal_compose[of zs' x' y' zs x y val] by(simp add: sw_def)

lemma swapVal_involutive[simp]: "((val ^[x \<and> y]_zs) ^[x \<and> y]_zs) = val"
unfolding swapVal_def by auto

lemma swapVal_sym: "(val ^[x \<and> y]_zs) = (val ^[y \<and> x]_zs)"
unfolding swapVal_def by(auto simp add: sw_sym)

lemma swapVal_preserves_sWls1:
assumes "sWlsVal SEM val"
shows "sWlsVal SEM (val ^[z1 \<and> z2]_zs)"
using assms unfolding sWlsVal_def swapVal_def by simp

theorem swapVal_preserves_sWls[simp]:
"sWlsVal SEM (val ^[z1 \<and> z2]_zs) = sWlsVal SEM val"
using swapVal_preserves_sWls1[of _ _ zs z1 z2] by fastforce

lemmas swapVal_simps = swapVal_ident swapVal_involutive swapVal_preserves_sWls

lemma updVal_swapVal:
"((val (x := sX)_xs) ^[y1 \<and> y2]_ys) =
 ((val ^[y1 \<and> y2]_ys) ((x @xs[y1 \<and> y2]_ys) := sX)_xs)"
unfolding swapVal_def by fastforce

lemma updVal_eqBut_eq:
assumes "eqBut val val' ys y"
shows "(val (y := sY)_ys) = (val' (y := sY)_ys)"
using assms unfolding eqBut_def by fastforce

lemma swapVal_preserves_eqBut:
assumes "eqBut val val' xs x"
shows "eqBut (val ^[z1 \<and> z2]_zs) (val' ^[z1 \<and> z2]_zs) xs (x @xs[z1 \<and> z2]_zs)"
using assms unfolding eqBut_def swapVal_def by force

subsection {* Interpretation maps *}

text{* An interpretation map, of syntax in a semantic domain,
is the usual one w.r.t. valuations.  Here we state its compostionality conditions
(including the ``substitution lemma"), and later we prove the existence of a map
satisfying these conditions.  *}

subsubsection {* Definitions *}

text {* Below, prefix ``pr" means ``preserves". *}

definition prWls where
"prWls g SEM \<equiv> \<forall> s X val.
    wls s X \<and> sWlsVal SEM val
    \<longrightarrow> sWls SEM s (g X val)"

definition prWlsAbs where
"prWlsAbs gA SEM \<equiv> \<forall> us s A val.
    wlsAbs (us,s) A \<and> sWlsVal SEM val
    \<longrightarrow> sWlsAbs SEM (us,s) (gA A val)"

definition prWlsAll where
"prWlsAll g gA SEM \<equiv> prWls g SEM \<and> prWlsAbs gA SEM"

definition prVar where
"prVar g SEM \<equiv> \<forall> xs x val.
    sWlsVal SEM val \<longrightarrow> g (Var xs x) val = val xs x"

definition prAbs where
"prAbs g gA SEM \<equiv> \<forall> xs s x X val.
    isInBar (xs,s) \<and> wls s X \<and> sWlsVal SEM val
    \<longrightarrow>
    gA (Abs xs x X) val =
    sAbs xs (\<lambda>sX. if sWls SEM (asSort xs) sX then g X (val (x := sX)_xs)
                                             else sDummy SEM s)"

definition prOp where
"prOp g gA SEM \<equiv> \<forall> delta inp binp val.
    wlsInp delta inp \<and> wlsBinp delta binp \<and> sWlsVal SEM val
    \<longrightarrow>
    g (Op delta inp binp) val =
    sOp SEM delta (lift (\<lambda>X. g X val) inp)
                  (lift (\<lambda>A. gA A val) binp)"

definition prCons where
"prCons g gA SEM \<equiv> prVar g SEM \<and> prAbs g gA SEM \<and> prOp g gA SEM"

definition prFresh where
"prFresh g SEM \<equiv> \<forall> ys y s X val val'.
   wls s X \<and> fresh ys y X \<and>
   sWlsVal SEM val \<and> sWlsVal SEM val' \<and> eqBut val val' ys y
   \<longrightarrow> g X val = g X val'"

definition prFreshAbs where
"prFreshAbs gA SEM \<equiv> \<forall> ys y us s A val val'.
   wlsAbs (us,s) A \<and> freshAbs ys y A \<and>
   sWlsVal SEM val \<and> sWlsVal SEM val' \<and> eqBut val val' ys y
   \<longrightarrow> gA A val = gA A val'"

definition prFreshAll where
"prFreshAll g gA SEM \<equiv> prFresh g SEM \<and> prFreshAbs gA SEM"

definition prSwap where
"prSwap g SEM \<equiv> \<forall> zs z1 z2 s X val.
   wls s X \<and> sWlsVal SEM val
   \<longrightarrow>
   g (X #[z1 \<and> z2]_zs) val =
   g X (val ^[z1 \<and> z2]_zs)"

definition prSwapAbs where
"prSwapAbs gA SEM \<equiv> \<forall> zs z1 z2 us s A val.
   wlsAbs (us,s) A \<and> sWlsVal SEM val
   \<longrightarrow>
   gA (A $[z1 \<and> z2]_zs) val =
   gA A (val ^[z1 \<and> z2]_zs)"

definition prSwapAll where
"prSwapAll g gA SEM \<equiv> prSwap g SEM \<and> prSwapAbs gA SEM"

definition prSubst where
"prSubst g SEM \<equiv> \<forall> ys Y y s X val.
    wls (asSort ys) Y \<and> wls s X
    \<and> sWlsVal SEM val
    \<longrightarrow>
    g (X #[Y / y]_ys) val =
    g X (val (y := g Y val)_ys)"

definition prSubstAbs where
"prSubstAbs g gA SEM \<equiv> \<forall> ys Y y us s A val.
    wls (asSort ys) Y \<and> wlsAbs (us,s) A
    \<and> sWlsVal SEM val
    \<longrightarrow>
    gA (A $[Y / y]_ys) val =
    gA A (val (y := g Y val)_ys)"

definition prSubstAll where
"prSubstAll g gA SEM \<equiv> prSubst g SEM \<and> prSubstAbs g gA SEM"

definition compInt where
"compInt g gA SEM \<equiv> prWlsAll g gA SEM \<and> prCons g gA SEM \<and>
 prFreshAll g gA SEM \<and> prSwapAll g gA SEM \<and> prSubstAll g gA SEM"

subsubsection {* Extension of domain preservation to inputs *}

lemma prWls_wlsInp:
assumes "wlsInp delta inp" and "prWls g SEM" and "sWlsVal SEM val"
shows "sWlsInp SEM delta (lift (\<lambda> X. g X val) inp)"
using assms unfolding sWlsInp_def wlsInp_iff liftAll2_def lift_def prWls_def
by (auto simp add: option.case_eq_if sameDom_def)

lemma prWlsAbs_wlsBinp:
assumes "wlsBinp delta binp" and "prWlsAbs gA SEM" and "sWlsVal SEM val"
shows "sWlsBinp SEM delta (lift (\<lambda> A. gA A val) binp)"
using assms unfolding sWlsBinp_def wlsBinp_iff liftAll2_def lift_def prWlsAbs_def
by (auto simp add: option.case_eq_if sameDom_def)

end (* context FixSyn *)
(***************************************)

subsection {* The iterative model associated to a semantic domain *}

text{*
``asIMOD SEM" stands for ``SEM (regarded) as a model".
%
\footnote{
We use the word ``model" as introduced in the theory ``Models-and-Recursion".
}
%
The associated model is built essentially as follows:
%
\\- Its carrier sets consist of functions from valuations to semantic items.
%
\\- The construct operations (i.e., those corresponding to the syntactic constructs
indicated in the given binding signature) are lifted componentwise from those of the semantic domain
``SEM" (also taking into account the higher-order nature of of the semantic counterparts of abstractions).
%
\\- For a map from valuations to items (terms or abstractions), freshness of a variable ``x"
is defined as being oblivious what the argument valuation returns for ``x".
%
\\- Swapping is defined componentwise, by two iterations of the notion of swapping the
returned value of a function.
%
\\- Substitution of a semantic term ``Y" for a variable ``y" is a semantic term ``X"
is defined to map each valuation ``val" to the application of ``X" to
[``val" updated at ``y" with whatever ``Y" returns for ``val"].

Note that:
%
\\- The construct operations definitions are determined by the desired clauses of the standard
notion of interpreting syntax in a semantic domains.
%
\\- Substitution and freshness are defined having in mind the (again standard) facts of
the interpretation commuting with substitution versus valuation update and the interpretation
being oblivious to the valuation of fresh variables.
*}

subsubsection {* Definition and basic facts  *}

text{*
The next two types of ``generalized items" are used to build models from semantic domains:
%
\footnote{
Recall that ``generalized items" inhabit models.
}
%
*}

type_synonym ('varSort,'var,'sTerm) gTerm = "('varSort,'var,'sTerm)val \<Rightarrow> 'sTerm"

type_synonym ('varSort,'var,'sTerm) gAbs = "('varSort,'var,'sTerm)val \<Rightarrow> ('varSort,'sTerm)sAbs"

(* *************************************************** *)
context FixSyn
begin

definition asIMOD ::
"('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom \<Rightarrow>
 ('index,'bindex,'varSort,'sort,'opSym,'var,
  ('varSort,'var,'sTerm)gTerm,
  ('varSort,'var,'sTerm)gAbs)model"
where
"asIMOD SEM \<equiv>
 \<lparr>igWls = \<lambda>s X. \<forall> val. (sWlsVal SEM val \<or> X val = undefined) \<and>
                      (sWlsVal SEM val \<longrightarrow> sWls SEM s (X val)),
  igWlsAbs = \<lambda>(xs,s) A. \<forall> val. (sWlsVal SEM val \<or> A val = undefined) \<and>
                              (sWlsVal SEM val \<longrightarrow> sWlsAbs SEM (xs,s) (A val)),
  igVar = \<lambda>ys y. \<lambda>val. if sWlsVal SEM val then val ys y else undefined,
  igAbs =
  \<lambda>xs x X. \<lambda>val. if sWlsVal SEM val
                   then sAbs xs (\<lambda>sX. if sWls SEM (asSort xs) sX
                                         then X (val (x := sX)_xs)
                                         else sDummy SEM (SOME s. sWls SEM s (X val)))
                   else undefined,
  igOp = \<lambda>delta inp binp. \<lambda>val.
          if sWlsVal SEM val then sOp SEM delta (lift (\<lambda>X. X val) inp)
                                                (lift (\<lambda>A. A val) binp)
                             else undefined,
  igFresh =
  \<lambda>ys y X. \<forall> val val'. sWlsVal SEM val \<and> sWlsVal SEM val' \<and> eqBut val val' ys y
                       \<longrightarrow> X val = X val',
  igFreshAbs =
  \<lambda>ys y A. \<forall> val val'. sWlsVal SEM val \<and> sWlsVal SEM val' \<and> eqBut val val' ys y
                       \<longrightarrow> A val = A val',
  igSwap = \<lambda>zs z1 z2 X. \<lambda>val. if sWlsVal SEM val then X (val ^[z1 \<and> z2]_zs)
                                                else undefined,
  igSwapAbs = \<lambda>zs z1 z2 A. \<lambda>val. if sWlsVal SEM val then A (val ^[z1 \<and> z2]_zs)
                                                   else undefined,
  igSubst = \<lambda>ys Y y X. \<lambda>val. if sWlsVal SEM val then X (val (y := Y val)_ys)
                                                else undefined,
  igSubstAbs = \<lambda>ys Y y A. \<lambda>val. if sWlsVal SEM val then A (val (y := Y val)_ys)
                                                   else undefined\<rparr>"

text{* Next we state, as usual, the direct definitions of the operators and relations
of associated model, freeing ourselves from
having to go through the ``asIMOD" definition each time we reason about them.  *}

lemma asIMOD_igWls:
"igWls (asIMOD SEM) s X \<longleftrightarrow>
 (\<forall> val. (sWlsVal SEM val \<or> X val = undefined) \<and>
         (sWlsVal SEM val \<longrightarrow> sWls SEM s (X val)))"
unfolding asIMOD_def by simp

lemma asIMOD_igWlsAbs:
"igWlsAbs (asIMOD SEM) (us,s) A \<longleftrightarrow>
 (\<forall> val. (sWlsVal SEM val \<or> A val = undefined) \<and>
         (sWlsVal SEM val \<longrightarrow> sWlsAbs SEM (us,s) (A val)))"
unfolding asIMOD_def by simp

lemma asIMOD_igOp:
"igOp (asIMOD SEM) delta inp binp =
(\<lambda>val. if sWlsVal SEM val then sOp SEM delta (lift (\<lambda>X. X val) inp)
                                             (lift (\<lambda>A. A val) binp)
                          else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igVar:
"igVar (asIMOD SEM) ys y = (\<lambda>val. if sWlsVal SEM val then val ys y else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igAbs:
"igAbs (asIMOD SEM) xs x X =
(\<lambda>val. if sWlsVal SEM val then sAbs xs (\<lambda>sX. if sWls SEM (asSort xs) sX
                                                then X (val (x := sX)_xs)
                                                else sDummy SEM (SOME s. sWls SEM s (X val)))
                          else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igAbs2:
fixes SEM :: "('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom"
assumes *: "sWlsDisj SEM" and **: "igWls (asIMOD SEM) s X"
shows "igAbs (asIMOD SEM) xs x X =
(\<lambda>val. if sWlsVal SEM val then sAbs xs (\<lambda>sX. if sWls SEM (asSort xs) sX
                                                then X (val (x := sX)_xs)
                                                else sDummy SEM s)
                          else undefined)"
proof-
  {fix val :: "('varSort,'var,'sTerm)val" assume val: "sWlsVal SEM val"
   hence Xval: "sWls SEM s (X val)"
   using ** unfolding asIMOD_igWls by simp
   hence "(SOME s. sWls SEM s (X val)) = s"
   using Xval * unfolding sWlsDisj_def by auto
  }
  thus ?thesis unfolding asIMOD_igAbs by fastforce
qed

lemma asIMOD_igFresh:
"igFresh (asIMOD SEM) ys y X =
(\<forall> val val'. sWlsVal SEM val \<and> sWlsVal SEM val' \<and> eqBut val val' ys y
             \<longrightarrow> X val = X val')"
unfolding asIMOD_def by simp

lemma asIMOD_igFreshAbs:
"igFreshAbs (asIMOD SEM) ys y A =
(\<forall> val val'. sWlsVal SEM val \<and> sWlsVal SEM val' \<and> eqBut val val' ys y
             \<longrightarrow> A val = A val')"
unfolding asIMOD_def by simp

lemma asIMOD_igSwap:
"igSwap (asIMOD SEM) zs z1 z2 X =
(\<lambda>val. if sWlsVal SEM val then X (val ^[z1 \<and> z2]_zs) else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igSwapAbs:
"igSwapAbs (asIMOD SEM) zs z1 z2 A =
(\<lambda>val. if sWlsVal SEM val then A (val ^[z1 \<and> z2]_zs) else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igSubst:
"igSubst (asIMOD SEM) ys Y y X =
(\<lambda>val. if sWlsVal SEM val then X (val (y := Y val)_ys) else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igSubstAbs:
"igSubstAbs (asIMOD SEM) ys Y y A =
(\<lambda>val. if sWlsVal SEM val then A (val (y := Y val)_ys) else undefined)"
unfolding asIMOD_def by simp

lemma asIMOD_igWlsInp:
assumes "sWlsNE SEM"
shows
"igWlsInp (asIMOD SEM) delta inp \<longleftrightarrow>
 ((\<forall> val. liftAll (\<lambda>X. sWlsVal SEM val \<or> X val = undefined) inp) \<and>
  (\<forall> val. sWlsVal SEM val \<longrightarrow> sWlsInp SEM delta (lift (\<lambda>X. X val) inp)))"
using assms apply safe
 subgoal by (simp add: asIMOD_igWls liftAll_def liftAll2_def igWlsInp_def
  sameDom_def split: option.splits) (metis option.distinct(1) option.exhaust)
 subgoal by (simp add: igWlsInp_def asIMOD_igWls liftAll_def liftAll2_def
  lift_def sWlsInp_def sameDom_def split: option.splits)
 subgoal by (simp add:igWlsInp_def asIMOD_igWls liftAll_def liftAll2_def
  lift_def sWlsInp_def sameDom_def split: option.splits)
  (metis (no_types) option.distinct(1) sWlsNE_imp_sWlsValNE sWlsValNE_def) .

lemma asIMOD_igSwapInp:
"sWlsVal SEM val \<Longrightarrow>
 lift (\<lambda>X. X val) (igSwapInp (asIMOD SEM) zs z1 z2 inp) =
 lift (\<lambda>X. X (swapVal zs z1 z2 val)) inp"
by (auto simp: igSwapInp_def asIMOD_igSwap lift_def split: option.splits)

lemma asIMOD_igSubstInp:
"sWlsVal SEM val \<Longrightarrow>
 lift (\<lambda>X. X val) (igSubstInp (asIMOD SEM) ys Y y inp) =
 lift (\<lambda>X. X (val (y := Y val)_ys)) inp"
by (auto simp: igSubstInp_def asIMOD_igSubst lift_def split: option.splits)

lemma asIMOD_igWlsBinp:
assumes "sWlsNE SEM"
shows
"igWlsBinp (asIMOD SEM) delta binp =
 ((\<forall> val. liftAll (\<lambda>X. sWlsVal SEM val \<or> X val = undefined) binp) \<and>
  (\<forall> val. sWlsVal SEM val \<longrightarrow> sWlsBinp SEM delta (lift (\<lambda>X. X val) binp)))"
using assms apply safe
 subgoal by (simp add: asIMOD_igWlsAbs liftAll_def liftAll2_def igWlsBinp_def
  sameDom_def split: option.splits)
 (metis option.distinct(1) option.exhaust surj_pair)
 subgoal by (simp add: igWlsBinp_def asIMOD_igWlsAbs liftAll_def liftAll2_def
  lift_def sWlsBinp_def sameDom_def split: option.splits)
 subgoal by (simp add:igWlsBinp_def asIMOD_igWlsAbs liftAll_def liftAll2_def
  lift_def sWlsBinp_def sameDom_def split: option.splits)
  (metis (no_types) old.prod.exhaust option.distinct(1) option.exhaust
   sWlsNE_imp_sWlsValNE sWlsValNE_def) .

lemma asIMOD_igSwapBinp:
"sWlsVal SEM val \<Longrightarrow>
 lift (\<lambda>A. A val) (igSwapBinp (asIMOD SEM) zs z1 z2 binp) =
 lift (\<lambda>A. A (swapVal zs z1 z2 val)) binp"
by (auto simp: igSwapBinp_def asIMOD_igSwapAbs lift_def split: option.splits)

lemma asIMOD_igSubstBinp:
"sWlsVal SEM val \<Longrightarrow>
 lift (\<lambda>A. A val) (igSubstBinp (asIMOD SEM) ys Y y binp) =
 lift (\<lambda>A. A (val (y := Y val)_ys)) binp"
by (auto simp: igSubstBinp_def asIMOD_igSubstAbs lift_def split: option.splits)

subsubsection {* The associated model is well-structured *}

text{* That is to say: it is a fresh-swap-subst
and fresh-subst-swap model (hence of course also a fresh-swap and fresh-subst) model. *}

text{* Domain disjointness: *}

lemma asIMOD_igWlsDisj:
"sWlsNE SEM \<Longrightarrow> sWlsDisj SEM \<Longrightarrow> igWlsDisj (asIMOD SEM)"
using sWlsNE_imp_sWlsValNE
by (fastforce simp: igWlsDisj_def asIMOD_igWls sWlsValNE_def sWlsDisj_def)

lemma asIMOD_igWlsAbsDisj:
"sWlsNE SEM \<Longrightarrow> sWlsDisj SEM \<Longrightarrow> igWlsAbsDisj (asIMOD SEM)"
using sWlsNE_imp_sWlsValNE sWlsDisj_imp_sWlsAbsDisj
by (fastforce simp: igWlsAbsDisj_def asIMOD_igWlsAbs sWlsAbsDisj_def sWlsValNE_def)

lemma asIMOD_igWlsAllDisj:
"sWlsNE SEM \<Longrightarrow> sWlsDisj SEM \<Longrightarrow> igWlsAllDisj (asIMOD SEM)"
unfolding igWlsAllDisj_def using asIMOD_igWlsDisj asIMOD_igWlsAbsDisj by auto

text {* Only ``bound arit" abstraction domains are inhabited: *}

lemma asIMOD_igWlsAbsIsInBar:
"sWlsNE SEM \<Longrightarrow> igWlsAbsIsInBar (asIMOD SEM)"
using sWlsNE_imp_sWlsValNE
by (auto simp: sWlsValNE_def igWlsAbsIsInBar_def asIMOD_igWlsAbs
         split: option.splits elim: sWlsAbs.elims(2))

text{* Domain preservation by the operators *}

text{* The constructs preserve the domains: *}

lemma asIMOD_igVarIPresIGWls: "igVarIPresIGWls (asIMOD SEM)"
unfolding igVarIPresIGWls_def asIMOD_igWls asIMOD_igVar sWlsVal_def by simp

lemma asIMOD_igAbsIPresIGWls:
"sWlsDisj SEM \<Longrightarrow> igAbsIPresIGWls (asIMOD SEM)"
unfolding igAbsIPresIGWls_def asIMOD_igWlsAbs apply clarify
subgoal for _ _ _ _ val
unfolding asIMOD_igAbs2 by (cases "sWlsVal SEM val") (auto simp: asIMOD_igWls) .

lemma asIMOD_igOpIPresIGWls:
"sOpPrSWls SEM \<Longrightarrow> sWlsNE SEM \<Longrightarrow> igOpIPresIGWls (asIMOD SEM)"
using asIMOD_igWlsInp asIMOD_igWlsBinp
by (fastforce simp: igOpIPresIGWls_def asIMOD_igWls asIMOD_igOp sOpPrSWls_def)

lemma asIMOD_igConsIPresIGWls:
"wlsSEM SEM \<Longrightarrow> igConsIPresIGWls (asIMOD SEM)"
unfolding igConsIPresIGWls_def wlsSEM_def
using asIMOD_igVarIPresIGWls asIMOD_igAbsIPresIGWls asIMOD_igOpIPresIGWls by auto

text{* Swap preserves the domains: *}

lemma asIMOD_igSwapIPresIGWls: "igSwapIPresIGWls (asIMOD SEM)"
unfolding igSwapIPresIGWls_def asIMOD_igSwap asIMOD_igWls by auto

lemma asIMOD_igSwapAbsIPresIGWlsAbs: "igSwapAbsIPresIGWlsAbs (asIMOD SEM)"
unfolding igSwapAbsIPresIGWlsAbs_def asIMOD_igSwapAbs asIMOD_igWlsAbs by auto

lemma asIMOD_igSwapAllIPresIGWlsAll: "igSwapAllIPresIGWlsAll (asIMOD SEM)"
unfolding igSwapAllIPresIGWlsAll_def
using asIMOD_igSwapIPresIGWls asIMOD_igSwapAbsIPresIGWlsAbs by auto

text {* Subst preserves the domains:  *}

lemma asIMOD_igSubstIPresIGWls: "igSubstIPresIGWls (asIMOD SEM)"
unfolding igSubstIPresIGWls_def asIMOD_igSubst asIMOD_igWls by simp

lemma asIMOD_igSubstAbsIPresIGWlsAbs: "igSubstAbsIPresIGWlsAbs (asIMOD SEM)"
unfolding igSubstAbsIPresIGWlsAbs_def asIMOD_igSubstAbs asIMOD_igWls asIMOD_igWlsAbs by simp

lemma asIMOD_igSubstAllIPresIGWlsAll: "igSubstAllIPresIGWlsAll (asIMOD SEM)"
unfolding igSubstAllIPresIGWlsAll_def
using asIMOD_igSubstIPresIGWls asIMOD_igSubstAbsIPresIGWlsAbs by auto

text {* The clauses for fresh hold:  *}

lemma asIMOD_igFreshIGVar: "igFreshIGVar (asIMOD SEM)"
unfolding igFreshIGVar_def asIMOD_igFresh asIMOD_igVar eqBut_def by force

lemma asIMOD_igFreshIGAbs1:
"sWlsDisj SEM \<Longrightarrow> igFreshIGAbs1 (asIMOD SEM)"
by(fastforce simp: igFreshIGAbs1_def asIMOD_igFresh asIMOD_igFreshAbs asIMOD_igAbs2 updVal_eqBut_eq)

lemma asIMOD_igFreshIGAbs2:
"sWlsDisj SEM \<Longrightarrow> igFreshIGAbs2 (asIMOD SEM)"
by(fastforce simp: igFreshIGAbs2_def asIMOD_igFresh asIMOD_igFreshAbs asIMOD_igAbs2  updVal_preserves_eqBut)

lemma asIMOD_igFreshIGOp:
fixes SEM :: "('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom"
shows "igFreshIGOp (asIMOD SEM)"
unfolding igFreshIGOp_def proof clarify
  fix ys y delta and inp :: "('index, ('varSort,'var,'sTerm)gTerm)input"
  and binp :: "('bindex, ('varSort,'var,'sTerm)gAbs)input"
  assume inp_fresh: "igFreshInp (asIMOD SEM) ys y inp"
                    "igFreshBinp (asIMOD SEM) ys y binp"
  show "igFresh (asIMOD SEM) ys y (igOp (asIMOD SEM) delta inp binp)"
  unfolding asIMOD_igFresh asIMOD_igOp proof safe
    fix val val'
    let ?sinp = "lift (\<lambda>X. X val) inp" let ?sinp' = "lift (\<lambda>X. X val') inp"
    let ?sbinp = "lift (\<lambda>A. A val) binp" let ?sbinp' = "lift (\<lambda>A. A val') binp"
    assume wls: "sWlsVal SEM val" "sWlsVal SEM val'" and "eqBut val val' ys y"
    hence "?sinp = ?sinp' \<and> ?sbinp = ?sbinp'"
    using inp_fresh
    by (auto simp: lift_def igFreshInp_def igFreshBinp_def errMOD_def liftAll_def
    asIMOD_igFresh asIMOD_igFreshAbs split: option.splits)
    then show "(if sWlsVal SEM val then sOp SEM delta (lift (\<lambda>X. X val) inp) (lift (\<lambda>A. A val) binp)
           else undefined) =
          (if sWlsVal SEM val' then sOp SEM delta (lift (\<lambda>X. X val') inp) (lift (\<lambda>A. A val') binp)
           else undefined)" using wls by auto
  qed
qed

lemma asIMOD_igFreshCls:
assumes "sWlsDisj SEM"
shows "igFreshCls (asIMOD SEM)"
using assms unfolding igFreshCls_def
using asIMOD_igFreshIGVar asIMOD_igFreshIGAbs1 asIMOD_igFreshIGAbs2 asIMOD_igFreshIGOp by auto

text {* The clauses for swap hold:  *}

lemma asIMOD_igSwapIGVar: "igSwapIGVar (asIMOD SEM)"
unfolding igSwapIGVar_def apply clarsimp apply(rule ext)
unfolding asIMOD_igSwap asIMOD_igVar apply clarsimp
unfolding swapVal_def by simp

lemma asIMOD_igSwapIGAbs: "igSwapIGAbs (asIMOD SEM)"
by (fastforce simp: igSwapIGAbs_def asIMOD_igSwap asIMOD_igSwapAbs asIMOD_igAbs updVal_swapVal)

lemma asIMOD_igSwapIGOp: "igSwapIGOp (asIMOD SEM)"
by (auto simp: igSwapIGOp_def asIMOD_igSwap asIMOD_igOp asIMOD_igSwapInp asIMOD_igSwapBinp)

lemma asIMOD_igSwapCls: "igSwapCls (asIMOD SEM)"
unfolding igSwapCls_def using asIMOD_igSwapIGVar asIMOD_igSwapIGAbs asIMOD_igSwapIGOp by auto

text{* The clauses for subst hold: *}

lemma asIMOD_igSubstIGVar1: "igSubstIGVar1 (asIMOD SEM)"
by (auto simp: igSubstIGVar1_def asIMOD_igSubst asIMOD_igVar asIMOD_igWls)

lemma asIMOD_igSubstIGVar2: "igSubstIGVar2 (asIMOD SEM)"
by (fastforce simp: igSubstIGVar2_def asIMOD_igSubst asIMOD_igVar asIMOD_igWls)

lemma asIMOD_igSubstIGAbs: "igSubstIGAbs (asIMOD SEM)"
unfolding igSubstIGAbs_def proof(clarify, rule ext)
  fix ys y Y xs x s X val
  assume Y: "igWls (asIMOD SEM) (asSort ys) Y"
  and X: "igWls (asIMOD SEM) s X" and x_diff_y: "xs \<noteq> ys \<or> x \<noteq> y"
  and x_fresh_Y: "igFresh (asIMOD SEM) xs x Y"
  show "igSubstAbs (asIMOD SEM) ys Y y (igAbs (asIMOD SEM) xs x X) val =
        igAbs (asIMOD SEM) xs x (igSubst (asIMOD SEM) ys Y y X) val"
  proof(cases "sWlsVal SEM val")
    case False
    thus ?thesis unfolding asIMOD_igSubst asIMOD_igSubstAbs asIMOD_igAbs by simp
  next
    case True
    hence Yval: "sWls SEM (asSort ys) (Y val)"
    using Y unfolding asIMOD_igWls by simp
    {fix sX assume sX: "sWls SEM (asSort xs) sX"
     let ?val_x = "val (x := sX)_xs"
     have "sWlsVal SEM ?val_x" using True sX by simp
     moreover have "eqBut ?val_x val xs x"
     unfolding eqBut_def updVal_def by simp
     ultimately have 1: "Y ?val_x = Y val"
     using True x_fresh_Y unfolding asIMOD_igFresh by simp
     let ?Left = "X ((val (y := Y val)_ys) (x := sX)_xs)"
     let ?Riight = "X (?val_x (y := Y ?val_x)_ys)"
     have "?Left = X (?val_x (y := Y val)_ys)"
     using x_diff_y by(auto simp add: updVal_commute)
     also have "\<dots> = ?Riight" using 1 by simp
     finally have "?Left = ?Riight" .
    }
    thus ?thesis using True Yval by(auto simp: asIMOD_igSubst asIMOD_igSubstAbs asIMOD_igAbs)
  qed
qed

lemma asIMOD_igSubstIGOp: "igSubstIGOp (asIMOD SEM)"
unfolding igSubstIGOp_def proof(clarify,rule ext)
  fix ys y Y delta inp binp val
  assume Y: "igWls (asIMOD SEM) (asSort ys) Y"
  and inp: "igWlsInp (asIMOD SEM) delta inp"
  and binp: "igWlsBinp (asIMOD SEM) delta binp"
  define inpsb binpsb where
  inpsb_def: "inpsb \<equiv> igSubstInp (asIMOD SEM) ys Y y inp"
             "binpsb \<equiv> igSubstBinp (asIMOD SEM) ys Y y binp"
  note inpsb_rev = inpsb_def[symmetric]
  let ?sinpsb = "lift (\<lambda>X. X (val (y := Y val)_ys)) inp"
  let ?sbinpsb = "lift (\<lambda>A. A (val (y := Y val)_ys)) binp"
  show "igSubst (asIMOD SEM) ys Y y (igOp (asIMOD SEM) delta inp binp) val =
        igOp (asIMOD SEM) delta (igSubstInp (asIMOD SEM) ys Y y inp)
                              (igSubstBinp (asIMOD SEM) ys Y y binp) val"
  unfolding inpsb_rev unfolding asIMOD_igSubst asIMOD_igOp unfolding inpsb_def
  apply(simp add: asIMOD_igSubstInp asIMOD_igSubstBinp)
  using Y unfolding asIMOD_def by auto
qed

lemma asIMOD_igSubstCls: "igSubstCls (asIMOD SEM)"
unfolding igSubstCls_def
using asIMOD_igSubstIGVar1 asIMOD_igSubstIGVar2 asIMOD_igSubstIGAbs asIMOD_igSubstIGOp by auto

text {* The fresh-swap-based congruence clause holds: *}

lemma updVal_swapVal_eqBut: "eqBut (val (x := sX)_xs) ((val (y := sX)_xs) ^[y \<and> x]_xs) xs y"
by (simp add: updVal_def swapVal_def eqBut_def sw_def)

lemma asIMOD_igAbsCongS: "sWlsDisj SEM \<Longrightarrow> igAbsCongS (asIMOD SEM)"
unfolding igAbsCongS_def asIMOD_igFresh asIMOD_igSwap asIMOD_igAbs2
apply safe apply (simp add: asIMOD_igAbs2)
by (rule ext) (metis (hide_lams) updVal_swapVal_eqBut swapVal_preserves_sWls updVal_preserves_sWls)

text {* The abstraction-renaming clause holds: *}

lemma asIMOD_igAbs3:
assumes "sWlsDisj SEM" and "igWls (asIMOD SEM) s X"
shows
"igAbs (asIMOD SEM) xs y (igSubst (asIMOD SEM) xs (igVar (asIMOD SEM) xs y) x X) =
 (\<lambda>val. if sWlsVal SEM val
            then sAbs xs (\<lambda>sX. if sWls SEM (asSort xs) sX
                                 then (igSubst (asIMOD SEM) xs (igVar (asIMOD SEM) xs y) x X) (val (y := sX)_xs)
                                 else sDummy SEM s)
            else undefined)"
using assms asIMOD_igVarIPresIGWls asIMOD_igSubstIPresIGWls
unfolding igVarIPresIGWls_def igSubstIPresIGWls_def
by (fastforce intro!: asIMOD_igAbs2)

lemma asIMOD_igAbsRen:
"sWlsDisj SEM \<Longrightarrow> igAbsRen (asIMOD SEM)"
unfolding igAbsRen_def asIMOD_igFresh asIMOD_igSwap apply safe
by (simp add: asIMOD_igAbs2 asIMOD_igAbs3)
   (auto intro!: ext simp: asIMOD_igAbs2 asIMOD_igAbs3 eqBut_def asIMOD_igSubst asIMOD_igVar)

text {* The associated model forms well-structured models of all 4 kinds: *}

lemma asIMOD_wlsFSw:
assumes "wlsSEM SEM"
shows "iwlsFSw (asIMOD SEM)"
using assms unfolding wlsSEM_def iwlsFSw_def
using assms asIMOD_igWlsAllDisj asIMOD_igWlsAbsIsInBar
asIMOD_igConsIPresIGWls asIMOD_igSwapAllIPresIGWlsAll
asIMOD_igFreshCls asIMOD_igSwapCls asIMOD_igAbsCongS
by auto

lemma asIMOD_wlsFSb:
assumes "wlsSEM SEM"
shows "iwlsFSb (asIMOD SEM)"
using assms unfolding wlsSEM_def iwlsFSb_def
using assms asIMOD_igWlsAllDisj asIMOD_igWlsAbsIsInBar
asIMOD_igConsIPresIGWls[of SEM] asIMOD_igSubstAllIPresIGWlsAll
asIMOD_igFreshCls  asIMOD_igSubstCls asIMOD_igAbsRen
by auto

lemma asIMOD_wlsFSwSb: "wlsSEM SEM \<Longrightarrow> iwlsFSwSb (asIMOD SEM)"
unfolding iwlsFSwSb_def
using asIMOD_wlsFSw asIMOD_igSubstAllIPresIGWlsAll asIMOD_igSubstCls by auto

lemma asIMOD_wlsFSbSw: "wlsSEM SEM \<Longrightarrow> iwlsFSbSw (asIMOD SEM)"
unfolding iwlsFSbSw_def
using asIMOD_wlsFSb asIMOD_igSwapAllIPresIGWlsAll asIMOD_igSwapCls by auto

subsection {* The semantic interpretation  *}

text{* The well-definedness of the semantic interpretation, as well
as its associated substitution lemma and non-dependence of fresh variables,
are the end products of this theory.

Note that in order to establish these results either fresh-subst-swap or
fresh-swap-subst aligebras would do the job, and, moreover, if we did not care
about swapping, fresh-subst aligebras would do the job.  Therefore, our
exhaustive study of the model from previous section had a deigree of redundancy w.r.t. to our main
igoal -- we pursued it however in order to better illustrate the rich structure laying under
the apparent paucity of the notion of a semantic domain.  Next, we choose to employ
fresh-subst-swap aligebras to establish the required results. (Recall however that either aligebraic route
we take, the initial morphism turns out to be the same function.)*}

definition semInt where "semInt SEM \<equiv> iter (asIMOD SEM)"

definition semIntAbs where "semIntAbs SEM \<equiv> iterAbs (asIMOD SEM)"

lemma semInt_prWls:
"wlsSEM SEM \<Longrightarrow> prWls (semInt SEM) SEM"
unfolding prWls_def using semIntAll_termFSwSbImorph
unfolding termFSwSbImorph_def termFSwImorph_def ipresWlsAll_def ipresWls_def asIMOD_igWls by auto

lemma semIntAbs_prWlsAbs:
"wlsSEM SEM \<Longrightarrow> prWlsAbs (semIntAbs SEM) SEM"
unfolding prWlsAbs_def using semIntAll_termFSwSbImorph
unfolding termFSwSbImorph_def termFSwImorph_def ipresWlsAll_def ipresWlsAbs_def asIMOD_igWlsAbs by blast

lemma semIntAll_prWlsAll:
"wlsSEM SEM \<Longrightarrow> prWlsAll (semInt SEM) (semIntAbs SEM) SEM"
unfolding prWlsAll_def by(simp add: semInt_prWls semIntAbs_prWlsAbs)

lemma semInt_prVar:
"wlsSEM SEM \<Longrightarrow> prVar (semInt SEM) SEM"
using semIntAll_termFSwSbImorph
unfolding prVar_def termFSwSbImorph_def termFSwImorph_def ipresCons_def ipresVar_def asIMOD_igVar
by fastforce

lemma semIntAll_prAbs:
fixes SEM :: "('index,'bindex,'varSort,'sort,'opSym,'sTerm)semDom"
assumes "wlsSEM SEM"
shows "prAbs (semInt SEM) (semIntAbs SEM) SEM"
proof-
  {fix xs s x X and val :: "('varSort,'var,'sTerm)val"
   assume xs_s: "isInBar (xs,s)" and X: "wls s X"
   and val: "sWlsVal SEM val"
   let ?L = "semIntAbs SEM (Abs xs x X)"
   let ?R = "\<lambda> val. sAbs xs (\<lambda>sX. if sWls SEM (asSort xs) sX
                              then semInt SEM X (val (x := sX)_xs)
                              else sDummy SEM s)"
   have "?L = igAbs (asIMOD SEM) xs x (semInt SEM X)"
   using xs_s X assms semIntAll_termFSwSbImorph[of SEM]
   unfolding termFSwSbImorph_def termFSwImorph_def ipresCons_def ipresAbs_def by auto
   moreover
   {have "prWls (semInt SEM) SEM" using assms semInt_prWls by auto
    hence 1: "sWls SEM s (semInt SEM X val)"
    using val X unfolding prWls_def by simp
    hence "(SOME s. sWls SEM s (semInt SEM X val)) = s"
    using 1 assms unfolding wlsSEM_def sWlsDisj_def by auto
    hence "igAbs (asIMOD SEM) xs x (semInt SEM X) val = ?R val"
    unfolding asIMOD_igAbs using val by fastforce
   }
   ultimately have "?L val = ?R val" by simp
  }
  thus ?thesis unfolding prAbs_def by auto
qed

lemma semIntAll_prOp:
assumes "wlsSEM SEM"
shows "prOp (semInt SEM) (semIntAbs SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prOp_def termFSwSbImorph_def termFSwImorph_def ipresCons_def ipresOp_def
asIMOD_igOp lift_comp comp_def by fastforce

lemma semIntAll_prCons:
assumes "wlsSEM SEM"
shows "prCons (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding prCons_def by(simp add: semInt_prVar semIntAll_prAbs semIntAll_prOp)

lemma semInt_prFresh:
assumes "wlsSEM SEM"
shows "prFresh (semInt SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prFresh_def termFSwSbImorph_def termFSwImorph_def ipresFreshAll_def ipresFresh_def
asIMOD_igFresh by fastforce

lemma semIntAbs_prFreshAbs:
assumes "wlsSEM SEM"
shows "prFreshAbs (semIntAbs SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prFreshAbs_def termFSwSbImorph_def termFSwImorph_def ipresFreshAll_def ipresFreshAbs_def
asIMOD_igFreshAbs by fastforce

lemma semIntAll_prFreshAll:
assumes "wlsSEM SEM"
shows "prFreshAll (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding prFreshAll_def by(simp add: semInt_prFresh semIntAbs_prFreshAbs)

lemma semInt_prSwap:
assumes "wlsSEM SEM"
shows "prSwap (semInt SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prSwap_def termFSwSbImorph_def termFSwImorph_def ipresSwapAll_def ipresSwap_def
asIMOD_igSwap by fastforce

lemma semIntAbs_prSwapAbs:
assumes "wlsSEM SEM"
shows "prSwapAbs (semIntAbs SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prSwapAbs_def termFSwSbImorph_def termFSwImorph_def ipresSwapAll_def ipresSwapAbs_def
asIMOD_igSwapAbs by fastforce

lemma semIntAll_prSwapAll:
assumes "wlsSEM SEM"
shows "prSwapAll (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding prSwapAll_def by(simp add: semInt_prSwap semIntAbs_prSwapAbs)

lemma semInt_prSubst:
assumes "wlsSEM SEM"
shows "prSubst (semInt SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prSubst_def termFSwSbImorph_def termFSwImorph_def ipresSubstAll_def ipresSubst_def
asIMOD_igSubst by fastforce

lemma semIntAbs_prSubstAbs:
assumes "wlsSEM SEM"
shows "prSubstAbs (semInt SEM) (semIntAbs SEM) SEM"
using assms semIntAll_termFSwSbImorph
unfolding prSubstAbs_def termFSwSbImorph_def termFSwImorph_def ipresSubstAll_def ipresSubstAbs_def
asIMOD_igSubstAbs by fastforce

lemma semIntAll_prSubstAll:
assumes "wlsSEM SEM"
shows "prSubstAll (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding prSubstAll_def by(simp add: semInt_prSubst semIntAbs_prSubstAbs)

theorem semIntAll_compInt:
assumes "wlsSEM SEM"
shows "compInt (semInt SEM) (semIntAbs SEM) SEM"
using assms unfolding compInt_def
by(simp add: semIntAll_prWlsAll semIntAll_prCons
semIntAll_prFreshAll semIntAll_prSwapAll semIntAll_prSubstAll)

lemmas semDom_simps = updVal_simps swapVal_simps

end (* context FixSyn *)

end


(*  Title:      HOL/Nitpick_Examples/Record_Nits.thy
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2009-2011

Examples featuring Nitpick applied to records.
*)

section \<open>Examples Featuring Nitpick Applied to Records\<close>

theory Record_Nits
imports MainRLT
begin

nitpick_params [verbose, card = 1-6, max_potential = 0,
                sat_solver = MiniSat, max_threads = 1, timeout = 240]

record point2d =
  xc :: int
  yc :: int

lemma "\<lparr>xc = x, yc = y\<rparr> = p\<lparr>xc := x, yc := y\<rparr>"
nitpick [expect = none]
sorry

lemma "\<lparr>xc = x, yc = y\<rparr> = p\<lparr>xc := x\<rparr>"
nitpick [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y\<rparr> \<noteq> p"
nitpick [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y\<rparr> = p"
nitpick [expect = genuine]
oops

record point3d = point2d +
  zc :: int

lemma "\<lparr>xc = x, yc = y, zc = z\<rparr> = p\<lparr>xc := x, yc := y, zc := z\<rparr>"
nitpick [expect = none]
sorry

lemma "\<lparr>xc = x, yc = y, zc = z\<rparr> = p\<lparr>xc := x\<rparr>"
nitpick [expect = genuine]
oops

lemma "\<lparr>xc = x, yc = y, zc = z\<rparr> = p\<lparr>zc := z\<rparr>"
nitpick [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y, zc := z\<rparr> \<noteq> p"
nitpick [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y, zc := z\<rparr> = p"
nitpick [expect = genuine]
oops

record point4d = point3d +
  wc :: int

lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>xc := x, yc := y, zc := z, wc := w\<rparr>"
nitpick [expect = none]
sorry

lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>xc := x\<rparr>"
nitpick [expect = genuine]
oops

lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>zc := z\<rparr>"
nitpick [expect = genuine]
oops

lemma "\<lparr>xc = x, yc = y, zc = z, wc = w\<rparr> = p\<lparr>wc := w\<rparr>"
nitpick [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y, zc := z, wc := w\<rparr> \<noteq> p"
nitpick [expect = genuine]
oops

lemma "p\<lparr>xc := x, yc := y, zc := z, wc := w\<rparr> = p"
nitpick [expect = genuine]
oops

end


(*<*)
(*
 * The worker/wrapper transformation, following Gill and Hutton.
 * (C)opyright 2009-2011, Peter Gammie, peteg42 at gmail.com.
 * License: BSD
 *)

theory FixedPointTheorems
imports
  HOLCF
begin

setup {*
  Thy_Output.antiquotation @{binding haskell} (Scan.lift Args.name)
    (fn _ => fn s => "\\" ^ "<" ^ s ^ "\\>")
*}

(* LaTeXsugar fights with HOLCF syntax: at least cdot *)

(* THEOREMS *)
notation (Rule output)
  Pure.imp  ("\<^raw:\mbox{}\inferrule{\mbox{>_\<^raw:}}>\<^raw:{\mbox{>_\<^raw:}}>")

syntax (Rule output)
  "_bigimpl" :: "asms \<Rightarrow> prop \<Rightarrow> prop"
  ("\<^raw:\mbox{}\inferrule{>_\<^raw:}>\<^raw:{\mbox{>_\<^raw:}}>")

  "_asms" :: "prop \<Rightarrow> asms \<Rightarrow> asms"
  ("\<^raw:\mbox{>_\<^raw:}\\>/ _")

  "_asm" :: "prop \<Rightarrow> asms" ("\<^raw:\mbox{>_\<^raw:}>")

(*>*)
section{* Fixed-point theorems for program transformation *}

text{*

We begin by recounting some standard theorems from the early days of
denotational semantics. The origins of these results are lost to
history; the interested reader can find some of it in
\citet{Bekic:1969, Manna:1974, Greibach:1975, Stoy:1977,
DBLP:books/daglib/0002432, Harel:1980, Plotkin:1983, Winskel:1993,
DBLP:journals/toplas/Sangiorgi09}.

*}

subsection{* The rolling rule *}

text{*

The \emph{rolling rule} captures what intuitively happens when we
re-order a recursive computation consisting of two parts. This theorem
dates from the 1970s at the latest -- see \citet[p210]{Stoy:1977} and
\citet{Plotkin:1983}. The following proofs were provided by
\citet{GillHutton:2009}.

*}

lemma rolling_rule_ltr: "fix\<cdot>(g oo f) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
proof -
  have "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    by (rule below_refl) -- {* reflexivity *}
  hence "g\<cdot>((f oo g)\<cdot>(fix\<cdot>(f oo g))) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    using fix_eq[where F="f oo g"] by simp -- {* computation *}
  hence "(g oo f)\<cdot>(g\<cdot>(fix\<cdot>(f oo g))) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    by simp -- {* re-associate @{term "op oo"} *}
  thus "fix\<cdot>(g oo f) \<sqsubseteq> g\<cdot>(fix\<cdot>(f oo g))"
    using fix_least_below by blast -- {* induction *}
qed

lemma rolling_rule_rtl: "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> fix\<cdot>(g oo f)"
proof -
  have "fix\<cdot>(f oo g) \<sqsubseteq> f\<cdot>(fix\<cdot>(g oo f))" by (rule rolling_rule_ltr)
  hence "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> g\<cdot>(f\<cdot>(fix\<cdot>(g oo f)))"
    by (rule monofun_cfun_arg) -- {* g is monotonic *}
  thus "g\<cdot>(fix\<cdot>(f oo g)) \<sqsubseteq> fix\<cdot>(g oo f)"
    using fix_eq[where F="g oo f"] by simp -- {* computation *}
qed

lemma rolling_rule: "fix\<cdot>(g oo f) = g\<cdot>(fix\<cdot>(f oo g))"
  by (rule below_antisym[OF rolling_rule_ltr rolling_rule_rtl])
(*

This property of a fixed-point operator is termed \emph{dinaturality}
by \citet{DBLP:conf/lics/SimpsonP00}.

*)

subsection{* Least-fixed-point fusion *}

text{*

\label{sec:lfp-fusion}

\emph{Least-fixed-point fusion} provides a kind of induction that has
proven to be very useful in calculational settings. Intuitively it
lifts the step-by-step correspondence between @{term "f"} and @{term
"h"} witnessed by the strict function @{term "g"} to the fixed points
of @{term "f"} and @{term "g"}:
\[
  \begin{diagram}
    \node{\bullet} \arrow{e,t}{h} \node{\bullet}\\
    \node{\bullet} \arrow{n,l}{g} \arrow{e,b}{f} \node{\bullet} \arrow{n,r}{g}
  \end{diagram}
  \qquad \Longrightarrow \qquad
  \begin{diagram}
    \node{\mathsf{fix}\ h}\\
    \node{\mathsf{fix}\ f} \arrow{n,r}{g}
  \end{diagram}
\]
\citet*{FokkingaMeijer:1991}, and also their later
\citet*{barbed-wire:1991}, made extensive use of this rule, as did
\citet{Tullsen:PhDThesis} in his program transformation tool PATH.
This diagram is strongly reminiscent of the simulations used to
establish refinement relations between imperative programs and their
specifications \citep*{EdR:cup98}.

The following proof is close to the third variant of
\citet[p215]{Stoy:1977}. We relate the two fixpoints using the rule
\texttt{parallel\_fix\_ind}:
\begin{center}
  @{thm[mode=Rule] parallel_fix_ind}
\end{center}
in a very straightforward way:

*}

lemma lfp_fusion:
  assumes "g\<cdot>\<bottom> = \<bottom>"
  assumes "g oo f = h oo g"
  shows "g\<cdot>(fix\<cdot>f) = fix\<cdot>h"
proof(induct rule: parallel_fix_ind)
  case 2 show "g\<cdot>\<bottom> = \<bottom>" by fact
  case (3 x y)
  from `g\<cdot>x = y` `g oo f = h oo g` show "g\<cdot>(f\<cdot>x) = h\<cdot>y"
    by (simp add: cfun_eq_iff)
qed simp

text{*

This lemma also goes by the name of \emph{Plotkin's axiom}
\citep{PittsAM:relpod} or \emph{uniformity}
\citep{DBLP:conf/lics/SimpsonP00}.

*}
(*<*)

(* The rest of this theory is only of historical interest. *)

text {* Some may find the pointed version easier to read. *}

lemma lfp_fusion_pointed:
  assumes Cfg: "\<And>f. C\<cdot>(F\<cdot>f) = G\<cdot>(C\<cdot>f)"
      and strictC: "C\<cdot>\<bottom> = \<bottom>"
  shows "C\<cdot>(fix\<cdot>F) = fix\<cdot>G"
  using lfp_fusion[where f=F and g=C and h=G] assms
  by (simp add: cfcomp1)

subsubsection{* More about @{text "lfp-fusion"} *}

text{*

Alternative proofs. This is the ``intuitive'' one
\citet[p125]{Gunter:1992} and \citet[p46]{Tullsen:PhDThesis}, where we
can shuffle @{term "g"} to the end of the the iteration of @{term "f"}
using @{term "fgh"}.

*}

lemma lfp_fusion2_aux:
  assumes fgh: "g oo f = h oo g"
  shows "g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>) = iterate i\<cdot>h\<cdot>(g\<cdot>\<bottom>)"
proof(induct i)
  case (Suc i)
  have "g\<cdot>(iterate (Suc i)\<cdot>f\<cdot>\<bottom>) = (g oo f)\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>)" by simp
  also have "... = h\<cdot>(g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>))" using fgh by (simp add: cfcomp1)
  also have "... = h\<cdot>(iterate i\<cdot>h\<cdot>(g\<cdot>\<bottom>))" using Suc by simp
  also have "... = iterate (Suc i)\<cdot>h\<cdot>(g\<cdot>\<bottom>)" by simp
  finally show ?case .
qed simp

lemma lfp_fusion2:
  assumes fgh: "g oo f = h oo g"
      and strictg: "g\<cdot>\<bottom> = \<bottom>"
  shows "g\<cdot>(fix\<cdot>f) = fix\<cdot>h"
proof -
  have "g\<cdot>(fix\<cdot>f) = g\<cdot>(\<Squnion>i. iterate i\<cdot>f\<cdot>\<bottom>)" by (simp only: fix_def2)
  also have "... = (\<Squnion>i. g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>))" by (simp add: contlub_cfun_arg)
  also have "... = (\<Squnion>i. (iterate i\<cdot>h\<cdot>(g\<cdot>\<bottom>)))" by (simp only: lfp_fusion2_aux[OF fgh])
  also have "... = fix\<cdot>h" using strictg by (simp only: fix_def2)
  finally show ?thesis .
qed

text{* This is the first one by \citet[p213]{Stoy:1977}, almost
identical to the above. *}

lemma lfp_fusion3_aux:
  assumes fgh: "g oo f = h oo g"
      and strictg: "g\<cdot>\<bottom> = \<bottom>"
  shows "g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>) = iterate i\<cdot>h\<cdot>\<bottom>"
proof(induct i)
  case 0 from strictg show ?case by simp
next
  case (Suc i)
  have "g\<cdot>(iterate (Suc i)\<cdot>f\<cdot>\<bottom>) = (g oo f)\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>)" by simp
  also have "... = h\<cdot>(g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>))" using fgh by (simp add: cfcomp1)
  also have "... = h\<cdot>(iterate i\<cdot>h\<cdot>\<bottom>)" using Suc by simp
  also have "... = iterate (Suc i)\<cdot>h\<cdot>\<bottom>" by simp
  finally show ?case .
qed

lemma lfp_fusion3:
  assumes fgh: "g oo f = h oo g"
      and strictg: "g\<cdot>\<bottom> = \<bottom>"
  shows "g\<cdot>(fix\<cdot>f) = fix\<cdot>h"
proof -
  have "g\<cdot>(fix\<cdot>f) = g\<cdot>(\<Squnion>i. iterate i\<cdot>f\<cdot>\<bottom>)" by (simp only: fix_def2)
  also have "... = (\<Squnion>i. g\<cdot>(iterate i\<cdot>f\<cdot>\<bottom>))" by (simp add: contlub_cfun_arg)
  also have "... = (\<Squnion>i. (iterate i\<cdot>h\<cdot>\<bottom>))" by (simp only: lfp_fusion3_aux[OF fgh strictg])
  also have "... = fix\<cdot>h" by (simp only: fix_def2)
  finally show ?thesis .
qed

text{* Stoy's second proof \citep[p214]{Stoy:1977} is similar to the
original proof using fixed-point induction. *}

lemma lfp_fusion4:
  assumes fgh: "g oo f = h oo g"
      and strictg: "g\<cdot>\<bottom> = \<bottom>"
  shows "g\<cdot>(fix\<cdot>f) = fix\<cdot>h"
proof(rule below_antisym)
  show "fix\<cdot>h \<sqsubseteq> g\<cdot>(fix\<cdot>f)"
  proof -
    have "h\<cdot>(g\<cdot>(fix\<cdot>f)) = (g oo f)\<cdot>(fix\<cdot>f)" using fgh by simp
    also have "... = g\<cdot>(fix\<cdot>f)" by (subst fix_eq, simp)
    finally show ?thesis by (rule fix_least)
  qed
  let ?P = "\<lambda>x. g\<cdot>x \<sqsubseteq> fix\<cdot>h"
  show "?P (fix\<cdot>f)"
  proof(induct rule: fix_ind[where P="?P"])
    case 2 with strictg show ?case by simp
  next
    case (3 x) hence indhyp: "g\<cdot>x \<sqsubseteq> fix\<cdot>h" .
    have "g\<cdot>(f\<cdot>x) = (h oo g)\<cdot>x" using fgh[symmetric] by simp
    with indhyp show "g\<cdot>(f\<cdot>x) \<sqsubseteq> fix\<cdot>h"
      by (subst fix_eq, simp add: monofun_cfun)
  qed simp
qed

text{* A wrinkly variant from \citet[p11]{barbed-wire:1991}. *}

lemma lfp_fusion_barbed_variant:
  assumes ff': "f\<cdot>\<bottom> = f'\<cdot>\<bottom>"
      and fgh: "f oo g = h oo f"
      and f'g'h: "f' oo g' = h oo f'"
  shows "f\<cdot>(fix\<cdot>g) = f'\<cdot>(fix\<cdot>g')"
proof(induct rule: parallel_fix_ind)
  case 2 show "f\<cdot>\<bottom> = f'\<cdot>\<bottom>" by (rule ff')
  case (3 x y)
  from `f\<cdot>x = f'\<cdot>y` have "h\<cdot>(f\<cdot>x) = h\<cdot>(f'\<cdot>y)" by simp
  with fgh f'g'h have "f\<cdot>(g\<cdot>x) = f'\<cdot>(g'\<cdot>y)"
    using cfcomp2[where f="f" and g="g", symmetric]
          cfcomp2[where f="f'" and g="g'", symmetric]
    by simp
  thus ?case by simp
qed simp
(*>*)

(*<*)
end
(*>*)


(* Property from Productive Use of Failure in Inductive Proof,
   Andrew Ireland and Alan Bundy, JAR 1996.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_21
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun rotate :: "Nat => 'a list => 'a list" where
  "rotate (Z) z = z"
| "rotate (S z2) (nil2) = nil2"
| "rotate (S z2) (cons2 x2 x3) =
     rotate z2 (x x3 (cons2 x2 (nil2)))"

fun length :: "'a list => Nat" where
  "length (nil2) = Z"
| "length (cons2 z xs) = S (length xs)"

theorem property0 :
  "((rotate (length y) (x y z)) = (x z y))"
  oops

end


(*<*)
theory IsarCliffLemma
imports HEAP1LemmasIJW
begin
(*>*)
lemma L1:
  assumes "disjoint s1 s2"
  and "s3 \<subseteq> s2"
  shows "disjoint s1 s3"
  using assms unfolding disjoint_def
  by blast

lemma L1pt5:
  shows "disjoint s2 (s1 - s2)"
    unfolding disjoint_def by simp

lemma L2:
    assumes "disjoint s1 s3"
    and "disjoint s2 s3"
    shows "disjoint (s1 \<union> s2) s3"
    using assms unfolding disjoint_def
    by blast

lemma L3:
  assumes *: "nat1_map f"
  shows "locs (S -\<triangleleft> f) \<subseteq> locs f"
proof
  fix x assume xin_domar: "x \<in> locs (S -\<triangleleft> f)"
  then have "x \<in>  (\<Union>s\<in>dom (S -\<triangleleft> f). locs_of s (the ((S -\<triangleleft> f) s)))"
    by (simp add: locs_def * dom_ar_nat1_map)
  then have "x \<in> ( \<Union>s\<in>dom f. locs_of s (the (f s)))"
    by (smt UN_iff f_in_dom_ar_apply_not_elem l_dom_ar_notin_dom_or)
  thus "x \<in> locs f" by (simp add: locs_def *)
qed

lemma L3pt5:
 assumes "s\<in> dom f"
 and "Disjoint f"
 and "nat1_map f"
 shows "locs ({s}-\<triangleleft> f) = locs f - locs_of s (the (f s))"
using assms by (simp add: l_locs_of_dom_ar)

lemma L4: "nat1 n \<Longrightarrow> nat1 m \<Longrightarrow> locs_of d (n+m) = (locs_of d n) \<union> (locs_of (d+n) m)"
unfolding locs_of_def
by auto

lemma that_lemma:
  assumes a1: "F1_inv f"
  and a2: "disjoint (locs_of d s) (locs f)"
  and a3: "d+s \<in> dom f"
  and a4: "nat1 s"
  shows "disjoint (locs_of d (s + (the (f (d+s)))))
                  (locs ({d+s} -\<triangleleft> f))"
proof -
  from a1 show ?thesis
  proof
  assume Disj: "Disjoint f"
  and n1map: "nat1_map f"
  show ?thesis --"Standard set-up of the problem complete"
  proof(subst L4) --" Step 1: backwards application of L4"
    show "nat1 s" by (rule a4) --"Direct from assm"
   next
    show "nat1 (the (f (d + s)))" -- "Step 2: solved (almost) directly from our hyp"
     using n1map nat1_map_def a3 by simp
   next --"Resulting goal"
    show "disjoint (locs_of d s \<union> locs_of (d + s) (the (f (d + s))))
                   (locs ({d + s} -\<triangleleft> f))"
    proof(rule L2) --"Step 3: backward application of L2"
      from a2 show "disjoint (locs_of d s) (locs ({d+s} -\<triangleleft>f))" --"Step 4"
      proof (rule L1)
        from n1map show "locs ({d + s} -\<triangleleft> f) \<subseteq> locs f" -- "Step 5"
         by(rule L3)
      qed
     next
      show "disjoint (locs_of (d + s) (the (f (d + s))))
                              (locs  ({d + s} -\<triangleleft> f))"
      proof (subst L3pt5) -- "Step 6: Substition of L3.5"
        from a3 Disj n1map show "d + s \<in> dom f" "Disjoint f" "nat1_map f"
         by simp_all
       next
        show "disjoint (locs_of (d + s) (the (f (d + s))))
            (locs f - locs_of (d + s) (the (f (d + s))))"
         by (rule L1pt5) --"Step 7"
      qed
    qed
  qed
qed
qed
(*<*)
end
(*>*)


theory regexp_RecSeq
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype ('a, 'b) Pair2 = Pair "'a" "'b"

datatype A = X | Y

datatype R
  = Nil2 | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   case x of
     | other =>
         case y of
           | other =>
               case x of
                 | other =>
                     case y of
                       | other => Seq x y
                       | Eps => x
                     end
                 | Eps => y
               end
           | Nil2 => y
         end
     | Nil2 => x
   end"

fun plus :: "R => R => R" where
"plus x y =
   case x of
     | other =>
         case y of
           | other => Plus x y
           | Nil2 => x
         end
     | Nil2 => y
   end"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun eqA :: "A => A => bool" where
"eqA (X) y = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun Consfst :: "'a => ((('a list), 'b) Pair2) list =>
                ((('a list), 'b) Pair2) list" where
"Consfst x (Nil2) = Nil2"
| "Consfst x (Cons2 (Pair xs y2) ys) =
     Cons2 (Pair (Cons2 x xs) y2) (Consfst x ys)"

fun split :: "'a list => ((('a list), ('a list)) Pair2) list" where
"split (Nil2) = Cons2 (Pair (Nil2) (Nil2)) (Nil2)"
| "split (Cons2 y s) =
     Cons2 (Pair (Nil2) (Cons2 y s)) (Consfst y (split s))"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun eps :: "R => bool" where
"eps x =
   case x of
     | other => False
     | Eps => True
     | Plus p q => or2 (eps p) (eps q)
     | Seq p2 q2 => and2 (eps p2) (eps q2)
     | Star y => True
   end"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil2)"

fun step :: "R => A => R" where
"step x y =
   case x of
     | other => Nil2
     | Atom a => (if eqA a y then Eps else Nil2)
     | Plus p q => plus (step p y) (step q y)
     | Seq p2 q2 =>
         plus (seq (step p2 y) q2) (seq (epsR p2) (step q2 y))
     | Star p3 => seq (step p3 y) x
   end"

fun recognise :: "R => A list => bool" where
"recognise x (Nil2) = eps x"
| "recognise x (Cons2 z xs) = recognise (step x z) xs"

fun recognisePair :: "R => R =>
                    (((A list), (A list)) Pair2) list => bool" where
"recognisePair x y (Nil2) = False"
| "recognisePair x y (Cons2 (Pair s1 s2) xs) =
     or2
       (and2 (recognise x s1) (recognise y s2)) (recognisePair x y xs)"

(*hipster seq
          plus
          or2
          eqA
          Consfst
          split
          and2
          eps
          epsR
          step
          recognise
          recognisePair *)

theorem x0 :
  "!! (p :: R) (q :: R) (s :: A list) .
     (recognise (Seq p q) s) = (recognisePair p q (split s))"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory "modal-correspondence"
  imports Main
begin

section \<open>A toy background theory\<close> (*skip on first read*)

(*Sets are encoded as characteristic functions/predicates (i.e. functions with a 'bool' codomain)*)
type_synonym 'a \<sigma> = \<open>'a \<Rightarrow> bool\<close>
(*Relations are encoded as set-valued functions*)
type_synonym ('a,'b)\<rho> = \<open>'a \<Rightarrow>'b \<sigma>\<close>
(*Convenient type constructors for unary & binary set-operators (allowing for some restricted two-sortedness).*)
type_synonym ('a,'b)\<O> = "('a \<sigma>,'b)\<rho>" (**i.e. 'a \<sigma> \<Rightarrow> 'b \<sigma>*)
type_synonym ('a,'b)\<O>\<^sub>2 = "'a \<sigma> \<Rightarrow> ('a,'b)\<O>" (**i.e. 'a \<sigma> \<Rightarrow> a \<sigma> \<Rightarrow> 'b \<sigma>*)

(*General functions naturally feature a monoidal structure with function composition as the fundamental
  binary operation and the identity function as the unit (i.e. a zero-ary operation or 'constant').*)
abbreviation (input) fcomp'::"('b \<Rightarrow> 'c) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'c" (infixl "\<^bold>\<circ>" 75)
  where "\<psi> \<^bold>\<circ> \<phi> \<equiv> \<lambda>x. \<psi>(\<phi> x)"
abbreviation (input) fid :: "('a \<Rightarrow> 'a)" ("ID")
  where "ID \<equiv> \<lambda>x. x"

(*We say that \<phi> below is a morphism wrt. some (pair of) zero-ary, unary, or binary function(s)*)
abbreviation (input) morph0::"'a \<Rightarrow> 'b \<Rightarrow> ('a \<Rightarrow> 'b)\<sigma>" ("_,_-MORPH")
  where "A,B-MORPH \<phi> \<equiv> \<phi> A = B"
abbreviation morph1::"('a \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)\<sigma>" ("_,_-MORPH")
  where "\<psi>,\<upsilon>-MORPH \<phi> \<equiv> \<forall>A. \<phi>(\<psi> A) = \<upsilon>(\<phi> A)"
abbreviation morph2::"('a \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a \<Rightarrow> 'b)\<sigma>" ("_,_-MORPH")
  where "\<xi>,\<delta>-MORPH \<phi> \<equiv> \<forall>A B. \<phi>(\<xi> A B) = \<delta> (\<phi> A) (\<phi> B)"

(*In the case of (curried) binary functions, we introduce a convenient unary operation: transposition.
 'Transposing' a binary function corresponds to swapping its arguments/parameters.
 In the case of relations this corresponds to the notions of converse (aka. inverse, reverse) relation.*)
abbreviation (input) transpose::"('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> 'c)" ("(_)\<Zcat>" [90])
  where \<open>f\<Zcat> \<equiv> \<lambda>a b. f b a\<close>

(*Relations, as functions, also exhibit a monoidal structure. For instance, they can also be composed.*)
definition rcomp::"('b,'c)\<rho> \<Rightarrow> ('a,'b)\<rho> \<Rightarrow> ('a,'c)\<rho>" (infixl "\<^bold>\<circ>\<^sup>r" 75)
  where "T \<^bold>\<circ>\<^sup>r R \<equiv> \<lambda>a c. \<exists>b. R a b \<and> T b c"
(*Equality plays the role of identity/unit elements (one identity for each type)*)
abbreviation (input) rid :: "('a,'a)\<rho>" ("ID\<^sup>r")
  where "ID\<^sup>r \<equiv> (=)"

(*The following definition of relation embedding generalizes the well-known notion of order-embedding.*)
abbreviation rel_embedding::"('a,'a)\<rho> \<Rightarrow> ('b,'b)\<rho> \<Rightarrow> ('a \<Rightarrow>'b) \<Rightarrow> bool" ("_,_-EMBD")
  where "\<rho>1,\<rho>2-EMBD \<phi> \<equiv> \<forall>A B. (\<rho>1 A B) \<longleftrightarrow> (\<rho>2 (\<phi> A) (\<phi> B))"

(*The algebra of sets is ordered by the standard subset relation, as defined below.*)
definition subset::"('a \<sigma>,'a \<sigma>)\<rho>" (infixr "\<^bold>\<subseteq>" 51)
  where "A \<^bold>\<subseteq> B \<equiv> \<forall>x. A x \<longrightarrow> B x"
(*The algebra of relations is also an ordered algebra. We define the standard relation-inclusion relation
  also by drawing upon the corresponding set counterparts.*)
abbreviation subsetR::"(('a,'b)\<rho>,('a,'b)\<rho>)\<rho>" (infixr "\<^bold>\<subseteq>\<^sup>r" 51)
  where "R \<^bold>\<subseteq>\<^sup>r T \<equiv> \<forall>a. R a \<^bold>\<subseteq> T a"

(*We can say of two unary operators \<phi> and \<psi> that they form an "adjoint" or "residuated" pair (notation: \<phi> \<stileturn> \<psi>).
 When \<phi> \<stileturn> \<psi> we say that \<phi> (\<psi>) is the left (right) "adjoint" or "residue" to \<psi> (\<phi>).*)
abbreviation Residuation::"(('a,'b)\<O>,('b,'a)\<O>)\<rho>" ("_\<stileturn>_")
  where "\<phi> \<stileturn> \<psi> \<equiv> \<forall>A B. \<phi> A \<^bold>\<subseteq> B \<longleftrightarrow> A \<^bold>\<subseteq> \<psi> B"

(*Given a relation R we can define the unary operators image and preimage (aka. inverse-image),
 in an analogous fashion as in the case of functions. These operators come in dual pairs as shown.*)
definition image::"('a,'b)\<rho> \<Rightarrow> ('a,'b)\<O>"
  where "image R     \<equiv> \<lambda>A. \<lambda>b. \<exists>a. R a b \<and> A a"
definition preimage::"('a,'b)\<rho> \<Rightarrow> ('b,'a)\<O>"
  where "preimage R  \<equiv> \<lambda>B. \<lambda>a. \<exists>b. R a b \<and> B b"
definition dimage::"('a,'b)\<rho> \<Rightarrow> ('a,'b)\<O>" (*dual image*)
  where "dimage R    \<equiv> \<lambda>A. \<lambda>b. \<forall>a. R a b \<longrightarrow> A a"
definition dpreimage::"('a,'b)\<rho> \<Rightarrow> ('b,'a)\<O>"  (*dual preimage*)
  where "dpreimage R \<equiv> \<lambda>B. \<lambda>a. \<forall>b. R a b \<longrightarrow> B b"

(*The (dual-)image of a relation corresponds to the (dual-)preimage of its converse and vice versa*)
lemma image_transp:  "image R = preimage R\<Zcat>" unfolding image_def preimage_def ..
lemma dimage_transp: "dimage R = dpreimage R\<Zcat>" unfolding dimage_def dpreimage_def ..

(*The operators above are in fact (dual) order-embeddings wrt. (converse) relation order*)
lemma preimage_order: "(\<^bold>\<subseteq>\<^sup>r),(\<^bold>\<subseteq>\<^sup>r)-EMBD preimage" unfolding preimage_def subset_def by force
lemma image_order: "(\<^bold>\<subseteq>\<^sup>r),(\<^bold>\<subseteq>\<^sup>r)-EMBD image" unfolding image_def subset_def by force
lemma dual_preimage_order: "(\<^bold>\<subseteq>\<^sup>r),(\<^bold>\<subseteq>\<^sup>r)\<Zcat>-EMBD dpreimage" unfolding dpreimage_def subset_def by metis
lemma dual_image_order: "(\<^bold>\<subseteq>\<^sup>r),(\<^bold>\<subseteq>\<^sup>r)\<Zcat>-EMBD dimage" unfolding dimage_def subset_def by blast

(*Moreover, they are (dual) monoid-homomorphisms (from the monoid of relations to the monoid of operators)*)
lemma image_id:    "ID\<^sup>r,ID-MORPH image" unfolding image_def by simp
lemma preimage_id: "ID\<^sup>r,ID-MORPH preimage" unfolding preimage_def by simp
lemma dimage_id: "ID\<^sup>r,ID-MORPH dimage" unfolding dimage_def by simp
lemma dpreimage_id: "ID\<^sup>r,ID-MORPH dpreimage" unfolding dpreimage_def by simp
lemma image_comp:    "(\<^bold>\<circ>\<^sup>r),(\<^bold>\<circ>)-MORPH image" unfolding image_def by (metis (no_types, opaque_lifting) rcomp_def)
lemma preimage_comp: "(\<^bold>\<circ>\<^sup>r),(\<^bold>\<circ>)\<Zcat>-MORPH preimage" unfolding preimage_def by (metis (no_types, opaque_lifting) rcomp_def)
lemma dimage_comp: "(\<^bold>\<circ>\<^sup>r),(\<^bold>\<circ>)-MORPH dimage" unfolding dimage_def by (metis (no_types, opaque_lifting) rcomp_def)
lemma dpreimage_comp: "(\<^bold>\<circ>\<^sup>r),(\<^bold>\<circ>)\<Zcat>-MORPH dpreimage" unfolding dpreimage_def by (metis (no_types, opaque_lifting) rcomp_def)

(*Interestingly, operators derived from relations form residuated pairs as shown below: *)
lemma residuation1: "image R \<stileturn> dpreimage R" by (smt (verit, del_insts) subset_def dpreimage_def image_def)
lemma residuation2: "preimage R \<stileturn> dimage R" by (smt (verit) subset_def dimage_def preimage_def)

section \<open>Automating modal correspondences\<close>

(*Let us introduce some properties of relations*)
definition \<open>reflexive R \<equiv> \<forall>a. R a a\<close>
definition \<open>symmetric R \<equiv> \<forall>a b. R a b \<longrightarrow> R b a\<close>
definition \<open>transitive R \<equiv> (\<forall>a b c. R a c \<and> R c b \<longrightarrow> R a b)\<close>
definition \<open>dense R \<equiv> \<forall>a b. R a b \<longrightarrow> (\<exists>c. R a c \<and> R c b)\<close>
definition \<open>euclidean R \<equiv> \<forall>a b c. R c a \<and> R c b \<longrightarrow> R a b\<close>

(*The key to automatically proving correspondences between conditions on relations and their respective
  unary operations lies on the following alternative relational-algebraic definitions*)
lemma reflexive_reldef: \<open>reflexive R = ID\<^sup>r \<^bold>\<subseteq>\<^sup>r R\<close> by (simp add: subset_def reflexive_def)
lemma symmetric_reldef: \<open>symmetric R = (R\<Zcat> \<^bold>\<subseteq>\<^sup>r R)\<close> by (metis (full_types) subset_def symmetric_def)
lemma euclidean_reldef: \<open>euclidean R = (R \<^bold>\<circ>\<^sup>r R\<Zcat> \<^bold>\<subseteq>\<^sup>r R)\<close> by (simp add: subset_def euclidean_def rcomp_def)
lemma transitive_reldef: \<open>transitive R = (R \<^bold>\<circ>\<^sup>r R \<^bold>\<subseteq>\<^sup>r R)\<close> by (simp add: subset_def rcomp_def transitive_def)
lemma dense_reldef: \<open>dense R = (R \<^bold>\<subseteq>\<^sup>r R \<^bold>\<circ>\<^sup>r R)\<close> by (simp add: subset_def dense_def rcomp_def)

(*For the sake of illustration let us now introduce a shallow embedding of a normal modal logic:*)
typedecl i (*type for possible worlds*)
consts R::"(i,i)\<rho>" (*the accessibility relation*)

(*Boolean logical connectives*)
abbreviation compl::"(i,i)\<O>" ("\<^bold>\<midarrow>") (*or type: ('a \<sigma>, 'a)\<rho> *)
  where \<open>\<^bold>\<midarrow>A \<equiv> \<lambda>x. \<not>A x\<close>
abbreviation mand::"(i,i)\<O>\<^sub>2" (infixr "\<^bold>\<and>" 54)
  where "A \<^bold>\<and> B \<equiv> \<lambda>x. A x \<and> B x"
abbreviation mor::"(i,i)\<O>\<^sub>2" (infixr "\<^bold>\<or>" 53)
  where "A \<^bold>\<or> B \<equiv> \<lambda>x. A x \<or> B x"
definition mimpl::"(i,i)\<O>\<^sub>2" (infixr "\<^bold>\<rightarrow>" 51)
  where "A \<^bold>\<rightarrow> B \<equiv> \<lambda>x. A x \<longrightarrow> B x" (** note that (set-)implication is made a definition*)
(*Modal operators*)
abbreviation box::"(i,i)\<O>" ("\<^bold>\<box>_"[80])
  where "\<^bold>\<box>A \<equiv> dpreimage R A"
abbreviation dia::"(i,i)\<O>" ("\<^bold>\<diamond>_"[80])
  where "\<^bold>\<diamond>A \<equiv> preimage R A"

(*Definition of modal validity: truth in all worlds*)
definition valid ("\<lfloor>_\<rfloor>")
  where "\<lfloor>F\<rfloor> \<equiv> \<forall>w. F w"

(*The following lemma is an algebraic-variant of the Deduction Theorem for modal logics.*)
lemma ADT: "\<lfloor>A \<^bold>\<rightarrow> B\<rfloor> = (A \<^bold>\<subseteq> B)" by (simp add: mimpl_def subset_def valid_def)

(*Let us now prove automatically several well-known modal correspondences. Observe how ATPs (via sledgehammer)
  manage to find the right definitions in the background theory, by cleverly exploiting the lemma 'ADT'
 and the 'XY_reldef' family of (definitional) lemmata.*)

lemma refl_corresp:  "reflexive R \<longleftrightarrow> (\<forall>P. \<lfloor>P \<^bold>\<rightarrow> \<^bold>\<diamond>P\<rfloor>)"
  by (metis ADT preimage_id preimage_order reflexive_reldef)
lemma refl_corresp': "reflexive R \<longleftrightarrow> (\<forall>P. \<lfloor>\<^bold>\<box>P \<^bold>\<rightarrow> P\<rfloor>)"
  by (metis ADT dpreimage_id dual_preimage_order reflexive_reldef)

lemma symm_corresp: "symmetric R \<longleftrightarrow> (\<forall>P. \<lfloor>P \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<diamond>P\<rfloor>)"
  by (metis ADT image_transp preimage_order residuation1 symmetric_reldef)
lemma symm_corresp': "symmetric R \<longleftrightarrow> (\<forall>P. \<lfloor>\<^bold>\<diamond>\<^bold>\<box>P \<^bold>\<rightarrow> P\<rfloor>)"
  by (metis ADT dimage_transp dual_preimage_order residuation2 symmetric_reldef)

lemma trans_corresp:  "transitive R \<longleftrightarrow> (\<forall>P. \<lfloor>\<^bold>\<diamond>\<^bold>\<diamond>P \<^bold>\<rightarrow> \<^bold>\<diamond>P\<rfloor>)"
  by (metis ADT preimage_comp preimage_order transitive_reldef)
lemma trans_corresp': "transitive R \<longleftrightarrow> (\<forall>P. \<lfloor>\<^bold>\<box>P \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<box>P\<rfloor>)"
  by (metis ADT dpreimage_comp dual_preimage_order transitive_reldef)

lemma dense_corresp: "dense R \<longleftrightarrow> (\<forall>P. \<lfloor>\<^bold>\<box>\<^bold>\<box>P \<^bold>\<rightarrow> \<^bold>\<box>P\<rfloor>)"
  by (metis ADT dense_reldef dpreimage_comp dual_preimage_order)
lemma dense_corresp': "dense R \<longleftrightarrow> (\<forall>P. \<lfloor>\<^bold>\<diamond>P \<^bold>\<rightarrow> \<^bold>\<diamond>\<^bold>\<diamond>P\<rfloor>)"
  by (metis ADT dense_reldef preimage_comp preimage_order)

lemma euclidean_corresp: "euclidean R \<longleftrightarrow> (\<forall>P. \<lfloor>\<^bold>\<diamond>P \<^bold>\<rightarrow> \<^bold>\<box>\<^bold>\<diamond>P\<rfloor>)"
  by (smt (verit, ccfv_SIG) ADT euclidean_reldef image_transp preimage_comp preimage_order residuation1)
lemma euclidean_corresp': "euclidean R \<longleftrightarrow> (\<forall>P. \<lfloor>\<^bold>\<diamond>\<^bold>\<box>P \<^bold>\<rightarrow> \<^bold>\<box>P\<rfloor>)"
  by (smt (verit, del_insts) ADT dimage_transp dpreimage_comp dual_preimage_order euclidean_reldef residuation2)

section \<open>Lemmon-Scott schema\<close>

(*Exercise: formalize and prove the Lemmon-Scott schema (cf. SEP article on modal logic:
    https://plato.stanford.edu/entries/logic-modal/#GenAxi)*)

end


(* IsageoCoq2_R1

Tarski_2D.thy

Version 2.2.0 IsaGeoCoq2_R1, Port part of GeoCoq 3.4.0
Version 2.1.0 IsaGeoCoq2_R1, Port part of GeoCoq 3.4.0
Copyright (C) 2021-2023 Roland Coghetto roland.coghetto ( a t ) cafr-msa2p.be
License: LGPGL

History
Version 1.0.0: IsaGeoCoq
Port part of GeoCoq 3.4.0 (https://geocoq.github.io/GeoCoq/) in Isabelle/Hol (Isabelle2021)

Copyright (C) 2021  Roland Coghetto roland_coghetto (at) hotmail.com

License: LGPL

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
*)

(*<*)
theory Tarski_2D

imports
  Tarski_Neutral

  begin

(*>*)

subsection "Tarski's axiom system for neutral geometry: 2D"

locale Tarski_2D = Tarski_neutral_dimensionless Bet Cong TPA TPB TPC
  for Bet  :: "TPoint \<Rightarrow> TPoint \<Rightarrow> TPoint \<Rightarrow> bool" ("(_ - _ - _) ")
  and Cong :: "TPoint \<Rightarrow> TPoint \<Rightarrow> TPoint \<Rightarrow> TPoint \<Rightarrow> bool"
  and TPA TPB TPC :: TPoint +
  assumes upper_dim: "\<forall> a b c p q.
                      p \<noteq> q \<and>
                      Cong a p a q \<and>
                      Cong b p b q \<and>
                      Cong c p c q
                      \<longrightarrow>
                      (Bet a b c \<or> Bet b c a \<or> Bet c a b)"

context Tarski_2D

begin

subsubsection "Line reflexivity: 2D"

lemma all_coplanar:
  "Coplanar A B C D"
proof -
  have "all_coplanar_axiom"
    using upper_dim all_coplanar_axiom_def by blast
  thus ?thesis
    using upper_dim_implies_all_coplanar
    by (meson all_coplanar_upper_dim coplanar_perm_22 ncop__ncols os__coplanar ts__coplanar
        upper_dim_implies_one_or_two_sides)
qed

lemma per2__col:
  assumes "Per A X C" and
    "X \<noteq> C" and
    "Per B X C"
  shows "Col A B X"
  using all_coplanar_axiom_def all_coplanar_upper_dim assms(1) assms(2) assms(3)
    upper_dim upper_dim_implies_per2__col by blast

lemma perp2__col:
  assumes "X Y Perp A B" and
    "X Z Perp A B"
  shows "Col X Y Z"
  by (meson cop_perp2__col Tarski_neutral_dimensionless_axioms all_coplanar assms(1) assms(2))

lemma l12_9_2D:
  assumes "A1 A2 Perp C1 C2" and
    "B1 B2 Perp C1 C2"
  shows "A1 A2 Par B1 B2"
  using l12_9 all_coplanar assms(1) assms(2) by auto

section "2D"

lemma perp_in2__col:
  assumes "P PerpAt A B X Y" and
    "P PerpAt A' B' X Y"
  shows "Col A B A'"
  using cop4_perp_in2__col all_coplanar assms by blast

lemma perp2_trans:
  assumes "P Perp2 A B C D" and
    "P Perp2 C D E F"
  shows "P Perp2 A B E F"
proof -
  obtain X Y where P1: "Col P X Y \<and> X Y Perp A B \<and> X Y Perp C D"
    using Perp2_def assms(1) by blast
  obtain X' Y' where P2: "Col P X' Y' \<and> X' Y' Perp C D \<and> X' Y' Perp E F"
    using Perp2_def assms(2) by blast
  {
    assume "X Y Par X' Y'"
    hence P3: "X Y ParStrict X' Y' \<or> (X \<noteq> Y \<and> X' \<noteq> Y' \<and> Col X X' Y' \<and> Col Y X' Y')"
      using Par_def by blast
    {
      assume "X Y ParStrict X' Y'"
      hence "P Perp2 A B E F"
        using P1 P2 par_not_col by auto
    }
    {
      assume "X \<noteq> Y \<and> X' \<noteq> Y' \<and> Col X X' Y' \<and> Col Y X' Y'"
      hence "P Perp2 A B E F"
        by (meson P1 P2 Perp2_def col_permutation_1 perp_col2)
    }
    hence "P Perp2 A B E F"
      using P3 \<open>X Y ParStrict X' Y' \<Longrightarrow> P Perp2 A B E F\<close> by blast
  }
  {
    assume "\<not> X Y Par X' Y'"
    hence "P Perp2 A B E F"
      using P1 P2 l12_9_2D by blast
  }
  thus ?thesis
    using \<open>X Y Par X' Y' \<Longrightarrow> P Perp2 A B E F\<close> by blast
qed

lemma perp2_par:
  assumes "PO Perp2 A B C D"
  shows "A B Par C D"
  using Perp2_def l12_9_2D Perp_perm assms by blast

section "Suite"

lemma not_par_strict_inter_exists:
  assumes "\<not> A1 B1 ParStrict A2 B2"
  shows "\<exists> X. Col X A1 B1 \<and> Col X A2 B2"
  using ParStrict_def all_coplanar assms by presburger

lemma not_par_inter_exists:
  assumes "\<not> A1 B1 Par A2 B2"
  shows "\<exists> X. Col X A1 B1 \<and> Col X A2 B2"
  using all_coplanar assms cop_npar__inter_exists by blast

end
end


section\<open>Array List\<close>
text\<open>Most of this has been contributed by Peter Lammich.\<close>
theory Array_List
imports
  Separation_Logic_Imperative_HOL.Array_Blit
begin
  text\<open>
    This implements a datastructure that efficiently supports two operations: appending an element and looking up the nth element.
  The implementation is straightforward.
\<close>
  text\<open>
    As underlying data structure an array is used.
  Since changing the length of an array requires copying, we double the size whenever the array needs to be expanded.
  We use a counter for the current length to track which elements are used and which are spares.
\<close>
  type_synonym 'a array_list = "'a array \<times> nat"

  definition "is_array_list l \<equiv> \<lambda>(a,n). \<exists>\<^sub>Al'. a \<mapsto>\<^sub>a l' * \<up>(n \<le> length l' \<and> l = take n l' \<and> length l'>0)"

  definition "initial_capacity \<equiv> 16::nat"

  definition "arl_empty \<equiv> do {
    a \<leftarrow> Array.new initial_capacity default;
    return (a,0)
  }"

  lemma [sep_heap_rules]: "< emp > arl_empty <is_array_list []>"
    by (sep_auto simp: arl_empty_def is_array_list_def initial_capacity_def)

  definition "arl_nth \<equiv> \<lambda>(a,n) i. do {
    Array.nth a i
  }"

  lemma [sep_heap_rules]: "i<length l \<Longrightarrow> < is_array_list l a > arl_nth a i <\<lambda>x. is_array_list l a * \<up>(x = l!i) >"
    by (sep_auto simp: arl_nth_def is_array_list_def split: prod.splits)

  definition "arl_append \<equiv> \<lambda>(a,n) x. do {
    len \<leftarrow> Array.len a;

    if n<len then do {
      a \<leftarrow> Array.upd n x a;
      return (a,n+1)
    } else do {
      let newcap = 2 * len;
      a \<leftarrow> array_grow a newcap default;
      a \<leftarrow> Array.upd n x a;
      return (a,n+1)
    }
  }"

  lemma [sep_heap_rules]: "
    < is_array_list l a >
      arl_append a x
    <\<lambda>a. is_array_list (l@[x]) a >\<^sub>t"
    by (sep_auto
      simp: arl_append_def is_array_list_def take_update_last neq_Nil_conv
      split: prod.splits nat.split)

  lemma is_array_list_prec: "precise is_array_list"
    unfolding is_array_list_def[abs_def]
    apply(rule preciseI)
    apply(simp split: prod.splits)
    using preciseD snga_prec by fastforce

  lemma is_array_list_lengthIA: "is_array_list l li \<Longrightarrow>\<^sub>A \<up>(snd li = length l) * true"
    by(sep_auto simp: is_array_list_def split: prod.splits)
    find_consts "assn \<Rightarrow> bool"
  lemma is_array_list_lengthI: "x \<Turnstile> is_array_list l li \<Longrightarrow> snd li = length l"
  using is_array_list_lengthIA by (metis (full_types) ent_pure_post_iff star_aci(2))

end